merged, resolving obvious conflicts in NEWS and src/Pure/System/isabelle_process.ML;
1.1 --- a/.hgignore Thu Dec 05 17:52:12 2013 +0100
1.2 +++ b/.hgignore Thu Dec 05 17:58:03 2013 +0100
1.3 @@ -5,7 +5,9 @@
1.4 *.jar
1.5 *.orig
1.6 *.rej
1.7 +*.pyc
1.8 .DS_Store
1.9 +.swp
1.10
1.11
1.12 syntax: regexp
2.1 --- a/Admin/MacOS/App1/README Thu Dec 05 17:52:12 2013 +0100
2.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
2.3 @@ -1,14 +0,0 @@
2.4 -Isabelle application bundle for MacOS
2.5 -=====================================
2.6 -
2.7 -Requirements:
2.8 -
2.9 -* CocoaDialog 2.1.1 http://cocoadialog.sourceforge.net/
2.10 -
2.11 -* Platypus 4.7 http://www.sveinbjorn.org/platypus
2.12 - Preferences: Install command line tool
2.13 -
2.14 -* final packaging:
2.15 -
2.16 - hdiutil create -srcfolder DIR DMG
2.17 -
3.1 --- a/Admin/MacOS/App1/build Thu Dec 05 17:52:12 2013 +0100
3.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
3.3 @@ -1,23 +0,0 @@
3.4 -#!/usr/bin/env bash
3.5 -#
3.6 -# Make Isabelle application bundle
3.7 -
3.8 -THIS="$(cd "$(dirname "$0")"; pwd)"
3.9 -
3.10 -COCOADIALOG_APP="/Applications/CocoaDialog.app"
3.11 -
3.12 -/usr/local/bin/platypus \
3.13 - -a Isabelle -u Isabelle \
3.14 - -I "de.tum.in.isabelle" \
3.15 - -i "$THIS/../isabelle.icns" \
3.16 - -D -X thy \
3.17 - -Q "$THIS/../theory.icns" \
3.18 - -p /bin/bash \
3.19 - -R \
3.20 - -o None \
3.21 - -f "$COCOADIALOG_APP" \
3.22 - "$THIS/script" \
3.23 - "$PWD/Isabelle.app"
3.24 -
3.25 -rm -f Contents/Resources/Isabelle
3.26 -ln -s Contents/Resources/Isabelle Isabelle.app/Isabelle
3.27 \ No newline at end of file
4.1 --- a/Admin/MacOS/App1/script Thu Dec 05 17:52:12 2013 +0100
4.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
4.3 @@ -1,82 +0,0 @@
4.4 -#!/usr/bin/env 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 -# global defaults
4.16 -
4.17 -ISABELLE_TOOL="$THIS/Isabelle/bin/isabelle"
4.18 -PROOFGENERAL_EMACS="$THIS/Aquamacs.app/Contents/MacOS/Aquamacs"
4.19 -
4.20 -
4.21 -# environment
4.22 -
4.23 -cd "$HOME"
4.24 -if [ -x /usr/libexec/path_helper ]; then
4.25 - eval $(/usr/libexec/path_helper -s)
4.26 -fi
4.27 -
4.28 -[ -z "$LANG" ] && export LANG=en_US.UTF-8
4.29 -
4.30 -
4.31 -# run interface with error feedback
4.32 -
4.33 -ISABELLE_INTERFACE_CHOICE="$("$ISABELLE_TOOL" getenv -b ISABELLE_INTERFACE_CHOICE)"
4.34 -if [ "$ISABELLE_INTERFACE_CHOICE" != emacs -a "$ISABELLE_INTERFACE_CHOICE" != jedit ]
4.35 -then
4.36 - declare -a CHOICE
4.37 - CHOICE=($("$THIS/CocoaDialog.app/Contents/MacOS/CocoaDialog" dropdown \
4.38 - --title Isabelle \
4.39 - --text "Which Isabelle interface?" \
4.40 - --items "Isabelle/jEdit PIDE" "Emacs / Proof General" \
4.41 - --button2 "OK, do not ask again" --button1 "OK"))
4.42 - if [ "${CHOICE[1]}" = 0 ]; then
4.43 - ISABELLE_INTERFACE_CHOICE=jedit
4.44 - else
4.45 - ISABELLE_INTERFACE_CHOICE=emacs
4.46 - fi
4.47 - if [ "${CHOICE[0]}" = 2 ]; then
4.48 - ISABELLE_HOME_USER="$("$ISABELLE_TOOL" getenv -b ISABELLE_HOME_USER)"
4.49 - mkdir -p "$ISABELLE_HOME_USER/etc"
4.50 - ( echo; echo "ISABELLE_INTERFACE_CHOICE=$ISABELLE_INTERFACE_CHOICE"; ) \
4.51 - >> "$ISABELLE_HOME_USER/etc/settings"
4.52 - "$THIS/CocoaDialog.app/Contents/MacOS/CocoaDialog" ok-msgbox \
4.53 - --title Isabelle \
4.54 - --text Note \
4.55 - --informative-text "ISABELLE_INTERFACE_CHOICE stored in $ISABELLE_HOME_USER/etc/settings" \
4.56 - --no-cancel
4.57 - fi
4.58 -fi
4.59 -
4.60 -OUTPUT="/tmp/isabelle$$.out"
4.61 -
4.62 -if [ "$ISABELLE_INTERFACE_CHOICE" = emacs ]; then
4.63 - ( "$ISABELLE_TOOL" emacs -p "$PROOFGENERAL_EMACS" "$@" ) > "$OUTPUT" 2>&1
4.64 - RC=$?
4.65 -else
4.66 - ( "$ISABELLE_TOOL" jedit -s "$@" ) > "$OUTPUT" 2>&1
4.67 - RC=$?
4.68 -fi
4.69 -
4.70 -if [ "$RC" != 0 ]; then
4.71 - echo >> "$OUTPUT"
4.72 - echo "Return code: $RC" >> "$OUTPUT"
4.73 -fi
4.74 -
4.75 -if [ $(stat -f "%z" "$OUTPUT") != 0 ]; then
4.76 - "$THIS/CocoaDialog.app/Contents/MacOS/CocoaDialog" textbox \
4.77 - --title "Isabelle" \
4.78 - --informative-text "Isabelle output" \
4.79 - --text-from-file "$OUTPUT" \
4.80 - --button1 "OK"
4.81 -fi
4.82 -
4.83 -rm -f "$OUTPUT"
4.84 -
4.85 -exit "$RC"
5.1 --- a/Admin/MacOS/App2/Isabelle.app/Contents/Info.plist Thu Dec 05 17:52:12 2013 +0100
5.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
5.3 @@ -1,48 +0,0 @@
5.4 -<?xml version="1.0" encoding="UTF-8"?>
5.5 -<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
5.6 -<plist version="1.0">
5.7 -<dict>
5.8 - <key>CFBundleDevelopmentRegion</key>
5.9 - <string>English</string>
5.10 - <key>CFBundleExecutable</key>
5.11 - <string>Isabelle</string>
5.12 - <key>CFBundleGetInfoString</key>
5.13 - <string>Isabelle</string>
5.14 - <key>CFBundleIconFile</key>
5.15 - <string>isabelle.icns</string>
5.16 - <key>CFBundleIdentifier</key>
5.17 - <string>de.tum.in.isabelle</string>
5.18 - <key>CFBundleInfoDictionaryVersion</key>
5.19 - <string>6.0</string>
5.20 - <key>CFBundleName</key>
5.21 - <string>Isabelle</string>
5.22 - <key>CFBundlePackageType</key>
5.23 - <string>APPL</string>
5.24 - <key>CFBundleShortVersionString</key>
5.25 - <string>????</string>
5.26 - <key>CFBundleSignature</key>
5.27 - <string>????</string>
5.28 - <key>CFBundleVersion</key>
5.29 - <string>????</string>
5.30 - <key>Java</key>
5.31 - <dict>
5.32 - <key>JVMVersion</key>
5.33 - <string>1.6</string>
5.34 - <key>VMOptions</key>
5.35 - <string>-Xms128m -Xmx512m -Xss2m</string>
5.36 - <key>ClassPath</key>
5.37 - <string>$JAVAROOT/isabelle-scala.jar</string>
5.38 - <key>MainClass</key>
5.39 - <string>isabelle.GUI_Setup</string>
5.40 - <key>Properties</key>
5.41 - <dict>
5.42 - <key>isabelle.home</key>
5.43 - <string>$APP_PACKAGE/Contents/Resources/Isabelle</string>
5.44 - <key>apple.laf.useScreenMenuBar</key>
5.45 - <string>true</string>
5.46 - <key>com.apple.mrj.application.apple.menu.about.name</key>
5.47 - <string>Isabelle</string>
5.48 - </dict>
5.49 - </dict>
5.50 -</dict>
5.51 -</plist>
6.1 --- a/Admin/MacOS/App2/Isabelle.app/Contents/MacOS/Isabelle Thu Dec 05 17:52:12 2013 +0100
6.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
6.3 @@ -1,1 +0,0 @@
6.4 -/System/Library/Frameworks/JavaVM.framework/Resources/MacOS/JavaApplicationStub
6.5 \ No newline at end of file
7.1 --- a/Admin/MacOS/App2/README Thu Dec 05 17:52:12 2013 +0100
7.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
7.3 @@ -1,7 +0,0 @@
7.4 -Isabelle/JVM application bundle for MacOS
7.5 -=========================================
7.6 -
7.7 -* http://developer.apple.com/documentation/Java/Conceptual/Java14Development/03-JavaDeployment/JavaDeployment.html
7.8 -
7.9 -* http://developer.apple.com/documentation/Java/Reference/Java_InfoplistRef/Articles/JavaDictionaryInfo.plistKeys.html#//apple_ref/doc/uid/TP40001969
7.10 -
8.1 --- a/Admin/MacOS/App2/mk Thu Dec 05 17:52:12 2013 +0100
8.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
8.3 @@ -1,12 +0,0 @@
8.4 -#!/usr/bin/env bash
8.5 -#
8.6 -# Make Isabelle/JVM application bundle
8.7 -
8.8 -THIS="$(cd "$(dirname "$0")"; pwd)"
8.9 -
8.10 -APP="$THIS/Isabelle.app"
8.11 -
8.12 -mkdir -p "$APP/Contents/Resources/Java"
8.13 -cp "$THIS/../../../lib/classes/isabelle-scala.jar" "$APP/Contents/Resources/Java"
8.14 -cp "$THIS/../isabelle.icns" "$APP/Contents/Resources"
8.15 -
9.1 --- a/Admin/MacOS/App3/Info.plist-part1 Thu Dec 05 17:52:12 2013 +0100
9.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
9.3 @@ -1,36 +0,0 @@
9.4 -<?xml version="1.0" ?>
9.5 -<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
9.6 -<plist version="1.0">
9.7 -<dict>
9.8 -<key>CFBundleDevelopmentRegion</key>
9.9 -<string>English</string>
9.10 -<key>CFBundleExecutable</key>
9.11 -<string>JavaAppLauncher</string>
9.12 -<key>CFBundleIconFile</key>
9.13 -<string>isabelle.icns</string>
9.14 -<key>CFBundleIdentifier</key>
9.15 -<string>de.tum.in.isabelle</string>
9.16 -<key>CFBundleDisplayName</key>
9.17 -<string>{ISABELLE_NAME}</string>
9.18 -<key>CFBundleInfoDictionaryVersion</key>
9.19 -<string>6.0</string>
9.20 -<key>CFBundleName</key>
9.21 -<string>{ISABELLE_NAME}</string>
9.22 -<key>CFBundlePackageType</key>
9.23 -<string>APPL</string>
9.24 -<key>CFBundleShortVersionString</key>
9.25 -<string>1.0</string>
9.26 -<key>CFBundleSignature</key>
9.27 -<string>????</string>
9.28 -<key>CFBundleVersion</key>
9.29 -<string>1</string>
9.30 -<key>NSHumanReadableCopyright</key>
9.31 -<string></string>
9.32 -<key>LSApplicationCategoryType</key>
9.33 -<string>public.app-category.developer-tools</string>
9.34 -<key>JVMRuntime</key>
9.35 -<string>jdk</string>
9.36 -<key>JVMMainClassName</key>
9.37 -<string>isabelle.Main</string>
9.38 -<key>JVMOptions</key>
9.39 -<array>
10.1 --- a/Admin/MacOS/App3/Info.plist-part2 Thu Dec 05 17:52:12 2013 +0100
10.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
10.3 @@ -1,7 +0,0 @@
10.4 -<string>-Disabelle.home=$APP_ROOT/Contents/Resources/{ISABELLE_NAME}</string>
10.5 -</array>
10.6 -<key>JVMArguments</key>
10.7 -<array>
10.8 -</array>
10.9 -</dict>
10.10 -</plist>
11.1 --- a/Admin/MacOS/App3/README Thu Dec 05 17:52:12 2013 +0100
11.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
11.3 @@ -1,8 +0,0 @@
11.4 -Isabelle/JVM application bundle for Mac OS X
11.5 -============================================
11.6 -
11.7 -* http://java.net/projects/appbundler
11.8 -
11.9 - see appbundler-1.0.jar
11.10 - see com/oracle/appbundler/JavaAppLauncher
11.11 -
12.1 --- a/Admin/MacOS/App3/Resources/en.lproj/Localizable.strings Thu Dec 05 17:52:12 2013 +0100
12.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
12.3 @@ -1,3 +0,0 @@
12.4 -"JRELoadError" = "Unable to load Java Runtime Environment.";
12.5 -"MainClassNameRequired" = "Main class name is required.";
12.6 -"JavaDirectoryNotFound" = "Unable to enumerate Java directory contents.";
13.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
13.2 +++ b/Admin/MacOS/Info.plist-part1 Thu Dec 05 17:58:03 2013 +0100
13.3 @@ -0,0 +1,36 @@
13.4 +<?xml version="1.0" ?>
13.5 +<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
13.6 +<plist version="1.0">
13.7 +<dict>
13.8 +<key>CFBundleDevelopmentRegion</key>
13.9 +<string>English</string>
13.10 +<key>CFBundleExecutable</key>
13.11 +<string>JavaAppLauncher</string>
13.12 +<key>CFBundleIconFile</key>
13.13 +<string>isabelle.icns</string>
13.14 +<key>CFBundleIdentifier</key>
13.15 +<string>de.tum.in.isabelle</string>
13.16 +<key>CFBundleDisplayName</key>
13.17 +<string>{ISABELLE_NAME}</string>
13.18 +<key>CFBundleInfoDictionaryVersion</key>
13.19 +<string>6.0</string>
13.20 +<key>CFBundleName</key>
13.21 +<string>{ISABELLE_NAME}</string>
13.22 +<key>CFBundlePackageType</key>
13.23 +<string>APPL</string>
13.24 +<key>CFBundleShortVersionString</key>
13.25 +<string>1.0</string>
13.26 +<key>CFBundleSignature</key>
13.27 +<string>????</string>
13.28 +<key>CFBundleVersion</key>
13.29 +<string>1</string>
13.30 +<key>NSHumanReadableCopyright</key>
13.31 +<string></string>
13.32 +<key>LSApplicationCategoryType</key>
13.33 +<string>public.app-category.developer-tools</string>
13.34 +<key>JVMRuntime</key>
13.35 +<string>jdk</string>
13.36 +<key>JVMMainClassName</key>
13.37 +<string>isabelle.Main</string>
13.38 +<key>JVMOptions</key>
13.39 +<array>
14.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
14.2 +++ b/Admin/MacOS/Info.plist-part2 Thu Dec 05 17:58:03 2013 +0100
14.3 @@ -0,0 +1,7 @@
14.4 +<string>-Disabelle.home=$APP_ROOT/Contents/Resources/{ISABELLE_NAME}</string>
14.5 +</array>
14.6 +<key>JVMArguments</key>
14.7 +<array>
14.8 +</array>
14.9 +</dict>
14.10 +</plist>
15.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
15.2 +++ b/Admin/MacOS/README Thu Dec 05 17:58:03 2013 +0100
15.3 @@ -0,0 +1,8 @@
15.4 +Isabelle/JVM application bundle for Mac OS X
15.5 +============================================
15.6 +
15.7 +* http://java.net/projects/appbundler
15.8 +
15.9 + see appbundler-1.0.jar
15.10 + see com/oracle/appbundler/JavaAppLauncher
15.11 +
16.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
16.2 +++ b/Admin/MacOS/Resources/en.lproj/Localizable.strings Thu Dec 05 17:58:03 2013 +0100
16.3 @@ -0,0 +1,3 @@
16.4 +"JRELoadError" = "Unable to load Java Runtime Environment.";
16.5 +"MainClassNameRequired" = "Main class name is required.";
16.6 +"JavaDirectoryNotFound" = "Unable to enumerate Java directory contents.";
17.1 Binary file Admin/MacOS/Resources/isabelle.icns has changed
18.1 Binary file Admin/MacOS/Resources/theory.icns has changed
19.1 Binary file Admin/MacOS/isabelle.icns has changed
20.1 Binary file Admin/MacOS/theory.icns has changed
21.1 --- a/Admin/Windows/launch4j/README Thu Dec 05 17:52:12 2013 +0100
21.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
21.3 @@ -1,4 +0,0 @@
21.4 -Java application wrapper for Windows
21.5 -====================================
21.6 -
21.7 -* http://launch4j.sourceforge.net
22.1 Binary file Admin/Windows/launch4j/isabelle.ico has changed
23.1 --- a/Admin/Windows/launch4j/isabelle.xml Thu Dec 05 17:52:12 2013 +0100
23.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
23.3 @@ -1,39 +0,0 @@
23.4 -<launch4jConfig>
23.5 - <dontWrapJar>true</dontWrapJar>
23.6 - <headerType>gui</headerType>
23.7 - <jar></jar>
23.8 - <outfile>Isabelle.exe</outfile>
23.9 - <errTitle></errTitle>
23.10 - <cmdLine></cmdLine>
23.11 - <chdir></chdir>
23.12 - <priority>normal</priority>
23.13 - <downloadUrl></downloadUrl>
23.14 - <supportUrl></supportUrl>
23.15 - <customProcName>false</customProcName>
23.16 - <stayAlive>true</stayAlive>
23.17 - <manifest></manifest>
23.18 - <icon>isabelle.ico</icon>
23.19 - <classPath>
23.20 - <mainClass>isabelle.Main</mainClass>
23.21 - <cp>%EXEDIR%\lib\classes\ext\Pure.jar</cp>
23.22 - <cp>%EXEDIR%\lib\classes\ext\scala-compiler.jar</cp>
23.23 - <cp>%EXEDIR%\lib\classes\ext\scala-library.jar</cp>
23.24 - <cp>%EXEDIR%\lib\classes\ext\scala-swing.jar</cp>
23.25 - <cp>%EXEDIR%\lib\classes\ext\scala-actors.jar</cp>
23.26 - <cp>%EXEDIR%\lib\classes\ext\scala-reflect.jar</cp>
23.27 - <cp>%EXEDIR%\src\Tools\jEdit\dist\jedit.jar</cp>
23.28 - </classPath>
23.29 - <jre>
23.30 - <path>%EXEDIR%\contrib\jdk\x86-cygwin</path>
23.31 - <minVersion></minVersion>
23.32 - <maxVersion></maxVersion>
23.33 - <jdkPreference>jdkOnly</jdkPreference>
23.34 - <opt>-Dfile.encoding=UTF-8 -server -Xms128m -Xmx1024m -Xss2m -Dactors.corePoolSize=4 -Dactors.enableForkJoin=false -Disabelle.home="%EXEDIR%"</opt>
23.35 - </jre>
23.36 - <splash>
23.37 - <file>isabelle.bmp</file>
23.38 - <waitForWindow>false</waitForWindow>
23.39 - <timeout>10</timeout>
23.40 - <timeoutErr>false</timeoutErr>
23.41 - </splash>
23.42 -</launch4jConfig>
23.43 \ No newline at end of file
24.1 --- a/Admin/isatest/isatest-stats Thu Dec 05 17:52:12 2013 +0100
24.2 +++ b/Admin/isatest/isatest-stats Thu Dec 05 17:58:03 2013 +0100
24.3 @@ -14,11 +14,9 @@
24.4 HOL-Auth
24.5 HOL-BNF
24.6 HOL-BNF-Examples
24.7 + HOL-BNF-LFP
24.8 HOL-BNF-Nitpick_Examples
24.9 - HOL-BNF-LFP
24.10 HOL-Bali
24.11 - HOL-Boogie
24.12 - HOL-Boogie-Examples
24.13 HOL-Cardinals
24.14 HOL-Cardinals-Base
24.15 HOL-Codegenerator_Test
25.1 --- a/Admin/lib/Tools/makedist_bundle Thu Dec 05 17:52:12 2013 +0100
25.2 +++ b/Admin/lib/Tools/makedist_bundle Thu Dec 05 17:58:03 2013 +0100
25.3 @@ -261,7 +261,7 @@
25.4 (
25.5 cd "$TMP"
25.6
25.7 - APP_TEMPLATE="$ISABELLE_HOME/Admin/MacOS/App3"
25.8 + APP_TEMPLATE="$ISABELLE_HOME/Admin/MacOS"
25.9 APP="${ISABELLE_NAME}.app"
25.10
25.11 for NAME in Java MacOS PlugIns Resources
25.12 @@ -289,7 +289,6 @@
25.13 done
25.14
25.15 cp -R "$APP_TEMPLATE/Resources/." "$APP/Contents/Resources/."
25.16 - cp "$APP_TEMPLATE/../isabelle.icns" "$APP/Contents/Resources/."
25.17
25.18 ln -sf "../Resources/${ISABELLE_NAME}/contrib/jdk/x86_64-darwin" \
25.19 "$APP/Contents/PlugIns/jdk"
26.1 --- a/CONTRIBUTORS Thu Dec 05 17:52:12 2013 +0100
26.2 +++ b/CONTRIBUTORS Thu Dec 05 17:58:03 2013 +0100
26.3 @@ -3,6 +3,10 @@
26.4 who is listed as an author in one of the source files of this Isabelle
26.5 distribution.
26.6
26.7 +Contributions to this Isabelle version
26.8 +--------------------------------------
26.9 +
26.10 +
26.11 Contributions to Isabelle2013-1
26.12 -------------------------------
26.13
27.1 --- a/NEWS Thu Dec 05 17:52:12 2013 +0100
27.2 +++ b/NEWS Thu Dec 05 17:58:03 2013 +0100
27.3 @@ -1,6 +1,98 @@
27.4 Isabelle NEWS -- history user-relevant changes
27.5 ==============================================
27.6
27.7 +New in this Isabelle version
27.8 +----------------------------
27.9 +
27.10 +*** Prover IDE -- Isabelle/Scala/jEdit ***
27.11 +
27.12 +* Auxiliary files ('ML_file' etc.) are managed by the Prover IDE.
27.13 +Open text buffers take precedence over copies within the file-system.
27.14 +
27.15 +
27.16 +*** HOL ***
27.17 +
27.18 +* Qualified constant names Wellfounded.acc, Wellfounded.accp.
27.19 +INCOMPATIBILITY.
27.20 +
27.21 +* Fact generalization and consolidation:
27.22 + neq_one_mod_two, mod_2_not_eq_zero_eq_one_int ~> not_mod_2_eq_0_eq_1
27.23 +INCOMPATIBILITY.
27.24 +
27.25 +* Purely algebraic definition of even. Fact generalization and consolidation:
27.26 + nat_even_iff_2_dvd, int_even_iff_2_dvd ~> even_iff_2_dvd
27.27 + even_zero_(nat|int) ~> even_zero
27.28 +INCOMPATIBILITY.
27.29 +
27.30 +* Abolished neg_numeral.
27.31 + * Canonical representation for minus one is "- 1".
27.32 + * Canonical representation for other negative numbers is "- (numeral _)".
27.33 + * When devising rule sets for number calculation, consider the
27.34 + following canonical cases: 0, 1, numeral _, - 1, - numeral _.
27.35 + * HOLogic.dest_number also recognizes numerals in non-canonical forms
27.36 + like "numeral One", "- numeral One", "- 0" and even "- … - _".
27.37 + * Syntax for negative numerals is mere input syntax.
27.38 +INCOMPATBILITY.
27.39 +
27.40 +* Elimination of fact duplicates:
27.41 + equals_zero_I ~> minus_unique
27.42 + diff_eq_0_iff_eq ~> right_minus_eq
27.43 + nat_infinite ~> infinite_UNIV_nat
27.44 + int_infinite ~> infinite_UNIV_int
27.45 +INCOMPATIBILITY.
27.46 +
27.47 +* Fact name consolidation:
27.48 + diff_def, diff_minus, ab_diff_minus ~> diff_conv_add_uminus
27.49 + minus_le_self_iff ~> neg_less_eq_nonneg
27.50 + le_minus_self_iff ~> less_eq_neg_nonpos
27.51 + neg_less_nonneg ~> neg_less_pos
27.52 + less_minus_self_iff ~> less_neg_neg [simp]
27.53 +INCOMPATIBILITY.
27.54 +
27.55 +* More simplification rules on unary and binary minus:
27.56 +add_diff_cancel, add_diff_cancel_left, add_le_same_cancel1,
27.57 +add_le_same_cancel2, add_less_same_cancel1, add_less_same_cancel2,
27.58 +add_minus_cancel, diff_add_cancel, le_add_same_cancel1,
27.59 +le_add_same_cancel2, less_add_same_cancel1, less_add_same_cancel2,
27.60 +minus_add_cancel, uminus_add_conv_diff. These correspondingly
27.61 +have been taken away from fact collections algebra_simps and
27.62 +field_simps. INCOMPATIBILITY.
27.63 +
27.64 +To restore proofs, the following patterns are helpful:
27.65 +
27.66 +a) Arbitrary failing proof not involving "diff_def":
27.67 +Consider simplification with algebra_simps or field_simps.
27.68 +
27.69 +b) Lifting rules from addition to subtraction:
27.70 +Try with "using <rule for addition> of [… "- _" …]" by simp".
27.71 +
27.72 +c) Simplification with "diff_def": just drop "diff_def".
27.73 +Consider simplification with algebra_simps or field_simps;
27.74 +or the brute way with
27.75 +"simp add: diff_conv_add_uminus del: add_uminus_conv_diff".
27.76 +
27.77 +* SUP and INF generalized to conditionally_complete_lattice
27.78 +
27.79 +* Theory Lubs moved HOL image to HOL-Library. It is replaced by
27.80 +Conditionally_Complete_Lattices. INCOMPATIBILITY.
27.81 +
27.82 +* Introduce bdd_above and bdd_below in Conditionally_Complete_Lattices, use them
27.83 +instead of explicitly stating boundedness of sets.
27.84 +
27.85 +* ccpo.admissible quantifies only over non-empty chains to allow
27.86 +more syntax-directed proof rules; the case of the empty chain
27.87 +shows up as additional case in fixpoint induction proofs.
27.88 +INCOMPATIBILITY
27.89 +
27.90 +*** ML ***
27.91 +
27.92 +* Toplevel function "use" refers to raw ML bootstrap environment,
27.93 +without Isar context nor antiquotations. Potential INCOMPATIBILITY.
27.94 +Note that 'ML_file' is the canonical command to load ML files into the
27.95 +formal context.
27.96 +
27.97 +
27.98 +
27.99 New in Isabelle2013-2 (December 2013)
27.100 -------------------------------------
27.101
27.102 @@ -457,6 +549,10 @@
27.103 sets ~> set
27.104 IMCOMPATIBILITY.
27.105
27.106 +* Nitpick:
27.107 + - Fixed soundness bug whereby mutually recursive datatypes could take
27.108 + infinite values.
27.109 +
27.110
27.111 *** ML ***
27.112
28.1 --- a/etc/isar-keywords.el Thu Dec 05 17:52:12 2013 +0100
28.2 +++ b/etc/isar-keywords.el Thu Dec 05 17:58:03 2013 +0100
28.3 @@ -1,6 +1,6 @@
28.4 ;;
28.5 ;; Keyword classification tables for Isabelle/Isar.
28.6 -;; Generated from HOL + HOL-Auth + HOL-BNF + HOL-BNF-LFP + HOL-Bali + HOL-Decision_Procs + HOL-IMP + HOL-Imperative_HOL + HOL-Import + HOL-Library + HOL-Mutabelle + HOL-Nominal + HOL-Proofs + HOL-Proofs-Extraction + HOL-SPARK + HOL-Statespace + HOL-TPTP + HOL-ex + HOLCF + Pure.
28.7 +;; Generated from HOL + HOL-Auth + HOL-BNF + HOL-BNF-LFP + HOL-Bali + HOL-Decision_Procs + HOL-IMP + HOL-Imperative_HOL + HOL-Import + HOL-Library + HOL-Mutabelle + HOL-Nominal + HOL-Proofs + HOL-Proofs-Extraction + HOL-SPARK + HOL-Statespace + HOL-TPTP + HOL-Word-SMT_Examples + HOL-ex + HOLCF + Pure.
28.8 ;; *** DO NOT EDIT *** DO NOT EDIT *** DO NOT EDIT ***
28.9 ;;
28.10
28.11 @@ -33,6 +33,7 @@
28.12 "axiomatization"
28.13 "back"
28.14 "bnf"
28.15 + "boogie_file"
28.16 "bundle"
28.17 "by"
28.18 "cannot_undo"
28.19 @@ -343,7 +344,6 @@
28.20 "module_name"
28.21 "monos"
28.22 "morphisms"
28.23 - "no_discs_sels"
28.24 "notes"
28.25 "obtains"
28.26 "open"
28.27 @@ -352,7 +352,6 @@
28.28 "parametric"
28.29 "permissive"
28.30 "pervasive"
28.31 - "rep_compat"
28.32 "shows"
28.33 "structure"
28.34 "type_class"
28.35 @@ -487,6 +486,7 @@
28.36 "atom_decl"
28.37 "attribute_setup"
28.38 "axiomatization"
28.39 + "boogie_file"
28.40 "bundle"
28.41 "case_of_simps"
28.42 "class"
29.1 --- a/src/Doc/Datatypes/Datatypes.thy Thu Dec 05 17:52:12 2013 +0100
29.2 +++ b/src/Doc/Datatypes/Datatypes.thy Thu Dec 05 17:58:03 2013 +0100
29.3 @@ -8,22 +8,9 @@
29.4 *)
29.5
29.6 theory Datatypes
29.7 -imports Setup
29.8 -keywords
29.9 - "primcorec_notyet" :: thy_decl
29.10 +imports Setup "~~/src/HOL/Library/Simps_Case_Conv"
29.11 begin
29.12
29.13 -(*<*)
29.14 -(* FIXME: Temporary setup until "primcorec" and "primcorecursive" are fully implemented. *)
29.15 -ML_command {*
29.16 -fun add_dummy_cmd _ _ lthy = lthy;
29.17 -
29.18 -val _ = Outer_Syntax.local_theory @{command_spec "primcorec_notyet"} ""
29.19 - (Parse.fixes -- Parse_Spec.where_alt_specs >> uncurry add_dummy_cmd);
29.20 -*}
29.21 -(*>*)
29.22 -
29.23 -
29.24 section {* Introduction
29.25 \label{sec:introduction} *}
29.26
29.27 @@ -54,17 +41,19 @@
29.28
29.29 text {*
29.30 \noindent
29.31 -The package also provides some convenience, notably automatically generated
29.32 -discriminators and selectors.
29.33 -
29.34 -In addition to plain inductive datatypes, the new package supports coinductive
29.35 -datatypes, or \emph{codatatypes}, which may have infinite values. For example,
29.36 -the following command introduces the type of lazy lists, which comprises both
29.37 -finite and infinite values:
29.38 +Furthermore, the package provides a lot of convenience, including automatically
29.39 +generated discriminators, selectors, and relators as well as a wealth of
29.40 +properties about them.
29.41 +
29.42 +In addition to inductive datatypes, the new package supports coinductive
29.43 +datatypes, or \emph{codatatypes}, which allow infinite values. For example, the
29.44 +following command introduces the type of lazy lists, which comprises both finite
29.45 +and infinite values:
29.46 *}
29.47
29.48 (*<*)
29.49 locale early
29.50 + locale late
29.51 (*>*)
29.52 codatatype (*<*)(in early) (*>*)'a llist = LNil | LCons 'a "'a llist"
29.53
29.54 @@ -80,10 +69,10 @@
29.55 codatatype (*<*)(in early) (*>*)'a tree\<^sub>i\<^sub>i = Node\<^sub>i\<^sub>i 'a "'a tree\<^sub>i\<^sub>i llist"
29.56
29.57 text {*
29.58 -The first two tree types allow only finite branches, whereas the last two allow
29.59 -branches of infinite length. Orthogonally, the nodes in the first and third
29.60 -types have finite branching, whereas those of the second and fourth may have
29.61 -infinitely many direct subtrees.
29.62 +The first two tree types allow only paths of finite length, whereas the last two
29.63 +allow infinite paths. Orthogonally, the nodes in the first and third types have
29.64 +finitely many direct subtrees, whereas those of the second and fourth may have
29.65 +infinite branching.
29.66
29.67 To use the package, it is necessary to import the @{theory BNF} theory, which
29.68 can be precompiled into the \texttt{HOL-BNF} image. The following commands show
29.69 @@ -152,15 +141,15 @@
29.70
29.71
29.72 \newbox\boxA
29.73 -\setbox\boxA=\hbox{\texttt{nospam}}
29.74 -
29.75 -\newcommand\authoremaili{\texttt{blan{\color{white}nospam}\kern-\wd\boxA{}chette@\allowbreak
29.76 +\setbox\boxA=\hbox{\texttt{NOSPAM}}
29.77 +
29.78 +\newcommand\authoremaili{\texttt{blan{\color{white}NOSPAM}\kern-\wd\boxA{}chette@\allowbreak
29.79 in.\allowbreak tum.\allowbreak de}}
29.80 -\newcommand\authoremailii{\texttt{lore{\color{white}nospam}\kern-\wd\boxA{}nz.panny@\allowbreak
29.81 +\newcommand\authoremailii{\texttt{lore{\color{white}NOSPAM}\kern-\wd\boxA{}nz.panny@\allowbreak
29.82 \allowbreak tum.\allowbreak de}}
29.83 -\newcommand\authoremailiii{\texttt{pope{\color{white}nospam}\kern-\wd\boxA{}scua@\allowbreak
29.84 +\newcommand\authoremailiii{\texttt{pope{\color{white}NOSPAM}\kern-\wd\boxA{}scua@\allowbreak
29.85 in.\allowbreak tum.\allowbreak de}}
29.86 -\newcommand\authoremailiv{\texttt{tray{\color{white}nospam}\kern-\wd\boxA{}tel@\allowbreak
29.87 +\newcommand\authoremailiv{\texttt{tray{\color{white}NOSPAM}\kern-\wd\boxA{}tel@\allowbreak
29.88 in.\allowbreak tum.\allowbreak de}}
29.89
29.90 The commands @{command datatype_new} and @{command primrec_new} are expected to
29.91 @@ -171,13 +160,6 @@
29.92 Comments and bug reports concerning either the tool or this tutorial should be
29.93 directed to the authors at \authoremaili, \authoremailii, \authoremailiii,
29.94 and \authoremailiv.
29.95 -
29.96 -\begin{framed}
29.97 -\noindent
29.98 -\textbf{Warning:}\enskip This tutorial and the package it describes are under
29.99 -construction. Please forgive their appearance. Should you have suggestions
29.100 -or comments regarding either, please let the authors know.
29.101 -\end{framed}
29.102 *}
29.103
29.104
29.105 @@ -195,7 +177,7 @@
29.106 text {*
29.107 Datatypes are illustrated through concrete examples featuring different flavors
29.108 of recursion. More examples can be found in the directory
29.109 -\verb|~~/src/HOL/BNF/Examples|.
29.110 +\verb|~~/src/HOL/|\allowbreak\verb|BNF/Examples|.
29.111 *}
29.112
29.113 subsubsection {* Nonrecursive Types
29.114 @@ -260,7 +242,8 @@
29.115
29.116 text {*
29.117 \noindent
29.118 -Lists were shown in the introduction. Terminated lists are a variant:
29.119 +Lists were shown in the introduction. Terminated lists are a variant that
29.120 +stores a value of type @{typ 'b} at the very end:
29.121 *}
29.122
29.123 datatype_new (*<*)(in early) (*>*)('a, 'b) tlist = TNil 'b | TCons 'a "('a, 'b) tlist"
29.124 @@ -310,7 +293,7 @@
29.125 Not all nestings are admissible. For example, this command will fail:
29.126 *}
29.127
29.128 - datatype_new 'a wrong = Wrong (*<*)'a
29.129 + datatype_new 'a wrong = W1 | W2 (*<*)'a
29.130 typ (*>*)"'a wrong \<Rightarrow> 'a"
29.131
29.132 text {*
29.133 @@ -321,7 +304,7 @@
29.134 *}
29.135
29.136 datatype_new ('a, 'b) fn = Fn "'a \<Rightarrow> 'b"
29.137 - datatype_new 'a also_wrong = Also_Wrong (*<*)'a
29.138 + datatype_new 'a also_wrong = W1 | W2 (*<*)'a
29.139 typ (*>*)"('a also_wrong, 'a) fn"
29.140
29.141 text {*
29.142 @@ -344,20 +327,30 @@
29.143 datatype_new} and @{command codatatype} commands.
29.144 Section~\ref{sec:registering-bounded-natural-functors} explains how to register
29.145 arbitrary type constructors as BNFs.
29.146 +
29.147 +Here is another example that fails:
29.148 *}
29.149
29.150 -
29.151 -subsubsection {* Custom Names and Syntaxes
29.152 - \label{sssec:datatype-custom-names-and-syntaxes} *}
29.153 + datatype_new 'a pow_list = PNil 'a (*<*)'a
29.154 + datatype_new 'a pow_list' = PNil' 'a (*>*)| PCons "('a * 'a) pow_list"
29.155 +
29.156 +text {*
29.157 +\noindent
29.158 +This one features a different flavor of nesting, where the recursive call in the
29.159 +type specification occurs around (rather than inside) another type constructor.
29.160 +*}
29.161 +
29.162 +subsubsection {* Auxiliary Constants and Properties
29.163 + \label{sssec:datatype-auxiliary-constants-and-properties} *}
29.164
29.165 text {*
29.166 The @{command datatype_new} command introduces various constants in addition to
29.167 the constructors. With each datatype are associated set functions, a map
29.168 function, a relator, discriminators, and selectors, all of which can be given
29.169 -custom names. In the example below, the traditional names
29.170 -@{text set}, @{text map}, @{text list_all2}, @{text null}, @{text hd}, and
29.171 -@{text tl} override the default names @{text list_set}, @{text list_map}, @{text
29.172 -list_rel}, @{text is_Nil}, @{text un_Cons1}, and @{text un_Cons2}:
29.173 +custom names. In the example below, the familiar names @{text null}, @{text hd},
29.174 +@{text tl}, @{text set}, @{text map}, and @{text list_all2}, override the
29.175 +default names @{text is_Nil}, @{text un_Cons1}, @{text un_Cons2},
29.176 +@{text set_list}, @{text map_list}, and @{text rel_list}:
29.177 *}
29.178
29.179 (*<*)
29.180 @@ -370,7 +363,7 @@
29.181 Cons (infixr "#" 65)
29.182
29.183 hide_type list
29.184 - hide_const Nil Cons hd tl set map list_all2 list_case list_rec
29.185 + hide_const Nil Cons hd tl set map list_all2
29.186
29.187 context early begin
29.188 (*>*)
29.189 @@ -380,14 +373,34 @@
29.190
29.191 text {*
29.192 \noindent
29.193 -The command introduces a discriminator @{const null} and a pair of selectors
29.194 -@{const hd} and @{const tl} characterized as follows:
29.195 +
29.196 +\begin{tabular}{@ {}ll@ {}}
29.197 +Constructors: &
29.198 + @{text "Nil \<Colon> 'a list"} \\
29.199 +&
29.200 + @{text "Cons \<Colon> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list"} \\
29.201 +Discriminator: &
29.202 + @{text "null \<Colon> 'a list \<Rightarrow> bool"} \\
29.203 +Selectors: &
29.204 + @{text "hd \<Colon> 'a list \<Rightarrow> 'a"} \\
29.205 +&
29.206 + @{text "tl \<Colon> 'a list \<Rightarrow> 'a list"} \\
29.207 +Set function: &
29.208 + @{text "set \<Colon> 'a list \<Rightarrow> 'a set"} \\
29.209 +Map function: &
29.210 + @{text "map \<Colon> ('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list"} \\
29.211 +Relator: &
29.212 + @{text "list_all2 \<Colon> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> bool"}
29.213 +\end{tabular}
29.214 +
29.215 +The discriminator @{const null} and the selectors @{const hd} and @{const tl}
29.216 +are characterized as follows:
29.217 %
29.218 \[@{thm list.collapse(1)[of xs, no_vars]}
29.219 \qquad @{thm list.collapse(2)[of xs, no_vars]}\]
29.220 %
29.221 -For two-constructor datatypes, a single discriminator constant suffices. The
29.222 -discriminator associated with @{const Cons} is simply
29.223 +For two-constructor datatypes, a single discriminator constant is sufficient.
29.224 +The discriminator associated with @{const Cons} is simply
29.225 @{term "\<lambda>xs. \<not> null xs"}.
29.226
29.227 The @{text defaults} clause following the @{const Nil} constructor specifies a
29.228 @@ -447,7 +460,7 @@
29.229 @@{command datatype_new} target? @{syntax dt_options}? \\
29.230 (@{syntax dt_name} '=' (@{syntax ctor} + '|') + @'and')
29.231 ;
29.232 - @{syntax_def dt_options}: '(' (('no_discs_sels' | 'rep_compat') + ',') ')'
29.233 + @{syntax_def dt_options}: '(' (('no_discs_sels' | 'no_code' | 'rep_compat') + ',') ')'
29.234 "}
29.235
29.236 The syntactic entity \synt{target} can be used to specify a local
29.237 @@ -464,6 +477,10 @@
29.238 should be generated.
29.239
29.240 \item
29.241 +The @{text "no_code"} option indicates that the datatype should not be
29.242 +registered for code generation.
29.243 +
29.244 +\item
29.245 The @{text "rep_compat"} option indicates that the generated names should
29.246 contain optional (and normally not displayed) ``@{text "new."}'' components to
29.247 prevent clashes with a later call to \keyw{rep\_datatype}. See
29.248 @@ -488,7 +505,7 @@
29.249 reference manual \cite{isabelle-isar-ref}.
29.250
29.251 The optional names preceding the type variables allow to override the default
29.252 -names of the set functions (@{text t_set1}, \ldots, @{text t_setM}).
29.253 +names of the set functions (@{text set1_t}, \ldots, @{text setM_t}).
29.254 Inside a mutually recursive specification, all defined datatypes must
29.255 mention exactly the same type variables in the same order.
29.256
29.257 @@ -589,6 +606,10 @@
29.258 or the function type. In principle, it should be possible to support old-style
29.259 datatypes as well, but the command does not support this yet (and there is
29.260 currently no way to register old-style datatypes as new-style datatypes).
29.261 +
29.262 +\item The recursor produced for types that recurse through functions has a
29.263 +different signature than with the old package. This makes it impossible to use
29.264 +the old \keyw{primrec} command.
29.265 \end{itemize}
29.266
29.267 An alternative to @{command datatype_new_compat} is to use the old package's
29.268 @@ -609,7 +630,7 @@
29.269 \begin{itemize}
29.270 \setlength{\itemsep}{0pt}
29.271
29.272 -\item \relax{Case combinator}: @{text t_case} (rendered using the familiar
29.273 +\item \relax{Case combinator}: @{text t.case_t} (rendered using the familiar
29.274 @{text case}--@{text of} syntax)
29.275
29.276 \item \relax{Discriminators}: @{text "t.is_C\<^sub>1"}, \ldots,
29.277 @@ -621,22 +642,22 @@
29.278 \phantom{\relax{Selectors:}} @{text t.un_C\<^sub>n1}$, \ldots, @{text t.un_C\<^sub>nk\<^sub>n}.
29.279
29.280 \item \relax{Set functions} (or \relax{natural transformations}):
29.281 -@{text t_set1}, \ldots, @{text t_setm}
29.282 -
29.283 -\item \relax{Map function} (or \relax{functorial action}): @{text t_map}
29.284 -
29.285 -\item \relax{Relator}: @{text t_rel}
29.286 -
29.287 -\item \relax{Iterator}: @{text t_fold}
29.288 -
29.289 -\item \relax{Recursor}: @{text t_rec}
29.290 +@{text set1_t}, \ldots, @{text t.setm_t}
29.291 +
29.292 +\item \relax{Map function} (or \relax{functorial action}): @{text t.map_t}
29.293 +
29.294 +\item \relax{Relator}: @{text t.rel_t}
29.295 +
29.296 +\item \relax{Iterator}: @{text t.fold_t}
29.297 +
29.298 +\item \relax{Recursor}: @{text t.rec_t}
29.299
29.300 \end{itemize}
29.301
29.302 \noindent
29.303 The case combinator, discriminators, and selectors are collectively called
29.304 \emph{destructors}. The prefix ``@{text "t."}'' is an optional component of the
29.305 -name and is normally hidden.
29.306 +names and is normally hidden.
29.307 *}
29.308
29.309
29.310 @@ -687,8 +708,9 @@
29.311 (*>*)
29.312
29.313 text {*
29.314 -The first subgroup of properties is concerned with the constructors.
29.315 -They are listed below for @{typ "'a list"}:
29.316 +The free constructor theorems are partitioned in three subgroups. The first
29.317 +subgroup of properties is concerned with the constructors. They are listed below
29.318 +for @{typ "'a list"}:
29.319
29.320 \begin{indentblock}
29.321 \begin{description}
29.322 @@ -715,7 +737,7 @@
29.323 \begin{indentblock}
29.324 \begin{description}
29.325
29.326 -\item[@{text "t."}\hthm{list.distinct {\upshape[}THEN notE}@{text ", elim!"}\hthm{\upshape]}\rm:] ~ \\
29.327 +\item[@{text "t."}\hthm{distinct {\upshape[}THEN notE}@{text ", elim!"}\hthm{\upshape]}\rm:] ~ \\
29.328 @{thm list.distinct(1)[THEN notE, elim!, no_vars]} \\
29.329 @{thm list.distinct(2)[THEN notE, elim!, no_vars]}
29.330
29.331 @@ -750,7 +772,7 @@
29.332 \end{indentblock}
29.333
29.334 \noindent
29.335 -The third and last subgroup revolves around discriminators and selectors:
29.336 +The third subgroup revolves around discriminators and selectors:
29.337
29.338 \begin{indentblock}
29.339 \begin{description}
29.340 @@ -793,11 +815,15 @@
29.341 \item[@{text "t."}\hthm{sel\_split\_asm}\rm:] ~ \\
29.342 @{thm list.sel_split_asm[no_vars]}
29.343
29.344 -\item[@{text "t."}\hthm{case\_conv\_if}\rm:] ~ \\
29.345 -@{thm list.case_conv_if[no_vars]}
29.346 +\item[@{text "t."}\hthm{case\_eq\_if}\rm:] ~ \\
29.347 +@{thm list.case_eq_if[no_vars]}
29.348
29.349 \end{description}
29.350 \end{indentblock}
29.351 +
29.352 +\noindent
29.353 +In addition, equational versions of @{text t.disc} are registered with the @{text "[code]"}
29.354 +attribute.
29.355 *}
29.356
29.357
29.358 @@ -805,7 +831,9 @@
29.359 \label{sssec:functorial-theorems} *}
29.360
29.361 text {*
29.362 -The BNF-related theorem are as follows:
29.363 +The functorial theorems are partitioned in two subgroups. The first subgroup
29.364 +consists of properties involving the constructors and either a set function, the
29.365 +map function, or the relator:
29.366
29.367 \begin{indentblock}
29.368 \begin{description}
29.369 @@ -818,16 +846,56 @@
29.370 @{thm list.map(1)[no_vars]} \\
29.371 @{thm list.map(2)[no_vars]}
29.372
29.373 -\item[@{text "t."}\hthm{rel\_inject} @{text "[simp, code]"}\rm:] ~ \\
29.374 +\item[@{text "t."}\hthm{rel\_inject} @{text "[simp]"}\rm:] ~ \\
29.375 @{thm list.rel_inject(1)[no_vars]} \\
29.376 @{thm list.rel_inject(2)[no_vars]}
29.377
29.378 -\item[@{text "t."}\hthm{rel\_distinct} @{text "[simp, code]"}\rm:] ~ \\
29.379 +\item[@{text "t."}\hthm{rel\_distinct} @{text "[simp]"}\rm:] ~ \\
29.380 @{thm list.rel_distinct(1)[no_vars]} \\
29.381 @{thm list.rel_distinct(2)[no_vars]}
29.382
29.383 \end{description}
29.384 \end{indentblock}
29.385 +
29.386 +\noindent
29.387 +In addition, equational versions of @{text t.rel_inject} and @{text
29.388 +rel_distinct} are registered with the @{text "[code]"} attribute.
29.389 +
29.390 +The second subgroup consists of more abstract properties of the set functions,
29.391 +the map function, and the relator:
29.392 +
29.393 +\begin{indentblock}
29.394 +\begin{description}
29.395 +
29.396 +\item[@{text "t."}\hthm{map\_comp}\rm:] ~ \\
29.397 +@{thm list.map_cong0[no_vars]}
29.398 +
29.399 +\item[@{text "t."}\hthm{map\_cong} @{text "[fundef_cong]"}\rm:] ~ \\
29.400 +@{thm list.map_cong[no_vars]}
29.401 +
29.402 +\item[@{text "t."}\hthm{map\_id}\rm:] ~ \\
29.403 +@{thm list.map_id[no_vars]}
29.404 +
29.405 +\item[@{text "t."}\hthm{rel\_compp}\rm:] ~ \\
29.406 +@{thm list.rel_compp[no_vars]}
29.407 +
29.408 +\item[@{text "t."}\hthm{rel\_conversep}\rm:] ~ \\
29.409 +@{thm list.rel_conversep[no_vars]}
29.410 +
29.411 +\item[@{text "t."}\hthm{rel\_eq}\rm:] ~ \\
29.412 +@{thm list.rel_eq[no_vars]}
29.413 +
29.414 +\item[@{text "t."}\hthm{rel\_flip}\rm:] ~ \\
29.415 +@{thm list.rel_flip[no_vars]}
29.416 +
29.417 +\item[@{text "t."}\hthm{rel\_mono}\rm:] ~ \\
29.418 +@{thm list.rel_mono[no_vars]}
29.419 +
29.420 +\item[@{text "t."}\hthm{set\_map}\rm:] ~ \\
29.421 +@{thm list.set_map[no_vars]}
29.422 +
29.423 +\end{description}
29.424 +\end{indentblock}
29.425 *}
29.426
29.427
29.428 @@ -889,18 +957,22 @@
29.429 is recommended to use @{command datatype_new_compat} or \keyw{rep\_datatype}
29.430 to register new-style datatypes as old-style datatypes.
29.431
29.432 -\item \emph{The recursor @{text "t_rec"} has a different signature for nested
29.433 -recursive datatypes.} In the old package, nested recursion was internally
29.434 -reduced to mutual recursion. This reduction was visible in the type of the
29.435 -recursor, used by \keyw{primrec}. In the new package, nested recursion is
29.436 -handled in a more modular fashion. The old-style recursor can be generated on
29.437 -demand using @{command primrec_new}, as explained in
29.438 +\item \emph{The constants @{text t_case} and @{text t_rec} are now called
29.439 +@{text case_t} and @{text rec_t}.}
29.440 +
29.441 +\item \emph{The recursor @{text rec_t} has a different signature for nested
29.442 +recursive datatypes.} In the old package, nested recursion through non-functions
29.443 +was internally reduced to mutual recursion. This reduction was visible in the
29.444 +type of the recursor, used by \keyw{primrec}. Recursion through functions was
29.445 +handled specially. In the new package, nested recursion (for functions and
29.446 +non-functions) is handled in a more modular fashion. The old-style recursor can
29.447 +be generated on demand using @{command primrec_new}, as explained in
29.448 Section~\ref{sssec:primrec-nested-as-mutual-recursion}, if the recursion is via
29.449 new-style datatypes.
29.450
29.451 -\item \emph{Accordingly, the induction principle is different for nested
29.452 -recursive datatypes.} Again, the old-style induction principle can be generated
29.453 -on demand using @{command primrec_new}, as explained in
29.454 +\item \emph{Accordingly, the induction rule is different for nested recursive
29.455 +datatypes.} Again, the old-style induction rule can be generated on demand using
29.456 +@{command primrec_new}, as explained in
29.457 Section~\ref{sssec:primrec-nested-as-mutual-recursion}, if the recursion is via
29.458 new-style datatypes.
29.459
29.460 @@ -940,9 +1012,9 @@
29.461 \label{sec:defining-recursive-functions} *}
29.462
29.463 text {*
29.464 -Recursive functions over datatypes can be specified using @{command
29.465 -primrec_new}, which supports primitive recursion, or using the more general
29.466 -\keyw{fun} and \keyw{function} commands. Here, the focus is on @{command
29.467 +Recursive functions over datatypes can be specified using the @{command
29.468 +primrec_new} command, which supports primitive recursion, or using the more
29.469 +general \keyw{fun} and \keyw{function} commands. Here, the focus is on @{command
29.470 primrec_new}; the other two commands are described in a separate tutorial
29.471 \cite{isabelle-function}.
29.472
29.473 @@ -1026,9 +1098,24 @@
29.474
29.475 text {*
29.476 \noindent
29.477 -The next example is not primitive recursive, but it can be defined easily using
29.478 -\keyw{fun}. The @{command datatype_new_compat} command is needed to register
29.479 -new-style datatypes for use with \keyw{fun} and \keyw{function}
29.480 +Pattern matching is only available for the argument on which the recursion takes
29.481 +place. Fortunately, it is easy to generate pattern-maching equations using the
29.482 +\keyw{simps\_of\_case} command provided by the theory
29.483 +\verb|~~/src/HOL/Library/Simps_Case_Conv|.
29.484 +*}
29.485 +
29.486 + simps_of_case at_simps: at.simps
29.487 +
29.488 +text {*
29.489 +This generates the lemma collection @{thm [source] at_simps}:
29.490 +%
29.491 +\[@{thm at_simps(1)[no_vars]}
29.492 + \qquad @{thm at_simps(2)[no_vars]}\]
29.493 +%
29.494 +The next example is defined using \keyw{fun} to escape the syntactic
29.495 +restrictions imposed on primitive recursive functions. The
29.496 +@{command datatype_new_compat} command is needed to register new-style datatypes
29.497 +for use with \keyw{fun} and \keyw{function}
29.498 (Section~\ref{sssec:datatype-new-compat}):
29.499 *}
29.500
29.501 @@ -1109,13 +1196,13 @@
29.502 \noindent
29.503 The next example features recursion through the @{text option} type. Although
29.504 @{text option} is not a new-style datatype, it is registered as a BNF with the
29.505 -map function @{const option_map}:
29.506 +map function @{const map_option}:
29.507 *}
29.508
29.509 primrec_new (*<*)(in early) (*>*)sum_btree :: "('a\<Colon>{zero,plus}) btree \<Rightarrow> 'a" where
29.510 "sum_btree (BNode a lt rt) =
29.511 - a + the_default 0 (option_map sum_btree lt) +
29.512 - the_default 0 (option_map sum_btree rt)"
29.513 + a + the_default 0 (map_option sum_btree lt) +
29.514 + the_default 0 (map_option sum_btree rt)"
29.515
29.516 text {*
29.517 \noindent
29.518 @@ -1124,28 +1211,51 @@
29.519 (@{text \<Rightarrow>}) is simply composition (@{text "op \<circ>"}):
29.520 *}
29.521
29.522 - primrec_new (*<*)(in early) (*>*)ftree_map :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
29.523 - "ftree_map f (FTLeaf x) = FTLeaf (f x)" |
29.524 - "ftree_map f (FTNode g) = FTNode (ftree_map f \<circ> g)"
29.525 + primrec_new (*<*)(in early) (*>*)relabel_ft :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
29.526 + "relabel_ft f (FTLeaf x) = FTLeaf (f x)" |
29.527 + "relabel_ft f (FTNode g) = FTNode (relabel_ft f \<circ> g)"
29.528
29.529 text {*
29.530 \noindent
29.531 -(No such map function is defined by the package because the type
29.532 -variable @{typ 'a} is dead in @{typ "'a ftree"}.)
29.533 -
29.534 -Using \keyw{fun} or \keyw{function}, recursion through functions can be
29.535 -expressed using $\lambda$-expressions and function application rather
29.536 -than through composition. For example:
29.537 +For convenience, recursion through functions can also be expressed using
29.538 +$\lambda$-abstractions and function application rather than through composition.
29.539 +For example:
29.540 *}
29.541
29.542 - datatype_new_compat ftree
29.543 + primrec_new relabel_ft :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
29.544 + "relabel_ft f (FTLeaf x) = FTLeaf (f x)" |
29.545 + "relabel_ft f (FTNode g) = FTNode (\<lambda>x. relabel_ft f (g x))"
29.546
29.547 text {* \blankline *}
29.548
29.549 - function ftree_map :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
29.550 - "ftree_map f (FTLeaf x) = FTLeaf (f x)" |
29.551 - "ftree_map f (FTNode g) = FTNode (\<lambda>x. ftree_map f (g x))"
29.552 - by auto (metis ftree.exhaust)
29.553 + primrec_new subtree_ft :: "'a \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
29.554 + "subtree_ft x (FTNode g) = g x"
29.555 +
29.556 +text {*
29.557 +\noindent
29.558 +For recursion through curried $n$-ary functions, $n$ applications of
29.559 +@{term "op \<circ>"} are necessary. The examples below illustrate the case where
29.560 +$n = 2$:
29.561 +*}
29.562 +
29.563 + datatype_new 'a ftree2 = FTLeaf2 'a | FTNode2 "'a \<Rightarrow> 'a \<Rightarrow> 'a ftree2"
29.564 +
29.565 +text {* \blankline *}
29.566 +
29.567 + primrec_new (*<*)(in early) (*>*)relabel_ft2 :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree2 \<Rightarrow> 'a ftree2" where
29.568 + "relabel_ft2 f (FTLeaf2 x) = FTLeaf2 (f x)" |
29.569 + "relabel_ft2 f (FTNode2 g) = FTNode2 (op \<circ> (op \<circ> (relabel_ft2 f)) g)"
29.570 +
29.571 +text {* \blankline *}
29.572 +
29.573 + primrec_new relabel_ft2 :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree2 \<Rightarrow> 'a ftree2" where
29.574 + "relabel_ft2 f (FTLeaf2 x) = FTLeaf2 (f x)" |
29.575 + "relabel_ft2 f (FTNode2 g) = FTNode2 (\<lambda>x y. relabel_ft2 f (g x y))"
29.576 +
29.577 +text {* \blankline *}
29.578 +
29.579 + primrec_new subtree_ft2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a ftree2 \<Rightarrow> 'a ftree2" where
29.580 + "subtree_ft2 x y (FTNode2 g) = g x y"
29.581
29.582
29.583 subsubsection {* Nested-as-Mutual Recursion
29.584 @@ -1177,12 +1287,12 @@
29.585
29.586 text {*
29.587 \noindent
29.588 -Appropriate induction principles are generated under the names
29.589 +Appropriate induction rules are generated as
29.590 @{thm [source] at\<^sub>f\<^sub>f.induct},
29.591 @{thm [source] ats\<^sub>f\<^sub>f.induct}, and
29.592 -@{thm [source] at\<^sub>f\<^sub>f_ats\<^sub>f\<^sub>f.induct}.
29.593 -
29.594 -%%% TODO: Add recursors.
29.595 +@{thm [source] at\<^sub>f\<^sub>f_ats\<^sub>f\<^sub>f.induct}. The
29.596 +induction rules and the underlying recursors are generated on a per-need basis
29.597 +and are kept in a cache to speed up subsequent definitions.
29.598
29.599 Here is a second example:
29.600 *}
29.601 @@ -1340,7 +1450,7 @@
29.602 \begin{itemize}
29.603 \setlength{\itemsep}{0pt}
29.604
29.605 -\item \emph{Theorems sometimes have different names.}
29.606 +\item \emph{Some theorems have different names.}
29.607 For $m > 1$ mutually recursive functions,
29.608 @{text "f\<^sub>1_\<dots>_f\<^sub>m.simps"} has been broken down into separate
29.609 subcollections @{text "f\<^sub>i.simps"}.
29.610 @@ -1415,7 +1525,7 @@
29.611 text {*
29.612 \noindent
29.613 Notice that the @{const cont} selector is associated with both @{const Skip}
29.614 -and @{const Choice}.
29.615 +and @{const Action}.
29.616 *}
29.617
29.618
29.619 @@ -1488,9 +1598,9 @@
29.620 \begin{itemize}
29.621 \setlength{\itemsep}{0pt}
29.622
29.623 -\item \relax{Coiterator}: @{text t_unfold}
29.624 -
29.625 -\item \relax{Corecursor}: @{text t_corec}
29.626 +\item \relax{Coiterator}: @{text unfold_t}
29.627 +
29.628 +\item \relax{Corecursor}: @{text corec_t}
29.629
29.630 \end{itemize}
29.631 *}
29.632 @@ -1606,10 +1716,10 @@
29.633 \label{sec:defining-corecursive-functions} *}
29.634
29.635 text {*
29.636 -Corecursive functions can be specified using @{command primcorec} and
29.637 -@{command primcorecursive}, which support primitive corecursion, or using the
29.638 -more general \keyw{partial\_function} command. Here, the focus is on
29.639 -the former two. More examples can be found in the directory
29.640 +Corecursive functions can be specified using the @{command primcorec} and
29.641 +\keyw{prim\-corec\-ursive} commands, which support primitive corecursion, or
29.642 +using the more general \keyw{partial\_function} command. Here, the focus is on
29.643 +the first two. More examples can be found in the directory
29.644 \verb|~~/src/HOL/BNF/Examples|.
29.645
29.646 Whereas recursive functions consume datatypes one constructor at a time,
29.647 @@ -1630,7 +1740,7 @@
29.648 This style is popular in the coalgebraic literature.
29.649
29.650 \item The \emph{constructor view} specifies $f$ by equations of the form
29.651 -\[@{text "\<dots> \<Longrightarrow> f x\<^sub>1 \<dots> x\<^sub>n = C \<dots>"}\]
29.652 +\[@{text "\<dots> \<Longrightarrow> f x\<^sub>1 \<dots> x\<^sub>n = C\<^sub>j \<dots>"}\]
29.653 This style is often more concise than the previous one.
29.654
29.655 \item The \emph{code view} specifies $f$ by a single equation of the form
29.656 @@ -1643,14 +1753,6 @@
29.657 All three styles are available as input syntax. Whichever syntax is chosen,
29.658 characteristic theorems for all three styles are generated.
29.659
29.660 -\begin{framed}
29.661 -\noindent
29.662 -\textbf{Warning:}\enskip The @{command primcorec} and @{command primcorecursive}
29.663 -commands are under development. Some of the functionality described here is
29.664 -vaporware. An alternative is to define corecursive functions directly using the
29.665 -generated @{text t_unfold} or @{text t_corec} combinators.
29.666 -\end{framed}
29.667 -
29.668 %%% TODO: partial_function? E.g. for defining tail recursive function on lazy
29.669 %%% lists (cf. terminal0 in TLList.thy)
29.670 *}
29.671 @@ -1668,11 +1770,6 @@
29.672 present the same examples expressed using the constructor and destructor views.
29.673 *}
29.674
29.675 -(*<*)
29.676 - locale code_view
29.677 - begin
29.678 -(*>*)
29.679 -
29.680 subsubsection {* Simple Corecursion
29.681 \label{sssec:primcorec-simple-corecursion} *}
29.682
29.683 @@ -1683,19 +1780,19 @@
29.684 *}
29.685
29.686 primcorec literate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a llist" where
29.687 - "literate f x = LCons x (literate f (f x))"
29.688 + "literate g x = LCons x (literate g (g x))"
29.689
29.690 text {* \blankline *}
29.691
29.692 primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a stream" where
29.693 - "siterate f x = SCons x (siterate f (f x))"
29.694 + "siterate g x = SCons x (siterate g (g x))"
29.695
29.696 text {*
29.697 \noindent
29.698 The constructor ensures that progress is made---i.e., the function is
29.699 \emph{productive}. The above functions compute the infinite lazy list or stream
29.700 -@{text "[x, f x, f (f x), \<dots>]"}. Productivity guarantees that prefixes
29.701 -@{text "[x, f x, f (f x), \<dots>, (f ^^ k) x]"} of arbitrary finite length
29.702 +@{text "[x, g x, g (g x), \<dots>]"}. Productivity guarantees that prefixes
29.703 +@{text "[x, g x, g (g x), \<dots>, (g ^^ k) x]"} of arbitrary finite length
29.704 @{text k} can be computed by unfolding the code equation a finite number of
29.705 times.
29.706
29.707 @@ -1714,7 +1811,7 @@
29.708 appear around constructors that guard corecursive calls:
29.709 *}
29.710
29.711 - primcorec_notyet lappend :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
29.712 + primcorec lappend :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
29.713 "lappend xs ys =
29.714 (case xs of
29.715 LNil \<Rightarrow> ys
29.716 @@ -1722,6 +1819,19 @@
29.717
29.718 text {*
29.719 \noindent
29.720 +Pattern matching is not supported by @{command primcorec}. Fortunately, it is
29.721 +easy to generate pattern-maching equations using the \keyw{simps\_of\_case}
29.722 +command provided by the theory \verb|~~/src/HOL/Library/Simps_Case_Conv|.
29.723 +*}
29.724 +
29.725 + simps_of_case lappend_simps: lappend.code
29.726 +
29.727 +text {*
29.728 +This generates the lemma collection @{thm [source] lappend_simps}:
29.729 +%
29.730 +\[@{thm lappend_simps(1)[no_vars]}
29.731 + \qquad @{thm lappend_simps(2)[no_vars]}\]
29.732 +%
29.733 Corecursion is useful to specify not only functions but also infinite objects:
29.734 *}
29.735
29.736 @@ -1735,7 +1845,7 @@
29.737 pseudorandom seed (@{text n}):
29.738 *}
29.739
29.740 - primcorec_notyet
29.741 + primcorec
29.742 random_process :: "'a stream \<Rightarrow> (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> 'a process"
29.743 where
29.744 "random_process s f n =
29.745 @@ -1780,43 +1890,71 @@
29.746 The next pair of examples generalize the @{const literate} and @{const siterate}
29.747 functions (Section~\ref{sssec:primcorec-nested-corecursion}) to possibly
29.748 infinite trees in which subnodes are organized either as a lazy list (@{text
29.749 -tree\<^sub>i\<^sub>i}) or as a finite set (@{text tree\<^sub>i\<^sub>s}):
29.750 +tree\<^sub>i\<^sub>i}) or as a finite set (@{text tree\<^sub>i\<^sub>s}). They rely on the map functions of
29.751 +the nesting type constructors to lift the corecursive calls:
29.752 *}
29.753
29.754 primcorec iterate\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>i" where
29.755 - "iterate\<^sub>i\<^sub>i f x = Node\<^sub>i\<^sub>i x (lmap (iterate\<^sub>i\<^sub>i f) (f x))"
29.756 + "iterate\<^sub>i\<^sub>i g x = Node\<^sub>i\<^sub>i x (lmap (iterate\<^sub>i\<^sub>i g) (g x))"
29.757
29.758 text {* \blankline *}
29.759
29.760 primcorec iterate\<^sub>i\<^sub>s :: "('a \<Rightarrow> 'a fset) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>s" where
29.761 - "iterate\<^sub>i\<^sub>s f x = Node\<^sub>i\<^sub>s x (fimage (iterate\<^sub>i\<^sub>s f) (f x))"
29.762 + "iterate\<^sub>i\<^sub>s g x = Node\<^sub>i\<^sub>s x (fimage (iterate\<^sub>i\<^sub>s g) (g x))"
29.763
29.764 text {*
29.765 \noindent
29.766 -Deterministic finite automata (DFAs) are traditionally defined as 5-tuples
29.767 -@{text "(Q, \<Sigma>, \<delta>, q\<^sub>0, F)"}, where @{text Q} is a finite set of states,
29.768 +Both examples follow the usual format for constructor arguments associated
29.769 +with nested recursive occurrences of the datatype. Consider
29.770 +@{const iterate\<^sub>i\<^sub>i}. The term @{term "g x"} constructs an @{typ "'a llist"}
29.771 +value, which is turned into an @{typ "'a tree\<^sub>i\<^sub>i llist"} value using
29.772 +@{const lmap}.
29.773 +
29.774 +This format may sometimes feel artificial. The following function constructs
29.775 +a tree with a single, infinite branch from a stream:
29.776 +*}
29.777 +
29.778 + primcorec tree\<^sub>i\<^sub>i_of_stream :: "'a stream \<Rightarrow> 'a tree\<^sub>i\<^sub>i" where
29.779 + "tree\<^sub>i\<^sub>i_of_stream s =
29.780 + Node\<^sub>i\<^sub>i (shd s) (lmap tree\<^sub>i\<^sub>i_of_stream (LCons (stl s) LNil))"
29.781 +
29.782 +text {*
29.783 +\noindent
29.784 +Fortunately, it is easy to prove the following lemma, where the corecursive call
29.785 +is moved inside the lazy list constructor, thereby eliminating the need for
29.786 +@{const lmap}:
29.787 +*}
29.788 +
29.789 + lemma tree\<^sub>i\<^sub>i_of_stream_alt:
29.790 + "tree\<^sub>i\<^sub>i_of_stream s = Node\<^sub>i\<^sub>i (shd s) (LCons (tree\<^sub>i\<^sub>i_of_stream (stl s)) LNil)"
29.791 + by (subst tree\<^sub>i\<^sub>i_of_stream.code) simp
29.792 +
29.793 +text {*
29.794 +The next example illustrates corecursion through functions, which is a bit
29.795 +special. Deterministic finite automata (DFAs) are traditionally defined as
29.796 +5-tuples @{text "(Q, \<Sigma>, \<delta>, q\<^sub>0, F)"}, where @{text Q} is a finite set of states,
29.797 @{text \<Sigma>} is a finite alphabet, @{text \<delta>} is a transition function, @{text q\<^sub>0}
29.798 is an initial state, and @{text F} is a set of final states. The following
29.799 function translates a DFA into a @{type state_machine}:
29.800 *}
29.801
29.802 - primcorec (*<*)(in early) (*>*)
29.803 - sm_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> 'a state_machine"
29.804 + primcorec
29.805 + (*<*)(in early) (*>*)sm_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> 'a state_machine"
29.806 where
29.807 - "sm_of_dfa \<delta> F q = State_Machine (q \<in> F) (sm_of_dfa \<delta> F o \<delta> q)"
29.808 + "sm_of_dfa \<delta> F q = State_Machine (q \<in> F) (sm_of_dfa \<delta> F \<circ> \<delta> q)"
29.809
29.810 text {*
29.811 \noindent
29.812 The map function for the function type (@{text \<Rightarrow>}) is composition
29.813 -(@{text "op \<circ>"}). For convenience, corecursion through functions can be
29.814 -expressed using $\lambda$-expressions and function application rather
29.815 +(@{text "op \<circ>"}). For convenience, corecursion through functions can
29.816 +also be expressed using $\lambda$-abstractions and function application rather
29.817 than through composition. For example:
29.818 *}
29.819
29.820 primcorec
29.821 sm_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> 'a state_machine"
29.822 where
29.823 - "sm_of_dfa \<delta> F q = State_Machine (q \<in> F) (sm_of_dfa \<delta> F o \<delta> q)"
29.824 + "sm_of_dfa \<delta> F q = State_Machine (q \<in> F) (\<lambda>a. sm_of_dfa \<delta> F (\<delta> q a))"
29.825
29.826 text {* \blankline *}
29.827
29.828 @@ -1833,9 +1971,32 @@
29.829 primcorec
29.830 or_sm :: "'a state_machine \<Rightarrow> 'a state_machine \<Rightarrow> 'a state_machine"
29.831 where
29.832 - "or_sm M N =
29.833 - State_Machine (accept M \<or> accept N)
29.834 - (\<lambda>a. or_sm (trans M a) (trans N a))"
29.835 + "or_sm M N = State_Machine (accept M \<or> accept N)
29.836 + (\<lambda>a. or_sm (trans M a) (trans N a))"
29.837 +
29.838 +text {*
29.839 +\noindent
29.840 +For recursion through curried $n$-ary functions, $n$ applications of
29.841 +@{term "op \<circ>"} are necessary. The examples below illustrate the case where
29.842 +$n = 2$:
29.843 +*}
29.844 +
29.845 + codatatype ('a, 'b) state_machine2 =
29.846 + State_Machine2 (accept2: bool) (trans2: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) state_machine2")
29.847 +
29.848 +text {* \blankline *}
29.849 +
29.850 + primcorec
29.851 + (*<*)(in early) (*>*)sm2_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> ('a, 'b) state_machine2"
29.852 + where
29.853 + "sm2_of_dfa \<delta> F q = State_Machine2 (q \<in> F) (op \<circ> (op \<circ> (sm2_of_dfa \<delta> F)) (\<delta> q))"
29.854 +
29.855 +text {* \blankline *}
29.856 +
29.857 + primcorec
29.858 + sm2_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> ('a, 'b) state_machine2"
29.859 + where
29.860 + "sm2_of_dfa \<delta> F q = State_Machine2 (q \<in> F) (\<lambda>a b. sm2_of_dfa \<delta> F (\<delta> q a b))"
29.861
29.862
29.863 subsubsection {* Nested-as-Mutual Corecursion
29.864 @@ -1848,15 +2009,31 @@
29.865 pretend that nested codatatypes are mutually corecursive. For example:
29.866 *}
29.867
29.868 - primcorec_notyet
29.869 +(*<*)
29.870 + context late
29.871 + begin
29.872 +(*>*)
29.873 + primcorec
29.874 iterate\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>i" and
29.875 iterates\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a llist \<Rightarrow> 'a tree\<^sub>i\<^sub>i llist"
29.876 where
29.877 - "iterate\<^sub>i\<^sub>i f x = Node\<^sub>i\<^sub>i x (iterates\<^sub>i\<^sub>i f (f x))" |
29.878 - "iterates\<^sub>i\<^sub>i f xs =
29.879 + "iterate\<^sub>i\<^sub>i g x = Node\<^sub>i\<^sub>i x (iterates\<^sub>i\<^sub>i g (g x))" |
29.880 + "iterates\<^sub>i\<^sub>i g xs =
29.881 (case xs of
29.882 LNil \<Rightarrow> LNil
29.883 - | LCons x xs' \<Rightarrow> LCons (iterate\<^sub>i\<^sub>i f x) (iterates\<^sub>i\<^sub>i f xs'))"
29.884 + | LCons x xs' \<Rightarrow> LCons (iterate\<^sub>i\<^sub>i g x) (iterates\<^sub>i\<^sub>i g xs'))"
29.885 +
29.886 +text {*
29.887 +\noindent
29.888 +Coinduction rules are generated as
29.889 +@{thm [source] iterate\<^sub>i\<^sub>i.coinduct},
29.890 +@{thm [source] iterates\<^sub>i\<^sub>i.coinduct}, and
29.891 +@{thm [source] iterate\<^sub>i\<^sub>i_iterates\<^sub>i\<^sub>i.coinduct}
29.892 +and analogously for @{text strong_coinduct}. These rules and the
29.893 +underlying corecursors are generated on a per-need basis and are kept in a cache
29.894 +to speed up subsequent definitions.
29.895 +*}
29.896 +
29.897 (*<*)
29.898 end
29.899 (*>*)
29.900 @@ -1866,7 +2043,7 @@
29.901 \label{ssec:primrec-constructor-view} *}
29.902
29.903 (*<*)
29.904 - locale ctr_view = code_view
29.905 + locale ctr_view
29.906 begin
29.907 (*>*)
29.908
29.909 @@ -1937,7 +2114,7 @@
29.910 \label{ssec:primrec-destructor-view} *}
29.911
29.912 (*<*)
29.913 - locale dest_view
29.914 + locale dtr_view
29.915 begin
29.916 (*>*)
29.917
29.918 @@ -1951,13 +2128,13 @@
29.919 primcorec literate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a llist" where
29.920 "\<not> lnull (literate _ x)" |
29.921 "lhd (literate _ x) = x" |
29.922 - "ltl (literate f x) = literate f (f x)"
29.923 + "ltl (literate g x) = literate g (g x)"
29.924
29.925 text {* \blankline *}
29.926
29.927 primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a stream" where
29.928 "shd (siterate _ x) = x" |
29.929 - "stl (siterate f x) = siterate f (f x)"
29.930 + "stl (siterate g x) = siterate g (g x)"
29.931
29.932 text {* \blankline *}
29.933
29.934 @@ -1993,6 +2170,9 @@
29.935 (*<*)
29.936 end
29.937
29.938 + locale dtr_view2
29.939 + begin
29.940 +
29.941 primcorec lappend :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
29.942 "lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)" |
29.943 (*>*)
29.944 @@ -2000,8 +2180,6 @@
29.945 (*<*) |
29.946 "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)" |
29.947 "ltl (lappend xs ys) = (if xs = LNil then ltl ys else lappend (ltl xs) ys)"
29.948 -
29.949 - context dest_view begin
29.950 (*>*)
29.951
29.952 text {*
29.953 @@ -2044,8 +2222,8 @@
29.954 text {* \blankline *}
29.955
29.956 primcorec iterate\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>i" where
29.957 - "lbl\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i f x) = x" |
29.958 - "sub\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i f x) = lmap (iterate\<^sub>i\<^sub>i f) (f x)"
29.959 + "lbl\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i g x) = x" |
29.960 + "sub\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i g x) = lmap (iterate\<^sub>i\<^sub>i g) (g x)"
29.961 (*<*)
29.962 end
29.963 (*>*)
29.964 @@ -2148,11 +2326,39 @@
29.965 \end{matharray}
29.966
29.967 @{rail "
29.968 - @@{command bnf} target? (name ':')? term \\
29.969 - term_list term term_list term?
29.970 + @@{command bnf} target? (name ':')? typ \\
29.971 + 'map:' term ('sets:' (term +))? 'bd:' term \\
29.972 + ('wits:' (term +))? ('rel:' term)?
29.973 +"}
29.974 +*}
29.975 +
29.976 +
29.977 +subsubsection {* \keyw{bnf\_decl}
29.978 + \label{sssec:bnf-decl} *}
29.979 +
29.980 +text {*
29.981 +%%% TODO: use command_def once the command is available
29.982 +\begin{matharray}{rcl}
29.983 + @{text "bnf_decl"} & : & @{text "local_theory \<rightarrow> local_theory"}
29.984 +\end{matharray}
29.985 +
29.986 +@{rail "
29.987 + @@{command bnf_decl} target? @{syntax dt_name}
29.988 ;
29.989 - X_list: '[' (X + ',') ']'
29.990 + @{syntax_def dt_name}: @{syntax tyargs}? name @{syntax map_rel}? mixfix?
29.991 + ;
29.992 + @{syntax_def tyargs}: typefree | '(' (((name | '-') ':')? typefree + ',') ')'
29.993 + ;
29.994 + @{syntax_def map_rel}: '(' ((('map' | 'rel') ':' name) +) ')'
29.995 "}
29.996 +
29.997 +Declares a fresh type and fresh constants (map, set, relator, cardinal bound)
29.998 +and asserts the bnf properties for these constants as axioms. Additionally,
29.999 +type arguments may be marked as dead (by using @{syntax "-"} instead of a name for the
29.1000 +set function)---this is the only difference of @{syntax dt_name} compared to
29.1001 +the syntax used by the @{command datatype_new}/@{command codatatype} commands.
29.1002 +
29.1003 +The axioms are sound, since one there exists a bnf of any given arity.
29.1004 *}
29.1005
29.1006
29.1007 @@ -2185,8 +2391,10 @@
29.1008 % old \keyw{datatype}
29.1009 %
29.1010 % * @{command wrap_free_constructors}
29.1011 -% * @{text "no_discs_sels"}, @{text "rep_compat"}
29.1012 +% * @{text "no_discs_sels"}, @{text "no_code"}, @{text "rep_compat"}
29.1013 % * hack to have both co and nonco view via locale (cf. ext nats)
29.1014 +% * code generator
29.1015 +% * eq, refl, simps
29.1016 *}
29.1017
29.1018
29.1019 @@ -2215,11 +2423,11 @@
29.1020 @{syntax_def wfc_discs_sels}: name_list (name_list_list name_term_list_list? )?
29.1021 ;
29.1022 @{syntax_def name_term}: (name ':' term)
29.1023 + ;
29.1024 + X_list: '[' (X + ',') ']'
29.1025 "}
29.1026
29.1027 -% options: no_discs_sels rep_compat
29.1028 -
29.1029 -% X_list is as for BNF
29.1030 +% options: no_discs_sels no_code rep_compat
29.1031
29.1032 \noindent
29.1033 Section~\ref{ssec:datatype-generated-theorems} lists the generated theorems.
29.1034 @@ -2307,8 +2515,9 @@
29.1035 suggested major simplifications to the internal constructions, much of which has
29.1036 yet to be implemented. Florian Haftmann and Christian Urban provided general
29.1037 advice on Isabelle and package writing. Stefan Milius and Lutz Schr\"oder
29.1038 -found an elegant proof to eliminate one of the BNF assumptions. Christian
29.1039 -Sternagel suggested many textual improvements to this tutorial.
29.1040 +found an elegant proof to eliminate one of the BNF assumptions. Andreas
29.1041 +Lochbihler and Christian Sternagel suggested many textual improvements to this
29.1042 +tutorial.
29.1043 *}
29.1044
29.1045 end
30.1 --- a/src/Doc/Datatypes/document/root.tex Thu Dec 05 17:52:12 2013 +0100
30.2 +++ b/src/Doc/Datatypes/document/root.tex Thu Dec 05 17:58:03 2013 +0100
30.3 @@ -58,10 +58,10 @@
30.4
30.5 \begin{abstract}
30.6 \noindent
30.7 -This tutorial describes how to use the new package for defining datatypes and
30.8 -codatatypes in Isabelle/HOL. The package provides five main commands:
30.9 +This tutorial describes the new package for defining datatypes and codatatypes
30.10 +in Isabelle/HOL. The package provides four main commands:
30.11 \keyw{datatype\_new}, \keyw{codatatype}, \keyw{primrec\_new},
30.12 -\keyw{primcorecursive}, and \keyw{primcorec}. The commands suffixed by
30.13 +and \keyw{primcorec}. The commands suffixed by
30.14 \keyw{\_new} are intended to subsume, and eventually replace, the corresponding
30.15 commands from the old datatype package.
30.16 \end{abstract}
31.1 --- a/src/Doc/Functions/Functions.thy Thu Dec 05 17:52:12 2013 +0100
31.2 +++ b/src/Doc/Functions/Functions.thy Thu Dec 05 17:58:03 2013 +0100
31.3 @@ -1003,13 +1003,13 @@
31.4 recursive calls. In general, there is one introduction rule for each
31.5 recursive call.
31.6
31.7 - The predicate @{term "accp findzero_rel"} is the accessible part of
31.8 + The predicate @{term "Wellfounded.accp findzero_rel"} is the accessible part of
31.9 that relation. An argument belongs to the accessible part, if it can
31.10 be reached in a finite number of steps (cf.~its definition in @{text
31.11 "Wellfounded.thy"}).
31.12
31.13 Since the domain predicate is just an abbreviation, you can use
31.14 - lemmas for @{const accp} and @{const findzero_rel} directly. Some
31.15 + lemmas for @{const Wellfounded.accp} and @{const findzero_rel} directly. Some
31.16 lemmas which are occasionally useful are @{thm [source] accpI}, @{thm [source]
31.17 accp_downward}, and of course the introduction and elimination rules
31.18 for the recursion relation @{thm [source] "findzero_rel.intros"} and @{thm
32.1 --- a/src/Doc/IsarImplementation/ML.thy Thu Dec 05 17:52:12 2013 +0100
32.2 +++ b/src/Doc/IsarImplementation/ML.thy Thu Dec 05 17:58:03 2013 +0100
32.3 @@ -1033,7 +1033,7 @@
32.4 without any message output.
32.5
32.6 \begin{warn}
32.7 - The actual error channel is accessed via @{ML Output.error_msg}, but
32.8 + The actual error channel is accessed via @{ML Output.error_message}, but
32.9 the old interaction protocol of Proof~General \emph{crashes} if that
32.10 function is used in regular ML code: error output and toplevel
32.11 command failure always need to coincide in classic TTY interaction.
33.1 --- a/src/Doc/JEdit/JEdit.thy Thu Dec 05 17:52:12 2013 +0100
33.2 +++ b/src/Doc/JEdit/JEdit.thy Thu Dec 05 17:58:03 2013 +0100
33.3 @@ -1068,12 +1068,6 @@
33.4 text {*
33.5 \begin{itemize}
33.6
33.7 - \item \textbf{Problem:} Lack of dependency management for auxiliary files
33.8 - that contribute to a theory (e.g.\ @{command ML_file}).
33.9 -
33.10 - \textbf{Workaround:} Re-load files manually within the prover, by
33.11 - editing corresponding command in the text.
33.12 -
33.13 \item \textbf{Problem:} Odd behavior of some diagnostic commands with
33.14 global side-effects, like writing a physical file.
33.15
34.1 --- a/src/Doc/Nitpick/document/root.tex Thu Dec 05 17:52:12 2013 +0100
34.2 +++ b/src/Doc/Nitpick/document/root.tex Thu Dec 05 17:58:03 2013 +0100
34.3 @@ -1965,6 +1965,8 @@
34.4 \texttt{.kki}, \texttt{.cnf}, \texttt{.out}, and
34.5 \texttt{.err}; you may safely remove them after Nitpick has run.
34.6
34.7 +\textbf{Warning:} This option is not thread-safe. Use at your own risks.
34.8 +
34.9 \nopagebreak
34.10 {\small See also \textit{debug} (\S\ref{output-format}).}
34.11 \end{enum}
34.12 @@ -2382,6 +2384,14 @@
34.13 \cite{kodkod-2009}. Unlike the standard version of MiniSat, the JNI version can
34.14 be used incrementally.
34.15
34.16 +\item[\labelitemi] \textbf{\textit{Riss3g}:} Riss3g is an efficient solver written in
34.17 +\cpp{}. To use Riss3g, set the environment variable \texttt{RISS3G\_HOME} to the
34.18 +directory that contains the \texttt{riss3g} executable.%
34.19 +\footref{cygwin-paths}
34.20 +The \cpp{} sources for Riss3g are available at
34.21 +\url{http://tools.computational-logic.org/content/riss3g.php}.
34.22 +Nitpick has been tested with the SAT Competition 2013 version.
34.23 +
34.24 \item[\labelitemi] \textbf{\textit{zChaff}:} zChaff is an older solver written
34.25 in \cpp{}. To use zChaff, set the environment variable \texttt{ZCHAFF\_HOME} to
34.26 the directory that contains the \texttt{zchaff} executable.%
34.27 @@ -2794,11 +2804,12 @@
34.28 \subsection{Registering Coinductive Datatypes}
34.29 \label{registering-coinductive-datatypes}
34.30
34.31 +Coinductive datatypes defined using the \textbf{codatatype} command that do not
34.32 +involve nested recursion through non-codatatypes are supported by Nitpick.
34.33 If you have defined a custom coinductive datatype, you can tell Nitpick about
34.34 -it, so that it can use an efficient Kodkod axiomatization similar to the one it
34.35 -uses for lazy lists. The interface for registering and unregistering coinductive
34.36 -datatypes consists of the following pair of functions defined in the
34.37 -\textit{Nitpick\_HOL} structure:
34.38 +it, so that it can use an efficient Kodkod axiomatization. The interface for
34.39 +registering and unregistering coinductive datatypes consists of the following
34.40 +pair of functions defined in the \textit{Nitpick\_HOL} structure:
34.41
34.42 \prew
34.43 $\textbf{val}\,~\textit{register\_codatatype\/} : {}$ \\
34.44 @@ -2886,6 +2897,12 @@
34.45 \item[\labelitemi] Nitpick produces spurious counterexamples when invoked after a
34.46 \textbf{guess} command in a structured proof.
34.47
34.48 +\item[\labelitemi] Datatypes defined using \textbf{datatype\_new} are not
34.49 +supported.
34.50 +
34.51 +\item[\labelitemi] Codatatypes defined using \textbf{codatatype} that
34.52 +involve nested recursion through non-codatatypes are not supported.
34.53 +
34.54 \item[\labelitemi] The \textit{nitpick\_xxx} attributes and the
34.55 \textit{Nitpick\_xxx.register\_yyy} functions can cause havoc if used
34.56 improperly.
35.1 --- a/src/Doc/ProgProve/Basics.thy Thu Dec 05 17:52:12 2013 +0100
35.2 +++ b/src/Doc/ProgProve/Basics.thy Thu Dec 05 17:58:03 2013 +0100
35.3 @@ -22,8 +22,8 @@
35.4 \item[type constructors,]
35.5 in particular @{text list}, the type of
35.6 lists, and @{text set}, the type of sets. Type constructors are written
35.7 -postfix, e.g.\ @{typ "nat list"} is the type of lists whose elements are
35.8 -natural numbers.
35.9 +postfix, i.e., after their arguments. For example,
35.10 +@{typ "nat list"} is the type of lists whose elements are natural numbers.
35.11 \item[function types,]
35.12 denoted by @{text"\<Rightarrow>"}.
35.13 \item[type variables,]
35.14 @@ -41,8 +41,8 @@
35.15 \begin{warn}
35.16 There are many predefined infix symbols like @{text "+"} and @{text"\<le>"}.
35.17 The name of the corresponding binary function is @{term"op +"},
35.18 -not just @{text"+"}. That is, @{term"x + y"} is syntactic sugar for
35.19 -\noquotes{@{term[source]"op + x y"}}.
35.20 +not just @{text"+"}. That is, @{term"x + y"} is nice surface syntax
35.21 +(``syntactic sugar'') for \noquotes{@{term[source]"op + x y"}}.
35.22 \end{warn}
35.23
35.24 HOL also supports some basic constructs from functional programming:
36.1 --- a/src/Doc/ProgProve/Bool_nat_list.thy Thu Dec 05 17:52:12 2013 +0100
36.2 +++ b/src/Doc/ProgProve/Bool_nat_list.thy Thu Dec 05 17:58:03 2013 +0100
36.3 @@ -99,10 +99,10 @@
36.4 For example, given the goal @{text"x + 0 = x"}, there is nothing to indicate
36.5 that you are talking about natural numbers. Hence Isabelle can only infer
36.6 that @{term x} is of some arbitrary type where @{text 0} and @{text"+"}
36.7 - exist. As a consequence, you will be unable to prove the
36.8 - goal. To alert you to such pitfalls, Isabelle flags numerals without a
36.9 - fixed type in its output: @{prop"x+0 = x"}. In this particular example,
36.10 - you need to include
36.11 + exist. As a consequence, you will be unable to prove the goal.
36.12 +% To alert you to such pitfalls, Isabelle flags numerals without a
36.13 +% fixed type in its output: @ {prop"x+0 = x"}.
36.14 + In this particular example, you need to include
36.15 an explicit type constraint, for example @{text"x+0 = (x::nat)"}. If there
36.16 is enough contextual information this may not be necessary: @{prop"Suc x =
36.17 x"} automatically implies @{text"x::nat"} because @{term Suc} is not
36.18 @@ -372,10 +372,10 @@
36.19 ys zs)"}. It appears almost mysterious because we suddenly complicate the
36.20 term by appending @{text Nil} on the left. What is really going on is this:
36.21 when proving some equality \mbox{@{prop"s = t"}}, both @{text s} and @{text t} are
36.22 -simplified to some common term @{text u}. This heuristic for equality proofs
36.23 +simplified until they ``meet in the middle''. This heuristic for equality proofs
36.24 works well for a functional programming context like ours. In the base case
36.25 -@{text s} is @{term"app (app Nil ys) zs"}, @{text t} is @{term"app Nil (app
36.26 -ys zs)"}, and @{text u} is @{term"app ys zs"}.
36.27 +both @{term"app (app Nil ys) zs"} and @{term"app Nil (app
36.28 +ys zs)"} are simplified to @{term"app ys zs"}, the term in the middle.
36.29
36.30 \subsection{Predefined Lists}
36.31 \label{sec:predeflists}
36.32 @@ -419,13 +419,19 @@
36.33 From now on lists are always the predefined lists.
36.34
36.35
36.36 -\subsection{Exercises}
36.37 +\subsection*{Exercises}
36.38 +
36.39 +\begin{exercise}
36.40 +Use the \isacom{value} command to evaluate the following expressions:
36.41 +@{term[source] "1 + (2::nat)"}, @{term[source] "1 + (2::int)"},
36.42 +@{term[source] "1 - (2::nat)"} and @{term[source] "1 - (2::int)"}.
36.43 +\end{exercise}
36.44
36.45 \begin{exercise}
36.46 Start from the definition of @{const add} given above.
36.47 -Prove it is associative (@{prop"add (add m n) p = add m (add n p)"})
36.48 -and commutative (@{prop"add m n = add n m"}). Define a recursive function
36.49 -@{text double} @{text"::"} @{typ"nat \<Rightarrow> nat"} and prove that @{prop"double m = add m m"}.
36.50 +Prove that @{const add} is associative and commutative.
36.51 +Define a recursive function @{text double} @{text"::"} @{typ"nat \<Rightarrow> nat"}
36.52 +and prove @{prop"double m = add m m"}.
36.53 \end{exercise}
36.54
36.55 \begin{exercise}
36.56 @@ -436,11 +442,15 @@
36.57
36.58 \begin{exercise}
36.59 Define a recursive function @{text "snoc ::"} @{typ"'a list \<Rightarrow> 'a \<Rightarrow> 'a list"}
36.60 -that appends an element to the end of a list. Do not use the predefined append
36.61 -operator @{text"@"}. With the help of @{text snoc} define a recursive function
36.62 -@{text "reverse ::"} @{typ"'a list \<Rightarrow> 'a list"} that reverses a list. Do not
36.63 -use the predefined function @{const rev}.
36.64 -Prove @{prop"reverse(reverse xs) = xs"}.
36.65 +that appends an element to the end of a list. With the help of @{text snoc}
36.66 +define a recursive function @{text "reverse ::"} @{typ"'a list \<Rightarrow> 'a list"}
36.67 +that reverses a list. Prove @{prop"reverse(reverse xs) = xs"}.
36.68 +\end{exercise}
36.69 +
36.70 +\begin{exercise}
36.71 +Define a recursive function @{text "sum ::"} @{typ"nat \<Rightarrow> nat"} such that
36.72 +\mbox{@{text"sum n"}} @{text"="} @{text"0 + ... + n"} and prove
36.73 +@{prop" sum(n::nat) = n * (n+1) div 2"}.
36.74 \end{exercise}
36.75 *}
36.76 (*<*)
37.1 --- a/src/Doc/ProgProve/Isar.thy Thu Dec 05 17:52:12 2013 +0100
37.2 +++ b/src/Doc/ProgProve/Isar.thy Thu Dec 05 17:58:03 2013 +0100
37.3 @@ -590,15 +590,15 @@
37.4 the fact just proved, in this case the preceding block. In general,
37.5 \isacom{note} introduces a new name for one or more facts.
37.6
37.7 -\subsection{Exercises}
37.8 +\subsection*{Exercises}
37.9
37.10 \exercise
37.11 Give a readable, structured proof of the following lemma:
37.12 *}
37.13 -lemma assumes T: "\<forall> x y. T x y \<or> T y x"
37.14 - and A: "\<forall> x y. A x y \<and> A y x \<longrightarrow> x = y"
37.15 - and TA: "\<forall> x y. T x y \<longrightarrow> A x y" and "A x y"
37.16 -shows "T x y"
37.17 +lemma assumes T: "\<forall>x y. T x y \<or> T y x"
37.18 + and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
37.19 + and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
37.20 + shows "T x y"
37.21 (*<*)oops(*>*)
37.22 text{*
37.23 \endexercise
37.24 @@ -612,10 +612,11 @@
37.25 text{*
37.26 Hint: There are predefined functions @{const_typ take} and @{const_typ drop}
37.27 such that @{text"take k [x\<^sub>1,\<dots>] = [x\<^sub>1,\<dots>,x\<^sub>k]"} and
37.28 -@{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let @{text simp} and especially
37.29 -sledgehammer find and apply the relevant @{const take} and @{const drop} lemmas for you.
37.30 +@{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let sledgehammer find and apply
37.31 +the relevant @{const take} and @{const drop} lemmas for you.
37.32 \endexercise
37.33
37.34 +
37.35 \section{Case Analysis and Induction}
37.36
37.37 \subsection{Datatype Case Analysis}
37.38 @@ -1018,7 +1019,7 @@
37.39 \isacom{lemma} @{text[source]"I r s t \<Longrightarrow> \<dots>"}
37.40 \end{isabelle}
37.41 Applying the standard form of
37.42 -rule induction in such a situation will lead to strange and typically unproveable goals.
37.43 +rule induction in such a situation will lead to strange and typically unprovable goals.
37.44 We can easily reduce this situation to the standard one by introducing
37.45 new variables @{text x}, @{text y}, @{text z} and reformulating the goal like this:
37.46 \begin{isabelle}
37.47 @@ -1040,7 +1041,7 @@
37.48 proof(induction "Suc m" arbitrary: m rule: ev.induct)
37.49 fix n assume IH: "\<And>m. n = Suc m \<Longrightarrow> \<not> ev m"
37.50 show "\<not> ev (Suc n)"
37.51 - proof --"contradition"
37.52 + proof --"contradiction"
37.53 assume "ev(Suc n)"
37.54 thus False
37.55 proof cases --"rule inversion"
37.56 @@ -1075,45 +1076,38 @@
37.57 @{text induct} method.
37.58 \end{warn}
37.59
37.60 -\subsection{Exercises}
37.61 +
37.62 +\subsection*{Exercises}
37.63 +
37.64 +
37.65 +\exercise
37.66 +Give a structured proof by rule inversion:
37.67 +*}
37.68 +
37.69 +lemma assumes a: "ev(Suc(Suc n))" shows "ev n"
37.70 +(*<*)oops(*>*)
37.71 +
37.72 +text{*
37.73 +\endexercise
37.74 +
37.75 +\begin{exercise}
37.76 +Give a structured proof of @{prop "\<not> ev(Suc(Suc(Suc 0)))"}
37.77 +by rule inversions. If there are no cases to be proved you can close
37.78 +a proof immediateley with \isacom{qed}.
37.79 +\end{exercise}
37.80 +
37.81 +\begin{exercise}
37.82 +Recall predicate @{text star} from \autoref{sec:star} and @{text iter}
37.83 +from Exercise~\ref{exe:iter}. Prove @{prop "iter r n x y \<Longrightarrow> star r x y"}
37.84 +in a structured style, do not just sledgehammer each case of the
37.85 +required induction.
37.86 +\end{exercise}
37.87
37.88 \begin{exercise}
37.89 Define a recursive function @{text "elems ::"} @{typ"'a list \<Rightarrow> 'a set"}
37.90 and prove @{prop "x : elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"}.
37.91 \end{exercise}
37.92 -
37.93 -\begin{exercise}
37.94 -A context-free grammar can be seen as an inductive definition where each
37.95 -nonterminal $A$ is an inductively defined predicate on lists of terminal
37.96 -symbols: $A(w)$ mans
37.97 -that $w$ is in the language generated by $A$. For example, the production $S
37.98 -\to a S b$ can be viewed as the implication @{prop"S w \<Longrightarrow> S (a # w @ [b])"}
37.99 -where @{text a} and @{text b} are constructors of some datatype of terminal
37.100 -symbols: \isacom{datatype} @{text"tsymbs = a | b | \<dots>"}
37.101 -
37.102 -Define the two grammars
37.103 -\[
37.104 -\begin{array}{r@ {\quad}c@ {\quad}l}
37.105 -S &\to& \varepsilon \quad\mid\quad a~S~b \quad\mid\quad S~S \\
37.106 -T &\to& \varepsilon \quad\mid\quad T~a~T~b
37.107 -\end{array}
37.108 -\]
37.109 -($\varepsilon$ is the empty word)
37.110 -as two inductive predicates and prove @{prop"S w \<longleftrightarrow> T w"}.
37.111 -\end{exercise}
37.112 -
37.113 *}
37.114 -(*
37.115 -lemma "\<not> ev(Suc(Suc(Suc 0)))"
37.116 -proof
37.117 - assume "ev(Suc(Suc(Suc 0)))"
37.118 - then show False
37.119 - proof cases
37.120 - case evSS
37.121 - from `ev(Suc 0)` show False by cases
37.122 - qed
37.123 -qed
37.124 -*)
37.125
37.126 (*<*)
37.127 end
38.1 --- a/src/Doc/ProgProve/Logic.thy Thu Dec 05 17:52:12 2013 +0100
38.2 +++ b/src/Doc/ProgProve/Logic.thy Thu Dec 05 17:58:03 2013 +0100
38.3 @@ -141,6 +141,28 @@
38.4 See \cite{Nipkow-Main} for the wealth of further predefined functions in theory
38.5 @{theory Main}.
38.6
38.7 +
38.8 +\subsection*{Exercises}
38.9 +
38.10 +\exercise
38.11 +Start from the data type of binary trees defined earlier:
38.12 +*}
38.13 +
38.14 +datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"
38.15 +
38.16 +text{*
38.17 +Define a function @{text "set ::"} @{typ "'a tree \<Rightarrow> 'a set"}
38.18 +that returns the elements in a tree and a function
38.19 +@{text "ord ::"} @{typ "int tree \<Rightarrow> bool"}
38.20 +the tests if an @{typ "int tree"} is ordered.
38.21 +
38.22 +Define a function @{text ins} that inserts an element into an ordered @{typ "int tree"}
38.23 +while maintaining the order of the tree. If the element is already in the tree, the
38.24 +same tree should be returned. Prove correctness of @{text ins}:
38.25 +@{prop "set(ins x t) = {x} \<union> set t"} and @{prop "ord t \<Longrightarrow> ord(ins i t)"}.
38.26 +\endexercise
38.27 +
38.28 +
38.29 \section{Proof Automation}
38.30
38.31 So far we have only seen @{text simp} and @{text auto}: Both perform
38.32 @@ -459,12 +481,12 @@
38.33 text{* In this particular example we could have backchained with
38.34 @{thm[source] Suc_leD}, too, but because the premise is more complicated than the conclusion this can easily lead to nontermination.
38.35
38.36 -\subsection{Finding Theorems}
38.37 -
38.38 -Command \isacom{find{\isacharunderscorekeyword}theorems} searches for specific theorems in the current
38.39 -theory. Search criteria include pattern matching on terms and on names.
38.40 -For details see the Isabelle/Isar Reference Manual~\cite{IsarRef}.
38.41 -\bigskip
38.42 +%\subsection{Finding Theorems}
38.43 +%
38.44 +%Command \isacom{find{\isacharunderscorekeyword}theorems} searches for specific theorems in the current
38.45 +%theory. Search criteria include pattern matching on terms and on names.
38.46 +%For details see the Isabelle/Isar Reference Manual~\cite{IsarRef}.
38.47 +%\bigskip
38.48
38.49 \begin{warn}
38.50 To ease readability we will drop the question marks
38.51 @@ -708,8 +730,8 @@
38.52 apply(rename_tac u x y)
38.53 defer
38.54 (*>*)
38.55 -txt{* The induction is over @{prop"star r x y"} and we try to prove
38.56 -\mbox{@{prop"star r y z \<Longrightarrow> star r x z"}},
38.57 +txt{* The induction is over @{prop"star r x y"} (the first matching assumption)
38.58 +and we try to prove \mbox{@{prop"star r y z \<Longrightarrow> star r x z"}},
38.59 which we abbreviate by @{prop"P x y"}. These are our two subgoals:
38.60 @{subgoals[display,indent=0]}
38.61 The first one is @{prop"P x x"}, the result of case @{thm[source]refl},
38.62 @@ -764,6 +786,95 @@
38.63 conditions}. In rule inductions, these side-conditions appear as additional
38.64 assumptions. The \isacom{for} clause seen in the definition of the reflexive
38.65 transitive closure merely simplifies the form of the induction rule.
38.66 +
38.67 +
38.68 +\subsection*{Exercises}
38.69 +
38.70 +\begin{exercise}
38.71 +Formalise the following definition of palindromes
38.72 +\begin{itemize}
38.73 +\item The empty list and a singleton list are palindromes.
38.74 +\item If @{text xs} is a palindrome, so is @{term "a # xs @ [a]"}.
38.75 +\end{itemize}
38.76 +as an inductive predicate @{text "palindrome ::"} @{typ "'a list \<Rightarrow> bool"}
38.77 +and prove that @{prop "rev xs = xs"} if @{text xs} is a palindrome.
38.78 +\end{exercise}
38.79 +
38.80 +\exercise
38.81 +We could also have defined @{const star} as follows:
38.82 +*}
38.83 +
38.84 +inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
38.85 +refl': "star' r x x" |
38.86 +step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"
38.87 +
38.88 +text{*
38.89 +The single @{text r} step is performer after rather than before the @{text star'}
38.90 +steps. Prove @{prop "star' r x y \<Longrightarrow> star r x y"} and
38.91 +@{prop "star r x y \<Longrightarrow> star r' x y"}. You may need lemmas.
38.92 +Note that rule induction fails
38.93 +if the assumption about the inductive predicate is not the first assumption.
38.94 +\endexercise
38.95 +
38.96 +\begin{exercise}\label{exe:iter}
38.97 +Analogous to @{const star}, give an inductive definition of the @{text n}-fold iteration
38.98 +of a relation @{text r}: @{term "iter r n x y"} should hold if there are @{text x\<^sub>0}, \dots, @{text x\<^sub>n}
38.99 +such that @{prop"x = x\<^sub>0"}, @{prop"x\<^sub>n = y"} and @{text"r x\<^bsub>i\<^esub> x\<^bsub>i+1\<^esub>"} for
38.100 +all @{prop"i < n"}. Correct and prove the following claim:
38.101 +@{prop"star r x y \<Longrightarrow> iter r n x y"}.
38.102 +\end{exercise}
38.103 +
38.104 +\begin{exercise}
38.105 +A context-free grammar can be seen as an inductive definition where each
38.106 +nonterminal $A$ is an inductively defined predicate on lists of terminal
38.107 +symbols: $A(w)$ mans that $w$ is in the language generated by $A$.
38.108 +For example, the production $S \to a S b$ can be viewed as the implication
38.109 +@{prop"S w \<Longrightarrow> S (a # w @ [b])"} where @{text a} and @{text b} are terminal symbols,
38.110 +i.e., elements of some alphabet. The alphabet can be defined like this:
38.111 +\isacom{datatype} @{text"alpha = a | b | \<dots>"}
38.112 +
38.113 +Define the two grammars (where $\varepsilon$ is the empty word)
38.114 +\[
38.115 +\begin{array}{r@ {\quad}c@ {\quad}l}
38.116 +S &\to& \varepsilon \quad\mid\quad aSb \quad\mid\quad SS \\
38.117 +T &\to& \varepsilon \quad\mid\quad TaTb
38.118 +\end{array}
38.119 +\]
38.120 +as two inductive predicates.
38.121 +If you think of @{text a} and @{text b} as ``@{text "("}'' and ``@{text ")"}'',
38.122 +the grammars defines strings of balanced parentheses.
38.123 +Prove @{prop"T w \<Longrightarrow> S w"} and @{prop "S w \<Longrightarrow> T w"} separately and conclude
38.124 +@{prop "S w = T w"}.
38.125 +\end{exercise}
38.126 +
38.127 +\ifsem
38.128 +\begin{exercise}
38.129 +In \autoref{sec:AExp} we defined a recursive evaluation function
38.130 +@{text "aval :: aexp \<Rightarrow> state \<Rightarrow> val"}.
38.131 +Define an inductive evaluation predicate
38.132 +@{text "aval_rel :: aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool"}
38.133 +and prove that it agrees with the recursive function:
38.134 +@{prop "aval_rel a s v \<Longrightarrow> aval a s = v"},
38.135 +@{prop "aval a s = v \<Longrightarrow> aval_rel a s v"} and thus
38.136 +\noquotes{@{prop [source] "aval_rel a s v \<longleftrightarrow> aval a s = v"}}.
38.137 +\end{exercise}
38.138 +
38.139 +\begin{exercise}
38.140 +Consider the stack machine from Chapter~3
38.141 +and recall the concept of \concept{stack underflow}
38.142 +from Exercise~\ref{exe:stack-underflow}.
38.143 +Define an inductive predicate
38.144 +@{text "ok :: nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool"}
38.145 +such that @{text "ok n is n'"} means that with any initial stack of length
38.146 +@{text n} the instructions @{text "is"} can be executed
38.147 +without stack underflow and that the final stack has length @{text n'}.
38.148 +Prove that @{text ok} correctly computes the final stack size
38.149 +@{prop[display] "\<lbrakk>ok n is n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec is s stk) = n'"}
38.150 +and that instruction sequences generated by @{text comp}
38.151 +cannot cause stack underflow: \ @{text "ok n (comp a) ?"} \ for
38.152 +some suitable value of @{text "?"}.
38.153 +\end{exercise}
38.154 +\fi
38.155 *}
38.156 (*<*)
38.157 end
39.1 --- a/src/Doc/ProgProve/Types_and_funs.thy Thu Dec 05 17:52:12 2013 +0100
39.2 +++ b/src/Doc/ProgProve/Types_and_funs.thy Thu Dec 05 17:58:03 2013 +0100
39.3 @@ -156,7 +156,7 @@
39.4
39.5 fun div2 :: "nat \<Rightarrow> nat" where
39.6 "div2 0 = 0" |
39.7 -"div2 (Suc 0) = Suc 0" |
39.8 +"div2 (Suc 0) = 0" |
39.9 "div2 (Suc(Suc n)) = Suc(div2 n)"
39.10
39.11 text{* does not just define @{const div2} but also proves a
39.12 @@ -171,16 +171,25 @@
39.13 This customized induction rule can simplify inductive proofs. For example,
39.14 *}
39.15
39.16 -lemma "div2(n+n) = n"
39.17 +lemma "div2(n) = n div 2"
39.18 apply(induction n rule: div2.induct)
39.19
39.20 -txt{* yields the 3 subgoals
39.21 +txt{* (where the infix @{text div} is the predefined division operation)
39.22 +yields the 3 subgoals
39.23 @{subgoals[display,margin=65]}
39.24 An application of @{text auto} finishes the proof.
39.25 Had we used ordinary structural induction on @{text n},
39.26 the proof would have needed an additional
39.27 case analysis in the induction step.
39.28
39.29 +This example leads to the following induction heuristic:
39.30 +\begin{quote}
39.31 +\emph{Let @{text f} be a recursive function.
39.32 +If the definition of @{text f} is more complicated
39.33 +than having one equation for each constructor of some datatype,
39.34 +then properties of @{text f} are best proved via @{text "f.induct"}.}
39.35 +\end{quote}
39.36 +
39.37 The general case is often called \concept{computation induction},
39.38 because the induction follows the (terminating!) computation.
39.39 For every defining equation
39.40 @@ -200,6 +209,35 @@
39.41 But note that the induction rule does not mention @{text f} at all,
39.42 except in its name, and is applicable independently of @{text f}.
39.43
39.44 +
39.45 +\subsection*{Exercises}
39.46 +
39.47 +\begin{exercise}
39.48 +Starting from the type @{text "'a tree"} defined in the text, define
39.49 +a function @{text "contents ::"} @{typ "'a tree \<Rightarrow> 'a list"}
39.50 +that collects all values in a tree in a list, in any order,
39.51 +without removing duplicates.
39.52 +Then define a function @{text "treesum ::"} @{typ "nat tree \<Rightarrow> nat"}
39.53 +that sums up all values in a tree of natural numbers
39.54 +and prove @{prop "treesum t = listsum(contents t)"}.
39.55 +\end{exercise}
39.56 +
39.57 +\begin{exercise}
39.58 +Define a new type @{text "'a tree2"} of binary trees where values are also
39.59 +stored in the leaves of the tree. Also reformulate the
39.60 +@{const mirror} function accordingly. Define two functions
39.61 +@{text "pre_order"} and @{text "post_order"} of type @{text "'a tree2 \<Rightarrow> 'a list"}
39.62 +that traverse a tree and collect all stored values in the respective order in
39.63 +a list. Prove @{prop "pre_order (mirror t) = rev (post_order t)"}.
39.64 +\end{exercise}
39.65 +
39.66 +\begin{exercise}
39.67 +Define a function @{text "intersperse ::"} @{typ "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"}
39.68 +such that @{text "intersperse a [x\<^sub>1, ..., x\<^sub>n] = [x\<^sub>1, a, x\<^sub>2, a, ..., a, x\<^sub>n]"}.
39.69 +Now prove that @{prop "map f (intersperse a xs) = intersperse (f a) (map f xs)"}.
39.70 +\end{exercise}
39.71 +
39.72 +
39.73 \section{Induction Heuristics}
39.74
39.75 We have already noted that theorems about recursive functions are proved by
39.76 @@ -307,6 +345,18 @@
39.77 matters in some cases. The variables that need to be quantified are typically
39.78 those that change in recursive calls.
39.79
39.80 +
39.81 +\subsection*{Exercises}
39.82 +
39.83 +\begin{exercise}
39.84 +Write a tail-recursive variant of the @{text add} function on @{typ nat}:
39.85 +@{term "itadd :: nat \<Rightarrow> nat \<Rightarrow> nat"}.
39.86 +Tail-recursive means that in the recursive case, @{text itadd} needs to call
39.87 +itself directly: \mbox{@{term"itadd (Suc m) n"}} @{text"= itadd \<dots>"}.
39.88 +Prove @{prop "itadd m n = add m n"}.
39.89 +\end{exercise}
39.90 +
39.91 +
39.92 \section{Simplification}
39.93
39.94 So far we have talked a lot about simplifying terms without explaining the concept. \concept{Simplification} means
39.95 @@ -481,9 +531,37 @@
39.96 splits all case-expressions over natural numbers. For an arbitrary
39.97 datatype @{text t} it is @{text "t.split"} instead of @{thm[source] nat.split}.
39.98 Method @{text auto} can be modified in exactly the same way.
39.99 +The modifier @{text "split:"} can be followed by multiple names.
39.100 +Splitting if or case-expressions in the assumptions requires
39.101 +@{text "split: if_splits"} or @{text "split: t.splits"}.
39.102
39.103
39.104 -\subsection{Exercises}
39.105 +\subsection*{Exercises}
39.106 +
39.107 +\exercise\label{exe:tree0}
39.108 +Define a datatype @{text tree0} of binary tree skeletons which do not store
39.109 +any information, neither in the inner nodes nor in the leaves.
39.110 +Define a function @{text "nodes :: tree0 \<Rightarrow> nat"} that counts the number of
39.111 +all nodes (inner nodes and leaves) in such a tree.
39.112 +Consider the following recursive function:
39.113 +*}
39.114 +(*<*)
39.115 +datatype tree0 = Tip | Node tree0 tree0
39.116 +(*>*)
39.117 +fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
39.118 +"explode 0 t = t" |
39.119 +"explode (Suc n) t = explode n (Node t t)"
39.120 +
39.121 +text {*
39.122 +Find an equation expressing the size of a tree after exploding it
39.123 +(\noquotes{@{term [source] "nodes (explode n t)"}}) as a function
39.124 +of @{term "nodes t"} and @{text n}. Prove your equation.
39.125 +You may use the usual arithmetic operators including the exponentiation
39.126 +operator ``@{text"^"}''. For example, \noquotes{@{prop [source] "2 ^ 2 = 4"}}.
39.127 +
39.128 +Hint: simplifying with the list of theorems @{thm[source] algebra_simps}
39.129 +takes care of common algebraic properties of the arithmetic operators.
39.130 +\endexercise
39.131
39.132 \exercise
39.133 Define arithmetic expressions in one variable over integers (type @{typ int})
39.134 @@ -506,8 +584,7 @@
39.135 that transforms an expression into a polynomial. This may require auxiliary
39.136 functions. Prove that @{text coeffs} preserves the value of the expression:
39.137 \mbox{@{prop"evalp (coeffs e) x = eval e x"}.}
39.138 -Hint: simplifying with @{thm[source] algebra_simps} takes care of
39.139 -common algebraic properties of @{text "+"} and @{text "*"}.
39.140 +Hint: consider the hint in Exercise~\ref{exe:tree0}.
39.141 \endexercise
39.142 *}
39.143 (*<*)
40.1 --- a/src/Doc/ProgProve/document/intro-isabelle.tex Thu Dec 05 17:52:12 2013 +0100
40.2 +++ b/src/Doc/ProgProve/document/intro-isabelle.tex Thu Dec 05 17:58:03 2013 +0100
40.3 @@ -16,7 +16,7 @@
40.4 of recursive functions.
40.5 \ifsem
40.6 \autoref{sec:CaseStudyExp} contains a
40.7 -little case study: arithmetic and boolean expressions, their evaluation,
40.8 +small case study: arithmetic and boolean expressions, their evaluation,
40.9 optimization and compilation.
40.10 \fi
40.11 \autoref{ch:Logic} introduces the rest of HOL: the
40.12 @@ -35,8 +35,8 @@
40.13 % in the intersection of computation and logic.
40.14
40.15 This introduction to the core of Isabelle is intentionally concrete and
40.16 -example-based: we concentrate on examples that illustrate the typical cases;
40.17 -we do not explain the general case if it can be inferred from the examples.
40.18 +example-based: we concentrate on examples that illustrate the typical cases
40.19 +without explaining the general case if it can be inferred from the examples.
40.20 We cover the essentials (from a functional programming point of view) as
40.21 quickly and compactly as possible.
40.22 \ifsem
40.23 @@ -46,7 +46,7 @@
40.24 For a comprehensive treatment of all things Isabelle we recommend the
40.25 \emph{Isabelle/Isar Reference Manual}~\cite{IsarRef}, which comes with the
40.26 Isabelle distribution.
40.27 -The tutorial by Nipkow, Paulson and Wenzel~\cite{LNCS2283} (in its updated version that comes with the Isabelle distribution) is still recommended for the wealth of examples and material, but its proof style is outdated. In particular it fails to cover the structured proof language Isar.
40.28 +The tutorial by Nipkow, Paulson and Wenzel~\cite{LNCS2283} (in its updated version that comes with the Isabelle distribution) is still recommended for the wealth of examples and material, but its proof style is outdated. In particular it does not cover the structured proof language Isar.
40.29
40.30 %This introduction to Isabelle has grown out of many years of teaching
40.31 %Isabelle courses.
40.32 @@ -88,7 +88,7 @@
40.33
40.34 \ifsem\else
40.35 \paragraph{Acknowledgements}
40.36 -I wish to thank the following people for their comments
40.37 -on this document:
40.38 -Florian Haftmann, Ren\'{e} Thiemann and Christian Sternagel.
40.39 +I wish to thank the following people for their comments on this document:
40.40 +Florian Haftmann, Ren\'{e} Thiemann, Sean Seefried, Christian Sternagel
40.41 +and Carl Witty.
40.42 \fi
40.43 \ No newline at end of file
41.1 --- a/src/Doc/Sledgehammer/document/root.tex Thu Dec 05 17:52:12 2013 +0100
41.2 +++ b/src/Doc/Sledgehammer/document/root.tex Thu Dec 05 17:58:03 2013 +0100
41.3 @@ -121,8 +121,8 @@
41.4
41.5 For Isabelle/jEdit users, Sledgehammer provides an automatic mode that can be
41.6 enabled via the ``Auto Sledgehammer'' option under ``Plugins > Plugin Options >
41.7 -Isabelle > General.'' In this mode, Sledgehammer is run on every newly entered
41.8 -theorem.
41.9 +Isabelle > General.'' In this mode, a reduced version of Sledgehammer is run on
41.10 +every newly entered theorem for a few seconds.
41.11
41.12 \newbox\boxA
41.13 \setbox\boxA=\hbox{\texttt{NOSPAM}}
41.14 @@ -719,12 +719,16 @@
41.15 If you use Isabelle/jEdit, Sledgehammer also provides an automatic mode that can
41.16 be enabled via the ``Auto Sledgehammer'' option under ``Plugins > Plugin Options
41.17 > Isabelle > General.'' For automatic runs, only the first prover set using
41.18 -\textit{provers} (\S\ref{mode-of-operation}) is considered, fewer facts are
41.19 -passed to the prover, \textit{slice} (\S\ref{mode-of-operation}) is disabled,
41.20 -\textit{strict} (\S\ref{problem-encoding}) is enabled, \textit{verbose}
41.21 -(\S\ref{output-format}) and \textit{debug} (\S\ref{output-format}) are disabled,
41.22 -and \textit{timeout} (\S\ref{timeouts}) is superseded by the ``Auto Time Limit''
41.23 -option in jEdit. Sledgehammer's output is also more concise.
41.24 +\textit{provers} (\S\ref{mode-of-operation}) is considered (typically E),
41.25 +\textit{slice} (\S\ref{mode-of-operation}) is disabled,
41.26 +\textit{minimize} (\S\ref{mode-of-operation}) is disabled, fewer facts are
41.27 +passed to the prover, \textit{fact\_filter} (\S\ref{relevance-filter}) is set to
41.28 +\textit{mepo}, \textit{strict} (\S\ref{problem-encoding}) is enabled,
41.29 +\textit{verbose} (\S\ref{output-format}) and \textit{debug}
41.30 +(\S\ref{output-format}) are disabled, \textit{preplay\_timeout}
41.31 +(\S\ref{timeouts}) is set to 0, and \textit{timeout} (\S\ref{timeouts}) is
41.32 +superseded by the ``Auto Time Limit'' option in jEdit. Sledgehammer's output is
41.33 +also more concise.
41.34
41.35 \subsection{Metis}
41.36
41.37 @@ -999,8 +1003,7 @@
41.38 number of facts. For SMT solvers, several slices are tried with the same options
41.39 each time but fewer and fewer facts. According to benchmarks with a timeout of
41.40 30 seconds, slicing is a valuable optimization, and you should probably leave it
41.41 -enabled unless you are conducting experiments. This option is implicitly
41.42 -disabled for (short) automatic runs.
41.43 +enabled unless you are conducting experiments.
41.44
41.45 \nopagebreak
41.46 {\small See also \textit{verbose} (\S\ref{output-format}).}
41.47 @@ -1035,6 +1038,8 @@
41.48 simultaneously. The files are identified by the prefixes \texttt{prob\_} and
41.49 \texttt{mash\_}; you may safely remove them after Sledgehammer has run.
41.50
41.51 +\textbf{Warning:} This option is not thread-safe. Use at your own risks.
41.52 +
41.53 \nopagebreak
41.54 {\small See also \textit{debug} (\S\ref{output-format}).}
41.55 \end{enum}
41.56 @@ -1282,14 +1287,12 @@
41.57
41.58 \opfalse{verbose}{quiet}
41.59 Specifies whether the \textbf{sledgehammer} command should explain what it does.
41.60 -This option is implicitly disabled for automatic runs.
41.61
41.62 \opfalse{debug}{no\_debug}
41.63 Specifies whether Sledgehammer should display additional debugging information
41.64 beyond what \textit{verbose} already displays. Enabling \textit{debug} also
41.65 enables \textit{verbose} and \textit{blocking} (\S\ref{mode-of-operation})
41.66 -behind the scenes. The \textit{debug} option is implicitly disabled for
41.67 -automatic runs.
41.68 +behind the scenes.
41.69
41.70 \nopagebreak
41.71 {\small See also \textit{spy} (\S\ref{mode-of-operation}) and
41.72 @@ -1349,8 +1352,6 @@
41.73 \opdefault{timeout}{float\_or\_none}{\upshape 30}
41.74 Specifies the maximum number of seconds that the automatic provers should spend
41.75 searching for a proof. This excludes problem preparation and is a soft limit.
41.76 -For automatic runs, the ``Auto Time Limit'' option under ``Plugins > Plugin
41.77 -Options > Isabelle > General'' is used instead.
41.78
41.79 \opdefault{preplay\_timeout}{float\_or\_none}{\upshape 3}
41.80 Specifies the maximum number of seconds that \textit{metis} or \textit{smt}
42.1 --- a/src/Doc/System/Sessions.thy Thu Dec 05 17:52:12 2013 +0100
42.2 +++ b/src/Doc/System/Sessions.thy Thu Dec 05 17:58:03 2013 +0100
42.3 @@ -399,7 +399,7 @@
42.4 \smallskip Build some session images with cleanup of their
42.5 descendants, while retaining their ancestry:
42.6 \begin{ttbox}
42.7 -isabelle build -b -c HOL-Boogie HOL-SPARK
42.8 +isabelle build -b -c HOL-Algebra HOL-Word
42.9 \end{ttbox}
42.10
42.11 \smallskip Clean all sessions without building anything:
43.1 --- a/src/Doc/Tutorial/document/rules.tex Thu Dec 05 17:52:12 2013 +0100
43.2 +++ b/src/Doc/Tutorial/document/rules.tex Thu Dec 05 17:58:03 2013 +0100
43.3 @@ -1,4 +1,4 @@
43.4 -%!TEX root = ../tutorial.tex
43.5 +%!TEX root = root.tex
43.6 \chapter{The Rules of the Game}
43.7 \label{chap:rules}
43.8
43.9 @@ -33,6 +33,8 @@
43.10 one symbol only. For predicate logic this can be
43.11 done, but when users define their own concepts they typically
43.12 have to refer to other symbols as well. It is best not to be dogmatic.
43.13 +Our system is not based on pure natural deduction, but includes elements from the sequent calculus
43.14 +and free-variable tableaux.
43.15
43.16 Natural deduction generally deserves its name. It is easy to use. Each
43.17 proof step consists of identifying the outermost symbol of a formula and
43.18 @@ -240,13 +242,14 @@
43.19 of a conjunction. Rules of this sort (where the conclusion is a subformula of a
43.20 premise) are called \textbf{destruction} rules because they take apart and destroy
43.21 a premise.%
43.22 -\footnote{This Isabelle terminology has no counterpart in standard logic texts,
43.23 +\footnote{This Isabelle terminology is not used in standard logic texts,
43.24 although the distinction between the two forms of elimination rule is well known.
43.25 Girard \cite[page 74]{girard89},\index{Girard, Jean-Yves|fnote}
43.26 for example, writes ``The elimination rules
43.27 [for $\disj$ and $\exists$] are very
43.28 bad. What is catastrophic about them is the parasitic presence of a formula [$R$]
43.29 -which has no structural link with the formula which is eliminated.''}
43.30 +which has no structural link with the formula which is eliminated.''
43.31 +These Isabelle rules are inspired by the sequent calculus.}
43.32
43.33 The first proof step applies conjunction introduction, leaving
43.34 two subgoals:
44.1 --- a/src/Doc/Tutorial/document/sets.tex Thu Dec 05 17:52:12 2013 +0100
44.2 +++ b/src/Doc/Tutorial/document/sets.tex Thu Dec 05 17:58:03 2013 +0100
44.3 @@ -660,8 +660,8 @@
44.4 \textbf{Composition} of relations (the infix \sdx{O}) is also
44.5 available:
44.6 \begin{isabelle}
44.7 -r\ O\ s\ \isasymequiv\ \isacharbraceleft(x,z).\ \isasymexists y.\ (x,y)\ \isasymin\ s\ \isasymand\ (y,z)\ \isasymin\ r\isacharbraceright
44.8 -\rulenamedx{rel_comp_def}
44.9 +r\ O\ s\ = \isacharbraceleft(x,z).\ \isasymexists y.\ (x,y)\ \isasymin\ s\ \isasymand\ (y,z)\ \isasymin\ r\isacharbraceright
44.10 +\rulenamedx{relcomp_unfold}
44.11 \end{isabelle}
44.12 %
44.13 This is one of the many lemmas proved about these concepts:
44.14 @@ -677,7 +677,7 @@
44.15 \isasymlbrakk r\isacharprime\ \isasymsubseteq\ r;\ s\isacharprime\
44.16 \isasymsubseteq\ s\isasymrbrakk\ \isasymLongrightarrow\ r\isacharprime\ O\
44.17 s\isacharprime\ \isasymsubseteq\ r\ O\ s%
44.18 -\rulename{rel_comp_mono}
44.19 +\rulename{relcomp_mono}
44.20 \end{isabelle}
44.21
44.22 \indexbold{converse!of a relation}%
44.23 @@ -695,7 +695,7 @@
44.24 Here is a typical law proved about converse and composition:
44.25 \begin{isabelle}
44.26 (r\ O\ s)\isasyminverse\ =\ s\isasyminverse\ O\ r\isasyminverse
44.27 -\rulename{converse_rel_comp}
44.28 +\rulename{converse_relcomp}
44.29 \end{isabelle}
44.30
44.31 \indexbold{image!under a relation}%
45.1 --- a/src/Doc/manual.bib Thu Dec 05 17:52:12 2013 +0100
45.2 +++ b/src/Doc/manual.bib Thu Dec 05 17:58:03 2013 +0100
45.3 @@ -194,7 +194,7 @@
45.4 @incollection{basin91,
45.5 author = {David Basin and Matt Kaufmann},
45.6 title = {The {Boyer-Moore} Prover and {Nuprl}: An Experimental
45.7 - Comparison},
45.8 + Comparison},
45.9 crossref = {huet-plotkin91},
45.10 pages = {89-119}}
45.11
45.12 @@ -472,7 +472,7 @@
45.13 @book{constable86,
45.14 author = {R. L. Constable and others},
45.15 title = {Implementing Mathematics with the Nuprl Proof
45.16 - Development System},
45.17 + Development System},
45.18 publisher = Prentice,
45.19 year = 1986}
45.20
45.21 @@ -505,7 +505,7 @@
45.22 @incollection{dybjer91,
45.23 author = {Peter Dybjer},
45.24 title = {Inductive Sets and Families in {Martin-L{\"o}f's} Type
45.25 - Theory and Their Set-Theoretic Semantics},
45.26 + Theory and Their Set-Theoretic Semantics},
45.27 crossref = {huet-plotkin91},
45.28 pages = {280-306}}
45.29
45.30 @@ -533,7 +533,7 @@
45.31 @InProceedings{felty91a,
45.32 Author = {Amy Felty},
45.33 Title = {A Logic Program for Transforming Sequent Proofs to Natural
45.34 - Deduction Proofs},
45.35 + Deduction Proofs},
45.36 crossref = {extensions91},
45.37 pages = {157-178}}
45.38
45.39 @@ -566,9 +566,9 @@
45.40
45.41 @inproceedings{OBJ,
45.42 author = {K. Futatsugi and J.A. Goguen and Jean-Pierre Jouannaud
45.43 - and J. Meseguer},
45.44 + and J. Meseguer},
45.45 title = {Principles of {OBJ2}},
45.46 - booktitle = POPL,
45.47 + booktitle = POPL,
45.48 year = 1985,
45.49 pages = {52-66}}
45.50
45.51 @@ -576,7 +576,7 @@
45.52
45.53 @book{gallier86,
45.54 author = {J. H. Gallier},
45.55 - title = {Logic for Computer Science:
45.56 + title = {Logic for Computer Science:
45.57 Foundations of Automatic Theorem Proving},
45.58 year = 1986,
45.59 publisher = {Harper \& Row}}
45.60 @@ -605,8 +605,8 @@
45.61 author = {Jean-Yves Girard},
45.62 title = {Proofs and Types},
45.63 year = 1989,
45.64 - publisher = CUP,
45.65 - note = {Translated by Yves LaFont and Paul Taylor}}
45.66 + publisher = CUP,
45.67 + note = {Translated by Yves Lafont and Paul Taylor}}
45.68
45.69 @Book{mgordon-hol,
45.70 editor = {M. J. C. Gordon and T. F. Melham},
45.71 @@ -777,21 +777,21 @@
45.72
45.73 @article{huet78,
45.74 author = {G. P. Huet and B. Lang},
45.75 - title = {Proving and Applying Program Transformations Expressed with
45.76 + title = {Proving and Applying Program Transformations Expressed with
45.77 Second-Order Patterns},
45.78 journal = acta,
45.79 volume = 11,
45.80 - year = 1978,
45.81 + year = 1978,
45.82 pages = {31-55}}
45.83
45.84 @inproceedings{huet88,
45.85 author = {G{\'e}rard Huet},
45.86 title = {Induction Principles Formalized in the {Calculus of
45.87 - Constructions}},
45.88 + Constructions}},
45.89 booktitle = {Programming of Future Generation Computers},
45.90 editor = {K. Fuchi and M. Nivat},
45.91 year = 1988,
45.92 - pages = {205-216},
45.93 + pages = {205-216},
45.94 publisher = {Elsevier}}
45.95
45.96 @inproceedings{Huffman-Kuncar:2013:lifting_transfer,
45.97 @@ -843,7 +843,7 @@
45.98 %K
45.99
45.100 @InProceedings{kammueller-locales,
45.101 - author = {Florian Kamm{\"u}ller and Markus Wenzel and
45.102 + author = {Florian Kamm{\"u}ller and Markus Wenzel and
45.103 Lawrence C. Paulson},
45.104 title = {Locales: A Sectioning Concept for {Isabelle}},
45.105 crossref = {tphols99}}
45.106 @@ -926,7 +926,7 @@
45.107 note = "\url{https://github.com/frelindb/agsyHOL}"}
45.108
45.109 @incollection{lochbihler-2010,
45.110 - title = "Coinduction",
45.111 + title = "Coinductive",
45.112 author = "Andreas Lochbihler",
45.113 booktitle = "The Archive of Formal Proofs",
45.114 editor = "Gerwin Klein and Tobias Nipkow and Lawrence C. Paulson",
45.115 @@ -944,7 +944,7 @@
45.116 author = {Gavin Lowe},
45.117 title = {Breaking and Fixing the {Needham}-{Schroeder} Public-Key
45.118 Protocol using {CSP} and {FDR}},
45.119 - booktitle = {Tools and Algorithms for the Construction and Analysis
45.120 + booktitle = {Tools and Algorithms for the Construction and Analysis
45.121 of Systems: second international workshop, TACAS '96},
45.122 editor = {T. Margaria and B. Steffen},
45.123 series = {LNCS 1055},
45.124 @@ -978,7 +978,7 @@
45.125 @incollection{melham89,
45.126 author = {Thomas F. Melham},
45.127 title = {Automating Recursive Type Definitions in Higher Order
45.128 - Logic},
45.129 + Logic},
45.130 pages = {341-386},
45.131 crossref = {birtwistle89}}
45.132
45.133 @@ -1057,7 +1057,7 @@
45.134
45.135 @InProceedings{NaraschewskiW-TPHOLs98,
45.136 author = {Wolfgang Naraschewski and Markus Wenzel},
45.137 - title =
45.138 + title =
45.139 {Object-Oriented Verification based on Record Subtyping in
45.140 Higher-Order Logic},
45.141 crossref = {tphols98}}
45.142 @@ -1190,8 +1190,8 @@
45.143 @book{nordstrom90,
45.144 author = {Bengt {Nordstr{\"o}m} and Kent Petersson and Jan Smith},
45.145 title = {Programming in {Martin-L{\"o}f}'s Type Theory. An
45.146 - Introduction},
45.147 - publisher = {Oxford University Press},
45.148 + Introduction},
45.149 + publisher = {Oxford University Press},
45.150 year = 1990}
45.151
45.152 %O
45.153 @@ -1251,7 +1251,7 @@
45.154 @InProceedings{paulson-COLOG,
45.155 author = {Lawrence C. Paulson},
45.156 title = {A Formulation of the Simple Theory of Types (for
45.157 - {Isabelle})},
45.158 + {Isabelle})},
45.159 pages = {246-274},
45.160 crossref = {colog88},
45.161 url = {\url{http://www.cl.cam.ac.uk/Research/Reports/TR175-lcp-simple.dvi.gz}}}
45.162 @@ -1304,7 +1304,7 @@
45.163 %replaces paulson-final
45.164 @Article{paulson-mscs,
45.165 author = {Lawrence C. Paulson},
45.166 - title = {Final Coalgebras as Greatest Fixed Points
45.167 + title = {Final Coalgebras as Greatest Fixed Points
45.168 in {ZF} Set Theory},
45.169 journal = {Mathematical Structures in Computer Science},
45.170 year = 1999,
45.171 @@ -1337,9 +1337,9 @@
45.172 crossref = {milner-fest}}
45.173
45.174 @book{milner-fest,
45.175 - title = {Proof, Language, and Interaction:
45.176 + title = {Proof, Language, and Interaction:
45.177 Essays in Honor of {Robin Milner}},
45.178 - booktitle = {Proof, Language, and Interaction:
45.179 + booktitle = {Proof, Language, and Interaction:
45.180 Essays in Honor of {Robin Milner}},
45.181 publisher = MIT,
45.182 year = 2000,
45.183 @@ -1427,7 +1427,7 @@
45.184 @book{paulson87,
45.185 author = {Lawrence C. Paulson},
45.186 title = {Logic and Computation: Interactive proof with Cambridge
45.187 - LCF},
45.188 + LCF},
45.189 year = 1987,
45.190 publisher = CUP}
45.191
45.192 @@ -1470,7 +1470,7 @@
45.193 @article{pelletier86,
45.194 author = {F. J. Pelletier},
45.195 title = {Seventy-five Problems for Testing Automatic Theorem
45.196 - Provers},
45.197 + Provers},
45.198 journal = JAR,
45.199 volume = 2,
45.200 pages = {191-216},
45.201 @@ -1486,13 +1486,13 @@
45.202 publisher = CUP,
45.203 year = 1993}
45.204
45.205 -@Article{pitts94,
45.206 +@Article{pitts94,
45.207 author = {Andrew M. Pitts},
45.208 title = {A Co-induction Principle for Recursively Defined Domains},
45.209 journal = TCS,
45.210 - volume = 124,
45.211 + volume = 124,
45.212 pages = {195-219},
45.213 - year = 1994}
45.214 + year = 1994}
45.215
45.216 @Article{plaisted90,
45.217 author = {David A. Plaisted},
45.218 @@ -1561,7 +1561,7 @@
45.219 @inproceedings{saaltink-fme,
45.220 author = {Mark Saaltink and Sentot Kromodimoeljo and Bill Pase and
45.221 Dan Craigen and Irwin Meisels},
45.222 - title = {An {EVES} Data Abstraction Example},
45.223 + title = {An {EVES} Data Abstraction Example},
45.224 pages = {578-596},
45.225 crossref = {fme93}}
45.226
45.227 @@ -1897,7 +1897,7 @@
45.228 author = {A. N. Whitehead and B. Russell},
45.229 title = {Principia Mathematica},
45.230 year = 1962,
45.231 - publisher = CUP,
45.232 + publisher = CUP,
45.233 note = {Paperback edition to *56,
45.234 abridged from the 2nd edition (1927)}}
45.235
45.236 @@ -1982,9 +1982,9 @@
45.237 @book{birtwistle89,
45.238 editor = {Graham Birtwistle and P. A. Subrahmanyam},
45.239 title = {Current Trends in Hardware Verification and Automated
45.240 - Theorem Proving},
45.241 + Theorem Proving},
45.242 booktitle = {Current Trends in Hardware Verification and Automated
45.243 - Theorem Proving},
45.244 + Theorem Proving},
45.245 publisher = {Springer},
45.246 year = 1989}
45.247
45.248 @@ -1997,9 +1997,9 @@
45.249
45.250 @Proceedings{cade12,
45.251 editor = {Alan Bundy},
45.252 - title = {Automated Deduction --- {CADE}-12
45.253 + title = {Automated Deduction --- {CADE}-12
45.254 International Conference},
45.255 - booktitle = {Automated Deduction --- {CADE}-12
45.256 + booktitle = {Automated Deduction --- {CADE}-12
45.257 International Conference},
45.258 year = 1994,
45.259 series = {LNAI 814},
45.260 @@ -2059,7 +2059,7 @@
45.261 title = {Extensions of Logic Programming},
45.262 booktitle = {Extensions of Logic Programming},
45.263 year = 1991,
45.264 - series = {LNAI 475},
45.265 + series = {LNAI 475},
45.266 publisher = {Springer}}
45.267
45.268 @proceedings{cade10,
45.269 @@ -2078,9 +2078,9 @@
45.270 year = 1993}
45.271
45.272 @book{wos-fest,
45.273 - title = {Automated Reasoning and its Applications:
45.274 + title = {Automated Reasoning and its Applications:
45.275 Essays in Honor of {Larry Wos}},
45.276 - booktitle = {Automated Reasoning and its Applications:
45.277 + booktitle = {Automated Reasoning and its Applications:
45.278 Essays in Honor of {Larry Wos}},
45.279 publisher = MIT,
45.280 year = 1997,
46.1 --- a/src/HOL/ATP.thy Thu Dec 05 17:52:12 2013 +0100
46.2 +++ b/src/HOL/ATP.thy Thu Dec 05 17:58:03 2013 +0100
46.3 @@ -18,34 +18,34 @@
46.4
46.5 subsection {* Higher-order reasoning helpers *}
46.6
46.7 -definition fFalse :: bool where [no_atp]:
46.8 +definition fFalse :: bool where
46.9 "fFalse \<longleftrightarrow> False"
46.10
46.11 -definition fTrue :: bool where [no_atp]:
46.12 +definition fTrue :: bool where
46.13 "fTrue \<longleftrightarrow> True"
46.14
46.15 -definition fNot :: "bool \<Rightarrow> bool" where [no_atp]:
46.16 +definition fNot :: "bool \<Rightarrow> bool" where
46.17 "fNot P \<longleftrightarrow> \<not> P"
46.18
46.19 -definition fComp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where [no_atp]:
46.20 +definition fComp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where
46.21 "fComp P = (\<lambda>x. \<not> P x)"
46.22
46.23 -definition fconj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
46.24 +definition fconj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
46.25 "fconj P Q \<longleftrightarrow> P \<and> Q"
46.26
46.27 -definition fdisj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
46.28 +definition fdisj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
46.29 "fdisj P Q \<longleftrightarrow> P \<or> Q"
46.30
46.31 -definition fimplies :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
46.32 +definition fimplies :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
46.33 "fimplies P Q \<longleftrightarrow> (P \<longrightarrow> Q)"
46.34
46.35 -definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where [no_atp]:
46.36 +definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
46.37 "fequal x y \<longleftrightarrow> (x = y)"
46.38
46.39 -definition fAll :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where [no_atp]:
46.40 +definition fAll :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
46.41 "fAll P \<longleftrightarrow> All P"
46.42
46.43 -definition fEx :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where [no_atp]:
46.44 +definition fEx :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
46.45 "fEx P \<longleftrightarrow> Ex P"
46.46
46.47 lemma fTrue_ne_fFalse: "fFalse \<noteq> fTrue"
47.1 --- a/src/HOL/Archimedean_Field.thy Thu Dec 05 17:52:12 2013 +0100
47.2 +++ b/src/HOL/Archimedean_Field.thy Thu Dec 05 17:58:03 2013 +0100
47.3 @@ -129,12 +129,8 @@
47.4 fix y z assume
47.5 "of_int y \<le> x \<and> x < of_int (y + 1)"
47.6 "of_int z \<le> x \<and> x < of_int (z + 1)"
47.7 - then have
47.8 - "of_int y \<le> x" "x < of_int (y + 1)"
47.9 - "of_int z \<le> x" "x < of_int (z + 1)"
47.10 - by simp_all
47.11 - from le_less_trans [OF `of_int y \<le> x` `x < of_int (z + 1)`]
47.12 - le_less_trans [OF `of_int z \<le> x` `x < of_int (y + 1)`]
47.13 + with le_less_trans [of "of_int y" "x" "of_int (z + 1)"]
47.14 + le_less_trans [of "of_int z" "x" "of_int (y + 1)"]
47.15 show "y = z" by (simp del: of_int_add)
47.16 qed
47.17
47.18 @@ -208,8 +204,8 @@
47.19 lemma floor_numeral [simp]: "floor (numeral v) = numeral v"
47.20 using floor_of_int [of "numeral v"] by simp
47.21
47.22 -lemma floor_neg_numeral [simp]: "floor (neg_numeral v) = neg_numeral v"
47.23 - using floor_of_int [of "neg_numeral v"] by simp
47.24 +lemma floor_neg_numeral [simp]: "floor (- numeral v) = - numeral v"
47.25 + using floor_of_int [of "- numeral v"] by simp
47.26
47.27 lemma zero_le_floor [simp]: "0 \<le> floor x \<longleftrightarrow> 0 \<le> x"
47.28 by (simp add: le_floor_iff)
47.29 @@ -222,7 +218,7 @@
47.30 by (simp add: le_floor_iff)
47.31
47.32 lemma neg_numeral_le_floor [simp]:
47.33 - "neg_numeral v \<le> floor x \<longleftrightarrow> neg_numeral v \<le> x"
47.34 + "- numeral v \<le> floor x \<longleftrightarrow> - numeral v \<le> x"
47.35 by (simp add: le_floor_iff)
47.36
47.37 lemma zero_less_floor [simp]: "0 < floor x \<longleftrightarrow> 1 \<le> x"
47.38 @@ -236,7 +232,7 @@
47.39 by (simp add: less_floor_iff)
47.40
47.41 lemma neg_numeral_less_floor [simp]:
47.42 - "neg_numeral v < floor x \<longleftrightarrow> neg_numeral v + 1 \<le> x"
47.43 + "- numeral v < floor x \<longleftrightarrow> - numeral v + 1 \<le> x"
47.44 by (simp add: less_floor_iff)
47.45
47.46 lemma floor_le_zero [simp]: "floor x \<le> 0 \<longleftrightarrow> x < 1"
47.47 @@ -250,7 +246,7 @@
47.48 by (simp add: floor_le_iff)
47.49
47.50 lemma floor_le_neg_numeral [simp]:
47.51 - "floor x \<le> neg_numeral v \<longleftrightarrow> x < neg_numeral v + 1"
47.52 + "floor x \<le> - numeral v \<longleftrightarrow> x < - numeral v + 1"
47.53 by (simp add: floor_le_iff)
47.54
47.55 lemma floor_less_zero [simp]: "floor x < 0 \<longleftrightarrow> x < 0"
47.56 @@ -264,7 +260,7 @@
47.57 by (simp add: floor_less_iff)
47.58
47.59 lemma floor_less_neg_numeral [simp]:
47.60 - "floor x < neg_numeral v \<longleftrightarrow> x < neg_numeral v"
47.61 + "floor x < - numeral v \<longleftrightarrow> x < - numeral v"
47.62 by (simp add: floor_less_iff)
47.63
47.64 text {* Addition and subtraction of integers *}
47.65 @@ -276,10 +272,6 @@
47.66 "floor (x + numeral v) = floor x + numeral v"
47.67 using floor_add_of_int [of x "numeral v"] by simp
47.68
47.69 -lemma floor_add_neg_numeral [simp]:
47.70 - "floor (x + neg_numeral v) = floor x + neg_numeral v"
47.71 - using floor_add_of_int [of x "neg_numeral v"] by simp
47.72 -
47.73 lemma floor_add_one [simp]: "floor (x + 1) = floor x + 1"
47.74 using floor_add_of_int [of x 1] by simp
47.75
47.76 @@ -290,10 +282,6 @@
47.77 "floor (x - numeral v) = floor x - numeral v"
47.78 using floor_diff_of_int [of x "numeral v"] by simp
47.79
47.80 -lemma floor_diff_neg_numeral [simp]:
47.81 - "floor (x - neg_numeral v) = floor x - neg_numeral v"
47.82 - using floor_diff_of_int [of x "neg_numeral v"] by simp
47.83 -
47.84 lemma floor_diff_one [simp]: "floor (x - 1) = floor x - 1"
47.85 using floor_diff_of_int [of x 1] by simp
47.86
47.87 @@ -357,8 +345,8 @@
47.88 lemma ceiling_numeral [simp]: "ceiling (numeral v) = numeral v"
47.89 using ceiling_of_int [of "numeral v"] by simp
47.90
47.91 -lemma ceiling_neg_numeral [simp]: "ceiling (neg_numeral v) = neg_numeral v"
47.92 - using ceiling_of_int [of "neg_numeral v"] by simp
47.93 +lemma ceiling_neg_numeral [simp]: "ceiling (- numeral v) = - numeral v"
47.94 + using ceiling_of_int [of "- numeral v"] by simp
47.95
47.96 lemma ceiling_le_zero [simp]: "ceiling x \<le> 0 \<longleftrightarrow> x \<le> 0"
47.97 by (simp add: ceiling_le_iff)
47.98 @@ -371,7 +359,7 @@
47.99 by (simp add: ceiling_le_iff)
47.100
47.101 lemma ceiling_le_neg_numeral [simp]:
47.102 - "ceiling x \<le> neg_numeral v \<longleftrightarrow> x \<le> neg_numeral v"
47.103 + "ceiling x \<le> - numeral v \<longleftrightarrow> x \<le> - numeral v"
47.104 by (simp add: ceiling_le_iff)
47.105
47.106 lemma ceiling_less_zero [simp]: "ceiling x < 0 \<longleftrightarrow> x \<le> -1"
47.107 @@ -385,7 +373,7 @@
47.108 by (simp add: ceiling_less_iff)
47.109
47.110 lemma ceiling_less_neg_numeral [simp]:
47.111 - "ceiling x < neg_numeral v \<longleftrightarrow> x \<le> neg_numeral v - 1"
47.112 + "ceiling x < - numeral v \<longleftrightarrow> x \<le> - numeral v - 1"
47.113 by (simp add: ceiling_less_iff)
47.114
47.115 lemma zero_le_ceiling [simp]: "0 \<le> ceiling x \<longleftrightarrow> -1 < x"
47.116 @@ -399,7 +387,7 @@
47.117 by (simp add: le_ceiling_iff)
47.118
47.119 lemma neg_numeral_le_ceiling [simp]:
47.120 - "neg_numeral v \<le> ceiling x \<longleftrightarrow> neg_numeral v - 1 < x"
47.121 + "- numeral v \<le> ceiling x \<longleftrightarrow> - numeral v - 1 < x"
47.122 by (simp add: le_ceiling_iff)
47.123
47.124 lemma zero_less_ceiling [simp]: "0 < ceiling x \<longleftrightarrow> 0 < x"
47.125 @@ -413,7 +401,7 @@
47.126 by (simp add: less_ceiling_iff)
47.127
47.128 lemma neg_numeral_less_ceiling [simp]:
47.129 - "neg_numeral v < ceiling x \<longleftrightarrow> neg_numeral v < x"
47.130 + "- numeral v < ceiling x \<longleftrightarrow> - numeral v < x"
47.131 by (simp add: less_ceiling_iff)
47.132
47.133 text {* Addition and subtraction of integers *}
47.134 @@ -425,10 +413,6 @@
47.135 "ceiling (x + numeral v) = ceiling x + numeral v"
47.136 using ceiling_add_of_int [of x "numeral v"] by simp
47.137
47.138 -lemma ceiling_add_neg_numeral [simp]:
47.139 - "ceiling (x + neg_numeral v) = ceiling x + neg_numeral v"
47.140 - using ceiling_add_of_int [of x "neg_numeral v"] by simp
47.141 -
47.142 lemma ceiling_add_one [simp]: "ceiling (x + 1) = ceiling x + 1"
47.143 using ceiling_add_of_int [of x 1] by simp
47.144
47.145 @@ -439,10 +423,6 @@
47.146 "ceiling (x - numeral v) = ceiling x - numeral v"
47.147 using ceiling_diff_of_int [of x "numeral v"] by simp
47.148
47.149 -lemma ceiling_diff_neg_numeral [simp]:
47.150 - "ceiling (x - neg_numeral v) = ceiling x - neg_numeral v"
47.151 - using ceiling_diff_of_int [of x "neg_numeral v"] by simp
47.152 -
47.153 lemma ceiling_diff_one [simp]: "ceiling (x - 1) = ceiling x - 1"
47.154 using ceiling_diff_of_int [of x 1] by simp
47.155
48.1 --- a/src/HOL/BNF/BNF.thy Thu Dec 05 17:52:12 2013 +0100
48.2 +++ b/src/HOL/BNF/BNF.thy Thu Dec 05 17:58:03 2013 +0100
48.3 @@ -10,7 +10,7 @@
48.4 header {* Bounded Natural Functors for (Co)datatypes *}
48.5
48.6 theory BNF
48.7 -imports More_BNFs BNF_LFP BNF_GFP Coinduction
48.8 +imports Countable_Set_Type BNF_LFP BNF_GFP BNF_Decl
48.9 begin
48.10
48.11 hide_const (open) image2 image2p vimage2p Gr Grp collect fsts snds setl setr
49.1 --- a/src/HOL/BNF/BNF_Comp.thy Thu Dec 05 17:52:12 2013 +0100
49.2 +++ b/src/HOL/BNF/BNF_Comp.thy Thu Dec 05 17:58:03 2013 +0100
49.3 @@ -11,6 +11,9 @@
49.4 imports Basic_BNFs
49.5 begin
49.6
49.7 +lemma wpull_id: "wpull UNIV B1 B2 id id id id"
49.8 +unfolding wpull_def by simp
49.9 +
49.10 lemma empty_natural: "(\<lambda>_. {}) o f = image g o (\<lambda>_. {})"
49.11 by (rule ext) simp
49.12
50.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
50.2 +++ b/src/HOL/BNF/BNF_Decl.thy Thu Dec 05 17:58:03 2013 +0100
50.3 @@ -0,0 +1,18 @@
50.4 +(* Title: HOL/BNF/BNF_Decl.thy
50.5 + Author: Dmitriy Traytel, TU Muenchen
50.6 + Copyright 2013
50.7 +
50.8 +Axiomatic declaration of bounded natural functors.
50.9 +*)
50.10 +
50.11 +header {* Axiomatic declaration of Bounded Natural Functors *}
50.12 +
50.13 +theory BNF_Decl
50.14 +imports BNF_Def
50.15 +keywords
50.16 + "bnf_decl" :: thy_decl
50.17 +begin
50.18 +
50.19 +ML_file "Tools/bnf_decl.ML"
50.20 +
50.21 +end
51.1 --- a/src/HOL/BNF/BNF_Def.thy Thu Dec 05 17:52:12 2013 +0100
51.2 +++ b/src/HOL/BNF/BNF_Def.thy Thu Dec 05 17:58:03 2013 +0100
51.3 @@ -9,6 +9,8 @@
51.4
51.5 theory BNF_Def
51.6 imports BNF_Util
51.7 + (*FIXME: register fundef_cong attribute in an interpretation to remove this dependency*)
51.8 + FunDef
51.9 keywords
51.10 "print_bnfs" :: diag and
51.11 "bnf" :: thy_goal
51.12 @@ -190,17 +192,17 @@
51.13 lemma vimage2pI: "R (f x) (g y) \<Longrightarrow> vimage2p f g R x y"
51.14 unfolding vimage2p_def by -
51.15
51.16 -lemma vimage2pD: "vimage2p f g R x y \<Longrightarrow> R (f x) (g y)"
51.17 - unfolding vimage2p_def by -
51.18 -
51.19 lemma fun_rel_iff_leq_vimage2p: "(fun_rel R S) f g = (R \<le> vimage2p f g S)"
51.20 unfolding fun_rel_def vimage2p_def by auto
51.21
51.22 lemma convol_image_vimage2p: "<f o fst, g o snd> ` Collect (split (vimage2p f g R)) \<subseteq> Collect (split R)"
51.23 unfolding vimage2p_def convol_def by auto
51.24
51.25 +(*FIXME: duplicates lemma from Record.thy*)
51.26 +lemma o_eq_dest_lhs: "a o b = c \<Longrightarrow> a (b v) = c v"
51.27 + by clarsimp
51.28 +
51.29 ML_file "Tools/bnf_def_tactics.ML"
51.30 ML_file "Tools/bnf_def.ML"
51.31
51.32 -
51.33 end
52.1 --- a/src/HOL/BNF/BNF_FP_Base.thy Thu Dec 05 17:52:12 2013 +0100
52.2 +++ b/src/HOL/BNF/BNF_FP_Base.thy Thu Dec 05 17:58:03 2013 +0100
52.3 @@ -13,12 +13,6 @@
52.4 imports BNF_Comp Ctr_Sugar
52.5 begin
52.6
52.7 -lemma not_TrueE: "\<not> True \<Longrightarrow> P"
52.8 -by (erule notE, rule TrueI)
52.9 -
52.10 -lemma neq_eq_eq_contradict: "\<lbrakk>t \<noteq> u; s = t; s = u\<rbrakk> \<Longrightarrow> P"
52.11 -by fast
52.12 -
52.13 lemma mp_conj: "(P \<longrightarrow> Q) \<and> R \<Longrightarrow> P \<Longrightarrow> R \<and> Q"
52.14 by auto
52.15
52.16 @@ -172,7 +166,5 @@
52.17 ML_file "Tools/bnf_fp_n2m.ML"
52.18 ML_file "Tools/bnf_fp_n2m_sugar.ML"
52.19 ML_file "Tools/bnf_fp_rec_sugar_util.ML"
52.20 -ML_file "Tools/bnf_fp_rec_sugar_tactics.ML"
52.21 -ML_file "Tools/bnf_fp_rec_sugar.ML"
52.22
52.23 end
53.1 --- a/src/HOL/BNF/BNF_GFP.thy Thu Dec 05 17:52:12 2013 +0100
53.2 +++ b/src/HOL/BNF/BNF_GFP.thy Thu Dec 05 17:58:03 2013 +0100
53.3 @@ -8,21 +8,29 @@
53.4 header {* Greatest Fixed Point Operation on Bounded Natural Functors *}
53.5
53.6 theory BNF_GFP
53.7 -imports BNF_FP_Base Equiv_Relations_More "~~/src/HOL/Library/Sublist"
53.8 +imports BNF_FP_Base Equiv_Relations_More List_Prefix
53.9 keywords
53.10 "codatatype" :: thy_decl and
53.11 "primcorecursive" :: thy_goal and
53.12 "primcorec" :: thy_decl
53.13 begin
53.14
53.15 +lemma not_TrueE: "\<not> True \<Longrightarrow> P"
53.16 +by (erule notE, rule TrueI)
53.17 +
53.18 +lemma neq_eq_eq_contradict: "\<lbrakk>t \<noteq> u; s = t; s = u\<rbrakk> \<Longrightarrow> P"
53.19 +by fast
53.20 +
53.21 lemma sum_case_expand_Inr: "f o Inl = g \<Longrightarrow> f x = sum_case g (f o Inr) x"
53.22 by (auto split: sum.splits)
53.23
53.24 lemma sum_case_expand_Inr': "f o Inl = g \<Longrightarrow> h = f o Inr \<longleftrightarrow> sum_case g h = f"
53.25 -by (metis sum_case_o_inj(1,2) surjective_sum)
53.26 +apply rule
53.27 + apply (rule ext, force split: sum.split)
53.28 +by (rule ext, metis sum_case_o_inj(2))
53.29
53.30 lemma converse_Times: "(A \<times> B) ^-1 = B \<times> A"
53.31 -by auto
53.32 +by fast
53.33
53.34 lemma equiv_proj:
53.35 assumes e: "equiv A R" and "z \<in> R"
53.36 @@ -37,7 +45,6 @@
53.37 (* Operators: *)
53.38 definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"
53.39
53.40 -
53.41 lemma Id_onD: "(a, b) \<in> Id_on A \<Longrightarrow> a = b"
53.42 unfolding Id_on_def by simp
53.43
53.44 @@ -56,9 +63,6 @@
53.45 lemma Id_on_Gr: "Id_on A = Gr A id"
53.46 unfolding Id_on_def Gr_def by auto
53.47
53.48 -lemma Id_on_UNIV_I: "x = y \<Longrightarrow> (x, y) \<in> Id_on UNIV"
53.49 -unfolding Id_on_def by auto
53.50 -
53.51 lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
53.52 unfolding image2_def by auto
53.53
53.54 @@ -77,6 +81,12 @@
53.55 lemma Gr_incl: "Gr A f \<subseteq> A <*> B \<longleftrightarrow> f ` A \<subseteq> B"
53.56 unfolding Gr_def by auto
53.57
53.58 +lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
53.59 +by blast
53.60 +
53.61 +lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
53.62 +by blast
53.63 +
53.64 lemma in_rel_Collect_split_eq: "in_rel (Collect (split X)) = X"
53.65 unfolding fun_eq_iff by auto
53.66
53.67 @@ -130,9 +140,6 @@
53.68 "R \<subseteq> relInvImage UNIV (relImage R f) f"
53.69 unfolding relInvImage_def relImage_def by auto
53.70
53.71 -lemma equiv_Image: "equiv A R \<Longrightarrow> (\<And>a b. (a, b) \<in> R \<Longrightarrow> a \<in> A \<and> b \<in> A \<and> R `` {a} = R `` {b})"
53.72 -unfolding equiv_def refl_on_def Image_def by (auto intro: transD symD)
53.73 -
53.74 lemma relImage_proj:
53.75 assumes "equiv A R"
53.76 shows "relImage R (proj R) \<subseteq> Id_on (A//R)"
53.77 @@ -143,7 +150,7 @@
53.78 lemma relImage_relInvImage:
53.79 assumes "R \<subseteq> f ` A <*> f ` A"
53.80 shows "relImage (relInvImage A R f) f = R"
53.81 -using assms unfolding relImage_def relInvImage_def by fastforce
53.82 +using assms unfolding relImage_def relInvImage_def by fast
53.83
53.84 lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
53.85 by simp
53.86 @@ -159,6 +166,8 @@
53.87
53.88 (*Extended Sublist*)
53.89
53.90 +definition clists where "clists r = |lists (Field r)|"
53.91 +
53.92 definition prefCl where
53.93 "prefCl Kl = (\<forall> kl1 kl2. prefixeq kl1 kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl)"
53.94 definition PrefCl where
53.95 @@ -255,13 +264,18 @@
53.96 shows "\<exists> a. a \<in> A \<and> p1 a = b1 \<and> p2 a = b2"
53.97 using assms unfolding wpull_def by blast
53.98
53.99 -lemma pickWP:
53.100 +lemma pickWP_raw:
53.101 assumes "wpull A B1 B2 f1 f2 p1 p2" and
53.102 "b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
53.103 -shows "pickWP A p1 p2 b1 b2 \<in> A"
53.104 - "p1 (pickWP A p1 p2 b1 b2) = b1"
53.105 - "p2 (pickWP A p1 p2 b1 b2) = b2"
53.106 -unfolding pickWP_def using assms someI_ex[OF pickWP_pred] by fastforce+
53.107 +shows "pickWP A p1 p2 b1 b2 \<in> A
53.108 + \<and> p1 (pickWP A p1 p2 b1 b2) = b1
53.109 + \<and> p2 (pickWP A p1 p2 b1 b2) = b2"
53.110 +unfolding pickWP_def using assms someI_ex[OF pickWP_pred] by fastforce
53.111 +
53.112 +lemmas pickWP =
53.113 + pickWP_raw[THEN conjunct1]
53.114 + pickWP_raw[THEN conjunct2, THEN conjunct1]
53.115 + pickWP_raw[THEN conjunct2, THEN conjunct2]
53.116
53.117 lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
53.118 unfolding Field_card_of csum_def by auto
53.119 @@ -293,21 +307,17 @@
53.120 lemma image2pI: "R x y \<Longrightarrow> (image2p f g R) (f x) (g y)"
53.121 unfolding image2p_def by blast
53.122
53.123 -lemma image2p_eqI: "\<lbrakk>fx = f x; gy = g y; R x y\<rbrakk> \<Longrightarrow> (image2p f g R) fx gy"
53.124 - unfolding image2p_def by blast
53.125 -
53.126 lemma image2pE: "\<lbrakk>(image2p f g R) fx gy; (\<And>x y. fx = f x \<Longrightarrow> gy = g y \<Longrightarrow> R x y \<Longrightarrow> P)\<rbrakk> \<Longrightarrow> P"
53.127 unfolding image2p_def by blast
53.128
53.129 lemma fun_rel_iff_geq_image2p: "(fun_rel R S) f g = (image2p f g R \<le> S)"
53.130 unfolding fun_rel_def image2p_def by auto
53.131
53.132 -lemma convol_image_image2p: "<f o fst, g o snd> ` Collect (split R) \<subseteq> Collect (split (image2p f g R))"
53.133 - unfolding convol_def image2p_def by fastforce
53.134 -
53.135 lemma fun_rel_image2p: "(fun_rel R (image2p f g R)) f g"
53.136 unfolding fun_rel_def image2p_def by auto
53.137
53.138 +ML_file "Tools/bnf_gfp_rec_sugar_tactics.ML"
53.139 +ML_file "Tools/bnf_gfp_rec_sugar.ML"
53.140 ML_file "Tools/bnf_gfp_util.ML"
53.141 ML_file "Tools/bnf_gfp_tactics.ML"
53.142 ML_file "Tools/bnf_gfp.ML"
54.1 --- a/src/HOL/BNF/BNF_LFP.thy Thu Dec 05 17:52:12 2013 +0100
54.2 +++ b/src/HOL/BNF/BNF_LFP.thy Thu Dec 05 17:58:03 2013 +0100
54.3 @@ -230,6 +230,7 @@
54.4 lemma predicate2D_vimage2p: "\<lbrakk>R \<le> vimage2p f g S; R x y\<rbrakk> \<Longrightarrow> S (f x) (g y)"
54.5 unfolding vimage2p_def by auto
54.6
54.7 +ML_file "Tools/bnf_lfp_rec_sugar.ML"
54.8 ML_file "Tools/bnf_lfp_util.ML"
54.9 ML_file "Tools/bnf_lfp_tactics.ML"
54.10 ML_file "Tools/bnf_lfp.ML"
55.1 --- a/src/HOL/BNF/BNF_Util.thy Thu Dec 05 17:52:12 2013 +0100
55.2 +++ b/src/HOL/BNF/BNF_Util.thy Thu Dec 05 17:58:03 2013 +0100
55.3 @@ -9,15 +9,11 @@
55.4 header {* Library for Bounded Natural Functors *}
55.5
55.6 theory BNF_Util
55.7 -imports Ctr_Sugar "../Cardinals/Cardinal_Arithmetic"
55.8 +imports "../Cardinals/Cardinal_Arithmetic_FP"
55.9 + (*FIXME: define fun_rel here, reuse in Transfer once this theory is in HOL*)
55.10 + Transfer
55.11 begin
55.12
55.13 -lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
55.14 -by blast
55.15 -
55.16 -lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
55.17 -by blast
55.18 -
55.19 definition collect where
55.20 "collect F x = (\<Union>f \<in> F. f x)"
55.21
55.22 @@ -32,12 +28,6 @@
55.23 (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow>
55.24 (\<exists> a \<in> A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2))"
55.25
55.26 -lemma fst_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> fst (snd x) = y"
55.27 -by simp
55.28 -
55.29 -lemma snd_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> snd (snd x) = z"
55.30 -by simp
55.31 -
55.32 lemma fstI: "x = (y, z) \<Longrightarrow> fst x = y"
55.33 by simp
55.34
55.35 @@ -47,9 +37,6 @@
55.36 lemma bijI: "\<lbrakk>\<And>x y. (f x = f y) = (x = y); \<And>y. \<exists>x. y = f x\<rbrakk> \<Longrightarrow> bij f"
55.37 unfolding bij_def inj_on_def by auto blast
55.38
55.39 -lemma Collect_pair_mem_eq: "{(x, y). (x, y) \<in> R} = R"
55.40 -by simp
55.41 -
55.42 (* Operator: *)
55.43 definition "Gr A f = {(a, f a) | a. a \<in> A}"
55.44
56.1 --- a/src/HOL/BNF/Basic_BNFs.thy Thu Dec 05 17:52:12 2013 +0100
56.2 +++ b/src/HOL/BNF/Basic_BNFs.thy Thu Dec 05 17:58:03 2013 +0100
56.3 @@ -11,31 +11,29 @@
56.4
56.5 theory Basic_BNFs
56.6 imports BNF_Def
56.7 + (*FIXME: define relators here, reuse in Lifting_* once this theory is in HOL*)
56.8 + Lifting_Sum
56.9 + Lifting_Product
56.10 + Main
56.11 begin
56.12
56.13 -lemma wpull_id: "wpull UNIV B1 B2 id id id id"
56.14 -unfolding wpull_def by simp
56.15 -
56.16 -lemmas natLeq_card_order = natLeq_Card_order[unfolded Field_natLeq]
56.17 -
56.18 -lemma ctwo_card_order: "card_order ctwo"
56.19 -using Card_order_ctwo by (unfold ctwo_def Field_card_of)
56.20 -
56.21 -lemma natLeq_cinfinite: "cinfinite natLeq"
56.22 -unfolding cinfinite_def Field_natLeq by (rule nat_infinite)
56.23 -
56.24 lemma wpull_Grp_def: "wpull A B1 B2 f1 f2 p1 p2 \<longleftrightarrow> Grp B1 f1 OO (Grp B2 f2)\<inverse>\<inverse> \<le> (Grp A p1)\<inverse>\<inverse> OO Grp A p2"
56.25 unfolding wpull_def Grp_def by auto
56.26
56.27 -bnf ID: "id :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ["\<lambda>x. {x}"] "\<lambda>_:: 'a. natLeq" ["id :: 'a \<Rightarrow> 'a"]
56.28 - "id :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
56.29 +bnf ID: 'a
56.30 + map: "id :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
56.31 + sets: "\<lambda>x. {x}"
56.32 + bd: natLeq
56.33 + rel: "id :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
56.34 apply (auto simp: Grp_def fun_eq_iff relcompp.simps natLeq_card_order natLeq_cinfinite)
56.35 apply (rule ordLess_imp_ordLeq[OF finite_ordLess_infinite[OF _ natLeq_Well_order]])
56.36 apply (auto simp add: Field_card_of Field_natLeq card_of_well_order_on)[3]
56.37 done
56.38
56.39 -bnf DEADID: "id :: 'a \<Rightarrow> 'a" [] "\<lambda>_:: 'a. natLeq +c |UNIV :: 'a set|" ["SOME x :: 'a. True"]
56.40 - "op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
56.41 +bnf DEADID: 'a
56.42 + map: "id :: 'a \<Rightarrow> 'a"
56.43 + bd: "natLeq +c |UNIV :: 'a set|"
56.44 + rel: "op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
56.45 by (auto simp add: wpull_Grp_def Grp_def
56.46 card_order_csum natLeq_card_order card_of_card_order_on
56.47 cinfinite_csum natLeq_cinfinite)
56.48 @@ -48,15 +46,20 @@
56.49
56.50 lemmas sum_set_defs = setl_def[abs_def] setr_def[abs_def]
56.51
56.52 -bnf sum_map [setl, setr] "\<lambda>_::'a + 'b. natLeq" [Inl, Inr] sum_rel
56.53 +bnf "'a + 'b"
56.54 + map: sum_map
56.55 + sets: setl setr
56.56 + bd: natLeq
56.57 + wits: Inl Inr
56.58 + rel: sum_rel
56.59 proof -
56.60 show "sum_map id id = id" by (rule sum_map.id)
56.61 next
56.62 - fix f1 f2 g1 g2
56.63 + fix f1 :: "'o \<Rightarrow> 's" and f2 :: "'p \<Rightarrow> 't" and g1 :: "'s \<Rightarrow> 'q" and g2 :: "'t \<Rightarrow> 'r"
56.64 show "sum_map (g1 o f1) (g2 o f2) = sum_map g1 g2 o sum_map f1 f2"
56.65 by (rule sum_map.comp[symmetric])
56.66 next
56.67 - fix x f1 f2 g1 g2
56.68 + fix x and f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r" and g1 g2
56.69 assume a1: "\<And>z. z \<in> setl x \<Longrightarrow> f1 z = g1 z" and
56.70 a2: "\<And>z. z \<in> setr x \<Longrightarrow> f2 z = g2 z"
56.71 thus "sum_map f1 f2 x = sum_map g1 g2 x"
56.72 @@ -66,11 +69,11 @@
56.73 case Inr thus ?thesis using a2 by (clarsimp simp: setr_def)
56.74 qed
56.75 next
56.76 - fix f1 f2
56.77 + fix f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r"
56.78 show "setl o sum_map f1 f2 = image f1 o setl"
56.79 by (rule ext, unfold o_apply) (simp add: setl_def split: sum.split)
56.80 next
56.81 - fix f1 f2
56.82 + fix f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r"
56.83 show "setr o sum_map f1 f2 = image f2 o setr"
56.84 by (rule ext, unfold o_apply) (simp add: setr_def split: sum.split)
56.85 next
56.86 @@ -78,13 +81,13 @@
56.87 next
56.88 show "cinfinite natLeq" by (rule natLeq_cinfinite)
56.89 next
56.90 - fix x
56.91 + fix x :: "'o + 'p"
56.92 show "|setl x| \<le>o natLeq"
56.93 apply (rule ordLess_imp_ordLeq)
56.94 apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
56.95 by (simp add: setl_def split: sum.split)
56.96 next
56.97 - fix x
56.98 + fix x :: "'o + 'p"
56.99 show "|setr x| \<le>o natLeq"
56.100 apply (rule ordLess_imp_ordLeq)
56.101 apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
56.102 @@ -148,7 +151,11 @@
56.103
56.104 lemmas prod_set_defs = fsts_def[abs_def] snds_def[abs_def]
56.105
56.106 -bnf map_pair [fsts, snds] "\<lambda>_::'a \<times> 'b. natLeq" [Pair] prod_rel
56.107 +bnf "'a \<times> 'b"
56.108 + map: map_pair
56.109 + sets: fsts snds
56.110 + bd: natLeq
56.111 + rel: prod_rel
56.112 proof (unfold prod_set_defs)
56.113 show "map_pair id id = id" by (rule map_pair.id)
56.114 next
56.115 @@ -193,7 +200,7 @@
56.116 Grp {x. {fst x} \<subseteq> Collect (split R) \<and> {snd x} \<subseteq> Collect (split S)} (map_pair snd snd)"
56.117 unfolding prod_set_defs prod_rel_def Grp_def relcompp.simps conversep.simps fun_eq_iff
56.118 by auto
56.119 -qed simp+
56.120 +qed
56.121
56.122 (* Categorical version of pullback: *)
56.123 lemma wpull_cat:
56.124 @@ -215,24 +222,11 @@
56.125 thus ?thesis using that by fastforce
56.126 qed
56.127
56.128 -lemma card_of_bounded_range:
56.129 - "|{f :: 'd \<Rightarrow> 'a. range f \<subseteq> B}| \<le>o |Func (UNIV :: 'd set) B|" (is "|?LHS| \<le>o |?RHS|")
56.130 -proof -
56.131 - let ?f = "\<lambda>f. %x. if f x \<in> B then f x else undefined"
56.132 - have "inj_on ?f ?LHS" unfolding inj_on_def
56.133 - proof (unfold fun_eq_iff, safe)
56.134 - fix g :: "'d \<Rightarrow> 'a" and f :: "'d \<Rightarrow> 'a" and x
56.135 - assume "range f \<subseteq> B" "range g \<subseteq> B" and eq: "\<forall>x. ?f f x = ?f g x"
56.136 - hence "f x \<in> B" "g x \<in> B" by auto
56.137 - with eq have "Some (f x) = Some (g x)" by metis
56.138 - thus "f x = g x" by simp
56.139 - qed
56.140 - moreover have "?f ` ?LHS \<subseteq> ?RHS" unfolding Func_def by fastforce
56.141 - ultimately show ?thesis using card_of_ordLeq by fast
56.142 -qed
56.143 -
56.144 -bnf "op \<circ>" [range] "\<lambda>_:: 'a \<Rightarrow> 'b. natLeq +c |UNIV :: 'a set|" ["%c x::'b::type. c::'a::type"]
56.145 - "fun_rel op ="
56.146 +bnf "'a \<Rightarrow> 'b"
56.147 + map: "op \<circ>"
56.148 + sets: range
56.149 + bd: "natLeq +c |UNIV :: 'a set|"
56.150 + rel: "fun_rel op ="
56.151 proof
56.152 fix f show "id \<circ> f = id f" by simp
56.153 next
56.154 @@ -258,7 +252,7 @@
56.155 next
56.156 fix f :: "'d => 'a"
56.157 have "|range f| \<le>o | (UNIV::'d set) |" (is "_ \<le>o ?U") by (rule card_of_image)
56.158 - also have "?U \<le>o natLeq +c ?U" by (rule ordLeq_csum2) (rule card_of_Card_order)
56.159 + also have "?U \<le>o natLeq +c ?U" by (rule ordLeq_csum2) (rule card_of_Card_order)
56.160 finally show "|range f| \<le>o natLeq +c ?U" .
56.161 next
56.162 fix A B1 B2 f1 f2 p1 p2 assume p: "wpull A B1 B2 f1 f2 p1 p2"
56.163 @@ -277,7 +271,7 @@
56.164 (Grp {x. range x \<subseteq> Collect (split R)} (op \<circ> fst))\<inverse>\<inverse> OO
56.165 Grp {x. range x \<subseteq> Collect (split R)} (op \<circ> snd)"
56.166 unfolding fun_rel_def Grp_def fun_eq_iff relcompp.simps conversep.simps subset_iff image_iff
56.167 - by auto (force, metis pair_collapse)
56.168 -qed auto
56.169 + by auto (force, metis (no_types) pair_collapse)
56.170 +qed
56.171
56.172 end
57.1 --- a/src/HOL/BNF/Coinduction.thy Thu Dec 05 17:52:12 2013 +0100
57.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
57.3 @@ -1,19 +0,0 @@
57.4 -(* Title: HOL/BNF/Coinduction.thy
57.5 - Author: Johannes Hölzl, TU Muenchen
57.6 - Author: Dmitriy Traytel, TU Muenchen
57.7 - Copyright 2013
57.8 -
57.9 -Coinduction method that avoids some boilerplate compared to coinduct.
57.10 -*)
57.11 -
57.12 -header {* Coinduction Method *}
57.13 -
57.14 -theory Coinduction
57.15 -imports BNF_Util
57.16 -begin
57.17 -
57.18 -ML_file "Tools/coinduction.ML"
57.19 -
57.20 -setup Coinduction.setup
57.21 -
57.22 -end
58.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
58.2 +++ b/src/HOL/BNF/Countable_Set_Type.thy Thu Dec 05 17:58:03 2013 +0100
58.3 @@ -0,0 +1,212 @@
58.4 +(* Title: HOL/BNF/Countable_Set_Type.thy
58.5 + Author: Andrei Popescu, TU Muenchen
58.6 + Copyright 2012
58.7 +
58.8 +Type of (at most) countable sets.
58.9 +*)
58.10 +
58.11 +header {* Type of (at Most) Countable Sets *}
58.12 +
58.13 +theory Countable_Set_Type
58.14 +imports
58.15 + More_BNFs
58.16 + "~~/src/HOL/Cardinals/Cardinals"
58.17 + "~~/src/HOL/Library/Countable_Set"
58.18 +begin
58.19 +
58.20 +subsection{* Cardinal stuff *}
58.21 +
58.22 +lemma countable_card_of_nat: "countable A \<longleftrightarrow> |A| \<le>o |UNIV::nat set|"
58.23 + unfolding countable_def card_of_ordLeq[symmetric] by auto
58.24 +
58.25 +lemma countable_card_le_natLeq: "countable A \<longleftrightarrow> |A| \<le>o natLeq"
58.26 + unfolding countable_card_of_nat using card_of_nat ordLeq_ordIso_trans ordIso_symmetric by blast
58.27 +
58.28 +lemma countable_or_card_of:
58.29 +assumes "countable A"
58.30 +shows "(finite A \<and> |A| <o |UNIV::nat set| ) \<or>
58.31 + (infinite A \<and> |A| =o |UNIV::nat set| )"
58.32 +proof (cases "finite A")
58.33 + case True thus ?thesis by (metis finite_iff_cardOf_nat)
58.34 +next
58.35 + case False with assms show ?thesis
58.36 + by (metis countable_card_of_nat infinite_iff_card_of_nat ordIso_iff_ordLeq)
58.37 +qed
58.38 +
58.39 +lemma countable_cases_card_of[elim]:
58.40 + assumes "countable A"
58.41 + obtains (Fin) "finite A" "|A| <o |UNIV::nat set|"
58.42 + | (Inf) "infinite A" "|A| =o |UNIV::nat set|"
58.43 + using assms countable_or_card_of by blast
58.44 +
58.45 +lemma countable_or:
58.46 + "countable A \<Longrightarrow> (\<exists> f::'a\<Rightarrow>nat. finite A \<and> inj_on f A) \<or> (\<exists> f::'a\<Rightarrow>nat. infinite A \<and> bij_betw f A UNIV)"
58.47 + by (elim countable_enum_cases) fastforce+
58.48 +
58.49 +lemma countable_cases[elim]:
58.50 + assumes "countable A"
58.51 + obtains (Fin) f :: "'a\<Rightarrow>nat" where "finite A" "inj_on f A"
58.52 + | (Inf) f :: "'a\<Rightarrow>nat" where "infinite A" "bij_betw f A UNIV"
58.53 + using assms countable_or by metis
58.54 +
58.55 +lemma countable_ordLeq:
58.56 +assumes "|A| \<le>o |B|" and "countable B"
58.57 +shows "countable A"
58.58 +using assms unfolding countable_card_of_nat by(rule ordLeq_transitive)
58.59 +
58.60 +lemma countable_ordLess:
58.61 +assumes AB: "|A| <o |B|" and B: "countable B"
58.62 +shows "countable A"
58.63 +using countable_ordLeq[OF ordLess_imp_ordLeq[OF AB] B] .
58.64 +
58.65 +subsection {* The type of countable sets *}
58.66 +
58.67 +typedef 'a cset = "{A :: 'a set. countable A}" morphisms rcset acset
58.68 + by (rule exI[of _ "{}"]) simp
58.69 +
58.70 +setup_lifting type_definition_cset
58.71 +
58.72 +declare
58.73 + rcset_inverse[simp]
58.74 + acset_inverse[Transfer.transferred, unfolded mem_Collect_eq, simp]
58.75 + acset_inject[Transfer.transferred, unfolded mem_Collect_eq, simp]
58.76 + rcset[Transfer.transferred, unfolded mem_Collect_eq, simp]
58.77 +
58.78 +lift_definition cin :: "'a \<Rightarrow> 'a cset \<Rightarrow> bool" is "op \<in>" parametric member_transfer
58.79 + ..
58.80 +lift_definition cempty :: "'a cset" is "{}" parametric empty_transfer
58.81 + by (rule countable_empty)
58.82 +lift_definition cinsert :: "'a \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is insert parametric Lifting_Set.insert_transfer
58.83 + by (rule countable_insert)
58.84 +lift_definition csingle :: "'a \<Rightarrow> 'a cset" is "\<lambda>x. {x}"
58.85 + by (rule countable_insert[OF countable_empty])
58.86 +lift_definition cUn :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op \<union>" parametric union_transfer
58.87 + by (rule countable_Un)
58.88 +lift_definition cInt :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op \<inter>" parametric inter_transfer
58.89 + by (rule countable_Int1)
58.90 +lift_definition cDiff :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op -" parametric Diff_transfer
58.91 + by (rule countable_Diff)
58.92 +lift_definition cimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a cset \<Rightarrow> 'b cset" is "op `" parametric image_transfer
58.93 + by (rule countable_image)
58.94 +
58.95 +subsection {* Registration as BNF *}
58.96 +
58.97 +lemma card_of_countable_sets_range:
58.98 +fixes A :: "'a set"
58.99 +shows "|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |{f::nat \<Rightarrow> 'a. range f \<subseteq> A}|"
58.100 +apply(rule card_of_ordLeqI[of from_nat_into]) using inj_on_from_nat_into
58.101 +unfolding inj_on_def by auto
58.102 +
58.103 +lemma card_of_countable_sets_Func:
58.104 +"|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |A| ^c natLeq"
58.105 +using card_of_countable_sets_range card_of_Func_UNIV[THEN ordIso_symmetric]
58.106 +unfolding cexp_def Field_natLeq Field_card_of
58.107 +by (rule ordLeq_ordIso_trans)
58.108 +
58.109 +lemma ordLeq_countable_subsets:
58.110 +"|A| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
58.111 +apply (rule card_of_ordLeqI[of "\<lambda> a. {a}"]) unfolding inj_on_def by auto
58.112 +
58.113 +lemma finite_countable_subset:
58.114 +"finite {X. X \<subseteq> A \<and> countable X} \<longleftrightarrow> finite A"
58.115 +apply default
58.116 + apply (erule contrapos_pp)
58.117 + apply (rule card_of_ordLeq_infinite)
58.118 + apply (rule ordLeq_countable_subsets)
58.119 + apply assumption
58.120 +apply (rule finite_Collect_conjI)
58.121 +apply (rule disjI1)
58.122 +by (erule finite_Collect_subsets)
58.123 +
58.124 +lemma rcset_to_rcset: "countable A \<Longrightarrow> rcset (the_inv rcset A) = A"
58.125 + apply (rule f_the_inv_into_f[unfolded inj_on_def image_iff])
58.126 + apply transfer' apply simp
58.127 + apply transfer' apply simp
58.128 + done
58.129 +
58.130 +lemma Collect_Int_Times:
58.131 +"{(x, y). R x y} \<inter> A \<times> B = {(x, y). R x y \<and> x \<in> A \<and> y \<in> B}"
58.132 +by auto
58.133 +
58.134 +definition cset_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a cset \<Rightarrow> 'b cset \<Rightarrow> bool" where
58.135 +"cset_rel R a b \<longleftrightarrow>
58.136 + (\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and>
58.137 + (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t)"
58.138 +
58.139 +lemma cset_rel_aux:
58.140 +"(\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and> (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t) \<longleftrightarrow>
58.141 + ((Grp {x. rcset x \<subseteq> {(a, b). R a b}} (cimage fst))\<inverse>\<inverse> OO
58.142 + Grp {x. rcset x \<subseteq> {(a, b). R a b}} (cimage snd)) a b" (is "?L = ?R")
58.143 +proof
58.144 + assume ?L
58.145 + def R' \<equiv> "the_inv rcset (Collect (split R) \<inter> (rcset a \<times> rcset b))"
58.146 + (is "the_inv rcset ?L'")
58.147 + have L: "countable ?L'" by auto
58.148 + hence *: "rcset R' = ?L'" unfolding R'_def using fset_to_fset by (intro rcset_to_rcset)
58.149 + thus ?R unfolding Grp_def relcompp.simps conversep.simps
58.150 + proof (intro CollectI prod_caseI exI[of _ a] exI[of _ b] exI[of _ R'] conjI refl)
58.151 + from * `?L` show "a = cimage fst R'" by transfer (auto simp: image_def Collect_Int_Times)
58.152 + next
58.153 + from * `?L` show "b = cimage snd R'" by transfer (auto simp: image_def Collect_Int_Times)
58.154 + qed simp_all
58.155 +next
58.156 + assume ?R thus ?L unfolding Grp_def relcompp.simps conversep.simps
58.157 + by transfer force
58.158 +qed
58.159 +
58.160 +bnf "'a cset"
58.161 + map: cimage
58.162 + sets: rcset
58.163 + bd: natLeq
58.164 + wits: "cempty"
58.165 + rel: cset_rel
58.166 +proof -
58.167 + show "cimage id = id" by transfer' simp
58.168 +next
58.169 + fix f g show "cimage (g \<circ> f) = cimage g \<circ> cimage f" by transfer' fastforce
58.170 +next
58.171 + fix C f g assume eq: "\<And>a. a \<in> rcset C \<Longrightarrow> f a = g a"
58.172 + thus "cimage f C = cimage g C" by transfer force
58.173 +next
58.174 + fix f show "rcset \<circ> cimage f = op ` f \<circ> rcset" by transfer' fastforce
58.175 +next
58.176 + show "card_order natLeq" by (rule natLeq_card_order)
58.177 +next
58.178 + show "cinfinite natLeq" by (rule natLeq_cinfinite)
58.179 +next
58.180 + fix C show "|rcset C| \<le>o natLeq" by transfer (unfold countable_card_le_natLeq)
58.181 +next
58.182 + fix A B1 B2 f1 f2 p1 p2
58.183 + assume wp: "wpull A B1 B2 f1 f2 p1 p2"
58.184 + show "wpull {x. rcset x \<subseteq> A} {x. rcset x \<subseteq> B1} {x. rcset x \<subseteq> B2}
58.185 + (cimage f1) (cimage f2) (cimage p1) (cimage p2)"
58.186 + unfolding wpull_def proof safe
58.187 + fix y1 y2
58.188 + assume Y1: "rcset y1 \<subseteq> B1" and Y2: "rcset y2 \<subseteq> B2"
58.189 + assume "cimage f1 y1 = cimage f2 y2"
58.190 + hence EQ: "f1 ` (rcset y1) = f2 ` (rcset y2)" by transfer
58.191 + with Y1 Y2 obtain X where X: "X \<subseteq> A"
58.192 + and Y1: "p1 ` X = rcset y1" and Y2: "p2 ` X = rcset y2"
58.193 + using wpull_image[OF wp] unfolding wpull_def Pow_def Bex_def mem_Collect_eq
58.194 + by (auto elim!: allE[of _ "rcset y1"] allE[of _ "rcset y2"])
58.195 + have "\<forall> y1' \<in> rcset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
58.196 + then obtain q1 where q1: "\<forall> y1' \<in> rcset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
58.197 + have "\<forall> y2' \<in> rcset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
58.198 + then obtain q2 where q2: "\<forall> y2' \<in> rcset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
58.199 + def X' \<equiv> "q1 ` (rcset y1) \<union> q2 ` (rcset y2)"
58.200 + have X': "X' \<subseteq> A" and Y1: "p1 ` X' = rcset y1" and Y2: "p2 ` X' = rcset y2"
58.201 + using X Y1 Y2 q1 q2 unfolding X'_def by fast+
58.202 + have fX': "countable X'" unfolding X'_def by simp
58.203 + then obtain x where X'eq: "X' = rcset x" by transfer blast
58.204 + show "\<exists>x\<in>{x. rcset x \<subseteq> A}. cimage p1 x = y1 \<and> cimage p2 x = y2"
58.205 + using X' Y1 Y2 unfolding X'eq by (intro bexI[of _ "x"]) (transfer, auto)
58.206 + qed
58.207 +next
58.208 + fix R
58.209 + show "cset_rel R =
58.210 + (Grp {x. rcset x \<subseteq> Collect (split R)} (cimage fst))\<inverse>\<inverse> OO
58.211 + Grp {x. rcset x \<subseteq> Collect (split R)} (cimage snd)"
58.212 + unfolding cset_rel_def[abs_def] cset_rel_aux by simp
58.213 +qed (transfer, simp)
58.214 +
58.215 +end
59.1 --- a/src/HOL/BNF/Countable_Type.thy Thu Dec 05 17:52:12 2013 +0100
59.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
59.3 @@ -1,91 +0,0 @@
59.4 -(* Title: HOL/BNF/Countable_Type.thy
59.5 - Author: Andrei Popescu, TU Muenchen
59.6 - Copyright 2012
59.7 -
59.8 -(At most) countable sets.
59.9 -*)
59.10 -
59.11 -header {* (At Most) Countable Sets *}
59.12 -
59.13 -theory Countable_Type
59.14 -imports
59.15 - "~~/src/HOL/Cardinals/Cardinals"
59.16 - "~~/src/HOL/Library/Countable_Set"
59.17 -begin
59.18 -
59.19 -subsection{* Cardinal stuff *}
59.20 -
59.21 -lemma countable_card_of_nat: "countable A \<longleftrightarrow> |A| \<le>o |UNIV::nat set|"
59.22 - unfolding countable_def card_of_ordLeq[symmetric] by auto
59.23 -
59.24 -lemma countable_card_le_natLeq: "countable A \<longleftrightarrow> |A| \<le>o natLeq"
59.25 - unfolding countable_card_of_nat using card_of_nat ordLeq_ordIso_trans ordIso_symmetric by blast
59.26 -
59.27 -lemma countable_or_card_of:
59.28 -assumes "countable A"
59.29 -shows "(finite A \<and> |A| <o |UNIV::nat set| ) \<or>
59.30 - (infinite A \<and> |A| =o |UNIV::nat set| )"
59.31 -proof (cases "finite A")
59.32 - case True thus ?thesis by (metis finite_iff_cardOf_nat)
59.33 -next
59.34 - case False with assms show ?thesis
59.35 - by (metis countable_card_of_nat infinite_iff_card_of_nat ordIso_iff_ordLeq)
59.36 -qed
59.37 -
59.38 -lemma countable_cases_card_of[elim]:
59.39 - assumes "countable A"
59.40 - obtains (Fin) "finite A" "|A| <o |UNIV::nat set|"
59.41 - | (Inf) "infinite A" "|A| =o |UNIV::nat set|"
59.42 - using assms countable_or_card_of by blast
59.43 -
59.44 -lemma countable_or:
59.45 - "countable A \<Longrightarrow> (\<exists> f::'a\<Rightarrow>nat. finite A \<and> inj_on f A) \<or> (\<exists> f::'a\<Rightarrow>nat. infinite A \<and> bij_betw f A UNIV)"
59.46 - by (elim countable_enum_cases) fastforce+
59.47 -
59.48 -lemma countable_cases[elim]:
59.49 - assumes "countable A"
59.50 - obtains (Fin) f :: "'a\<Rightarrow>nat" where "finite A" "inj_on f A"
59.51 - | (Inf) f :: "'a\<Rightarrow>nat" where "infinite A" "bij_betw f A UNIV"
59.52 - using assms countable_or by metis
59.53 -
59.54 -lemma countable_ordLeq:
59.55 -assumes "|A| \<le>o |B|" and "countable B"
59.56 -shows "countable A"
59.57 -using assms unfolding countable_card_of_nat by(rule ordLeq_transitive)
59.58 -
59.59 -lemma countable_ordLess:
59.60 -assumes AB: "|A| <o |B|" and B: "countable B"
59.61 -shows "countable A"
59.62 -using countable_ordLeq[OF ordLess_imp_ordLeq[OF AB] B] .
59.63 -
59.64 -subsection{* The type of countable sets *}
59.65 -
59.66 -typedef 'a cset = "{A :: 'a set. countable A}" morphisms rcset acset
59.67 - by (rule exI[of _ "{}"]) simp
59.68 -
59.69 -setup_lifting type_definition_cset
59.70 -
59.71 -declare
59.72 - rcset_inverse[simp]
59.73 - acset_inverse[Transfer.transferred, unfolded mem_Collect_eq, simp]
59.74 - acset_inject[Transfer.transferred, unfolded mem_Collect_eq, simp]
59.75 - rcset[Transfer.transferred, unfolded mem_Collect_eq, simp]
59.76 -
59.77 -lift_definition cin :: "'a \<Rightarrow> 'a cset \<Rightarrow> bool" is "op \<in>" parametric member_transfer
59.78 - ..
59.79 -lift_definition cempty :: "'a cset" is "{}" parametric empty_transfer
59.80 - by (rule countable_empty)
59.81 -lift_definition cinsert :: "'a \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is insert parametric Lifting_Set.insert_transfer
59.82 - by (rule countable_insert)
59.83 -lift_definition csingle :: "'a \<Rightarrow> 'a cset" is "\<lambda>x. {x}"
59.84 - by (rule countable_insert[OF countable_empty])
59.85 -lift_definition cUn :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op \<union>" parametric union_transfer
59.86 - by (rule countable_Un)
59.87 -lift_definition cInt :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op \<inter>" parametric inter_transfer
59.88 - by (rule countable_Int1)
59.89 -lift_definition cDiff :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op -" parametric Diff_transfer
59.90 - by (rule countable_Diff)
59.91 -lift_definition cimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a cset \<Rightarrow> 'b cset" is "op `" parametric image_transfer
59.92 - by (rule countable_image)
59.93 -
59.94 -end
60.1 --- a/src/HOL/BNF/Ctr_Sugar.thy Thu Dec 05 17:52:12 2013 +0100
60.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
60.3 @@ -1,30 +0,0 @@
60.4 -(* Title: HOL/BNF/Ctr_Sugar.thy
60.5 - Author: Jasmin Blanchette, TU Muenchen
60.6 - Copyright 2012
60.7 -
60.8 -Wrapping existing freely generated type's constructors.
60.9 -*)
60.10 -
60.11 -header {* Wrapping Existing Freely Generated Type's Constructors *}
60.12 -
60.13 -theory Ctr_Sugar
60.14 -imports Main
60.15 -keywords
60.16 - "wrap_free_constructors" :: thy_goal and
60.17 - "no_discs_sels" and
60.18 - "rep_compat"
60.19 -begin
60.20 -
60.21 -lemma iffI_np: "\<lbrakk>x \<Longrightarrow> \<not> y; \<not> x \<Longrightarrow> y\<rbrakk> \<Longrightarrow> \<not> x \<longleftrightarrow> y"
60.22 -by (erule iffI) (erule contrapos_pn)
60.23 -
60.24 -lemma iff_contradict:
60.25 -"\<not> P \<Longrightarrow> P \<longleftrightarrow> Q \<Longrightarrow> Q \<Longrightarrow> R"
60.26 -"\<not> Q \<Longrightarrow> P \<longleftrightarrow> Q \<Longrightarrow> P \<Longrightarrow> R"
60.27 -by blast+
60.28 -
60.29 -ML_file "Tools/ctr_sugar_util.ML"
60.30 -ML_file "Tools/ctr_sugar_tactics.ML"
60.31 -ML_file "Tools/ctr_sugar.ML"
60.32 -
60.33 -end
61.1 --- a/src/HOL/BNF/Equiv_Relations_More.thy Thu Dec 05 17:52:12 2013 +0100
61.2 +++ b/src/HOL/BNF/Equiv_Relations_More.thy Thu Dec 05 17:58:03 2013 +0100
61.3 @@ -59,7 +59,7 @@
61.4
61.5 lemma in_quotient_imp_in_rel:
61.6 "\<lbrakk>equiv A r; X \<in> A//r; {x,y} \<subseteq> X\<rbrakk> \<Longrightarrow> (x,y) \<in> r"
61.7 -using quotient_eq_iff by fastforce
61.8 +using quotient_eq_iff[THEN iffD1] by fastforce
61.9
61.10 lemma in_quotient_imp_closed:
61.11 "\<lbrakk>equiv A r; X \<in> A//r; x \<in> X; (x,y) \<in> r\<rbrakk> \<Longrightarrow> y \<in> X"
62.1 --- a/src/HOL/BNF/Examples/Derivation_Trees/DTree.thy Thu Dec 05 17:52:12 2013 +0100
62.2 +++ b/src/HOL/BNF/Examples/Derivation_Trees/DTree.thy Thu Dec 05 17:58:03 2013 +0100
62.3 @@ -11,8 +11,6 @@
62.4 imports Prelim
62.5 begin
62.6
62.7 -hide_fact (open) Lifting_Product.prod_rel_def
62.8 -
62.9 typedecl N
62.10 typedecl T
62.11
62.12 @@ -22,8 +20,8 @@
62.13
62.14 definition "Node n as \<equiv> NNode n (the_inv fset as)"
62.15 definition "cont \<equiv> fset o ccont"
62.16 -definition "unfold rt ct \<equiv> dtree_unfold rt (the_inv fset o ct)"
62.17 -definition "corec rt ct \<equiv> dtree_corec rt (the_inv fset o ct)"
62.18 +definition "unfold rt ct \<equiv> unfold_dtree rt (the_inv fset o ct)"
62.19 +definition "corec rt ct \<equiv> corec_dtree rt (the_inv fset o ct)"
62.20
62.21 lemma finite_cont[simp]: "finite (cont tr)"
62.22 unfolding cont_def o_apply by (cases tr, clarsimp)
63.1 --- a/src/HOL/BNF/Examples/Derivation_Trees/Parallel.thy Thu Dec 05 17:52:12 2013 +0100
63.2 +++ b/src/HOL/BNF/Examples/Derivation_Trees/Parallel.thy Thu Dec 05 17:58:03 2013 +0100
63.3 @@ -12,7 +12,6 @@
63.4 begin
63.5
63.6 no_notation plus_class.plus (infixl "+" 65)
63.7 -no_notation Sublist.parallel (infixl "\<parallel>" 50)
63.8
63.9 consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)
63.10
63.11 @@ -145,4 +144,4 @@
63.12 thus ?thesis by blast
63.13 qed
63.14
63.15 -end
63.16 \ No newline at end of file
63.17 +end
64.1 --- a/src/HOL/BNF/Examples/Koenig.thy Thu Dec 05 17:52:12 2013 +0100
64.2 +++ b/src/HOL/BNF/Examples/Koenig.thy Thu Dec 05 17:58:03 2013 +0100
64.3 @@ -12,44 +12,33 @@
64.4 imports TreeFI Stream
64.5 begin
64.6
64.7 -(* selectors for streams *)
64.8 -lemma shd_def': "shd as = fst (stream_dtor as)"
64.9 -apply (case_tac as)
64.10 -apply (auto simp add: shd_def)
64.11 -by (simp add: Stream_def stream.dtor_ctor)
64.12 -
64.13 -lemma stl_def': "stl as = snd (stream_dtor as)"
64.14 -apply (case_tac as)
64.15 -apply (auto simp add: stl_def)
64.16 -by (simp add: Stream_def stream.dtor_ctor)
64.17 -
64.18 (* infinite trees: *)
64.19 coinductive infiniteTr where
64.20 -"\<lbrakk>tr' \<in> listF_set (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
64.21 +"\<lbrakk>tr' \<in> set_listF (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
64.22
64.23 lemma infiniteTr_strong_coind[consumes 1, case_names sub]:
64.24 assumes *: "phi tr" and
64.25 -**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr' \<or> infiniteTr tr'"
64.26 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set_listF (sub tr). phi tr' \<or> infiniteTr tr'"
64.27 shows "infiniteTr tr"
64.28 using assms by (elim infiniteTr.coinduct) blast
64.29
64.30 lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
64.31 assumes *: "phi tr" and
64.32 -**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr'"
64.33 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set_listF (sub tr). phi tr'"
64.34 shows "infiniteTr tr"
64.35 using assms by (elim infiniteTr.coinduct) blast
64.36
64.37 lemma infiniteTr_sub[simp]:
64.38 -"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> listF_set (sub tr). infiniteTr tr')"
64.39 +"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> set_listF (sub tr). infiniteTr tr')"
64.40 by (erule infiniteTr.cases) blast
64.41
64.42 primcorec konigPath where
64.43 "shd (konigPath t) = lab t"
64.44 -| "stl (konigPath t) = konigPath (SOME tr. tr \<in> listF_set (sub t) \<and> infiniteTr tr)"
64.45 +| "stl (konigPath t) = konigPath (SOME tr. tr \<in> set_listF (sub t) \<and> infiniteTr tr)"
64.46
64.47 (* proper paths in trees: *)
64.48 coinductive properPath where
64.49 -"\<lbrakk>shd as = lab tr; tr' \<in> listF_set (sub tr); properPath (stl as) tr'\<rbrakk> \<Longrightarrow>
64.50 +"\<lbrakk>shd as = lab tr; tr' \<in> set_listF (sub tr); properPath (stl as) tr'\<rbrakk> \<Longrightarrow>
64.51 properPath as tr"
64.52
64.53 lemma properPath_strong_coind[consumes 1, case_names shd_lab sub]:
64.54 @@ -57,7 +46,7 @@
64.55 **: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
64.56 ***: "\<And> as tr.
64.57 phi as tr \<Longrightarrow>
64.58 - \<exists> tr' \<in> listF_set (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
64.59 + \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
64.60 shows "properPath as tr"
64.61 using assms by (elim properPath.coinduct) blast
64.62
64.63 @@ -66,7 +55,7 @@
64.64 **: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
64.65 ***: "\<And> as tr.
64.66 phi as tr \<Longrightarrow>
64.67 - \<exists> tr' \<in> listF_set (sub tr). phi (stl as) tr'"
64.68 + \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr'"
64.69 shows "properPath as tr"
64.70 using properPath_strong_coind[of phi, OF * **] *** by blast
64.71
64.72 @@ -76,7 +65,7 @@
64.73
64.74 lemma properPath_sub:
64.75 "properPath as tr \<Longrightarrow>
64.76 - \<exists> tr' \<in> listF_set (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
64.77 + \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
64.78 by (erule properPath.cases) blast
64.79
64.80 (* prove the following by coinduction *)
64.81 @@ -88,10 +77,10 @@
64.82 assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
64.83 proof (coinduction arbitrary: tr as rule: properPath_coind)
64.84 case (sub tr as)
64.85 - let ?t = "SOME t'. t' \<in> listF_set (sub tr) \<and> infiniteTr t'"
64.86 - from sub have "\<exists>t' \<in> listF_set (sub tr). infiniteTr t'" by simp
64.87 - then have "\<exists>t'. t' \<in> listF_set (sub tr) \<and> infiniteTr t'" by blast
64.88 - then have "?t \<in> listF_set (sub tr) \<and> infiniteTr ?t" by (rule someI_ex)
64.89 + let ?t = "SOME t'. t' \<in> set_listF (sub tr) \<and> infiniteTr t'"
64.90 + from sub have "\<exists>t' \<in> set_listF (sub tr). infiniteTr t'" by simp
64.91 + then have "\<exists>t'. t' \<in> set_listF (sub tr) \<and> infiniteTr t'" by blast
64.92 + then have "?t \<in> set_listF (sub tr) \<and> infiniteTr ?t" by (rule someI_ex)
64.93 moreover have "stl (konigPath tr) = konigPath ?t" by simp
64.94 ultimately show ?case using sub by blast
64.95 qed simp
65.1 --- a/src/HOL/BNF/Examples/ListF.thy Thu Dec 05 17:52:12 2013 +0100
65.2 +++ b/src/HOL/BNF/Examples/ListF.thy Thu Dec 05 17:58:03 2013 +0100
65.3 @@ -62,7 +62,7 @@
65.4 "i < lengthh xs \<Longrightarrow> nthh (mapF f xs) i = f (nthh xs i)"
65.5 by (induct rule: nthh.induct) auto
65.6
65.7 -lemma nthh_listF_set[simp]: "i < lengthh xs \<Longrightarrow> nthh xs i \<in> listF_set xs"
65.8 +lemma nthh_listF_set[simp]: "i < lengthh xs \<Longrightarrow> nthh xs i \<in> set_listF xs"
65.9 by (induct rule: nthh.induct) auto
65.10
65.11 lemma NilF_iff[iff]: "(lengthh xs = 0) = (xs = NilF)"
65.12 @@ -105,7 +105,7 @@
65.13 qed simp
65.14
65.15 lemma list_set_nthh[simp]:
65.16 - "(x \<in> listF_set xs) \<Longrightarrow> (\<exists>i < lengthh xs. nthh xs i = x)"
65.17 + "(x \<in> set_listF xs) \<Longrightarrow> (\<exists>i < lengthh xs. nthh xs i = x)"
65.18 by (induct xs) (auto, induct rule: nthh.induct, auto)
65.19
65.20 end
66.1 --- a/src/HOL/BNF/Examples/Misc_Codatatype.thy Thu Dec 05 17:52:12 2013 +0100
66.2 +++ b/src/HOL/BNF/Examples/Misc_Codatatype.thy Thu Dec 05 17:58:03 2013 +0100
66.3 @@ -19,9 +19,9 @@
66.4
66.5 codatatype simple'' = X1'' nat int | X2''
66.6
66.7 -codatatype 'a stream = Stream 'a "'a stream"
66.8 +codatatype 'a stream = Stream (shd: 'a) (stl: "'a stream")
66.9
66.10 -codatatype 'a mylist = MyNil | MyCons 'a "'a mylist"
66.11 +codatatype 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
66.12
66.13 codatatype ('b, 'c, 'd, 'e) some_passive =
66.14 SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
67.1 --- a/src/HOL/BNF/Examples/Misc_Datatype.thy Thu Dec 05 17:52:12 2013 +0100
67.2 +++ b/src/HOL/BNF/Examples/Misc_Datatype.thy Thu Dec 05 17:58:03 2013 +0100
67.3 @@ -19,7 +19,7 @@
67.4
67.5 datatype_new simple'' = X1'' nat int | X2''
67.6
67.7 -datatype_new 'a mylist = MyNil | MyCons 'a "'a mylist"
67.8 +datatype_new 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
67.9
67.10 datatype_new ('b, 'c, 'd, 'e) some_passive =
67.11 SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
68.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
68.2 +++ b/src/HOL/BNF/Examples/Misc_Primcorec.thy Thu Dec 05 17:58:03 2013 +0100
68.3 @@ -0,0 +1,112 @@
68.4 +(* Title: HOL/BNF/Examples/Misc_Primcorec.thy
68.5 + Author: Jasmin Blanchette, TU Muenchen
68.6 + Copyright 2013
68.7 +
68.8 +Miscellaneous primitive corecursive function definitions.
68.9 +*)
68.10 +
68.11 +header {* Miscellaneous Primitive Corecursive Function Definitions *}
68.12 +
68.13 +theory Misc_Primcorec
68.14 +imports Misc_Codatatype
68.15 +begin
68.16 +
68.17 +primcorec simple_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple" where
68.18 + "simple_of_bools b b' = (if b then if b' then X1 else X2 else if b' then X3 else X4)"
68.19 +
68.20 +primcorec simple'_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple'" where
68.21 + "simple'_of_bools b b' =
68.22 + (if b then if b' then X1' () else X2' () else if b' then X3' () else X4' ())"
68.23 +
68.24 +primcorec inc_simple'' :: "nat \<Rightarrow> simple'' \<Rightarrow> simple''" where
68.25 + "inc_simple'' k s = (case s of X1'' n i \<Rightarrow> X1'' (n + k) (i + int k) | X2'' \<Rightarrow> X2'')"
68.26 +
68.27 +primcorec sinterleave :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
68.28 + "sinterleave s s' = Stream (shd s) (sinterleave s' (stl s))"
68.29 +
68.30 +primcorec myapp :: "'a mylist \<Rightarrow> 'a mylist \<Rightarrow> 'a mylist" where
68.31 + "myapp xs ys =
68.32 + (if xs = MyNil then ys
68.33 + else if ys = MyNil then xs
68.34 + else MyCons (myhd xs) (myapp (mytl xs) ys))"
68.35 +
68.36 +primcorec shuffle_sp :: "('a, 'b, 'c, 'd) some_passive \<Rightarrow> ('d, 'a, 'b, 'c) some_passive" where
68.37 + "shuffle_sp sp =
68.38 + (case sp of
68.39 + SP1 sp' \<Rightarrow> SP1 (shuffle_sp sp')
68.40 + | SP2 a \<Rightarrow> SP3 a
68.41 + | SP3 b \<Rightarrow> SP4 b
68.42 + | SP4 c \<Rightarrow> SP5 c
68.43 + | SP5 d \<Rightarrow> SP2 d)"
68.44 +
68.45 +primcorec rename_lam :: "(string \<Rightarrow> string) \<Rightarrow> lambda \<Rightarrow> lambda" where
68.46 + "rename_lam f l =
68.47 + (case l of
68.48 + Var s \<Rightarrow> Var (f s)
68.49 + | App l l' \<Rightarrow> App (rename_lam f l) (rename_lam f l')
68.50 + | Abs s l \<Rightarrow> Abs (f s) (rename_lam f l)
68.51 + | Let SL l \<Rightarrow> Let (fimage (map_pair f (rename_lam f)) SL) (rename_lam f l))"
68.52 +
68.53 +primcorec
68.54 + j1_sum :: "('a\<Colon>{zero,one,plus}) \<Rightarrow> 'a J1" and
68.55 + j2_sum :: "'a \<Rightarrow> 'a J2"
68.56 +where
68.57 + "n = 0 \<Longrightarrow> is_J11 (j1_sum n)" |
68.58 + "un_J111 (j1_sum _) = 0" |
68.59 + "un_J112 (j1_sum _) = j1_sum 0" |
68.60 + "un_J121 (j1_sum n) = n + 1" |
68.61 + "un_J122 (j1_sum n) = j2_sum (n + 1)" |
68.62 + "n = 0 \<Longrightarrow> is_J21 (j2_sum n)" |
68.63 + "un_J221 (j2_sum n) = j1_sum (n + 1)" |
68.64 + "un_J222 (j2_sum n) = j2_sum (n + 1)"
68.65 +
68.66 +primcorec forest_of_mylist :: "'a tree mylist \<Rightarrow> 'a forest" where
68.67 + "forest_of_mylist ts =
68.68 + (case ts of
68.69 + MyNil \<Rightarrow> FNil
68.70 + | MyCons t ts \<Rightarrow> FCons t (forest_of_mylist ts))"
68.71 +
68.72 +primcorec mylist_of_forest :: "'a forest \<Rightarrow> 'a tree mylist" where
68.73 + "mylist_of_forest f =
68.74 + (case f of
68.75 + FNil \<Rightarrow> MyNil
68.76 + | FCons t ts \<Rightarrow> MyCons t (mylist_of_forest ts))"
68.77 +
68.78 +primcorec semi_stream :: "'a stream \<Rightarrow> 'a stream" where
68.79 + "semi_stream s = Stream (shd s) (semi_stream (stl (stl s)))"
68.80 +
68.81 +primcorec
68.82 + tree'_of_stream :: "'a stream \<Rightarrow> 'a tree'" and
68.83 + branch_of_stream :: "'a stream \<Rightarrow> 'a branch"
68.84 +where
68.85 + "tree'_of_stream s =
68.86 + TNode' (branch_of_stream (semi_stream s)) (branch_of_stream (semi_stream (stl s)))" |
68.87 + "branch_of_stream s = (case s of Stream h t \<Rightarrow> Branch h (tree'_of_stream t))"
68.88 +
68.89 +primcorec
68.90 + freeze_exp :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) exp \<Rightarrow> ('a, 'b) exp" and
68.91 + freeze_trm :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) trm \<Rightarrow> ('a, 'b) trm" and
68.92 + freeze_factor :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) factor \<Rightarrow> ('a, 'b) factor"
68.93 +where
68.94 + "freeze_exp g e =
68.95 + (case e of
68.96 + Term t \<Rightarrow> Term (freeze_trm g t)
68.97 + | Sum t e \<Rightarrow> Sum (freeze_trm g t) (freeze_exp g e))" |
68.98 + "freeze_trm g t =
68.99 + (case t of
68.100 + Factor f \<Rightarrow> Factor (freeze_factor g f)
68.101 + | Prod f t \<Rightarrow> Prod (freeze_factor g f) (freeze_trm g t))" |
68.102 + "freeze_factor g f =
68.103 + (case f of
68.104 + C a \<Rightarrow> C a
68.105 + | V b \<Rightarrow> C (g b)
68.106 + | Paren e \<Rightarrow> Paren (freeze_exp g e))"
68.107 +
68.108 +primcorec poly_unity :: "'a poly_unit" where
68.109 + "poly_unity = U (\<lambda>_. poly_unity)"
68.110 +
68.111 +primcorec build_cps :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool stream) \<Rightarrow> 'a \<Rightarrow> bool stream \<Rightarrow> 'a cps" where
68.112 + "shd b \<Longrightarrow> build_cps f g a b = CPS1 a" |
68.113 + "_ \<Longrightarrow> build_cps f g a b = CPS2 (\<lambda>a. build_cps f g (f a) (g a))"
68.114 +
68.115 +end
69.1 --- a/src/HOL/BNF/Examples/Misc_Primrec.thy Thu Dec 05 17:52:12 2013 +0100
69.2 +++ b/src/HOL/BNF/Examples/Misc_Primrec.thy Thu Dec 05 17:58:03 2013 +0100
69.3 @@ -14,7 +14,7 @@
69.4 primrec_new nat_of_simple :: "simple \<Rightarrow> nat" where
69.5 "nat_of_simple X1 = 1" |
69.6 "nat_of_simple X2 = 2" |
69.7 - "nat_of_simple X3 = 2" |
69.8 + "nat_of_simple X3 = 3" |
69.9 "nat_of_simple X4 = 4"
69.10
69.11 primrec_new simple_of_simple' :: "simple' \<Rightarrow> simple" where
70.1 --- a/src/HOL/BNF/Examples/Process.thy Thu Dec 05 17:52:12 2013 +0100
70.2 +++ b/src/HOL/BNF/Examples/Process.thy Thu Dec 05 17:58:03 2013 +0100
70.3 @@ -22,7 +22,7 @@
70.4 subsection {* Basic properties *}
70.5
70.6 declare
70.7 - pre_process_rel_def[simp]
70.8 + rel_pre_process_def[simp]
70.9 sum_rel_def[simp]
70.10 prod_rel_def[simp]
70.11
70.12 @@ -81,24 +81,17 @@
70.13
70.14 datatype x_y_ax = x | y | ax
70.15
70.16 -definition "isA \<equiv> \<lambda> K. case K of x \<Rightarrow> False |y \<Rightarrow> True |ax \<Rightarrow> True"
70.17 -definition "pr \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> ''b'' |ax \<Rightarrow> ''a''"
70.18 -definition "co \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> x |ax \<Rightarrow> x"
70.19 -lemmas Action_defs = isA_def pr_def co_def
70.20 +primcorec F :: "x_y_ax \<Rightarrow> char list process" where
70.21 + "xyax = x \<Longrightarrow> isChoice (F xyax)"
70.22 +| "ch1Of (F xyax) = F ax"
70.23 +| "ch2Of (F xyax) = F y"
70.24 +| "prefOf (F xyax) = (if xyax = y then ''b'' else ''a'')"
70.25 +| "contOf (F xyax) = F x"
70.26
70.27 -definition "c1 \<equiv> \<lambda> K. case K of x \<Rightarrow> ax |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
70.28 -definition "c2 \<equiv> \<lambda> K. case K of x \<Rightarrow> y |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
70.29 -lemmas Choice_defs = c1_def c2_def
70.30 -
70.31 -definition "F \<equiv> process_unfold isA pr co c1 c2"
70.32 definition "X = F x" definition "Y = F y" definition "AX = F ax"
70.33
70.34 lemma X_Y_AX: "X = Choice AX Y" "Y = Action ''b'' X" "AX = Action ''a'' X"
70.35 -unfolding X_def Y_def AX_def F_def
70.36 -using process.unfold(2)[of isA x "pr" co c1 c2]
70.37 - process.unfold(1)[of isA y "pr" co c1 c2]
70.38 - process.unfold(1)[of isA ax "pr" co c1 c2]
70.39 -unfolding Action_defs Choice_defs by simp_all
70.40 +unfolding X_def Y_def AX_def by (subst F.code, simp)+
70.41
70.42 (* end product: *)
70.43 lemma X_AX:
71.1 --- a/src/HOL/BNF/Examples/Stream.thy Thu Dec 05 17:52:12 2013 +0100
71.2 +++ b/src/HOL/BNF/Examples/Stream.thy Thu Dec 05 17:58:03 2013 +0100
71.3 @@ -18,7 +18,7 @@
71.4 code_datatype Stream
71.5
71.6 lemma stream_case_cert:
71.7 - assumes "CASE \<equiv> stream_case c"
71.8 + assumes "CASE \<equiv> case_stream c"
71.9 shows "CASE (a ## s) \<equiv> c a s"
71.10 using assms by simp_all
71.11
71.12 @@ -87,10 +87,10 @@
71.13 by (induct xs) auto
71.14
71.15
71.16 -subsection {* set of streams with elements in some fixes set *}
71.17 +subsection {* set of streams with elements in some fixed set *}
71.18
71.19 coinductive_set
71.20 - streams :: "'a set => 'a stream set"
71.21 + streams :: "'a set \<Rightarrow> 'a stream set"
71.22 for A :: "'a set"
71.23 where
71.24 Stream[intro!, simp, no_atp]: "\<lbrakk>a \<in> A; s \<in> streams A\<rbrakk> \<Longrightarrow> a ## s \<in> streams A"
71.25 @@ -98,6 +98,15 @@
71.26 lemma shift_streams: "\<lbrakk>w \<in> lists A; s \<in> streams A\<rbrakk> \<Longrightarrow> w @- s \<in> streams A"
71.27 by (induct w) auto
71.28
71.29 +lemma streams_Stream: "x ## s \<in> streams A \<longleftrightarrow> x \<in> A \<and> s \<in> streams A"
71.30 + by (auto elim: streams.cases)
71.31 +
71.32 +lemma streams_stl: "s \<in> streams A \<Longrightarrow> stl s \<in> streams A"
71.33 + by (cases s) (auto simp: streams_Stream)
71.34 +
71.35 +lemma streams_shd: "s \<in> streams A \<Longrightarrow> shd s \<in> A"
71.36 + by (cases s) (auto simp: streams_Stream)
71.37 +
71.38 lemma sset_streams:
71.39 assumes "sset s \<subseteq> A"
71.40 shows "s \<in> streams A"
71.41 @@ -105,6 +114,28 @@
71.42 case streams then show ?case by (cases s) simp
71.43 qed
71.44
71.45 +lemma streams_sset:
71.46 + assumes "s \<in> streams A"
71.47 + shows "sset s \<subseteq> A"
71.48 +proof
71.49 + fix x assume "x \<in> sset s" from this `s \<in> streams A` show "x \<in> A"
71.50 + by (induct s) (auto intro: streams_shd streams_stl)
71.51 +qed
71.52 +
71.53 +lemma streams_iff_sset: "s \<in> streams A \<longleftrightarrow> sset s \<subseteq> A"
71.54 + by (metis sset_streams streams_sset)
71.55 +
71.56 +lemma streams_mono: "s \<in> streams A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> s \<in> streams B"
71.57 + unfolding streams_iff_sset by auto
71.58 +
71.59 +lemma smap_streams: "s \<in> streams A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> smap f s \<in> streams B"
71.60 + unfolding streams_iff_sset stream.set_map by auto
71.61 +
71.62 +lemma streams_empty: "streams {} = {}"
71.63 + by (auto elim: streams.cases)
71.64 +
71.65 +lemma streams_UNIV[simp]: "streams UNIV = UNIV"
71.66 + by (auto simp: streams_iff_sset)
71.67
71.68 subsection {* nth, take, drop for streams *}
71.69
71.70 @@ -234,6 +265,9 @@
71.71 lemma stream_all_shift[simp]: "stream_all P (xs @- s) = (list_all P xs \<and> stream_all P s)"
71.72 unfolding stream_all_iff list_all_iff by auto
71.73
71.74 +lemma stream_all_Stream: "stream_all P (x ## X) \<longleftrightarrow> P x \<and> stream_all P X"
71.75 + by simp
71.76 +
71.77
71.78 subsection {* recurring stream out of a list *}
71.79
71.80 @@ -285,59 +319,60 @@
71.81 by (induct n arbitrary: u) (auto simp: rotate1_rotate_swap rotate1_hd_tl rotate_conv_mod[symmetric])
71.82
71.83
71.84 +subsection {* iterated application of a function *}
71.85 +
71.86 +primcorec siterate where
71.87 + "shd (siterate f x) = x"
71.88 +| "stl (siterate f x) = siterate f (f x)"
71.89 +
71.90 +lemma stake_Suc: "stake (Suc n) s = stake n s @ [s !! n]"
71.91 + by (induct n arbitrary: s) auto
71.92 +
71.93 +lemma snth_siterate[simp]: "siterate f x !! n = (f^^n) x"
71.94 + by (induct n arbitrary: x) (auto simp: funpow_swap1)
71.95 +
71.96 +lemma sdrop_siterate[simp]: "sdrop n (siterate f x) = siterate f ((f^^n) x)"
71.97 + by (induct n arbitrary: x) (auto simp: funpow_swap1)
71.98 +
71.99 +lemma stake_siterate[simp]: "stake n (siterate f x) = map (\<lambda>n. (f^^n) x) [0 ..< n]"
71.100 + by (induct n arbitrary: x) (auto simp del: stake.simps(2) simp: stake_Suc)
71.101 +
71.102 +lemma sset_siterate: "sset (siterate f x) = {(f^^n) x | n. True}"
71.103 + by (auto simp: sset_range)
71.104 +
71.105 +lemma smap_siterate: "smap f (siterate f x) = siterate f (f x)"
71.106 + by (coinduction arbitrary: x) auto
71.107 +
71.108 +
71.109 subsection {* stream repeating a single element *}
71.110
71.111 -primcorec same where
71.112 - "shd (same x) = x"
71.113 -| "stl (same x) = same x"
71.114 +abbreviation "sconst \<equiv> siterate id"
71.115
71.116 -lemma snth_same[simp]: "same x !! n = x"
71.117 - unfolding same_def by (induct n) auto
71.118 +lemma shift_replicate_sconst[simp]: "replicate n x @- sconst x = sconst x"
71.119 + by (subst (3) stake_sdrop[symmetric]) (simp add: map_replicate_trivial)
71.120
71.121 -lemma stake_same[simp]: "stake n (same x) = replicate n x"
71.122 - unfolding same_def by (induct n) (auto simp: upt_rec)
71.123 +lemma stream_all_same[simp]: "sset (sconst x) = {x}"
71.124 + by (simp add: sset_siterate)
71.125
71.126 -lemma sdrop_same[simp]: "sdrop n (same x) = same x"
71.127 - unfolding same_def by (induct n) auto
71.128 +lemma same_cycle: "sconst x = cycle [x]"
71.129 + by coinduction auto
71.130
71.131 -lemma shift_replicate_same[simp]: "replicate n x @- same x = same x"
71.132 - by (metis sdrop_same stake_same stake_sdrop)
71.133 +lemma smap_sconst: "smap f (sconst x) = sconst (f x)"
71.134 + by coinduction auto
71.135
71.136 -lemma stream_all_same[simp]: "stream_all P (same x) \<longleftrightarrow> P x"
71.137 - unfolding stream_all_def by auto
71.138 -
71.139 -lemma same_cycle: "same x = cycle [x]"
71.140 - by coinduction auto
71.141 +lemma sconst_streams: "x \<in> A \<Longrightarrow> sconst x \<in> streams A"
71.142 + by (simp add: streams_iff_sset)
71.143
71.144
71.145 subsection {* stream of natural numbers *}
71.146
71.147 -primcorec fromN :: "nat \<Rightarrow> nat stream" where
71.148 - "fromN n = n ## fromN (n + 1)"
71.149 -
71.150 -lemma snth_fromN[simp]: "fromN n !! m = n + m"
71.151 - unfolding fromN_def by (induct m arbitrary: n) auto
71.152 -
71.153 -lemma stake_fromN[simp]: "stake m (fromN n) = [n ..< m + n]"
71.154 - unfolding fromN_def by (induct m arbitrary: n) (auto simp: upt_rec)
71.155 -
71.156 -lemma sdrop_fromN[simp]: "sdrop m (fromN n) = fromN (n + m)"
71.157 - unfolding fromN_def by (induct m arbitrary: n) auto
71.158 -
71.159 -lemma sset_fromN[simp]: "sset (fromN n) = {n ..}" (is "?L = ?R")
71.160 -proof safe
71.161 - fix m assume "m \<in> ?L"
71.162 - moreover
71.163 - { fix s assume "m \<in> sset s" "\<exists>n'\<ge>n. s = fromN n'"
71.164 - hence "n \<le> m" by (induct arbitrary: n rule: sset_induct1) fastforce+
71.165 - }
71.166 - ultimately show "n \<le> m" by auto
71.167 -next
71.168 - fix m assume "n \<le> m" thus "m \<in> ?L" by (metis le_iff_add snth_fromN snth_sset)
71.169 -qed
71.170 +abbreviation "fromN \<equiv> siterate Suc"
71.171
71.172 abbreviation "nats \<equiv> fromN 0"
71.173
71.174 +lemma sset_fromN[simp]: "sset (fromN n) = {n ..}"
71.175 + by (auto simp add: sset_siterate) arith
71.176 +
71.177
71.178 subsection {* flatten a stream of lists *}
71.179
71.180 @@ -498,26 +533,4 @@
71.181 "smap2 f s1 s2 = smap (split f) (szip s1 s2)"
71.182 by (coinduction arbitrary: s1 s2) auto
71.183
71.184 -
71.185 -subsection {* iterated application of a function *}
71.186 -
71.187 -primcorec siterate where
71.188 - "shd (siterate f x) = x"
71.189 -| "stl (siterate f x) = siterate f (f x)"
71.190 -
71.191 -lemma stake_Suc: "stake (Suc n) s = stake n s @ [s !! n]"
71.192 - by (induct n arbitrary: s) auto
71.193 -
71.194 -lemma snth_siterate[simp]: "siterate f x !! n = (f^^n) x"
71.195 - by (induct n arbitrary: x) (auto simp: funpow_swap1)
71.196 -
71.197 -lemma sdrop_siterate[simp]: "sdrop n (siterate f x) = siterate f ((f^^n) x)"
71.198 - by (induct n arbitrary: x) (auto simp: funpow_swap1)
71.199 -
71.200 -lemma stake_siterate[simp]: "stake n (siterate f x) = map (\<lambda>n. (f^^n) x) [0 ..< n]"
71.201 - by (induct n arbitrary: x) (auto simp del: stake.simps(2) simp: stake_Suc)
71.202 -
71.203 -lemma sset_siterate: "sset (siterate f x) = {(f^^n) x | n. True}"
71.204 - by (auto simp: sset_range)
71.205 -
71.206 end
72.1 --- a/src/HOL/BNF/More_BNFs.thy Thu Dec 05 17:52:12 2013 +0100
72.2 +++ b/src/HOL/BNF/More_BNFs.thy Thu Dec 05 17:58:03 2013 +0100
72.3 @@ -15,13 +15,17 @@
72.4 Basic_BNFs
72.5 "~~/src/HOL/Library/FSet"
72.6 "~~/src/HOL/Library/Multiset"
72.7 - Countable_Type
72.8 begin
72.9
72.10 lemma option_rec_conv_option_case: "option_rec = option_case"
72.11 by (simp add: fun_eq_iff split: option.split)
72.12
72.13 -bnf Option.map [Option.set] "\<lambda>_::'a option. natLeq" ["None"] option_rel
72.14 +bnf "'a option"
72.15 + map: Option.map
72.16 + sets: Option.set
72.17 + bd: natLeq
72.18 + wits: None
72.19 + rel: option_rel
72.20 proof -
72.21 show "Option.map id = id" by (simp add: fun_eq_iff Option.map_def split: option.split)
72.22 next
72.23 @@ -94,7 +98,12 @@
72.24 (\<exists>zs \<in> ?A. map p1 zs = as \<and> map p2 zs = bs)" by blast
72.25 qed
72.26
72.27 -bnf map [set] "\<lambda>_::'a list. natLeq" ["[]"]
72.28 +bnf "'a list"
72.29 + map: map
72.30 + sets: set
72.31 + bd: natLeq
72.32 + wits: Nil
72.33 + rel: list_all2
72.34 proof -
72.35 show "map id = id" by (rule List.map.id)
72.36 next
72.37 @@ -115,8 +124,16 @@
72.38 fix x
72.39 show "|set x| \<le>o natLeq"
72.40 by (metis List.finite_set finite_iff_ordLess_natLeq ordLess_imp_ordLeq)
72.41 +next
72.42 + fix R
72.43 + show "list_all2 R =
72.44 + (Grp {x. set x \<subseteq> {(x, y). R x y}} (map fst))\<inverse>\<inverse> OO
72.45 + Grp {x. set x \<subseteq> {(x, y). R x y}} (map snd)"
72.46 + unfolding list_all2_def[abs_def] Grp_def fun_eq_iff relcompp.simps conversep.simps
72.47 + by (force simp: zip_map_fst_snd)
72.48 qed (simp add: wpull_map)+
72.49
72.50 +
72.51 (* Finite sets *)
72.52
72.53 lemma wpull_image:
72.54 @@ -189,7 +206,7 @@
72.55 by (transfer, clarsimp, metis fst_conv)
72.56 qed
72.57
72.58 -lemma wpull_fmap:
72.59 +lemma wpull_fimage:
72.60 assumes "wpull A B1 B2 f1 f2 p1 p2"
72.61 shows "wpull {x. fset x \<subseteq> A} {x. fset x \<subseteq> B1} {x. fset x \<subseteq> B2}
72.62 (fimage f1) (fimage f2) (fimage p1) (fimage p2)"
72.63 @@ -214,7 +231,12 @@
72.64 using X' Y1 Y2 by (auto simp: X'eq intro!: exI[of _ "x"]) (transfer, blast)+
72.65 qed
72.66
72.67 -bnf fimage [fset] "\<lambda>_::'a fset. natLeq" ["{||}"] fset_rel
72.68 +bnf "'a fset"
72.69 + map: fimage
72.70 + sets: fset
72.71 + bd: natLeq
72.72 + wits: "{||}"
72.73 + rel: fset_rel
72.74 apply -
72.75 apply transfer' apply simp
72.76 apply transfer' apply force
72.77 @@ -223,7 +245,7 @@
72.78 apply (rule natLeq_card_order)
72.79 apply (rule natLeq_cinfinite)
72.80 apply transfer apply (metis ordLess_imp_ordLeq finite_iff_ordLess_natLeq)
72.81 - apply (erule wpull_fmap)
72.82 + apply (erule wpull_fimage)
72.83 apply (simp add: Grp_def relcompp.simps conversep.simps fun_eq_iff fset_rel_alt fset_rel_aux)
72.84 apply transfer apply simp
72.85 done
72.86 @@ -235,121 +257,6 @@
72.87
72.88 lemmas [simp] = fset.map_comp fset.map_id fset.set_map
72.89
72.90 -(* Countable sets *)
72.91 -
72.92 -lemma card_of_countable_sets_range:
72.93 -fixes A :: "'a set"
72.94 -shows "|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |{f::nat \<Rightarrow> 'a. range f \<subseteq> A}|"
72.95 -apply(rule card_of_ordLeqI[of from_nat_into]) using inj_on_from_nat_into
72.96 -unfolding inj_on_def by auto
72.97 -
72.98 -lemma card_of_countable_sets_Func:
72.99 -"|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |A| ^c natLeq"
72.100 -using card_of_countable_sets_range card_of_Func_UNIV[THEN ordIso_symmetric]
72.101 -unfolding cexp_def Field_natLeq Field_card_of
72.102 -by (rule ordLeq_ordIso_trans)
72.103 -
72.104 -lemma ordLeq_countable_subsets:
72.105 -"|A| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
72.106 -apply (rule card_of_ordLeqI[of "\<lambda> a. {a}"]) unfolding inj_on_def by auto
72.107 -
72.108 -lemma finite_countable_subset:
72.109 -"finite {X. X \<subseteq> A \<and> countable X} \<longleftrightarrow> finite A"
72.110 -apply default
72.111 - apply (erule contrapos_pp)
72.112 - apply (rule card_of_ordLeq_infinite)
72.113 - apply (rule ordLeq_countable_subsets)
72.114 - apply assumption
72.115 -apply (rule finite_Collect_conjI)
72.116 -apply (rule disjI1)
72.117 -by (erule finite_Collect_subsets)
72.118 -
72.119 -lemma rcset_to_rcset: "countable A \<Longrightarrow> rcset (the_inv rcset A) = A"
72.120 - apply (rule f_the_inv_into_f[unfolded inj_on_def image_iff])
72.121 - apply transfer' apply simp
72.122 - apply transfer' apply simp
72.123 - done
72.124 -
72.125 -lemma Collect_Int_Times:
72.126 -"{(x, y). R x y} \<inter> A \<times> B = {(x, y). R x y \<and> x \<in> A \<and> y \<in> B}"
72.127 -by auto
72.128 -
72.129 -definition cset_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a cset \<Rightarrow> 'b cset \<Rightarrow> bool" where
72.130 -"cset_rel R a b \<longleftrightarrow>
72.131 - (\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and>
72.132 - (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t)"
72.133 -
72.134 -lemma cset_rel_aux:
72.135 -"(\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and> (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t) \<longleftrightarrow>
72.136 - ((Grp {x. rcset x \<subseteq> {(a, b). R a b}} (cimage fst))\<inverse>\<inverse> OO
72.137 - Grp {x. rcset x \<subseteq> {(a, b). R a b}} (cimage snd)) a b" (is "?L = ?R")
72.138 -proof
72.139 - assume ?L
72.140 - def R' \<equiv> "the_inv rcset (Collect (split R) \<inter> (rcset a \<times> rcset b))"
72.141 - (is "the_inv rcset ?L'")
72.142 - have L: "countable ?L'" by auto
72.143 - hence *: "rcset R' = ?L'" unfolding R'_def using fset_to_fset by (intro rcset_to_rcset)
72.144 - thus ?R unfolding Grp_def relcompp.simps conversep.simps
72.145 - proof (intro CollectI prod_caseI exI[of _ a] exI[of _ b] exI[of _ R'] conjI refl)
72.146 - from * `?L` show "a = cimage fst R'" by transfer (auto simp: image_def Collect_Int_Times)
72.147 - next
72.148 - from * `?L` show "b = cimage snd R'" by transfer (auto simp: image_def Collect_Int_Times)
72.149 - qed simp_all
72.150 -next
72.151 - assume ?R thus ?L unfolding Grp_def relcompp.simps conversep.simps
72.152 - by transfer force
72.153 -qed
72.154 -
72.155 -bnf cimage [rcset] "\<lambda>_::'a cset. natLeq" ["cempty"] cset_rel
72.156 -proof -
72.157 - show "cimage id = id" by transfer' simp
72.158 -next
72.159 - fix f g show "cimage (g \<circ> f) = cimage g \<circ> cimage f" by transfer' fastforce
72.160 -next
72.161 - fix C f g assume eq: "\<And>a. a \<in> rcset C \<Longrightarrow> f a = g a"
72.162 - thus "cimage f C = cimage g C" by transfer force
72.163 -next
72.164 - fix f show "rcset \<circ> cimage f = op ` f \<circ> rcset" by transfer' fastforce
72.165 -next
72.166 - show "card_order natLeq" by (rule natLeq_card_order)
72.167 -next
72.168 - show "cinfinite natLeq" by (rule natLeq_cinfinite)
72.169 -next
72.170 - fix C show "|rcset C| \<le>o natLeq" by transfer (unfold countable_card_le_natLeq)
72.171 -next
72.172 - fix A B1 B2 f1 f2 p1 p2
72.173 - assume wp: "wpull A B1 B2 f1 f2 p1 p2"
72.174 - show "wpull {x. rcset x \<subseteq> A} {x. rcset x \<subseteq> B1} {x. rcset x \<subseteq> B2}
72.175 - (cimage f1) (cimage f2) (cimage p1) (cimage p2)"
72.176 - unfolding wpull_def proof safe
72.177 - fix y1 y2
72.178 - assume Y1: "rcset y1 \<subseteq> B1" and Y2: "rcset y2 \<subseteq> B2"
72.179 - assume "cimage f1 y1 = cimage f2 y2"
72.180 - hence EQ: "f1 ` (rcset y1) = f2 ` (rcset y2)" by transfer
72.181 - with Y1 Y2 obtain X where X: "X \<subseteq> A"
72.182 - and Y1: "p1 ` X = rcset y1" and Y2: "p2 ` X = rcset y2"
72.183 - using wpull_image[OF wp] unfolding wpull_def Pow_def Bex_def mem_Collect_eq
72.184 - by (auto elim!: allE[of _ "rcset y1"] allE[of _ "rcset y2"])
72.185 - have "\<forall> y1' \<in> rcset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
72.186 - then obtain q1 where q1: "\<forall> y1' \<in> rcset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
72.187 - have "\<forall> y2' \<in> rcset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
72.188 - then obtain q2 where q2: "\<forall> y2' \<in> rcset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
72.189 - def X' \<equiv> "q1 ` (rcset y1) \<union> q2 ` (rcset y2)"
72.190 - have X': "X' \<subseteq> A" and Y1: "p1 ` X' = rcset y1" and Y2: "p2 ` X' = rcset y2"
72.191 - using X Y1 Y2 q1 q2 unfolding X'_def by fast+
72.192 - have fX': "countable X'" unfolding X'_def by simp
72.193 - then obtain x where X'eq: "X' = rcset x" by transfer blast
72.194 - show "\<exists>x\<in>{x. rcset x \<subseteq> A}. cimage p1 x = y1 \<and> cimage p2 x = y2"
72.195 - using X' Y1 Y2 unfolding X'eq by (intro bexI[of _ "x"]) (transfer, auto)
72.196 - qed
72.197 -next
72.198 - fix R
72.199 - show "cset_rel R =
72.200 - (Grp {x. rcset x \<subseteq> Collect (split R)} (cimage fst))\<inverse>\<inverse> OO
72.201 - Grp {x. rcset x \<subseteq> Collect (split R)} (cimage snd)"
72.202 - unfolding cset_rel_def[abs_def] cset_rel_aux by simp
72.203 -qed (transfer, simp)
72.204 -
72.205
72.206 (* Multisets *)
72.207
72.208 @@ -874,22 +781,26 @@
72.209 by transfer
72.210 (auto intro!: ordLess_imp_ordLeq simp: finite_iff_ordLess_natLeq[symmetric] multiset_def)
72.211
72.212 -bnf mmap [set_of] "\<lambda>_::'a multiset. natLeq" ["{#}"]
72.213 +bnf "'a multiset"
72.214 + map: mmap
72.215 + sets: set_of
72.216 + bd: natLeq
72.217 + wits: "{#}"
72.218 by (auto simp add: mmap_id0 mmap_comp set_of_mmap natLeq_card_order natLeq_cinfinite set_of_bd
72.219 intro: mmap_cong wpull_mmap)
72.220
72.221 -inductive multiset_rel' where
72.222 -Zero: "multiset_rel' R {#} {#}"
72.223 +inductive rel_multiset' where
72.224 +Zero: "rel_multiset' R {#} {#}"
72.225 |
72.226 -Plus: "\<lbrakk>R a b; multiset_rel' R M N\<rbrakk> \<Longrightarrow> multiset_rel' R (M + {#a#}) (N + {#b#})"
72.227 +Plus: "\<lbrakk>R a b; rel_multiset' R M N\<rbrakk> \<Longrightarrow> rel_multiset' R (M + {#a#}) (N + {#b#})"
72.228
72.229 -lemma multiset_map_Zero_iff[simp]: "mmap f M = {#} \<longleftrightarrow> M = {#}"
72.230 +lemma map_multiset_Zero_iff[simp]: "mmap f M = {#} \<longleftrightarrow> M = {#}"
72.231 by (metis image_is_empty multiset.set_map set_of_eq_empty_iff)
72.232
72.233 -lemma multiset_map_Zero[simp]: "mmap f {#} = {#}" by simp
72.234 +lemma map_multiset_Zero[simp]: "mmap f {#} = {#}" by simp
72.235
72.236 -lemma multiset_rel_Zero: "multiset_rel R {#} {#}"
72.237 -unfolding multiset_rel_def Grp_def by auto
72.238 +lemma rel_multiset_Zero: "rel_multiset R {#} {#}"
72.239 +unfolding rel_multiset_def Grp_def by auto
72.240
72.241 declare multiset.count[simp]
72.242 declare Abs_multiset_inverse[simp]
72.243 @@ -897,7 +808,7 @@
72.244 declare union_preserves_multiset[simp]
72.245
72.246
72.247 -lemma multiset_map_Plus[simp]: "mmap f (M1 + M2) = mmap f M1 + mmap f M2"
72.248 +lemma map_multiset_Plus[simp]: "mmap f (M1 + M2) = mmap f M1 + mmap f M2"
72.249 proof (intro multiset_eqI, transfer fixing: f)
72.250 fix x :: 'a and M1 M2 :: "'b \<Rightarrow> nat"
72.251 assume "M1 \<in> multiset" "M2 \<in> multiset"
72.252 @@ -910,12 +821,12 @@
72.253 by (auto simp: setsum.distrib[symmetric])
72.254 qed
72.255
72.256 -lemma multiset_map_singl[simp]: "mmap f {#a#} = {#f a#}"
72.257 +lemma map_multiset_singl[simp]: "mmap f {#a#} = {#f a#}"
72.258 by transfer auto
72.259
72.260 -lemma multiset_rel_Plus:
72.261 -assumes ab: "R a b" and MN: "multiset_rel R M N"
72.262 -shows "multiset_rel R (M + {#a#}) (N + {#b#})"
72.263 +lemma rel_multiset_Plus:
72.264 +assumes ab: "R a b" and MN: "rel_multiset R M N"
72.265 +shows "rel_multiset R (M + {#a#}) (N + {#b#})"
72.266 proof-
72.267 {fix y assume "R a b" and "set_of y \<subseteq> {(x, y). R x y}"
72.268 hence "\<exists>ya. mmap fst y + {#a#} = mmap fst ya \<and>
72.269 @@ -925,13 +836,13 @@
72.270 }
72.271 thus ?thesis
72.272 using assms
72.273 - unfolding multiset_rel_def Grp_def by force
72.274 + unfolding rel_multiset_def Grp_def by force
72.275 qed
72.276
72.277 -lemma multiset_rel'_imp_multiset_rel:
72.278 -"multiset_rel' R M N \<Longrightarrow> multiset_rel R M N"
72.279 -apply(induct rule: multiset_rel'.induct)
72.280 -using multiset_rel_Zero multiset_rel_Plus by auto
72.281 +lemma rel_multiset'_imp_rel_multiset:
72.282 +"rel_multiset' R M N \<Longrightarrow> rel_multiset R M N"
72.283 +apply(induct rule: rel_multiset'.induct)
72.284 +using rel_multiset_Zero rel_multiset_Plus by auto
72.285
72.286 lemma mcard_mmap[simp]: "mcard (mmap f M) = mcard M"
72.287 proof -
72.288 @@ -942,8 +853,7 @@
72.289 using finite_Collect_mem .
72.290 ultimately have fin: "finite {b. \<exists>a. f a = b \<and> a \<in># M}" by(rule finite_subset)
72.291 have i: "inj_on A ?B" unfolding inj_on_def A_def apply clarsimp
72.292 - by (metis (lifting, mono_tags) mem_Collect_eq rel_simps(54)
72.293 - setsum_gt_0_iff setsum_infinite)
72.294 + by (metis (lifting, full_types) mem_Collect_eq neq0_conv setsum.neutral)
72.295 have 0: "\<And> b. 0 < setsum (count M) (A b) \<longleftrightarrow> (\<exists> a \<in> A b. count M a > 0)"
72.296 apply safe
72.297 apply (metis less_not_refl setsum_gt_0_iff setsum_infinite)
72.298 @@ -964,10 +874,10 @@
72.299 then show ?thesis unfolding mcard_unfold_setsum A_def by transfer
72.300 qed
72.301
72.302 -lemma multiset_rel_mcard:
72.303 -assumes "multiset_rel R M N"
72.304 +lemma rel_multiset_mcard:
72.305 +assumes "rel_multiset R M N"
72.306 shows "mcard M = mcard N"
72.307 -using assms unfolding multiset_rel_def Grp_def by auto
72.308 +using assms unfolding rel_multiset_def Grp_def by auto
72.309
72.310 lemma multiset_induct2[case_names empty addL addR]:
72.311 assumes empty: "P {#} {#}"
72.312 @@ -1022,68 +932,67 @@
72.313 qed
72.314
72.315 lemma msed_rel_invL:
72.316 -assumes "multiset_rel R (M + {#a#}) N"
72.317 -shows "\<exists> N1 b. N = N1 + {#b#} \<and> R a b \<and> multiset_rel R M N1"
72.318 +assumes "rel_multiset R (M + {#a#}) N"
72.319 +shows "\<exists> N1 b. N = N1 + {#b#} \<and> R a b \<and> rel_multiset R M N1"
72.320 proof-
72.321 obtain K where KM: "mmap fst K = M + {#a#}"
72.322 and KN: "mmap snd K = N" and sK: "set_of K \<subseteq> {(a, b). R a b}"
72.323 using assms
72.324 - unfolding multiset_rel_def Grp_def by auto
72.325 + unfolding rel_multiset_def Grp_def by auto
72.326 obtain K1 ab where K: "K = K1 + {#ab#}" and a: "fst ab = a"
72.327 and K1M: "mmap fst K1 = M" using msed_map_invR[OF KM] by auto
72.328 obtain N1 where N: "N = N1 + {#snd ab#}" and K1N1: "mmap snd K1 = N1"
72.329 using msed_map_invL[OF KN[unfolded K]] by auto
72.330 have Rab: "R a (snd ab)" using sK a unfolding K by auto
72.331 - have "multiset_rel R M N1" using sK K1M K1N1
72.332 - unfolding K multiset_rel_def Grp_def by auto
72.333 + have "rel_multiset R M N1" using sK K1M K1N1
72.334 + unfolding K rel_multiset_def Grp_def by auto
72.335 thus ?thesis using N Rab by auto
72.336 qed
72.337
72.338 lemma msed_rel_invR:
72.339 -assumes "multiset_rel R M (N + {#b#})"
72.340 -shows "\<exists> M1 a. M = M1 + {#a#} \<and> R a b \<and> multiset_rel R M1 N"
72.341 +assumes "rel_multiset R M (N + {#b#})"
72.342 +shows "\<exists> M1 a. M = M1 + {#a#} \<and> R a b \<and> rel_multiset R M1 N"
72.343 proof-
72.344 obtain K where KN: "mmap snd K = N + {#b#}"
72.345 and KM: "mmap fst K = M" and sK: "set_of K \<subseteq> {(a, b). R a b}"
72.346 using assms
72.347 - unfolding multiset_rel_def Grp_def by auto
72.348 + unfolding rel_multiset_def Grp_def by auto
72.349 obtain K1 ab where K: "K = K1 + {#ab#}" and b: "snd ab = b"
72.350 and K1N: "mmap snd K1 = N" using msed_map_invR[OF KN] by auto
72.351 obtain M1 where M: "M = M1 + {#fst ab#}" and K1M1: "mmap fst K1 = M1"
72.352 using msed_map_invL[OF KM[unfolded K]] by auto
72.353 have Rab: "R (fst ab) b" using sK b unfolding K by auto
72.354 - have "multiset_rel R M1 N" using sK K1N K1M1
72.355 - unfolding K multiset_rel_def Grp_def by auto
72.356 + have "rel_multiset R M1 N" using sK K1N K1M1
72.357 + unfolding K rel_multiset_def Grp_def by auto
72.358 thus ?thesis using M Rab by auto
72.359 qed
72.360
72.361 -lemma multiset_rel_imp_multiset_rel':
72.362 -assumes "multiset_rel R M N"
72.363 -shows "multiset_rel' R M N"
72.364 +lemma rel_multiset_imp_rel_multiset':
72.365 +assumes "rel_multiset R M N"
72.366 +shows "rel_multiset' R M N"
72.367 using assms proof(induct M arbitrary: N rule: measure_induct_rule[of mcard])
72.368 case (less M)
72.369 - have c: "mcard M = mcard N" using multiset_rel_mcard[OF less.prems] .
72.370 + have c: "mcard M = mcard N" using rel_multiset_mcard[OF less.prems] .
72.371 show ?case
72.372 proof(cases "M = {#}")
72.373 case True hence "N = {#}" using c by simp
72.374 - thus ?thesis using True multiset_rel'.Zero by auto
72.375 + thus ?thesis using True rel_multiset'.Zero by auto
72.376 next
72.377 case False then obtain M1 a where M: "M = M1 + {#a#}" by (metis multi_nonempty_split)
72.378 - obtain N1 b where N: "N = N1 + {#b#}" and R: "R a b" and ms: "multiset_rel R M1 N1"
72.379 + obtain N1 b where N: "N = N1 + {#b#}" and R: "R a b" and ms: "rel_multiset R M1 N1"
72.380 using msed_rel_invL[OF less.prems[unfolded M]] by auto
72.381 - have "multiset_rel' R M1 N1" using less.hyps[of M1 N1] ms unfolding M by simp
72.382 - thus ?thesis using multiset_rel'.Plus[of R a b, OF R] unfolding M N by simp
72.383 + have "rel_multiset' R M1 N1" using less.hyps[of M1 N1] ms unfolding M by simp
72.384 + thus ?thesis using rel_multiset'.Plus[of R a b, OF R] unfolding M N by simp
72.385 qed
72.386 qed
72.387
72.388 -lemma multiset_rel_multiset_rel':
72.389 -"multiset_rel R M N = multiset_rel' R M N"
72.390 -using multiset_rel_imp_multiset_rel' multiset_rel'_imp_multiset_rel by auto
72.391 +lemma rel_multiset_rel_multiset':
72.392 +"rel_multiset R M N = rel_multiset' R M N"
72.393 +using rel_multiset_imp_rel_multiset' rel_multiset'_imp_rel_multiset by auto
72.394
72.395 -(* The main end product for multiset_rel: inductive characterization *)
72.396 -theorems multiset_rel_induct[case_names empty add, induct pred: multiset_rel] =
72.397 - multiset_rel'.induct[unfolded multiset_rel_multiset_rel'[symmetric]]
72.398 -
72.399 +(* The main end product for rel_multiset: inductive characterization *)
72.400 +theorems rel_multiset_induct[case_names empty add, induct pred: rel_multiset] =
72.401 + rel_multiset'.induct[unfolded rel_multiset_rel_multiset'[symmetric]]
72.402
72.403
72.404 (* Advanced relator customization *)
72.405 @@ -1153,5 +1062,4 @@
72.406 qed
72.407 qed
72.408
72.409 -
72.410 end
73.1 --- a/src/HOL/BNF/README.html Thu Dec 05 17:52:12 2013 +0100
73.2 +++ b/src/HOL/BNF/README.html Thu Dec 05 17:58:03 2013 +0100
73.3 @@ -20,7 +20,8 @@
73.4 possibly infinite depth. The framework draws heavily from category theory.
73.5
73.6 <p>
73.7 -The package is described in the following paper:
73.8 +The package is described in <tt>isabelle doc datatypes</tt> and in the following
73.9 +paper:
73.10
73.11 <ul>
73.12 <li><a href="http://www21.in.tum.de/~traytel/papers/lics12-codatatypes/index.html">Foundational, Compositional (Co)datatypes for Higher-Order Logic—Category Theory Applied to Theorem Proving</a>, <br>
73.13 @@ -37,17 +38,10 @@
73.14 The key notion underlying the package is that of a <i>bounded natural functor</i>
73.15 (<i>BNF</i>)—an enriched type constructor satisfying specific properties
73.16 preserved by interesting categorical operations (composition, least fixed point,
73.17 -and greatest fixed point). The <tt>Basic_BNFs.thy</tt> and <tt>More_BNFs.thy</tt>
73.18 -files register various basic types, notably for sums, products, function spaces,
73.19 -finite sets, multisets, and countable sets. Custom BNFs can be registered as well.
73.20 -
73.21 -<p>
73.22 -<b>Warning:</b> The package is under development. Please contact any nonempty
73.23 -subset of
73.24 -<a href="mailto:traytel@in.tum.de">the</a>
73.25 -<a href="mailto:popescua@in.tum.de">above</a>
73.26 -<a href="mailto:blanchette@in.tum.de">authors</a>
73.27 -if you have questions or comments.
73.28 +and greatest fixed point). The <tt>Basic_BNFs.thy</tt>, <tt>More_BNFs.thy</tt>,
73.29 +and <tt>Countable_Set_Type.thy</tt> files register various basic types, notably
73.30 +for sums, products, function spaces, finite sets, multisets, and countable sets.
73.31 +Custom BNFs can be registered as well.
73.32
73.33 </body>
73.34
74.1 --- a/src/HOL/BNF/Tools/bnf_comp.ML Thu Dec 05 17:52:12 2013 +0100
74.2 +++ b/src/HOL/BNF/Tools/bnf_comp.ML Thu Dec 05 17:58:03 2013 +0100
74.3 @@ -147,7 +147,7 @@
74.4 val (sets, sets_alt) = map_split mk_set (0 upto ilive - 1);
74.5
74.6 (*(inner_1.bd +c ... +c inner_m.bd) *c outer.bd*)
74.7 - val bd = Term.absdummy CCA (mk_cprod (Library.foldr1 (uncurry mk_csum) inner_bds) outer_bd);
74.8 + val bd = mk_cprod (Library.foldr1 (uncurry mk_csum) inner_bds) outer_bd;
74.9
74.10 fun map_id0_tac _ =
74.11 mk_comp_map_id0_tac (map_id0_of_bnf outer) (map_cong0_of_bnf outer)
74.12 @@ -257,7 +257,7 @@
74.13
74.14 val (bnf', lthy') =
74.15 bnf_def const_policy (K Dont_Note) qualify tacs wit_tac (SOME (oDs @ flat Dss)) Binding.empty
74.16 - Binding.empty [] (((((b, mapx), sets), bd), wits), SOME rel) lthy;
74.17 + Binding.empty [] ((((((b, CCA), mapx), sets), bd), wits), SOME rel) lthy;
74.18 in
74.19 (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
74.20 end;
74.21 @@ -351,7 +351,7 @@
74.22
74.23 val (bnf', lthy') =
74.24 bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME (killedAs @ Ds)) Binding.empty
74.25 - Binding.empty [] (((((b, mapx), sets), Term.absdummy T bd), wits), SOME rel) lthy;
74.26 + Binding.empty [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
74.27 in
74.28 (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
74.29 end;
74.30 @@ -433,7 +433,7 @@
74.31
74.32 val (bnf', lthy') =
74.33 bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME Ds) Binding.empty Binding.empty
74.34 - [] (((((b, mapx), sets), Term.absdummy T bd), wits), SOME rel) lthy;
74.35 + [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
74.36 in
74.37 (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
74.38 end;
74.39 @@ -506,7 +506,7 @@
74.40
74.41 val (bnf', lthy') =
74.42 bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME Ds) Binding.empty Binding.empty
74.43 - [] (((((b, mapx), sets), Term.absdummy T bd), wits), SOME rel) lthy;
74.44 + [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
74.45 in
74.46 (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
74.47 end;
74.48 @@ -643,7 +643,7 @@
74.49 val (bnf', lthy') =
74.50 bnf_def Hardly_Inline (user_policy Dont_Note) qualify tacs wit_tac (SOME deads)
74.51 Binding.empty Binding.empty []
74.52 - (((((b, bnf_map), bnf_sets), Term.absdummy T bnf_bd'), bnf_wits), SOME bnf_rel) lthy;
74.53 + ((((((b, T), bnf_map), bnf_sets), bnf_bd'), bnf_wits), SOME bnf_rel) lthy;
74.54 in
74.55 ((bnf', deads), lthy')
74.56 end;
75.1 --- a/src/HOL/BNF/Tools/bnf_comp_tactics.ML Thu Dec 05 17:52:12 2013 +0100
75.2 +++ b/src/HOL/BNF/Tools/bnf_comp_tactics.ML Thu Dec 05 17:58:03 2013 +0100
75.3 @@ -164,10 +164,9 @@
75.4 fun mk_comp_wit_tac ctxt Gwit_thms collect_set_map Fwit_thms =
75.5 ALLGOALS (dtac @{thm in_Union_o_assoc}) THEN
75.6 unfold_thms_tac ctxt (collect_set_map :: comp_wit_thms) THEN
75.7 - REPEAT_DETERM (
75.8 - atac 1 ORELSE
75.9 - REPEAT_DETERM (eresolve_tac @{thms UnionE UnE imageE} 1) THEN
75.10 - (TRY o dresolve_tac Gwit_thms THEN'
75.11 + REPEAT_DETERM ((atac ORELSE'
75.12 + REPEAT_DETERM o eresolve_tac @{thms UnionE UnE} THEN'
75.13 + etac imageE THEN' TRY o dresolve_tac Gwit_thms THEN'
75.14 (etac FalseE ORELSE'
75.15 hyp_subst_tac ctxt THEN'
75.16 dresolve_tac Fwit_thms THEN'
76.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
76.2 +++ b/src/HOL/BNF/Tools/bnf_decl.ML Thu Dec 05 17:58:03 2013 +0100
76.3 @@ -0,0 +1,96 @@
76.4 +(* Title: HOL/BNF/Tools/bnf_decl.ML
76.5 + Author: Dmitriy Traytel, TU Muenchen
76.6 + Copyright 2013
76.7 +
76.8 +Axiomatic declaration of bounded natural functors.
76.9 +*)
76.10 +
76.11 +signature BNF_DECL =
76.12 +sig
76.13 + val bnf_decl: (binding option * (typ * sort)) list -> binding -> mixfix -> binding -> binding ->
76.14 + local_theory -> BNF_Def.bnf * local_theory
76.15 +end
76.16 +
76.17 +structure BNF_Decl : BNF_DECL =
76.18 +struct
76.19 +
76.20 +open BNF_Util
76.21 +open BNF_Def
76.22 +
76.23 +fun prepare_decl prepare_constraint prepare_typ raw_vars b mx user_mapb user_relb lthy =
76.24 + let
76.25 + fun prepare_type_arg (set_opt, (ty, c)) =
76.26 + let val s = fst (dest_TFree (prepare_typ lthy ty)) in
76.27 + (set_opt, (s, prepare_constraint lthy c))
76.28 + end;
76.29 + val ((user_setbs, vars), raw_vars') =
76.30 + map prepare_type_arg raw_vars
76.31 + |> `split_list
76.32 + |>> apfst (map_filter I);
76.33 + val deads = map_filter (fn (NONE, x) => SOME x | _ => NONE) raw_vars';
76.34 +
76.35 + fun mk_b name user_b =
76.36 + (if Binding.is_empty user_b then Binding.prefix_name (name ^ "_") b else user_b)
76.37 + |> Binding.qualify false (Binding.name_of b);
76.38 + val (Tname, lthy) = Typedecl.basic_typedecl (b, length vars, mx) lthy;
76.39 + val (bd_type_Tname, lthy) =
76.40 + Typedecl.basic_typedecl (mk_b "bd_type" Binding.empty, length deads, NoSyn) lthy;
76.41 + val T = Type (Tname, map TFree vars);
76.42 + val bd_type_T = Type (bd_type_Tname, map TFree deads);
76.43 + val lives = map TFree (filter_out (member (op =) deads) vars);
76.44 + val live = length lives;
76.45 + val _ = "Trying to declare a BNF with no live variables" |> null lives ? error;
76.46 + val (lives', _) = BNF_Util.mk_TFrees (length lives)
76.47 + (fold Variable.declare_typ (map TFree vars) lthy);
76.48 + val T' = Term.typ_subst_atomic (lives ~~ lives') T;
76.49 + val mapT = map2 (curry op -->) lives lives' ---> T --> T';
76.50 + val setTs = map (fn U => T --> HOLogic.mk_setT U) lives;
76.51 + val bdT = BNF_Util.mk_relT (bd_type_T, bd_type_T);
76.52 + val mapb = mk_b BNF_Def.mapN user_mapb;
76.53 + val bdb = mk_b "bd" Binding.empty;
76.54 + val setbs = map2 (fn b => fn i => mk_b (BNF_Def.mk_setN i) b) user_setbs
76.55 + (if live = 1 then [0] else 1 upto live);
76.56 + val lthy = Local_Theory.background_theory
76.57 + (Sign.add_consts_i ((mapb, mapT, NoSyn) :: (bdb, bdT, NoSyn) ::
76.58 + map2 (fn b => fn T => (b, T, NoSyn)) setbs setTs))
76.59 + lthy;
76.60 + val Fmap = Const (Local_Theory.full_name lthy mapb, mapT);
76.61 + val Fsets = map2 (fn setb => fn setT =>
76.62 + Const (Local_Theory.full_name lthy setb, setT)) setbs setTs;
76.63 + val Fbd = Const (Local_Theory.full_name lthy bdb, bdT);
76.64 + val (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, _) =
76.65 + prepare_def Do_Inline (user_policy Note_Some) I (K I) (K I) (SOME (map TFree deads))
76.66 + user_mapb user_relb user_setbs ((((((Binding.empty, T), Fmap), Fsets), Fbd), []), NONE) lthy;
76.67 +
76.68 + fun mk_wits_tac set_maps = K (TRYALL Goal.conjunction_tac) THEN' the triv_tac_opt set_maps;
76.69 + val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
76.70 + fun mk_wit_thms set_maps =
76.71 + Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) (mk_wits_tac set_maps)
76.72 + |> Conjunction.elim_balanced (length wit_goals)
76.73 + |> map2 (Conjunction.elim_balanced o length) wit_goalss
76.74 + |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
76.75 +
76.76 + val ((_, [thms]), (lthy_old, lthy)) = Local_Theory.background_theory_result
76.77 + (Specification.axiomatization [] [((mk_b "axioms" Binding.empty, []), goals)]) lthy
76.78 + ||> `Local_Theory.restore;
76.79 + val phi = Proof_Context.export_morphism lthy_old lthy;
76.80 + in
76.81 + BNF_Def.register_bnf key (after_qed mk_wit_thms (map single (Morphism.fact phi thms)) lthy)
76.82 + end;
76.83 +
76.84 +val bnf_decl = prepare_decl (K I) (K I);
76.85 +
76.86 +fun read_constraint _ NONE = HOLogic.typeS
76.87 + | read_constraint ctxt (SOME s) = Syntax.read_sort ctxt s;
76.88 +
76.89 +val bnf_decl_cmd = prepare_decl read_constraint Syntax.parse_typ;
76.90 +
76.91 +val parse_bnf_decl =
76.92 + parse_type_args_named_constrained -- parse_binding -- parse_map_rel_bindings -- Parse.opt_mixfix;
76.93 +
76.94 +val _ =
76.95 + Outer_Syntax.local_theory @{command_spec "bnf_decl"} "bnf declaration"
76.96 + (parse_bnf_decl >>
76.97 + (fn (((bsTs, b), (mapb, relb)), mx) => bnf_decl_cmd bsTs b mx mapb relb #> snd));
76.98 +
76.99 +end;
77.1 --- a/src/HOL/BNF/Tools/bnf_def.ML Thu Dec 05 17:52:12 2013 +0100
77.2 +++ b/src/HOL/BNF/Tools/bnf_def.ML Thu Dec 05 17:58:03 2013 +0100
77.3 @@ -77,14 +77,20 @@
77.4 val wit_thms_of_bnf: bnf -> thm list
77.5 val wit_thmss_of_bnf: bnf -> thm list list
77.6
77.7 + val mk_map: int -> typ list -> typ list -> term -> term
77.8 + val mk_rel: int -> typ list -> typ list -> term -> term
77.9 + val build_map: Proof.context -> (typ * typ -> term) -> typ * typ -> term
77.10 + val build_rel: Proof.context -> (typ * typ -> term) -> typ * typ -> term
77.11 + val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list
77.12 + val map_flattened_map_args: Proof.context -> string -> (term list -> 'a list) -> term list ->
77.13 + 'a list
77.14 +
77.15 val mk_witness: int list * term -> thm list -> nonemptiness_witness
77.16 val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
77.17 val wits_of_bnf: bnf -> nonemptiness_witness list
77.18
77.19 val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list
77.20
77.21 - val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list
77.22 -
77.23 datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
77.24 datatype fact_policy = Dont_Note | Note_Some | Note_All
77.25
77.26 @@ -95,11 +101,20 @@
77.27 Proof.context
77.28
77.29 val print_bnfs: Proof.context -> unit
77.30 + val prepare_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
77.31 + (Proof.context -> 'a -> typ) -> (Proof.context -> 'b -> term) -> typ list option ->
77.32 + binding -> binding -> binding list ->
77.33 + (((((binding * 'a) * 'b) * 'b list) * 'b) * 'b list) * 'b option -> Proof.context ->
77.34 + string * term list *
77.35 + ((thm list -> {context: Proof.context, prems: thm list} -> tactic) option * term list list) *
77.36 + ((thm list -> thm list list) -> thm list list -> Proof.context -> bnf * local_theory) *
77.37 + local_theory * thm list
77.38 +
77.39 val bnf_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
77.40 ({prems: thm list, context: Proof.context} -> tactic) list ->
77.41 ({prems: thm list, context: Proof.context} -> tactic) -> typ list option -> binding ->
77.42 binding -> binding list ->
77.43 - ((((binding * term) * term list) * term) * term list) * term option ->
77.44 + (((((binding * typ) * term) * term list) * term) * term list) * term option ->
77.45 local_theory -> bnf * local_theory
77.46 end;
77.47
77.48 @@ -110,7 +125,7 @@
77.49 open BNF_Tactics
77.50 open BNF_Def_Tactics
77.51
77.52 -val fundef_cong_attrs = @{attributes [fundef_cong]};
77.53 +val fundefcong_attrs = @{attributes [fundef_cong]};
77.54
77.55 type axioms = {
77.56 map_id0: thm,
77.57 @@ -447,7 +462,6 @@
77.58 #> Option.map (morph_bnf (Morphism.thm_morphism (Thm.transfer (Proof_Context.theory_of ctxt))));
77.59
77.60
77.61 -
77.62 (* Utilities *)
77.63
77.64 fun normalize_set insts instA set =
77.65 @@ -487,6 +501,46 @@
77.66 else minimize ((I, wit) :: done) todo;
77.67 in minimize [] wits end;
77.68
77.69 +fun mk_map live Ts Us t =
77.70 + let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
77.71 + Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
77.72 + end;
77.73 +
77.74 +fun mk_rel live Ts Us t =
77.75 + let val [Type (_, Ts0), Type (_, Us0)] = binder_types (snd (strip_typeN live (fastype_of t))) in
77.76 + Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
77.77 + end;
77.78 +
77.79 +fun build_map_or_rel mk const of_bnf dest ctxt build_simple =
77.80 + let
77.81 + fun build (TU as (T, U)) =
77.82 + if T = U then
77.83 + const T
77.84 + else
77.85 + (case TU of
77.86 + (Type (s, Ts), Type (s', Us)) =>
77.87 + if s = s' then
77.88 + let
77.89 + val bnf = the (bnf_of ctxt s);
77.90 + val live = live_of_bnf bnf;
77.91 + val mapx = mk live Ts Us (of_bnf bnf);
77.92 + val TUs' = map dest (fst (strip_typeN live (fastype_of mapx)));
77.93 + in Term.list_comb (mapx, map build TUs') end
77.94 + else
77.95 + build_simple TU
77.96 + | _ => build_simple TU);
77.97 + in build end;
77.98 +
77.99 +val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT;
77.100 +val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T;
77.101 +
77.102 +fun map_flattened_map_args ctxt s map_args fs =
77.103 + let
77.104 + val flat_fs = flatten_type_args_of_bnf (the (bnf_of ctxt s)) Term.dummy fs;
77.105 + val flat_fs' = map_args flat_fs;
77.106 + in
77.107 + permute_like (op aconv) flat_fs fs flat_fs'
77.108 + end;
77.109
77.110
77.111 (* Names *)
77.112 @@ -525,8 +579,8 @@
77.113 val rel_conversepN = "rel_conversep";
77.114 val rel_monoN = "rel_mono"
77.115 val rel_mono_strongN = "rel_mono_strong"
77.116 -val rel_OON = "rel_compp";
77.117 -val rel_OO_GrpN = "rel_compp_Grp";
77.118 +val rel_comppN = "rel_compp";
77.119 +val rel_compp_GrpN = "rel_compp_Grp";
77.120
77.121 datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
77.122
77.123 @@ -582,16 +636,16 @@
77.124 val notes =
77.125 [(map_compN, [Lazy.force (#map_comp facts)], []),
77.126 (map_cong0N, [#map_cong0 axioms], []),
77.127 - (map_congN, [Lazy.force (#map_cong facts)], fundef_cong_attrs),
77.128 + (map_congN, [Lazy.force (#map_cong facts)], fundefcong_attrs),
77.129 (map_idN, [Lazy.force (#map_id facts)], []),
77.130 + (rel_comppN, [Lazy.force (#rel_OO facts)], []),
77.131 + (rel_compp_GrpN, no_refl [#rel_OO_Grp axioms], []),
77.132 + (rel_conversepN, [Lazy.force (#rel_conversep facts)], []),
77.133 (rel_eqN, [Lazy.force (#rel_eq facts)], []),
77.134 (rel_flipN, [Lazy.force (#rel_flip facts)], []),
77.135 - (set_mapN, map Lazy.force (#set_map facts), []),
77.136 - (rel_OO_GrpN, no_refl [#rel_OO_Grp axioms], []),
77.137 (rel_GrpN, [Lazy.force (#rel_Grp facts)], []),
77.138 - (rel_conversepN, [Lazy.force (#rel_conversep facts)], []),
77.139 (rel_monoN, [Lazy.force (#rel_mono facts)], []),
77.140 - (rel_OON, [Lazy.force (#rel_OO facts)], [])]
77.141 + (set_mapN, map Lazy.force (#set_map facts), [])]
77.142 |> filter_out (null o #2)
77.143 |> map (fn (thmN, thms, attrs) =>
77.144 ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)),
77.145 @@ -606,20 +660,18 @@
77.146
77.147 (* Define new BNFs *)
77.148
77.149 -fun prepare_def const_policy mk_fact_policy qualify prep_term Ds_opt map_b rel_b set_bs
77.150 - (((((raw_bnf_b, raw_map), raw_sets), raw_bd_Abs), raw_wits), raw_rel_opt) no_defs_lthy =
77.151 +fun prepare_def const_policy mk_fact_policy qualify prep_typ prep_term Ds_opt map_b rel_b set_bs
77.152 + ((((((raw_bnf_b, raw_bnf_T), raw_map), raw_sets), raw_bd), raw_wits), raw_rel_opt)
77.153 + no_defs_lthy =
77.154 let
77.155 val fact_policy = mk_fact_policy no_defs_lthy;
77.156 val bnf_b = qualify raw_bnf_b;
77.157 val live = length raw_sets;
77.158 - val nwits = length raw_wits;
77.159
77.160 + val T_rhs = prep_typ no_defs_lthy raw_bnf_T;
77.161 val map_rhs = prep_term no_defs_lthy raw_map;
77.162 val set_rhss = map (prep_term no_defs_lthy) raw_sets;
77.163 - val (bd_rhsT, bd_rhs) = (case prep_term no_defs_lthy raw_bd_Abs of
77.164 - Abs (_, T, t) => (T, t)
77.165 - | _ => error "Bad bound constant");
77.166 - val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
77.167 + val bd_rhs = prep_term no_defs_lthy raw_bd;
77.168
77.169 fun err T =
77.170 error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
77.171 @@ -627,15 +679,15 @@
77.172
77.173 val (bnf_b, key) =
77.174 if Binding.eq_name (bnf_b, Binding.empty) then
77.175 - (case bd_rhsT of
77.176 + (case T_rhs of
77.177 Type (C, Ts) => if forall (can dest_TFree) Ts
77.178 - then (Binding.qualified_name C, C) else err bd_rhsT
77.179 + then (Binding.qualified_name C, C) else err T_rhs
77.180 | T => err T)
77.181 else (bnf_b, Local_Theory.full_name no_defs_lthy bnf_b);
77.182
77.183 - val def_qualify = Binding.qualify false (Binding.name_of bnf_b);
77.184 + val def_qualify = Binding.conceal o Binding.qualify false (Binding.name_of bnf_b);
77.185
77.186 - fun mk_suffix_binding suf = Binding.suffix_name ("_" ^ suf) bnf_b;
77.187 + fun mk_prefix_binding pre = Binding.prefix_name (pre ^ "_") bnf_b;
77.188
77.189 fun maybe_define user_specified (b, rhs) lthy =
77.190 let
77.191 @@ -660,7 +712,7 @@
77.192 lthy |> not (pointer_eq (lthy_old, lthy)) ? Local_Theory.restore;
77.193
77.194 val map_bind_def =
77.195 - (fn () => def_qualify (if Binding.is_empty map_b then mk_suffix_binding mapN else map_b),
77.196 + (fn () => def_qualify (if Binding.is_empty map_b then mk_prefix_binding mapN else map_b),
77.197 map_rhs);
77.198 val set_binds_defs =
77.199 let
77.200 @@ -668,25 +720,18 @@
77.201 (case try (nth set_bs) (i - 1) of
77.202 SOME b => if Binding.is_empty b then get_b else K b
77.203 | NONE => get_b) #> def_qualify;
77.204 - val bs = if live = 1 then [set_name 1 (fn () => mk_suffix_binding setN)]
77.205 - else map (fn i => set_name i (fn () => mk_suffix_binding (mk_setN i))) (1 upto live);
77.206 + val bs = if live = 1 then [set_name 1 (fn () => mk_prefix_binding setN)]
77.207 + else map (fn i => set_name i (fn () => mk_prefix_binding (mk_setN i))) (1 upto live);
77.208 in bs ~~ set_rhss end;
77.209 - val bd_bind_def = (fn () => def_qualify (mk_suffix_binding bdN), bd_rhs);
77.210 - val wit_binds_defs =
77.211 - let
77.212 - val bs = if nwits = 1 then [fn () => def_qualify (mk_suffix_binding witN)]
77.213 - else map (fn i => fn () => def_qualify (mk_suffix_binding (mk_witN i))) (1 upto nwits);
77.214 - in bs ~~ wit_rhss end;
77.215 + val bd_bind_def = (fn () => def_qualify (mk_prefix_binding bdN), bd_rhs);
77.216
77.217 - val (((((bnf_map_term, raw_map_def),
77.218 + val ((((bnf_map_term, raw_map_def),
77.219 (bnf_set_terms, raw_set_defs)),
77.220 - (bnf_bd_term, raw_bd_def)),
77.221 - (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
77.222 + (bnf_bd_term, raw_bd_def)), (lthy, lthy_old)) =
77.223 no_defs_lthy
77.224 |> maybe_define true map_bind_def
77.225 ||>> apfst split_list o fold_map (maybe_define true) set_binds_defs
77.226 ||>> maybe_define true bd_bind_def
77.227 - ||>> apfst split_list o fold_map (maybe_define true) wit_binds_defs
77.228 ||> `(maybe_restore no_defs_lthy);
77.229
77.230 val phi = Proof_Context.export_morphism lthy_old lthy;
77.231 @@ -694,7 +739,6 @@
77.232 val bnf_map_def = Morphism.thm phi raw_map_def;
77.233 val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
77.234 val bnf_bd_def = Morphism.thm phi raw_bd_def;
77.235 - val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
77.236
77.237 val bnf_map = Morphism.term phi bnf_map_term;
77.238
77.239 @@ -709,11 +753,14 @@
77.240
77.241 val CA_params = map TVar (Term.add_tvarsT CA []);
77.242
77.243 + val bnf_T = Morphism.typ phi T_rhs;
77.244 + val bad_args = Term.add_tfreesT bnf_T [];
77.245 + val _ = if null bad_args then () else error ("Locally fixed type arguments " ^
77.246 + commas_quote (map (Syntax.string_of_typ no_defs_lthy o TFree) bad_args));
77.247 +
77.248 val bnf_sets = map2 (normalize_set CA_params) alphas (map (Morphism.term phi) bnf_set_terms);
77.249 - val bdT = Morphism.typ phi bd_rhsT;
77.250 val bnf_bd =
77.251 - Term.subst_TVars (Term.add_tvar_namesT bdT [] ~~ CA_params) (Morphism.term phi bnf_bd_term);
77.252 - val bnf_wits = map (normalize_wit CA_params CA alphas o Morphism.term phi) bnf_wit_terms;
77.253 + Term.subst_TVars (Term.add_tvar_namesT bnf_T [] ~~ CA_params) (Morphism.term phi bnf_bd_term);
77.254
77.255 (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
77.256 val deads = (case Ds_opt of
77.257 @@ -770,7 +817,6 @@
77.258 val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
77.259 val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
77.260 val bnf_bd_As = mk_bnf_t As' bnf_bd;
77.261 - val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
77.262
77.263 val pre_names_lthy = lthy;
77.264 val ((((((((((((((((((((((((fs, gs), hs), x), y), zs), ys), As),
77.265 @@ -824,12 +870,26 @@
77.266 | SOME raw_rel => prep_term no_defs_lthy raw_rel);
77.267
77.268 val rel_bind_def =
77.269 - (fn () => def_qualify (if Binding.is_empty rel_b then mk_suffix_binding relN else rel_b),
77.270 + (fn () => def_qualify (if Binding.is_empty rel_b then mk_prefix_binding relN else rel_b),
77.271 rel_rhs);
77.272
77.273 - val ((bnf_rel_term, raw_rel_def), (lthy, lthy_old)) =
77.274 + val wit_rhss =
77.275 + if null raw_wits then
77.276 + [fold_rev Term.absdummy As' (Term.list_comb (bnf_map_AsAs,
77.277 + map2 (fn T => fn i => Term.absdummy T (Bound i)) As' (live downto 1)) $
77.278 + Const (@{const_name undefined}, CA'))]
77.279 + else map (prep_term no_defs_lthy) raw_wits;
77.280 + val nwits = length wit_rhss;
77.281 + val wit_binds_defs =
77.282 + let
77.283 + val bs = if nwits = 1 then [fn () => def_qualify (mk_prefix_binding witN)]
77.284 + else map (fn i => fn () => def_qualify (mk_prefix_binding (mk_witN i))) (1 upto nwits);
77.285 + in bs ~~ wit_rhss end;
77.286 +
77.287 + val (((bnf_rel_term, raw_rel_def), (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
77.288 lthy
77.289 |> maybe_define (is_some raw_rel_opt) rel_bind_def
77.290 + ||>> apfst split_list o fold_map (maybe_define (not (null raw_wits))) wit_binds_defs
77.291 ||> `(maybe_restore lthy);
77.292
77.293 val phi = Proof_Context.export_morphism lthy_old lthy;
77.294 @@ -841,11 +901,9 @@
77.295 val rel = mk_bnf_rel pred2RTs CA' CB';
77.296 val relAsAs = mk_bnf_rel self_pred2RTs CA' CA';
77.297
77.298 - val _ = case no_reflexive (raw_map_def :: raw_set_defs @ [raw_bd_def] @
77.299 - raw_wit_defs @ [raw_rel_def]) of
77.300 - [] => ()
77.301 - | defs => Proof_Display.print_consts true lthy_old (K false)
77.302 - (map (dest_Free o fst o Logic.dest_equals o prop_of) defs);
77.303 + val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
77.304 + val bnf_wits = map (normalize_wit CA_params CA alphas o Morphism.term phi) bnf_wit_terms;
77.305 + val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
77.306
77.307 val map_id0_goal =
77.308 let val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As') in
77.309 @@ -945,11 +1003,14 @@
77.310 map wit_goal (0 upto live - 1)
77.311 end;
77.312
77.313 - val wit_goalss = map mk_wit_goals bnf_wit_As;
77.314 + val trivial_wit_tac = mk_trivial_wit_tac bnf_wit_defs;
77.315
77.316 - fun after_qed thms lthy =
77.317 + val wit_goalss =
77.318 + (if null raw_wits then SOME trivial_wit_tac else NONE, map mk_wit_goals bnf_wit_As);
77.319 +
77.320 + fun after_qed mk_wit_thms thms lthy =
77.321 let
77.322 - val (axioms, wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
77.323 + val (axioms, nontriv_wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
77.324
77.325 val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
77.326 val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
77.327 @@ -1022,6 +1083,9 @@
77.328
77.329 val set_map = map (fn thm => Lazy.lazy (fn () => mk_set_map thm)) (#set_map0 axioms);
77.330
77.331 + val wit_thms =
77.332 + if null nontriv_wit_thms then mk_wit_thms (map Lazy.force set_map) else nontriv_wit_thms;
77.333 +
77.334 fun mk_in_bd () =
77.335 let
77.336 val bdT = fst (dest_relT (fastype_of bnf_bd_As));
77.337 @@ -1265,35 +1329,45 @@
77.338 (bnf, Local_Theory.declaration {syntax = false, pervasive = true}
77.339 (fn phi => Data.map (Symtab.default (key, morph_bnf phi bnf))) lthy);
77.340
77.341 -(* TODO: Once the invariant "nwits > 0" holds, remove "mk_conjunction_balanced'" and "rtac TrueI"
77.342 - below *)
77.343 -fun mk_conjunction_balanced' [] = @{prop True}
77.344 - | mk_conjunction_balanced' ts = Logic.mk_conjunction_balanced ts;
77.345 -
77.346 fun bnf_def const_policy fact_policy qualify tacs wit_tac Ds map_b rel_b set_bs =
77.347 - (fn (_, goals, wit_goalss, after_qed, lthy, one_step_defs) =>
77.348 + (fn (_, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, one_step_defs) =>
77.349 let
77.350 - val wits_tac =
77.351 - K (TRYALL Goal.conjunction_tac) THEN' K (TRYALL (rtac TrueI)) THEN'
77.352 - mk_unfold_thms_then_tac lthy one_step_defs wit_tac;
77.353 - val wit_goals = map mk_conjunction_balanced' wit_goalss;
77.354 - val wit_thms =
77.355 - Goal.prove_sorry lthy [] [] (mk_conjunction_balanced' wit_goals) wits_tac
77.356 - |> Conjunction.elim_balanced (length wit_goals)
77.357 - |> map2 (Conjunction.elim_balanced o length) wit_goalss
77.358 - |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
77.359 + fun mk_wits_tac set_maps =
77.360 + K (TRYALL Goal.conjunction_tac) THEN'
77.361 + (case triv_tac_opt of
77.362 + SOME tac => tac set_maps
77.363 + | NONE => mk_unfold_thms_then_tac lthy one_step_defs wit_tac);
77.364 + val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
77.365 + fun mk_wit_thms set_maps =
77.366 + Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) (mk_wits_tac set_maps)
77.367 + |> Conjunction.elim_balanced (length wit_goals)
77.368 + |> map2 (Conjunction.elim_balanced o length) wit_goalss
77.369 + |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
77.370 in
77.371 map2 (Thm.close_derivation oo Goal.prove_sorry lthy [] [])
77.372 goals (map (mk_unfold_thms_then_tac lthy one_step_defs) tacs)
77.373 - |> (fn thms => after_qed (map single thms @ wit_thms) lthy)
77.374 - end) oo prepare_def const_policy fact_policy qualify (K I) Ds map_b rel_b set_bs;
77.375 + |> (fn thms => after_qed mk_wit_thms (map single thms) lthy)
77.376 + end) oo prepare_def const_policy fact_policy qualify (K I) (K I) Ds map_b rel_b set_bs;
77.377
77.378 -val bnf_cmd = (fn (key, goals, wit_goals, after_qed, lthy, defs) =>
77.379 - Proof.unfolding ([[(defs, [])]])
77.380 - (Proof.theorem NONE (snd o register_bnf key oo after_qed)
77.381 - (map (single o rpair []) goals @ map (map (rpair [])) wit_goals) lthy)) oo
77.382 - prepare_def Do_Inline (user_policy Note_Some) I Syntax.read_term NONE Binding.empty Binding.empty
77.383 - [];
77.384 +val bnf_cmd = (fn (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, defs) =>
77.385 + let
77.386 + val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
77.387 + fun mk_triv_wit_thms tac set_maps =
77.388 + Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals)
77.389 + (K (TRYALL Goal.conjunction_tac) THEN' tac set_maps)
77.390 + |> Conjunction.elim_balanced (length wit_goals)
77.391 + |> map2 (Conjunction.elim_balanced o length) wit_goalss
77.392 + |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
77.393 + val (mk_wit_thms, nontriv_wit_goals) =
77.394 + (case triv_tac_opt of
77.395 + NONE => (fn _ => [], map (map (rpair [])) wit_goalss)
77.396 + | SOME tac => (mk_triv_wit_thms tac, []));
77.397 + in
77.398 + Proof.unfolding ([[(defs, [])]])
77.399 + (Proof.theorem NONE (snd o register_bnf key oo after_qed mk_wit_thms)
77.400 + (map (single o rpair []) goals @ nontriv_wit_goals) lthy)
77.401 + end) oo prepare_def Do_Inline (user_policy Note_Some) I Syntax.read_typ Syntax.read_term NONE
77.402 + Binding.empty Binding.empty [];
77.403
77.404 fun print_bnfs ctxt =
77.405 let
77.406 @@ -1328,9 +1402,14 @@
77.407 val _ =
77.408 Outer_Syntax.local_theory_to_proof @{command_spec "bnf"}
77.409 "register a type as a bounded natural functor"
77.410 - ((parse_opt_binding_colon -- Parse.term --
77.411 - (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) -- Parse.term --
77.412 - (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) -- Scan.option Parse.term)
77.413 + (parse_opt_binding_colon -- Parse.typ --|
77.414 + (Parse.reserved "map" -- @{keyword ":"}) -- Parse.term --
77.415 + (Scan.option ((Parse.reserved "sets" -- @{keyword ":"}) |--
77.416 + Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term)) >> the_default []) --|
77.417 + (Parse.reserved "bd" -- @{keyword ":"}) -- Parse.term --
77.418 + (Scan.option ((Parse.reserved "wits" -- @{keyword ":"}) |--
77.419 + Scan.repeat1 (Scan.unless (Parse.reserved "rel") Parse.term)) >> the_default []) --
77.420 + Scan.option ((Parse.reserved "rel" -- @{keyword ":"}) |-- Parse.term)
77.421 >> bnf_cmd);
77.422
77.423 end;
78.1 --- a/src/HOL/BNF/Tools/bnf_def_tactics.ML Thu Dec 05 17:52:12 2013 +0100
78.2 +++ b/src/HOL/BNF/Tools/bnf_def_tactics.ML Thu Dec 05 17:58:03 2013 +0100
78.3 @@ -31,7 +31,10 @@
78.4 {prems: thm list, context: Proof.context} -> tactic
78.5
78.6 val mk_in_bd_tac: int -> thm -> thm -> thm -> thm -> thm list -> thm list -> thm -> thm -> thm ->
78.7 - thm -> {prems: 'a, context: Proof.context} -> tactic
78.8 + thm -> {prems: thm list, context: Proof.context} -> tactic
78.9 +
78.10 + val mk_trivial_wit_tac: thm list -> thm list -> {prems: thm list, context: Proof.context} ->
78.11 + tactic
78.12 end;
78.13
78.14 structure BNF_Def_Tactics : BNF_DEF_TACTICS =
78.15 @@ -302,4 +305,8 @@
78.16 map_comp RS sym, map_id])] 1
78.17 end;
78.18
78.19 +fun mk_trivial_wit_tac wit_defs set_maps {context = ctxt, prems = _} =
78.20 + unfold_thms_tac ctxt wit_defs THEN HEADGOAL (EVERY' (map (fn thm =>
78.21 + dtac (thm RS equalityD1 RS set_mp) THEN' etac imageE THEN' atac) set_maps)) THEN ALLGOALS atac;
78.22 +
78.23 end;
79.1 --- a/src/HOL/BNF/Tools/bnf_fp_def_sugar.ML Thu Dec 05 17:52:12 2013 +0100
79.2 +++ b/src/HOL/BNF/Tools/bnf_fp_def_sugar.ML Thu Dec 05 17:58:03 2013 +0100
79.3 @@ -25,7 +25,9 @@
79.4 sel_co_iterssss: thm list list list list};
79.5
79.6 val of_fp_sugar: (fp_sugar -> 'a list) -> fp_sugar -> 'a
79.7 + val eq_fp_sugar: fp_sugar * fp_sugar -> bool
79.8 val morph_fp_sugar: morphism -> fp_sugar -> fp_sugar
79.9 + val transfer_fp_sugar: Proof.context -> fp_sugar -> fp_sugar
79.10 val fp_sugar_of: Proof.context -> string -> fp_sugar option
79.11 val fp_sugars_of: Proof.context -> fp_sugar list
79.12
79.13 @@ -39,17 +41,14 @@
79.14 'a list
79.15 val mk_co_iter: theory -> BNF_FP_Util.fp_kind -> typ -> typ list -> term -> term
79.16 val nesty_bnfs: Proof.context -> typ list list list -> typ list -> BNF_Def.bnf list
79.17 - val mk_map: int -> typ list -> typ list -> term -> term
79.18 - val mk_rel: int -> typ list -> typ list -> term -> term
79.19 - val build_map: local_theory -> (typ * typ -> term) -> typ * typ -> term
79.20 - val build_rel: local_theory -> (typ * typ -> term) -> typ * typ -> term
79.21 - val dest_map: Proof.context -> string -> term -> term * term list
79.22 - val dest_ctr: Proof.context -> string -> term -> term * term list
79.23
79.24 type lfp_sugar_thms =
79.25 (thm list * thm * Args.src list)
79.26 * (thm list list * thm list list * Args.src list)
79.27
79.28 + val morph_lfp_sugar_thms: morphism -> lfp_sugar_thms -> lfp_sugar_thms
79.29 + val transfer_lfp_sugar_thms: Proof.context -> lfp_sugar_thms -> lfp_sugar_thms
79.30 +
79.31 type gfp_sugar_thms =
79.32 ((thm list * thm) list * Args.src list)
79.33 * (thm list list * thm list list * Args.src list)
79.34 @@ -57,6 +56,9 @@
79.35 * (thm list list * thm list list * Args.src list)
79.36 * (thm list list list * thm list list list * Args.src list)
79.37
79.38 + val morph_gfp_sugar_thms: morphism -> gfp_sugar_thms -> gfp_sugar_thms
79.39 + val transfer_gfp_sugar_thms: Proof.context -> gfp_sugar_thms -> gfp_sugar_thms
79.40 +
79.41 val mk_co_iters_prelims: BNF_FP_Util.fp_kind -> typ list list list -> typ list -> typ list ->
79.42 int list -> int list list -> term list list -> Proof.context ->
79.43 (term list list
79.44 @@ -87,13 +89,14 @@
79.45 string * term list * term list list * ((term list list * term list list list)
79.46 * (typ list * typ list list)) list ->
79.47 thm -> thm list -> thm list -> thm list list -> BNF_Def.bnf list -> typ list -> typ list ->
79.48 - int list list -> int list list -> int list -> thm list list -> Ctr_Sugar.ctr_sugar list ->
79.49 - term list list -> thm list list -> (thm list -> thm list) -> local_theory -> gfp_sugar_thms
79.50 + typ list -> typ list list list -> int list list -> int list list -> int list -> thm list list ->
79.51 + Ctr_Sugar.ctr_sugar list -> term list list -> thm list list -> (thm list -> thm list) ->
79.52 + local_theory -> gfp_sugar_thms
79.53 val co_datatypes: BNF_FP_Util.fp_kind -> (mixfix list -> binding list -> binding list ->
79.54 binding list list -> binding list -> (string * sort) list -> typ list * typ list list ->
79.55 BNF_Def.bnf list -> local_theory -> BNF_FP_Util.fp_result * local_theory) ->
79.56 - (bool * bool) * (((((binding * (typ * sort)) list * binding) * (binding * binding)) * mixfix) *
79.57 - ((((binding * binding) * (binding * typ) list) * (binding * term) list) *
79.58 + (bool * (bool * bool)) * (((((binding * (typ * sort)) list * binding) * (binding * binding))
79.59 + * mixfix) * ((((binding * binding) * (binding * typ) list) * (binding * term) list) *
79.60 mixfix) list) list ->
79.61 local_theory -> local_theory
79.62 val parse_co_datatype_cmd: BNF_FP_Util.fp_kind -> (mixfix list -> binding list -> binding list ->
79.63 @@ -207,8 +210,8 @@
79.64 val id_def = @{thm id_def};
79.65 val mp_conj = @{thm mp_conj};
79.66
79.67 -val nitpick_attrs = @{attributes [nitpick_simp]};
79.68 -val code_nitpick_simp_attrs = Code.add_default_eqn_attrib :: nitpick_attrs;
79.69 +val nitpicksimp_attrs = @{attributes [nitpick_simp]};
79.70 +val code_nitpicksimp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs;
79.71 val simp_attrs = @{attributes [simp]};
79.72
79.73 fun tvar_subst thy Ts Us =
79.74 @@ -232,7 +235,9 @@
79.75 | flat_corec_preds_predsss_gettersss (p :: ps) (qss :: qsss) (fss :: fsss) =
79.76 p :: flat_corec_predss_getterss qss fss @ flat_corec_preds_predsss_gettersss ps qsss fsss;
79.77
79.78 -fun mk_tupled_fun x f xs = HOLogic.tupled_lambda x (Term.list_comb (f, xs));
79.79 +fun mk_tupled_fun x f xs =
79.80 + if xs = [x] then f else HOLogic.tupled_lambda x (Term.list_comb (f, xs));
79.81 +
79.82 fun mk_uncurried2_fun f xss =
79.83 mk_tupled_fun (HOLogic.mk_tuple (map HOLogic.mk_tuple xss)) f (flat_rec_arg_args xss);
79.84
79.85 @@ -287,66 +292,6 @@
79.86 | unzip_corecT _ (Type (@{type_name sum}, Ts)) = Ts
79.87 | unzip_corecT _ T = [T];
79.88
79.89 -fun mk_map live Ts Us t =
79.90 - let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
79.91 - Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
79.92 - end;
79.93 -
79.94 -fun mk_rel live Ts Us t =
79.95 - let val [Type (_, Ts0), Type (_, Us0)] = binder_types (snd (strip_typeN live (fastype_of t))) in
79.96 - Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
79.97 - end;
79.98 -
79.99 -local
79.100 -
79.101 -fun build_map_or_rel mk const of_bnf dest lthy build_simple =
79.102 - let
79.103 - fun build (TU as (T, U)) =
79.104 - if T = U then
79.105 - const T
79.106 - else
79.107 - (case TU of
79.108 - (Type (s, Ts), Type (s', Us)) =>
79.109 - if s = s' then
79.110 - let
79.111 - val bnf = the (bnf_of lthy s);
79.112 - val live = live_of_bnf bnf;
79.113 - val mapx = mk live Ts Us (of_bnf bnf);
79.114 - val TUs' = map dest (fst (strip_typeN live (fastype_of mapx)));
79.115 - in Term.list_comb (mapx, map build TUs') end
79.116 - else
79.117 - build_simple TU
79.118 - | _ => build_simple TU);
79.119 - in build end;
79.120 -
79.121 -in
79.122 -
79.123 -val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT;
79.124 -val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T;
79.125 -
79.126 -end;
79.127 -
79.128 -val dummy_var_name = "?f"
79.129 -
79.130 -fun mk_map_pattern ctxt s =
79.131 - let
79.132 - val bnf = the (bnf_of ctxt s);
79.133 - val mapx = map_of_bnf bnf;
79.134 - val live = live_of_bnf bnf;
79.135 - val (f_Ts, _) = strip_typeN live (fastype_of mapx);
79.136 - val fs = map_index (fn (i, T) => Var ((dummy_var_name, i), T)) f_Ts;
79.137 - in
79.138 - (mapx, betapplys (mapx, fs))
79.139 - end;
79.140 -
79.141 -fun dest_map ctxt s call =
79.142 - let
79.143 - val (map0, pat) = mk_map_pattern ctxt s;
79.144 - val (_, tenv) = fo_match ctxt call pat;
79.145 - in
79.146 - (map0, Vartab.fold_rev (fn (_, (_, f)) => cons f) tenv [])
79.147 - end;
79.148 -
79.149 fun liveness_of_fp_bnf n bnf =
79.150 (case T_of_bnf bnf of
79.151 Type (_, Ts) => map (not o member (op =) (deads_of_bnf bnf)) Ts
79.152 @@ -388,12 +333,19 @@
79.153 fun nesty_bnfs ctxt ctr_Tsss Us =
79.154 map_filter (bnf_of ctxt) (fold (fold (fold (add_nesty_bnf_names Us))) ctr_Tsss []);
79.155
79.156 -fun indexify proj xs f p = f (find_index (curry op = (proj p)) xs) p;
79.157 +fun indexify proj xs f p = f (find_index (curry (op =) (proj p)) xs) p;
79.158
79.159 type lfp_sugar_thms =
79.160 (thm list * thm * Args.src list)
79.161 * (thm list list * thm list list * Args.src list)
79.162
79.163 +fun morph_lfp_sugar_thms phi ((inducts, induct, induct_attrs), (foldss, recss, iter_attrs)) =
79.164 + ((map (Morphism.thm phi) inducts, Morphism.thm phi induct, induct_attrs),
79.165 + (map (map (Morphism.thm phi)) foldss, map (map (Morphism.thm phi)) recss, iter_attrs));
79.166 +
79.167 +val transfer_lfp_sugar_thms =
79.168 + morph_lfp_sugar_thms o Morphism.thm_morphism o Thm.transfer o Proof_Context.theory_of;
79.169 +
79.170 type gfp_sugar_thms =
79.171 ((thm list * thm) list * Args.src list)
79.172 * (thm list list * thm list list * Args.src list)
79.173 @@ -401,6 +353,23 @@
79.174 * (thm list list * thm list list * Args.src list)
79.175 * (thm list list list * thm list list list * Args.src list);
79.176
79.177 +fun morph_gfp_sugar_thms phi ((coinducts_pairs, coinduct_attrs),
79.178 + (unfoldss, corecss, coiter_attrs), (disc_unfoldss, disc_corecss, disc_iter_attrs),
79.179 + (disc_unfold_iffss, disc_corec_iffss, disc_iter_iff_attrs),
79.180 + (sel_unfoldsss, sel_corecsss, sel_iter_attrs)) =
79.181 + ((map (apfst (map (Morphism.thm phi)) o apsnd (Morphism.thm phi)) coinducts_pairs,
79.182 + coinduct_attrs),
79.183 + (map (map (Morphism.thm phi)) unfoldss, map (map (Morphism.thm phi)) corecss, coiter_attrs),
79.184 + (map (map (Morphism.thm phi)) disc_unfoldss, map (map (Morphism.thm phi)) disc_corecss,
79.185 + disc_iter_attrs),
79.186 + (map (map (Morphism.thm phi)) disc_unfold_iffss, map (map (Morphism.thm phi)) disc_corec_iffss,
79.187 + disc_iter_iff_attrs),
79.188 + (map (map (map (Morphism.thm phi))) sel_unfoldsss,
79.189 + map (map (map (Morphism.thm phi))) sel_corecsss, sel_iter_attrs));
79.190 +
79.191 +val transfer_gfp_sugar_thms =
79.192 + morph_gfp_sugar_thms o Morphism.thm_morphism o Thm.transfer o Proof_Context.theory_of;
79.193 +
79.194 fun mk_iter_fun_arg_types0 n ms = map2 dest_tupleT ms o dest_sumTN_balanced n o domain_type;
79.195
79.196 fun mk_iter_fun_arg_types ctr_Tsss ns mss =
79.197 @@ -430,7 +399,7 @@
79.198 ns mss ctr_Tsss ctor_iter_fun_Tss;
79.199
79.200 val z_Tsss' = map (map flat_rec_arg_args) z_Tssss;
79.201 - val h_Tss = map2 (map2 (curry op --->)) z_Tsss' Css;
79.202 + val h_Tss = map2 (map2 (curry (op --->))) z_Tsss' Css;
79.203
79.204 val hss = map2 (map2 retype_free) h_Tss gss;
79.205 val zssss_hd = map2 (map2 (map2 (retype_free o hd))) z_Tssss ysss;
79.206 @@ -452,7 +421,7 @@
79.207 val f_sum_prod_Ts = map range_type fun_Ts;
79.208 val f_prod_Tss = map2 dest_sumTN_balanced ns f_sum_prod_Ts;
79.209 val f_Tsss = map2 (map2 (dest_tupleT o length)) ctr_Tsss' f_prod_Tss;
79.210 - val f_Tssss = map3 (fn C => map2 (map2 (map (curry op --> C) oo unzip_corecT)))
79.211 + val f_Tssss = map3 (fn C => map2 (map2 (map (curry (op -->) C) oo unzip_corecT)))
79.212 Cs ctr_Tsss' f_Tsss;
79.213 val q_Tssss = map (map (map (fn [_] => [] | [_, T] => [mk_pred1T (domain_type T)]))) f_Tssss;
79.214 in
79.215 @@ -536,18 +505,12 @@
79.216 ((xtor_co_iterss, iters_args_types, coiters_args_types), lthy')
79.217 end;
79.218
79.219 -fun mk_iter_body ctor_iter fss xssss =
79.220 - Term.list_comb (ctor_iter, map2 (mk_sum_caseN_balanced oo map2 mk_uncurried2_fun) fss xssss);
79.221 -
79.222 fun mk_preds_getterss_join c cps sum_prod_T cqfss =
79.223 let val n = length cqfss in
79.224 Term.lambda c (mk_IfN sum_prod_T cps
79.225 (map2 (mk_InN_balanced sum_prod_T n) (map HOLogic.mk_tuple cqfss) (1 upto n)))
79.226 end;
79.227
79.228 -fun mk_coiter_body cs cpss f_sum_prod_Ts cqfsss dtor_coiter =
79.229 - Term.list_comb (dtor_coiter, map4 mk_preds_getterss_join cs cpss f_sum_prod_Ts cqfsss);
79.230 -
79.231 fun define_co_iters fp fpT Cs binding_specs lthy0 =
79.232 let
79.233 val thy = Proof_Context.theory_of lthy0;
79.234 @@ -556,8 +519,8 @@
79.235 #> Config.get lthy0 bnf_note_all = false ? Binding.conceal;
79.236
79.237 val ((csts, defs), (lthy', lthy)) = lthy0
79.238 - |> apfst split_list o fold_map (fn (b, spec) =>
79.239 - Specification.definition (SOME (b, NONE, NoSyn), ((maybe_conceal_def_binding b, []), spec))
79.240 + |> apfst split_list o fold_map (fn (b, rhs) =>
79.241 + Local_Theory.define ((b, NoSyn), ((maybe_conceal_def_binding b, []), rhs))
79.242 #>> apsnd snd) binding_specs
79.243 ||> `Local_Theory.restore;
79.244
79.245 @@ -575,14 +538,10 @@
79.246
79.247 val fpT_to_C as Type (_, [fpT, _]) = snd (strip_typeN nn (fastype_of (hd ctor_iters)));
79.248
79.249 - fun generate_iter suf (f_Tss, _, fss, xssss) ctor_iter =
79.250 - let
79.251 - val res_T = fold_rev (curry op --->) f_Tss fpT_to_C;
79.252 - val b = mk_binding suf;
79.253 - val spec =
79.254 - mk_Trueprop_eq (lists_bmoc fss (Free (Binding.name_of b, res_T)),
79.255 - mk_iter_body ctor_iter fss xssss);
79.256 - in (b, spec) end;
79.257 + fun generate_iter pre (_, _, fss, xssss) ctor_iter =
79.258 + (mk_binding pre,
79.259 + fold_rev (fold_rev Term.lambda) fss (Term.list_comb (ctor_iter,
79.260 + map2 (mk_sum_caseN_balanced oo map2 mk_uncurried2_fun) fss xssss)));
79.261 in
79.262 define_co_iters Least_FP fpT Cs (map3 generate_iter iterNs iter_args_typess' ctor_iters) lthy
79.263 end;
79.264 @@ -594,14 +553,10 @@
79.265
79.266 val C_to_fpT as Type (_, [_, fpT]) = snd (strip_typeN nn (fastype_of (hd dtor_coiters)));
79.267
79.268 - fun generate_coiter suf ((pfss, cqfsss), (f_sum_prod_Ts, pf_Tss)) dtor_coiter =
79.269 - let
79.270 - val res_T = fold_rev (curry op --->) pf_Tss C_to_fpT;
79.271 - val b = mk_binding suf;
79.272 - val spec =
79.273 - mk_Trueprop_eq (lists_bmoc pfss (Free (Binding.name_of b, res_T)),
79.274 - mk_coiter_body cs cpss f_sum_prod_Ts cqfsss dtor_coiter);
79.275 - in (b, spec) end;
79.276 + fun generate_coiter pre ((pfss, cqfsss), (f_sum_prod_Ts, pf_Tss)) dtor_coiter =
79.277 + (mk_binding pre,
79.278 + fold_rev (fold_rev Term.lambda) pfss (Term.list_comb (dtor_coiter,
79.279 + map4 mk_preds_getterss_join cs cpss f_sum_prod_Ts cqfsss)));
79.280 in
79.281 define_co_iters Greatest_FP fpT Cs
79.282 (map3 generate_coiter coiterNs coiter_args_typess' dtor_coiters) lthy
79.283 @@ -645,7 +600,7 @@
79.284 val lives = lives_of_bnf bnf;
79.285 val sets = sets_of_bnf bnf;
79.286 fun mk_set U =
79.287 - (case find_index (curry op = U) lives of
79.288 + (case find_index (curry (op =) U) lives of
79.289 ~1 => Term.dummy
79.290 | i => nth sets i);
79.291 in
79.292 @@ -662,7 +617,7 @@
79.293 end;
79.294
79.295 fun mk_raw_prem_prems _ (x as Free (_, Type _)) (X as TFree _) =
79.296 - [([], (find_index (curry op = X) Xs + 1, x))]
79.297 + [([], (find_index (curry (op =) X) Xs + 1, x))]
79.298 | mk_raw_prem_prems names_lthy (x as Free (s, Type (T_name, Ts0))) (Type (_, Xs_Ts0)) =
79.299 (case AList.lookup (op =) setss_nested T_name of
79.300 NONE => []
79.301 @@ -702,7 +657,7 @@
79.302
79.303 val goal =
79.304 Library.foldr (Logic.list_implies o apfst (map mk_prem)) (raw_premss,
79.305 - HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry op $) ps us)));
79.306 + HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry (op $)) ps us)));
79.307
79.308 val kksss = map (map (map (fst o snd) o #2)) raw_premss;
79.309
79.310 @@ -763,13 +718,13 @@
79.311 val rec_thmss = mk_iter_thmss rec_args_types recs rec_defs (map co_rec_of ctor_iter_thmss);
79.312 in
79.313 ((induct_thms, induct_thm, [induct_case_names_attr]),
79.314 - (fold_thmss, rec_thmss, code_nitpick_simp_attrs @ simp_attrs))
79.315 + (fold_thmss, rec_thmss, code_nitpicksimp_attrs @ simp_attrs))
79.316 end;
79.317
79.318 fun derive_coinduct_coiters_thms_for_types pre_bnfs (z, cs, cpss,
79.319 coiters_args_types as [((pgss, crgsss), _), ((phss, cshsss), _)])
79.320 - dtor_coinduct dtor_injects dtor_ctors dtor_coiter_thmss nesting_bnfs fpTs Cs kss mss ns
79.321 - ctr_defss (ctr_sugars : ctr_sugar list) coiterss coiter_defss export_args lthy =
79.322 + dtor_coinduct dtor_injects dtor_ctors dtor_coiter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss
79.323 + mss ns ctr_defss (ctr_sugars : ctr_sugar list) coiterss coiter_defss export_args lthy =
79.324 let
79.325 fun mk_ctor_dtor_coiter_thm dtor_inject dtor_ctor coiter =
79.326 iffD1 OF [dtor_inject, trans OF [coiter, dtor_ctor RS sym]];
79.327 @@ -821,40 +776,29 @@
79.328 map4 (fn u => fn v => fn uvr => fn uv_eq =>
79.329 fold_rev Term.lambda [u, v] (HOLogic.mk_disj (uvr, uv_eq))) us vs uvrs uv_eqs;
79.330
79.331 - (* TODO: generalize (cf. "build_map") *)
79.332 - fun build_rel rs' T =
79.333 - (case find_index (curry op = T) fpTs of
79.334 - ~1 =>
79.335 - if exists_subtype_in fpTs T then
79.336 - let
79.337 - val Type (s, Ts) = T
79.338 - val bnf = the (bnf_of lthy s);
79.339 - val live = live_of_bnf bnf;
79.340 - val rel = mk_rel live Ts Ts (rel_of_bnf bnf);
79.341 - val Ts' = map domain_type (fst (strip_typeN live (fastype_of rel)));
79.342 - in Term.list_comb (rel, map (build_rel rs') Ts') end
79.343 - else
79.344 - HOLogic.eq_const T
79.345 - | kk => nth rs' kk);
79.346 + fun build_the_rel rs' T Xs_T =
79.347 + build_rel lthy (fn (_, X) => nth rs' (find_index (curry (op =) X) Xs)) (T, Xs_T)
79.348 + |> Term.subst_atomic_types (Xs ~~ fpTs);
79.349
79.350 - fun build_rel_app rs' usel vsel = fold rapp [usel, vsel] (build_rel rs' (fastype_of usel));
79.351 + fun build_rel_app rs' usel vsel Xs_T =
79.352 + fold rapp [usel, vsel] (build_the_rel rs' (fastype_of usel) Xs_T);
79.353
79.354 - fun mk_prem_ctr_concls rs' n k udisc usels vdisc vsels =
79.355 + fun mk_prem_ctr_concls rs' n k udisc usels vdisc vsels ctrXs_Ts =
79.356 (if k = n then [] else [HOLogic.mk_eq (udisc, vdisc)]) @
79.357 (if null usels then
79.358 []
79.359 else
79.360 [Library.foldr HOLogic.mk_imp (if n = 1 then [] else [udisc, vdisc],
79.361 - Library.foldr1 HOLogic.mk_conj (map2 (build_rel_app rs') usels vsels))]);
79.362 + Library.foldr1 HOLogic.mk_conj (map3 (build_rel_app rs') usels vsels ctrXs_Ts))]);
79.363
79.364 - fun mk_prem_concl rs' n udiscs uselss vdiscs vselss =
79.365 - Library.foldr1 HOLogic.mk_conj
79.366 - (flat (map5 (mk_prem_ctr_concls rs' n) (1 upto n) udiscs uselss vdiscs vselss))
79.367 + fun mk_prem_concl rs' n udiscs uselss vdiscs vselss ctrXs_Tss =
79.368 + Library.foldr1 HOLogic.mk_conj (flat (map6 (mk_prem_ctr_concls rs' n)
79.369 + (1 upto n) udiscs uselss vdiscs vselss ctrXs_Tss))
79.370 handle List.Empty => @{term True};
79.371
79.372 - fun mk_prem rs' uvr u v n udiscs uselss vdiscs vselss =
79.373 + fun mk_prem rs' uvr u v n udiscs uselss vdiscs vselss ctrXs_Tss =
79.374 fold_rev Logic.all [u, v] (Logic.mk_implies (HOLogic.mk_Trueprop uvr,
79.375 - HOLogic.mk_Trueprop (mk_prem_concl rs' n udiscs uselss vdiscs vselss)));
79.376 + HOLogic.mk_Trueprop (mk_prem_concl rs' n udiscs uselss vdiscs vselss ctrXs_Tss)));
79.377
79.378 val concl =
79.379 HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
79.380 @@ -862,8 +806,8 @@
79.381 uvrs us vs));
79.382
79.383 fun mk_goal rs' =
79.384 - Logic.list_implies (map8 (mk_prem rs') uvrs us vs ns udiscss uselsss vdiscss vselsss,
79.385 - concl);
79.386 + Logic.list_implies (map9 (mk_prem rs') uvrs us vs ns udiscss uselsss vdiscss vselsss
79.387 + ctrXs_Tsss, concl);
79.388
79.389 val goals = map mk_goal [rs, strong_rs];
79.390
79.391 @@ -1024,14 +968,14 @@
79.392 coinduct_consumes_attr :: coinduct_case_names_attr :: coinduct_case_concl_attrs;
79.393 in
79.394 ((coinduct_thms_pairs, coinduct_case_attrs),
79.395 - (unfold_thmss, corec_thmss, code_nitpick_simp_attrs),
79.396 + (unfold_thmss, corec_thmss, code_nitpicksimp_attrs),
79.397 (disc_unfold_thmss, disc_corec_thmss, []),
79.398 (disc_unfold_iff_thmss, disc_corec_iff_thmss, simp_attrs),
79.399 (sel_unfold_thmsss, sel_corec_thmsss, simp_attrs))
79.400 end;
79.401
79.402 fun define_co_datatypes prepare_constraint prepare_typ prepare_term fp construct_fp
79.403 - (wrap_opts as (no_discs_sels, rep_compat), specs) no_defs_lthy0 =
79.404 + (wrap_opts as (no_discs_sels, (_, rep_compat)), specs) no_defs_lthy0 =
79.405 let
79.406 (* TODO: sanity checks on arguments *)
79.407
79.408 @@ -1074,7 +1018,7 @@
79.409
79.410 val qsoty = quote o Syntax.string_of_typ fake_lthy;
79.411
79.412 - val _ = (case duplicates (op =) unsorted_As of [] => ()
79.413 + val _ = (case Library.duplicates (op =) unsorted_As of [] => ()
79.414 | A :: _ => error ("Duplicate type parameter " ^ qsoty A ^ " in " ^ co_prefix fp ^
79.415 "datatype specification"));
79.416
79.417 @@ -1087,7 +1031,7 @@
79.418
79.419 val mixfixes = map mixfix_of specs;
79.420
79.421 - val _ = (case duplicates Binding.eq_name fp_bs of [] => ()
79.422 + val _ = (case Library.duplicates Binding.eq_name fp_bs of [] => ()
79.423 | b :: _ => error ("Duplicate type name declaration " ^ quote (Binding.name_of b)));
79.424
79.425 val ctr_specss = map ctr_specs_of specs;
79.426 @@ -1380,18 +1324,25 @@
79.427 val (rel_distinct_thms, _) =
79.428 join_halves n half_rel_distinct_thmss other_half_rel_distinct_thmss;
79.429
79.430 + val anonymous_notes =
79.431 + [(map (fn th => th RS @{thm eq_False[THEN iffD2]}) rel_distinct_thms,
79.432 + code_nitpicksimp_attrs),
79.433 + (map2 (fn th => fn 0 => th RS @{thm eq_True[THEN iffD2]} | _ => th)
79.434 + rel_inject_thms ms, code_nitpicksimp_attrs)]
79.435 + |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
79.436 +
79.437 val notes =
79.438 - [(mapN, map_thms, code_nitpick_simp_attrs @ simp_attrs),
79.439 - (rel_distinctN, rel_distinct_thms, code_nitpick_simp_attrs @ simp_attrs),
79.440 - (rel_injectN, rel_inject_thms, code_nitpick_simp_attrs @ simp_attrs),
79.441 - (setN, flat set_thmss, code_nitpick_simp_attrs @ simp_attrs)]
79.442 + [(mapN, map_thms, code_nitpicksimp_attrs @ simp_attrs),
79.443 + (rel_distinctN, rel_distinct_thms, simp_attrs),
79.444 + (rel_injectN, rel_inject_thms, simp_attrs),
79.445 + (setN, flat set_thmss, code_nitpicksimp_attrs @ simp_attrs)]
79.446 |> massage_simple_notes fp_b_name;
79.447 in
79.448 (((map_thms, rel_inject_thms, rel_distinct_thms, set_thmss), ctr_sugar),
79.449 - lthy |> Local_Theory.notes notes |> snd)
79.450 + lthy |> Local_Theory.notes (anonymous_notes @ notes) |> snd)
79.451 end;
79.452
79.453 - fun mk_binding suf = qualify false fp_b_name (Binding.suffix_name ("_" ^ suf) fp_b);
79.454 + fun mk_binding pre = qualify false fp_b_name (Binding.prefix_name (pre ^ "_") fp_b);
79.455
79.456 fun massage_res (((maps_sets_rels, ctr_sugar), co_iter_res), lthy) =
79.457 (((maps_sets_rels, (ctrs, xss, ctr_defs, ctr_sugar)), co_iter_res), lthy);
79.458 @@ -1457,8 +1408,9 @@
79.459 (disc_unfold_iff_thmss, disc_corec_iff_thmss, disc_coiter_iff_attrs),
79.460 (sel_unfold_thmsss, sel_corec_thmsss, sel_coiter_attrs)) =
79.461 derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
79.462 - dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs kss mss ns ctr_defss
79.463 - ctr_sugars coiterss coiter_defss (Proof_Context.export lthy' no_defs_lthy) lthy;
79.464 + dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss ns
79.465 + ctr_defss ctr_sugars coiterss coiter_defss (Proof_Context.export lthy' no_defs_lthy)
79.466 + lthy;
79.467
79.468 val sel_unfold_thmss = map flat sel_unfold_thmsss;
79.469 val sel_corec_thmss = map flat sel_corec_thmsss;
79.470 @@ -1496,6 +1448,12 @@
79.471 (unfoldN, unfold_thmss, K coiter_attrs)]
79.472 |> massage_multi_notes;
79.473
79.474 + fun is_codatatype (Type (s, _)) =
79.475 + (case fp_sugar_of lthy s of SOME {fp = Greatest_FP, ...} => true | _ => false)
79.476 + | is_codatatype _ = false;
79.477 +
79.478 + val nitpick_supported = forall (is_codatatype o T_of_bnf) nested_bnfs;
79.479 +
79.480 fun register_nitpick fpT ({ctrs, casex, ...} : ctr_sugar) =
79.481 Nitpick_HOL.register_codatatype fpT (fst (dest_Const casex))
79.482 (map (dest_Const o mk_ctr As) ctrs)
79.483 @@ -1507,7 +1465,7 @@
79.484 ctr_sugars coiterss mapss [coinduct_thm, strong_coinduct_thm]
79.485 (transpose [unfold_thmss, corec_thmss]) (transpose [disc_unfold_thmss, disc_corec_thmss])
79.486 (transpose [sel_unfold_thmsss, sel_corec_thmsss])
79.487 - |> fold2 register_nitpick fpTs ctr_sugars
79.488 + |> nitpick_supported ? fold2 register_nitpick fpTs ctr_sugars
79.489 end;
79.490
79.491 val lthy'' = lthy'
79.492 @@ -1543,24 +1501,13 @@
79.493
79.494 val parse_type_arg_named_constrained = parse_opt_binding_colon -- parse_type_arg_constrained;
79.495
79.496 +(*FIXME: use parse_type_args_named_constrained from BNF_Util and thus
79.497 + allow users to kill certain arguments of a (co)datatype*)
79.498 val parse_type_args_named_constrained =
79.499 parse_type_arg_constrained >> (single o pair Binding.empty) ||
79.500 @{keyword "("} |-- Parse.!!! (Parse.list1 parse_type_arg_named_constrained --| @{keyword ")"}) ||
79.501 Scan.succeed [];
79.502
79.503 -val parse_map_rel_binding = Parse.short_ident --| @{keyword ":"} -- parse_binding;
79.504 -
79.505 -val no_map_rel = (Binding.empty, Binding.empty);
79.506 -
79.507 -fun extract_map_rel ("map", b) = apfst (K b)
79.508 - | extract_map_rel ("rel", b) = apsnd (K b)
79.509 - | extract_map_rel (s, _) = error ("Unknown label " ^ quote s ^ " (expected \"map\" or \"rel\")");
79.510 -
79.511 -val parse_map_rel_bindings =
79.512 - @{keyword "("} |-- Scan.repeat parse_map_rel_binding --| @{keyword ")"}
79.513 - >> (fn ps => fold extract_map_rel ps no_map_rel) ||
79.514 - Scan.succeed no_map_rel;
79.515 -
79.516 val parse_ctr_spec =
79.517 parse_opt_binding_colon -- parse_binding -- Scan.repeat parse_ctr_arg --
79.518 Scan.optional parse_defaults [] -- Parse.opt_mixfix;
80.1 --- a/src/HOL/BNF/Tools/bnf_fp_def_sugar_tactics.ML Thu Dec 05 17:52:12 2013 +0100
80.2 +++ b/src/HOL/BNF/Tools/bnf_fp_def_sugar_tactics.ML Thu Dec 05 17:58:03 2013 +0100
80.3 @@ -151,12 +151,17 @@
80.4 (atac ORELSE' REPEAT o etac conjE THEN'
80.5 full_simp_tac
80.6 (ss_only (@{thm prod.inject} :: no_refl discs @ rel_eqs @ more_simp_thms) ctxt) THEN'
80.7 - REPEAT o etac conjE THEN_MAYBE' REPEAT o hyp_subst_tac ctxt THEN' REPEAT o rtac conjI THEN'
80.8 - REPEAT o (rtac refl ORELSE' atac));
80.9 + REPEAT o etac conjE THEN_MAYBE' REPEAT o hyp_subst_tac ctxt THEN'
80.10 + REPEAT o (resolve_tac [refl, conjI] ORELSE' atac));
80.11
80.12 fun mk_coinduct_distinct_ctrs_tac ctxt discs discs' =
80.13 - hyp_subst_tac ctxt THEN' REPEAT o etac conjE THEN'
80.14 - full_simp_tac (ss_only (refl :: no_refl (union Thm.eq_thm discs discs') @ basic_simp_thms) ctxt);
80.15 + let
80.16 + val discs'' = map (perhaps (try (fn th => th RS @{thm notnotD}))) (discs @ discs')
80.17 + |> distinct Thm.eq_thm_prop;
80.18 + in
80.19 + hyp_subst_tac ctxt THEN' REPEAT o etac conjE THEN'
80.20 + full_simp_tac (ss_only (refl :: no_refl discs'' @ basic_simp_thms) ctxt)
80.21 + end;
80.22
80.23 fun mk_coinduct_discharge_prem_tac ctxt rel_eqs' nn kk n pre_rel_def dtor_ctor exhaust ctr_defs
80.24 discss selss =
81.1 --- a/src/HOL/BNF/Tools/bnf_fp_n2m.ML Thu Dec 05 17:52:12 2013 +0100
81.2 +++ b/src/HOL/BNF/Tools/bnf_fp_n2m.ML Thu Dec 05 17:58:03 2013 +0100
81.3 @@ -23,7 +23,7 @@
81.4 open BNF_FP_N2M_Tactics
81.5
81.6 fun force_typ ctxt T =
81.7 - map_types Type_Infer.paramify_vars
81.8 + map_types Type_Infer.paramify_vars
81.9 #> Type.constraint T
81.10 #> Syntax.check_term ctxt
81.11 #> singleton (Variable.polymorphic ctxt);
81.12 @@ -99,10 +99,6 @@
81.13 val fp_nesty_bnfss = fp_bnfs :: nesty_bnfss;
81.14 val fp_nesty_bnfs = distinct eq_bnf (flat fp_nesty_bnfss);
81.15
81.16 - fun abstract t =
81.17 - let val Ts = Term.add_frees t [];
81.18 - in fold_rev Term.absfree (filter (member op = Ts) phis') t end;
81.19 -
81.20 val rels =
81.21 let
81.22 fun find_rel T As Bs = fp_nesty_bnfss
81.23 @@ -121,10 +117,11 @@
81.24 in
81.25 Term.list_comb (rel, rels)
81.26 end
81.27 - | mk_rel (T as TFree _) _ = nth phis (find_index (curry op = T) As)
81.28 + | mk_rel (T as TFree _) _ = (nth phis (find_index (curry op = T) As)
81.29 + handle General.Subscript => HOLogic.eq_const T)
81.30 | mk_rel _ _ = raise Fail "fpTs contains schematic type variables";
81.31 in
81.32 - map2 (abstract oo mk_rel) fpTs fpTs'
81.33 + map2 (fold_rev Term.absfree phis' oo mk_rel) fpTs fpTs'
81.34 end;
81.35
81.36 val pre_rels = map2 (fn Ds => mk_rel_of_bnf Ds (As @ fpTs) (Bs @ fpTs')) Dss bnfs;
81.37 @@ -224,7 +221,7 @@
81.38 fun mk_s TU' =
81.39 let
81.40 val i = find_index (fn T => co_alg_argT TU' = T) Xs;
81.41 - val sF = co_alg_funT TU';
81.42 + val sF = co_alg_funT TU';
81.43 val F = nth iter_preTs i;
81.44 val s = nth iter_strs i;
81.45 in
81.46 @@ -238,7 +235,7 @@
81.47 |> force_typ names_lthy smapT
81.48 |> hidden_to_unit;
81.49 val smap_argTs = strip_typeN live (fastype_of smap) |> fst;
81.50 - fun mk_smap_arg TU =
81.51 + fun mk_smap_arg TU =
81.52 (if domain_type TU = range_type TU then
81.53 HOLogic.id_const (domain_type TU)
81.54 else if is_rec then
81.55 @@ -265,7 +262,7 @@
81.56 in
81.57 (case b_opt of
81.58 NONE => ((t, Drule.dummy_thm), lthy)
81.59 - | SOME b => Local_Theory.define ((b, NoSyn), ((Thm.def_binding b, []),
81.60 + | SOME b => Local_Theory.define ((b, NoSyn), ((Binding.conceal (Thm.def_binding b), []),
81.61 fold_rev Term.absfree (if is_rec then rec_strs' else fold_strs') t)) lthy |>> apsnd snd)
81.62 end;
81.63
81.64 @@ -376,6 +373,6 @@
81.65 |> morph_fp_result (Morphism.term_morphism (singleton (Variable.polymorphic lthy))));
81.66 in
81.67 (fp_res, lthy)
81.68 - end
81.69 + end;
81.70
81.71 end;
82.1 --- a/src/HOL/BNF/Tools/bnf_fp_n2m_sugar.ML Thu Dec 05 17:52:12 2013 +0100
82.2 +++ b/src/HOL/BNF/Tools/bnf_fp_n2m_sugar.ML Thu Dec 05 17:58:03 2013 +0100
82.3 @@ -7,14 +7,16 @@
82.4
82.5 signature BNF_FP_N2M_SUGAR =
82.6 sig
82.7 - val mutualize_fp_sugars: bool -> BNF_FP_Util.fp_kind -> binding list -> typ list ->
82.8 - (term -> int list) -> term list list list list -> BNF_FP_Def_Sugar.fp_sugar list ->
82.9 - local_theory ->
82.10 + val unfold_let: term -> term
82.11 + val dest_map: Proof.context -> string -> term -> term * term list
82.12 +
82.13 + val mutualize_fp_sugars: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) ->
82.14 + term list list list list -> BNF_FP_Def_Sugar.fp_sugar list -> local_theory ->
82.15 (BNF_FP_Def_Sugar.fp_sugar list
82.16 * (BNF_FP_Def_Sugar.lfp_sugar_thms option * BNF_FP_Def_Sugar.gfp_sugar_thms option))
82.17 * local_theory
82.18 - val pad_and_indexify_calls: BNF_FP_Def_Sugar.fp_sugar list -> int ->
82.19 - (term * term list list) list list -> term list list list list
82.20 + val indexify_callsss: BNF_FP_Def_Sugar.fp_sugar -> (term * term list list) list ->
82.21 + term list list list
82.22 val nested_to_mutual_fps: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) ->
82.23 (term * term list list) list list -> local_theory ->
82.24 (typ list * int list * BNF_FP_Def_Sugar.fp_sugar list
82.25 @@ -34,171 +36,245 @@
82.26
82.27 val n2mN = "n2m_"
82.28
82.29 +type n2m_sugar = fp_sugar list * (lfp_sugar_thms option * gfp_sugar_thms option);
82.30 +
82.31 +structure Data = Generic_Data
82.32 +(
82.33 + type T = n2m_sugar Typtab.table;
82.34 + val empty = Typtab.empty;
82.35 + val extend = I;
82.36 + val merge = Typtab.merge (eq_fst (eq_list eq_fp_sugar));
82.37 +);
82.38 +
82.39 +fun morph_n2m_sugar phi (fp_sugars, (lfp_sugar_thms_opt, gfp_sugar_thms_opt)) =
82.40 + (map (morph_fp_sugar phi) fp_sugars,
82.41 + (Option.map (morph_lfp_sugar_thms phi) lfp_sugar_thms_opt,
82.42 + Option.map (morph_gfp_sugar_thms phi) gfp_sugar_thms_opt));
82.43 +
82.44 +val transfer_n2m_sugar =
82.45 + morph_n2m_sugar o Morphism.thm_morphism o Thm.transfer o Proof_Context.theory_of;
82.46 +
82.47 +fun n2m_sugar_of ctxt =
82.48 + Typtab.lookup (Data.get (Context.Proof ctxt))
82.49 + #> Option.map (transfer_n2m_sugar ctxt);
82.50 +
82.51 +fun register_n2m_sugar key n2m_sugar =
82.52 + Local_Theory.declaration {syntax = false, pervasive = false}
82.53 + (fn phi => Data.map (Typtab.default (key, morph_n2m_sugar phi n2m_sugar)));
82.54 +
82.55 +fun unfold_let (Const (@{const_name Let}, _) $ arg1 $ arg2) = unfold_let (betapply (arg2, arg1))
82.56 + | unfold_let (Const (@{const_name prod_case}, _) $ t) =
82.57 + (case unfold_let t of
82.58 + t' as Abs (s1, T1, Abs (s2, T2, _)) =>
82.59 + let
82.60 + val x = (s1 ^ s2, Term.maxidx_of_term t + 1);
82.61 + val v = Var (x, HOLogic.mk_prodT (T1, T2));
82.62 + in
82.63 + lambda v (unfold_let (betapplys (t', [HOLogic.mk_fst v, HOLogic.mk_snd v])))
82.64 + end
82.65 + | _ => t)
82.66 + | unfold_let (t $ u) = betapply (unfold_let t, unfold_let u)
82.67 + | unfold_let (Abs (s, T, t)) = Abs (s, T, unfold_let t)
82.68 + | unfold_let t = t;
82.69 +
82.70 +fun mk_map_pattern ctxt s =
82.71 + let
82.72 + val bnf = the (bnf_of ctxt s);
82.73 + val mapx = map_of_bnf bnf;
82.74 + val live = live_of_bnf bnf;
82.75 + val (f_Ts, _) = strip_typeN live (fastype_of mapx);
82.76 + val fs = map_index (fn (i, T) => Var (("?f", i), T)) f_Ts;
82.77 + in
82.78 + (mapx, betapplys (mapx, fs))
82.79 + end;
82.80 +
82.81 +fun dest_map ctxt s call =
82.82 + let
82.83 + val (map0, pat) = mk_map_pattern ctxt s;
82.84 + val (_, tenv) = fo_match ctxt call pat;
82.85 + in
82.86 + (map0, Vartab.fold_rev (fn (_, (_, f)) => cons f) tenv [])
82.87 + end;
82.88 +
82.89 +fun dest_abs_or_applied_map _ _ (Abs (_, _, t)) = (Term.dummy, [t])
82.90 + | dest_abs_or_applied_map ctxt s (t1 $ _) = dest_map ctxt s t1;
82.91 +
82.92 +fun map_partition f xs =
82.93 + fold_rev (fn x => fn (ys, (good, bad)) =>
82.94 + case f x of SOME y => (y :: ys, (x :: good, bad)) | NONE => (ys, (good, x :: bad)))
82.95 + xs ([], ([], []));
82.96 +
82.97 +fun key_of_fp_eqs fp fpTs fp_eqs =
82.98 + Type (fp_case fp "l" "g", fpTs @ maps (fn (x, T) => [TFree x, T]) fp_eqs);
82.99 +
82.100 (* TODO: test with sort constraints on As *)
82.101 -(* TODO: use right sorting order for "fp_sort" w.r.t. original BNFs (?) -- treat new variables
82.102 - as deads? *)
82.103 -fun mutualize_fp_sugars mutualize fp bs fpTs get_indices callssss fp_sugars0 no_defs_lthy0 =
82.104 - if mutualize orelse has_duplicates (op =) fpTs then
82.105 - let
82.106 - val thy = Proof_Context.theory_of no_defs_lthy0;
82.107 +fun mutualize_fp_sugars fp bs fpTs get_indices callssss fp_sugars0 no_defs_lthy0 =
82.108 + let
82.109 + val thy = Proof_Context.theory_of no_defs_lthy0;
82.110
82.111 - val qsotm = quote o Syntax.string_of_term no_defs_lthy0;
82.112 + val qsotm = quote o Syntax.string_of_term no_defs_lthy0;
82.113
82.114 - fun heterogeneous_call t = error ("Heterogeneous recursive call: " ^ qsotm t);
82.115 - fun incompatible_calls t1 t2 =
82.116 - error ("Incompatible recursive calls: " ^ qsotm t1 ^ " vs. " ^ qsotm t2);
82.117 + fun incompatible_calls t1 t2 =
82.118 + error ("Incompatible " ^ co_prefix fp ^ "recursive calls: " ^ qsotm t1 ^ " vs. " ^ qsotm t2);
82.119 + fun nested_self_call t =
82.120 + error ("Unsupported nested self-call " ^ qsotm t);
82.121
82.122 - val b_names = map Binding.name_of bs;
82.123 - val fp_b_names = map base_name_of_typ fpTs;
82.124 + val b_names = map Binding.name_of bs;
82.125 + val fp_b_names = map base_name_of_typ fpTs;
82.126
82.127 - val nn = length fpTs;
82.128 + val nn = length fpTs;
82.129
82.130 - fun target_ctr_sugar_of_fp_sugar fpT ({T, index, ctr_sugars, ...} : fp_sugar) =
82.131 - let
82.132 - val rho = Vartab.fold (cons o apsnd snd) (Sign.typ_match thy (T, fpT) Vartab.empty) [];
82.133 - val phi = Morphism.term_morphism (Term.subst_TVars rho);
82.134 - in
82.135 - morph_ctr_sugar phi (nth ctr_sugars index)
82.136 - end;
82.137 + fun target_ctr_sugar_of_fp_sugar fpT ({T, index, ctr_sugars, ...} : fp_sugar) =
82.138 + let
82.139 + val rho = Vartab.fold (cons o apsnd snd) (Sign.typ_match thy (T, fpT) Vartab.empty) [];
82.140 + val phi = Morphism.term_morphism (Term.subst_TVars rho);
82.141 + in
82.142 + morph_ctr_sugar phi (nth ctr_sugars index)
82.143 + end;
82.144
82.145 - val ctr_defss = map (of_fp_sugar #ctr_defss) fp_sugars0;
82.146 - val mapss = map (of_fp_sugar #mapss) fp_sugars0;
82.147 - val ctr_sugars0 = map2 target_ctr_sugar_of_fp_sugar fpTs fp_sugars0;
82.148 + val ctr_defss = map (of_fp_sugar #ctr_defss) fp_sugars0;
82.149 + val mapss = map (of_fp_sugar #mapss) fp_sugars0;
82.150 + val ctr_sugars = map2 target_ctr_sugar_of_fp_sugar fpTs fp_sugars0;
82.151
82.152 - val ctrss = map #ctrs ctr_sugars0;
82.153 - val ctr_Tss = map (map fastype_of) ctrss;
82.154 + val ctrss = map #ctrs ctr_sugars;
82.155 + val ctr_Tss = map (map fastype_of) ctrss;
82.156
82.157 - val As' = fold (fold Term.add_tfreesT) ctr_Tss [];
82.158 - val As = map TFree As';
82.159 + val As' = fold (fold Term.add_tfreesT) ctr_Tss [];
82.160 + val As = map TFree As';
82.161
82.162 - val ((Cs, Xs), no_defs_lthy) =
82.163 - no_defs_lthy0
82.164 - |> fold Variable.declare_typ As
82.165 - |> mk_TFrees nn
82.166 - ||>> variant_tfrees fp_b_names;
82.167 + val ((Cs, Xs), no_defs_lthy) =
82.168 + no_defs_lthy0
82.169 + |> fold Variable.declare_typ As
82.170 + |> mk_TFrees nn
82.171 + ||>> variant_tfrees fp_b_names;
82.172
82.173 - fun freeze_fp_default (T as Type (s, Ts)) =
82.174 - (case find_index (curry (op =) T) fpTs of
82.175 - ~1 => Type (s, map freeze_fp_default Ts)
82.176 - | kk => nth Xs kk)
82.177 - | freeze_fp_default T = T;
82.178 + fun check_call_dead live_call call =
82.179 + if null (get_indices call) then () else incompatible_calls live_call call;
82.180
82.181 - fun get_indices_checked call =
82.182 - (case get_indices call of
82.183 - _ :: _ :: _ => heterogeneous_call call
82.184 - | kks => kks);
82.185 + fun freeze_fpTs_simple (T as Type (s, Ts)) =
82.186 + (case find_index (curry (op =) T) fpTs of
82.187 + ~1 => Type (s, map freeze_fpTs_simple Ts)
82.188 + | kk => nth Xs kk)
82.189 + | freeze_fpTs_simple T = T;
82.190
82.191 - fun freeze_fp calls (T as Type (s, Ts)) =
82.192 - (case map_filter (try (snd o dest_map no_defs_lthy s)) calls of
82.193 - [] =>
82.194 - (case union (op = o pairself fst)
82.195 - (maps (fn call => map (rpair call) (get_indices_checked call)) calls) [] of
82.196 - [] => freeze_fp_default T
82.197 - | [(kk, _)] => nth Xs kk
82.198 - | (_, call1) :: (_, call2) :: _ => incompatible_calls call1 call2)
82.199 - | callss =>
82.200 - Type (s, map2 freeze_fp (flatten_type_args_of_bnf (the (bnf_of no_defs_lthy s)) []
82.201 - (transpose callss)) Ts))
82.202 - | freeze_fp _ T = T;
82.203 + fun freeze_fpTs_map (fpT as Type (_, Ts')) (callss, (live_call :: _, dead_calls))
82.204 + (T as Type (s, Ts)) =
82.205 + if Ts' = Ts then
82.206 + nested_self_call live_call
82.207 + else
82.208 + (List.app (check_call_dead live_call) dead_calls;
82.209 + Type (s, map2 (freeze_fpTs fpT) (flatten_type_args_of_bnf (the (bnf_of no_defs_lthy s)) []
82.210 + (transpose callss)) Ts))
82.211 + and freeze_fpTs fpT calls (T as Type (s, _)) =
82.212 + (case map_partition (try (snd o dest_map no_defs_lthy s)) calls of
82.213 + ([], _) =>
82.214 + (case map_partition (try (snd o dest_abs_or_applied_map no_defs_lthy s)) calls of
82.215 + ([], _) => freeze_fpTs_simple T
82.216 + | callsp => freeze_fpTs_map fpT callsp T)
82.217 + | callsp => freeze_fpTs_map fpT callsp T)
82.218 + | freeze_fpTs _ _ T = T;
82.219
82.220 - val ctr_Tsss = map (map binder_types) ctr_Tss;
82.221 - val ctrXs_Tsss = map2 (map2 (map2 freeze_fp)) callssss ctr_Tsss;
82.222 - val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss;
82.223 - val Ts = map (body_type o hd) ctr_Tss;
82.224 + val ctr_Tsss = map (map binder_types) ctr_Tss;
82.225 + val ctrXs_Tsss = map3 (map2 o map2 o freeze_fpTs) fpTs callssss ctr_Tsss;
82.226 + val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss;
82.227 + val ctr_Ts = map (body_type o hd) ctr_Tss;
82.228
82.229 - val ns = map length ctr_Tsss;
82.230 - val kss = map (fn n => 1 upto n) ns;
82.231 - val mss = map (map length) ctr_Tsss;
82.232 + val ns = map length ctr_Tsss;
82.233 + val kss = map (fn n => 1 upto n) ns;
82.234 + val mss = map (map length) ctr_Tsss;
82.235
82.236 - val fp_eqs = map dest_TFree Xs ~~ ctrXs_sum_prod_Ts;
82.237 + val fp_eqs = map dest_TFree Xs ~~ ctrXs_sum_prod_Ts;
82.238 + val key = key_of_fp_eqs fp fpTs fp_eqs;
82.239 + in
82.240 + (case n2m_sugar_of no_defs_lthy key of
82.241 + SOME n2m_sugar => (n2m_sugar, no_defs_lthy)
82.242 + | NONE =>
82.243 + let
82.244 + val base_fp_names = Name.variant_list [] fp_b_names;
82.245 + val fp_bs = map2 (fn b_name => fn base_fp_name =>
82.246 + Binding.qualify true b_name (Binding.name (n2mN ^ base_fp_name)))
82.247 + b_names base_fp_names;
82.248
82.249 - val base_fp_names = Name.variant_list [] fp_b_names;
82.250 - val fp_bs = map2 (fn b_name => fn base_fp_name =>
82.251 - Binding.qualify true b_name (Binding.name (n2mN ^ base_fp_name)))
82.252 - b_names base_fp_names;
82.253 + val (pre_bnfs, (fp_res as {xtor_co_iterss = xtor_co_iterss0, xtor_co_induct, dtor_injects,
82.254 + dtor_ctors, xtor_co_iter_thmss, ...}, lthy)) =
82.255 + fp_bnf (construct_mutualized_fp fp fpTs fp_sugars0) fp_bs As' fp_eqs no_defs_lthy;
82.256
82.257 - val (pre_bnfs, (fp_res as {xtor_co_iterss = xtor_co_iterss0, xtor_co_induct,
82.258 - dtor_injects, dtor_ctors, xtor_co_iter_thmss, ...}, lthy)) =
82.259 - fp_bnf (construct_mutualized_fp fp fpTs fp_sugars0) fp_bs As' fp_eqs no_defs_lthy;
82.260 + val nesting_bnfs = nesty_bnfs lthy ctrXs_Tsss As;
82.261 + val nested_bnfs = nesty_bnfs lthy ctrXs_Tsss Xs;
82.262
82.263 - val nesting_bnfs = nesty_bnfs lthy ctrXs_Tsss As;
82.264 - val nested_bnfs = nesty_bnfs lthy ctrXs_Tsss Xs;
82.265 + val ((xtor_co_iterss, iters_args_types, coiters_args_types), _) =
82.266 + mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy;
82.267
82.268 - val ((xtor_co_iterss, iters_args_types, coiters_args_types), _) =
82.269 - mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy;
82.270 + fun mk_binding b suf = Binding.suffix_name ("_" ^ suf) b;
82.271
82.272 - fun mk_binding b suf = Binding.suffix_name ("_" ^ suf) b;
82.273 + val ((co_iterss, co_iter_defss), lthy) =
82.274 + fold_map2 (fn b =>
82.275 + (if fp = Least_FP then define_iters [foldN, recN] (the iters_args_types)
82.276 + else define_coiters [unfoldN, corecN] (the coiters_args_types))
82.277 + (mk_binding b) fpTs Cs) fp_bs xtor_co_iterss lthy
82.278 + |>> split_list;
82.279
82.280 - val ((co_iterss, co_iter_defss), lthy) =
82.281 - fold_map2 (fn b =>
82.282 - (if fp = Least_FP then define_iters [foldN, recN] (the iters_args_types)
82.283 - else define_coiters [unfoldN, corecN] (the coiters_args_types))
82.284 - (mk_binding b) fpTs Cs) fp_bs xtor_co_iterss lthy
82.285 - |>> split_list;
82.286 + val ((co_inducts, un_fold_thmss, co_rec_thmss, disc_unfold_thmss, disc_corec_thmss,
82.287 + sel_unfold_thmsss, sel_corec_thmsss), fp_sugar_thms) =
82.288 + if fp = Least_FP then
82.289 + derive_induct_iters_thms_for_types pre_bnfs (the iters_args_types) xtor_co_induct
82.290 + xtor_co_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss
82.291 + co_iterss co_iter_defss lthy
82.292 + |> `(fn ((_, induct, _), (fold_thmss, rec_thmss, _)) =>
82.293 + ([induct], fold_thmss, rec_thmss, [], [], [], []))
82.294 + ||> (fn info => (SOME info, NONE))
82.295 + else
82.296 + derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
82.297 + dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss
82.298 + ns ctr_defss ctr_sugars co_iterss co_iter_defss
82.299 + (Proof_Context.export lthy no_defs_lthy) lthy
82.300 + |> `(fn ((coinduct_thms_pairs, _), (unfold_thmss, corec_thmss, _),
82.301 + (disc_unfold_thmss, disc_corec_thmss, _), _,
82.302 + (sel_unfold_thmsss, sel_corec_thmsss, _)) =>
82.303 + (map snd coinduct_thms_pairs, unfold_thmss, corec_thmss, disc_unfold_thmss,
82.304 + disc_corec_thmss, sel_unfold_thmsss, sel_corec_thmsss))
82.305 + ||> (fn info => (NONE, SOME info));
82.306
82.307 - val rho = tvar_subst thy Ts fpTs;
82.308 - val ctr_sugar_phi =
82.309 - Morphism.compose (Morphism.typ_morphism (Term.typ_subst_TVars rho))
82.310 - (Morphism.term_morphism (Term.subst_TVars rho));
82.311 - val inst_ctr_sugar = morph_ctr_sugar ctr_sugar_phi;
82.312 + val phi = Proof_Context.export_morphism no_defs_lthy no_defs_lthy0;
82.313
82.314 - val ctr_sugars = map inst_ctr_sugar ctr_sugars0;
82.315 + fun mk_target_fp_sugar (kk, T) =
82.316 + {T = T, fp = fp, index = kk, pre_bnfs = pre_bnfs, nested_bnfs = nested_bnfs,
82.317 + nesting_bnfs = nesting_bnfs, fp_res = fp_res, ctr_defss = ctr_defss,
82.318 + ctr_sugars = ctr_sugars, co_iterss = co_iterss, mapss = mapss, co_inducts = co_inducts,
82.319 + co_iter_thmsss = transpose [un_fold_thmss, co_rec_thmss],
82.320 + disc_co_itersss = transpose [disc_unfold_thmss, disc_corec_thmss],
82.321 + sel_co_iterssss = transpose [sel_unfold_thmsss, sel_corec_thmsss]}
82.322 + |> morph_fp_sugar phi;
82.323
82.324 - val ((co_inducts, un_fold_thmss, co_rec_thmss, disc_unfold_thmss, disc_corec_thmss,
82.325 - sel_unfold_thmsss, sel_corec_thmsss), fp_sugar_thms) =
82.326 - if fp = Least_FP then
82.327 - derive_induct_iters_thms_for_types pre_bnfs (the iters_args_types) xtor_co_induct
82.328 - xtor_co_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss
82.329 - co_iterss co_iter_defss lthy
82.330 - |> `(fn ((_, induct, _), (fold_thmss, rec_thmss, _)) =>
82.331 - ([induct], fold_thmss, rec_thmss, [], [], [], []))
82.332 - ||> (fn info => (SOME info, NONE))
82.333 - else
82.334 - derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
82.335 - dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs kss mss ns ctr_defss
82.336 - ctr_sugars co_iterss co_iter_defss (Proof_Context.export lthy no_defs_lthy) lthy
82.337 - |> `(fn ((coinduct_thms_pairs, _), (unfold_thmss, corec_thmss, _),
82.338 - (disc_unfold_thmss, disc_corec_thmss, _), _,
82.339 - (sel_unfold_thmsss, sel_corec_thmsss, _)) =>
82.340 - (map snd coinduct_thms_pairs, unfold_thmss, corec_thmss, disc_unfold_thmss,
82.341 - disc_corec_thmss, sel_unfold_thmsss, sel_corec_thmsss))
82.342 - ||> (fn info => (NONE, SOME info));
82.343 -
82.344 - val phi = Proof_Context.export_morphism no_defs_lthy no_defs_lthy0;
82.345 -
82.346 - fun mk_target_fp_sugar (kk, T) =
82.347 - {T = T, fp = fp, index = kk, pre_bnfs = pre_bnfs, nested_bnfs = nested_bnfs,
82.348 - nesting_bnfs = nesting_bnfs, fp_res = fp_res, ctr_defss = ctr_defss,
82.349 - ctr_sugars = ctr_sugars, co_iterss = co_iterss, mapss = mapss, co_inducts = co_inducts,
82.350 - co_iter_thmsss = transpose [un_fold_thmss, co_rec_thmss],
82.351 - disc_co_itersss = transpose [disc_unfold_thmss, disc_corec_thmss],
82.352 - sel_co_iterssss = transpose [sel_unfold_thmsss, sel_corec_thmsss]}
82.353 - |> morph_fp_sugar phi;
82.354 - in
82.355 - ((map_index mk_target_fp_sugar fpTs, fp_sugar_thms), lthy)
82.356 - end
82.357 - else
82.358 - (* TODO: reorder hypotheses and predicates in (co)induction rules? *)
82.359 - ((fp_sugars0, (NONE, NONE)), no_defs_lthy0);
82.360 + val n2m_sugar = (map_index mk_target_fp_sugar fpTs, fp_sugar_thms);
82.361 + in
82.362 + (n2m_sugar, lthy |> register_n2m_sugar key n2m_sugar)
82.363 + end)
82.364 + end;
82.365
82.366 fun indexify_callsss fp_sugar callsss =
82.367 let
82.368 val {ctrs, ...} = of_fp_sugar #ctr_sugars fp_sugar;
82.369 - fun do_ctr ctr =
82.370 + fun indexify_ctr ctr =
82.371 (case AList.lookup Term.aconv_untyped callsss ctr of
82.372 NONE => replicate (num_binder_types (fastype_of ctr)) []
82.373 - | SOME callss => map (map Envir.beta_eta_contract) callss);
82.374 + | SOME callss => map (map (Envir.beta_eta_contract o unfold_let)) callss);
82.375 in
82.376 - map do_ctr ctrs
82.377 + map indexify_ctr ctrs
82.378 end;
82.379
82.380 -fun pad_and_indexify_calls fp_sugars0 = map2 indexify_callsss fp_sugars0 oo pad_list [];
82.381 +fun retypargs tyargs (Type (s, _)) = Type (s, tyargs);
82.382 +
82.383 +fun fold_subtype_pairs f (T as Type (s, Ts), U as Type (s', Us)) =
82.384 + f (T, U) #> (if s = s' then fold (fold_subtype_pairs f) (Ts ~~ Us) else I)
82.385 + | fold_subtype_pairs f TU = f TU;
82.386
82.387 fun nested_to_mutual_fps fp actual_bs actual_Ts get_indices actual_callssss0 lthy =
82.388 let
82.389 val qsoty = quote o Syntax.string_of_typ lthy;
82.390 val qsotys = space_implode " or " o map qsoty;
82.391
82.392 + fun duplicate_datatype T = error (qsoty T ^ " is not mutually recursive with itself");
82.393 fun not_co_datatype0 T = error (qsoty T ^ " is not a " ^ co_prefix fp ^ "datatype");
82.394 fun not_co_datatype (T as Type (s, _)) =
82.395 if fp = Least_FP andalso
82.396 @@ -208,32 +284,80 @@
82.397 not_co_datatype0 T
82.398 | not_co_datatype T = not_co_datatype0 T;
82.399 fun not_mutually_nested_rec Ts1 Ts2 =
82.400 - error (qsotys Ts1 ^ " is neither mutually recursive with nor nested recursive via " ^
82.401 - qsotys Ts2);
82.402 + error (qsotys Ts1 ^ " is neither mutually recursive with " ^ qsotys Ts2 ^
82.403 + " nor nested recursive via " ^ qsotys Ts2);
82.404
82.405 - val perm_actual_Ts as Type (_, ty_args0) :: _ =
82.406 - sort (int_ord o pairself Term.size_of_typ) actual_Ts;
82.407 + val _ = (case Library.duplicates (op =) actual_Ts of [] => () | T :: _ => duplicate_datatype T);
82.408
82.409 - fun check_enrich_with_mutuals _ [] = []
82.410 - | check_enrich_with_mutuals seen ((T as Type (T_name, ty_args)) :: Ts) =
82.411 - (case fp_sugar_of lthy T_name of
82.412 - SOME ({fp = fp', fp_res = {Ts = Ts', ...}, ...}) =>
82.413 - if fp = fp' then
82.414 + val perm_actual_Ts =
82.415 + sort (prod_ord int_ord Term_Ord.typ_ord o pairself (`Term.size_of_typ)) actual_Ts;
82.416 +
82.417 + fun the_ctrs_of (Type (s, Ts)) = map (mk_ctr Ts) (#ctrs (the (ctr_sugar_of lthy s)));
82.418 +
82.419 + fun the_fp_sugar_of (T as Type (T_name, _)) =
82.420 + (case fp_sugar_of lthy T_name of
82.421 + SOME (fp_sugar as {fp = fp', ...}) => if fp = fp' then fp_sugar else not_co_datatype T
82.422 + | NONE => not_co_datatype T);
82.423 +
82.424 + fun gen_rhss_in gen_Ts rho subTs =
82.425 + let
82.426 + fun maybe_insert (T, Type (_, gen_tyargs)) =
82.427 + if member (op =) subTs T then insert (op =) gen_tyargs else I
82.428 + | maybe_insert _ = I;
82.429 +
82.430 + val ctrs = maps the_ctrs_of gen_Ts;
82.431 + val gen_ctr_Ts = maps (binder_types o fastype_of) ctrs;
82.432 + val ctr_Ts = map (Term.typ_subst_atomic rho) gen_ctr_Ts;
82.433 + in
82.434 + fold (fold_subtype_pairs maybe_insert) (ctr_Ts ~~ gen_ctr_Ts) []
82.435 + end;
82.436 +
82.437 + fun gather_types _ _ num_groups seen gen_seen [] = (num_groups, seen, gen_seen)
82.438 + | gather_types lthy rho num_groups seen gen_seen ((T as Type (_, tyargs)) :: Ts) =
82.439 + let
82.440 + val {fp_res = {Ts = mutual_Ts0, ...}, ...} = the_fp_sugar_of T;
82.441 + val mutual_Ts = map (retypargs tyargs) mutual_Ts0;
82.442 +
82.443 + val _ = seen = [] orelse exists (exists_subtype_in seen) mutual_Ts orelse
82.444 + not_mutually_nested_rec mutual_Ts seen;
82.445 +
82.446 + fun fresh_tyargs () =
82.447 let
82.448 - val mutual_Ts = map (fn Type (s, _) => Type (s, ty_args)) Ts';
82.449 - val _ =
82.450 - seen = [] orelse exists (exists_subtype_in seen) mutual_Ts orelse
82.451 - not_mutually_nested_rec mutual_Ts seen;
82.452 - val (seen', Ts') = List.partition (member (op =) mutual_Ts) Ts;
82.453 + (* The name "'z" is unlikely to clash with the context, yielding more cache hits. *)
82.454 + val (gen_tyargs, lthy') =
82.455 + variant_tfrees (replicate (length tyargs) "z") lthy
82.456 + |>> map Logic.varifyT_global;
82.457 + val rho' = (gen_tyargs ~~ tyargs) @ rho;
82.458 in
82.459 - mutual_Ts @ check_enrich_with_mutuals (seen @ T :: seen') Ts'
82.460 - end
82.461 - else
82.462 - not_co_datatype T
82.463 - | NONE => not_co_datatype T)
82.464 - | check_enrich_with_mutuals _ (T :: _) = not_co_datatype T;
82.465 + (rho', gen_tyargs, gen_seen, lthy')
82.466 + end;
82.467
82.468 - val perm_Ts = check_enrich_with_mutuals [] perm_actual_Ts;
82.469 + val (rho', gen_tyargs, gen_seen', lthy') =
82.470 + if exists (exists_subtype_in seen) mutual_Ts then
82.471 + (case gen_rhss_in gen_seen rho mutual_Ts of
82.472 + [] => fresh_tyargs ()
82.473 + | gen_tyargss as gen_tyargs :: gen_tyargss_tl =>
82.474 + let
82.475 + val unify_pairs = split_list (maps (curry (op ~~) gen_tyargs) gen_tyargss_tl);
82.476 + val mgu = Type.raw_unifys unify_pairs Vartab.empty;
82.477 + val gen_tyargs' = map (Envir.subst_type mgu) gen_tyargs;
82.478 + val gen_seen' = map (Envir.subst_type mgu) gen_seen;
82.479 + in
82.480 + (rho, gen_tyargs', gen_seen', lthy)
82.481 + end)
82.482 + else
82.483 + fresh_tyargs ();
82.484 +
82.485 + val gen_mutual_Ts = map (retypargs gen_tyargs) mutual_Ts0;
82.486 + val Ts' = filter_out (member (op =) mutual_Ts) Ts;
82.487 + in
82.488 + gather_types lthy' rho' (num_groups + 1) (seen @ mutual_Ts) (gen_seen' @ gen_mutual_Ts)
82.489 + Ts'
82.490 + end
82.491 + | gather_types _ _ _ _ _ (T :: _) = not_co_datatype T;
82.492 +
82.493 + val (num_groups, perm_Ts, perm_gen_Ts) = gather_types lthy [] 0 [] [] perm_actual_Ts;
82.494 + val perm_frozen_gen_Ts = map Logic.unvarifyT_global perm_gen_Ts;
82.495
82.496 val missing_Ts = perm_Ts |> subtract (op =) actual_Ts;
82.497 val Ts = actual_Ts @ missing_Ts;
82.498 @@ -241,6 +365,8 @@
82.499 val nn = length Ts;
82.500 val kks = 0 upto nn - 1;
82.501
82.502 + val callssss0 = pad_list [] nn actual_callssss0;
82.503 +
82.504 val common_name = mk_common_name (map Binding.name_of actual_bs);
82.505 val bs = pad_list (Binding.name common_name) nn actual_bs;
82.506
82.507 @@ -249,16 +375,19 @@
82.508
82.509 val perm_bs = permute bs;
82.510 val perm_kks = permute kks;
82.511 + val perm_callssss0 = permute callssss0;
82.512 val perm_fp_sugars0 = map (the o fp_sugar_of lthy o fst o dest_Type) perm_Ts;
82.513
82.514 - val mutualize = exists (fn Type (_, ty_args) => ty_args <> ty_args0) Ts;
82.515 - val perm_callssss = pad_and_indexify_calls perm_fp_sugars0 nn actual_callssss0;
82.516 + val perm_callssss = map2 indexify_callsss perm_fp_sugars0 perm_callssss0;
82.517
82.518 val get_perm_indices = map (fn kk => find_index (curry (op =) kk) perm_kks) o get_indices;
82.519
82.520 val ((perm_fp_sugars, fp_sugar_thms), lthy) =
82.521 - mutualize_fp_sugars mutualize fp perm_bs perm_Ts get_perm_indices perm_callssss
82.522 - perm_fp_sugars0 lthy;
82.523 + if num_groups > 1 then
82.524 + mutualize_fp_sugars fp perm_bs perm_frozen_gen_Ts get_perm_indices perm_callssss
82.525 + perm_fp_sugars0 lthy
82.526 + else
82.527 + ((perm_fp_sugars0, (NONE, NONE)), lthy);
82.528
82.529 val fp_sugars = unpermute perm_fp_sugars;
82.530 in
83.1 --- a/src/HOL/BNF/Tools/bnf_fp_rec_sugar.ML Thu Dec 05 17:52:12 2013 +0100
83.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
83.3 @@ -1,986 +0,0 @@
83.4 -(* Title: HOL/BNF/Tools/bnf_fp_rec_sugar.ML
83.5 - Author: Lorenz Panny, TU Muenchen
83.6 - Copyright 2013
83.7 -
83.8 -Recursor and corecursor sugar.
83.9 -*)
83.10 -
83.11 -signature BNF_FP_REC_SUGAR =
83.12 -sig
83.13 - val add_primrec: (binding * typ option * mixfix) list ->
83.14 - (Attrib.binding * term) list -> local_theory -> (term list * thm list list) * local_theory
83.15 - val add_primrec_cmd: (binding * string option * mixfix) list ->
83.16 - (Attrib.binding * string) list -> local_theory -> (term list * thm list list) * local_theory
83.17 - val add_primrec_global: (binding * typ option * mixfix) list ->
83.18 - (Attrib.binding * term) list -> theory -> (term list * thm list list) * theory
83.19 - val add_primrec_overloaded: (string * (string * typ) * bool) list ->
83.20 - (binding * typ option * mixfix) list ->
83.21 - (Attrib.binding * term) list -> theory -> (term list * thm list list) * theory
83.22 - val add_primrec_simple: ((binding * typ) * mixfix) list -> term list ->
83.23 - local_theory -> (string list * (term list * (int list list * thm list list))) * local_theory
83.24 - val add_primcorecursive_cmd: bool ->
83.25 - (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list ->
83.26 - Proof.context -> Proof.state
83.27 - val add_primcorec_cmd: bool ->
83.28 - (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list ->
83.29 - local_theory -> local_theory
83.30 -end;
83.31 -
83.32 -structure BNF_FP_Rec_Sugar : BNF_FP_REC_SUGAR =
83.33 -struct
83.34 -
83.35 -open BNF_Util
83.36 -open BNF_FP_Util
83.37 -open BNF_FP_Rec_Sugar_Util
83.38 -open BNF_FP_Rec_Sugar_Tactics
83.39 -
83.40 -val codeN = "code"
83.41 -val ctrN = "ctr"
83.42 -val discN = "disc"
83.43 -val selN = "sel"
83.44 -
83.45 -val nitpick_attrs = @{attributes [nitpick_simp]};
83.46 -val simp_attrs = @{attributes [simp]};
83.47 -val code_nitpick_attrs = Code.add_default_eqn_attrib :: nitpick_attrs;
83.48 -val code_nitpick_simp_attrs = Code.add_default_eqn_attrib :: nitpick_attrs @ simp_attrs;
83.49 -
83.50 -exception Primrec_Error of string * term list;
83.51 -
83.52 -fun primrec_error str = raise Primrec_Error (str, []);
83.53 -fun primrec_error_eqn str eqn = raise Primrec_Error (str, [eqn]);
83.54 -fun primrec_error_eqns str eqns = raise Primrec_Error (str, eqns);
83.55 -
83.56 -fun finds eq = fold_map (fn x => List.partition (curry eq x) #>> pair x);
83.57 -
83.58 -val free_name = try (fn Free (v, _) => v);
83.59 -val const_name = try (fn Const (v, _) => v);
83.60 -val undef_const = Const (@{const_name undefined}, dummyT);
83.61 -
83.62 -fun permute_args n t = list_comb (t, map Bound (0 :: (n downto 1)))
83.63 - |> fold (K (Term.abs (Name.uu, dummyT))) (0 upto n);
83.64 -val abs_tuple = HOLogic.tupled_lambda o HOLogic.mk_tuple;
83.65 -fun drop_All t = subst_bounds (strip_qnt_vars @{const_name all} t |> map Free |> rev,
83.66 - strip_qnt_body @{const_name all} t)
83.67 -fun abstract vs =
83.68 - let fun a n (t $ u) = a n t $ a n u
83.69 - | a n (Abs (v, T, b)) = Abs (v, T, a (n + 1) b)
83.70 - | a n t = let val idx = find_index (equal t) vs in
83.71 - if idx < 0 then t else Bound (n + idx) end
83.72 - in a 0 end;
83.73 -fun mk_prod1 Ts (t, u) = HOLogic.pair_const (fastype_of1 (Ts, t)) (fastype_of1 (Ts, u)) $ t $ u;
83.74 -fun mk_tuple1 Ts = the_default HOLogic.unit o try (foldr1 (mk_prod1 Ts));
83.75 -
83.76 -fun get_indices fixes t = map (fst #>> Binding.name_of #> Free) fixes
83.77 - |> map_index (fn (i, v) => if exists_subterm (equal v) t then SOME i else NONE)
83.78 - |> map_filter I;
83.79 -
83.80 -
83.81 -(* Primrec *)
83.82 -
83.83 -type eqn_data = {
83.84 - fun_name: string,
83.85 - rec_type: typ,
83.86 - ctr: term,
83.87 - ctr_args: term list,
83.88 - left_args: term list,
83.89 - right_args: term list,
83.90 - res_type: typ,
83.91 - rhs_term: term,
83.92 - user_eqn: term
83.93 -};
83.94 -
83.95 -fun dissect_eqn lthy fun_names eqn' =
83.96 - let
83.97 - val eqn = drop_All eqn' |> HOLogic.dest_Trueprop
83.98 - handle TERM _ =>
83.99 - primrec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn';
83.100 - val (lhs, rhs) = HOLogic.dest_eq eqn
83.101 - handle TERM _ =>
83.102 - primrec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn';
83.103 - val (fun_name, args) = strip_comb lhs
83.104 - |>> (fn x => if is_Free x then fst (dest_Free x)
83.105 - else primrec_error_eqn "malformed function equation (does not start with free)" eqn);
83.106 - val (left_args, rest) = take_prefix is_Free args;
83.107 - val (nonfrees, right_args) = take_suffix is_Free rest;
83.108 - val num_nonfrees = length nonfrees;
83.109 - val _ = num_nonfrees = 1 orelse if num_nonfrees = 0 then
83.110 - primrec_error_eqn "constructor pattern missing in left-hand side" eqn else
83.111 - primrec_error_eqn "more than one non-variable argument in left-hand side" eqn;
83.112 - val _ = member (op =) fun_names fun_name orelse
83.113 - primrec_error_eqn "malformed function equation (does not start with function name)" eqn
83.114 -
83.115 - val (ctr, ctr_args) = strip_comb (the_single nonfrees);
83.116 - val _ = try (num_binder_types o fastype_of) ctr = SOME (length ctr_args) orelse
83.117 - primrec_error_eqn "partially applied constructor in pattern" eqn;
83.118 - val _ = let val d = duplicates (op =) (left_args @ ctr_args @ right_args) in null d orelse
83.119 - primrec_error_eqn ("duplicate variable \"" ^ Syntax.string_of_term lthy (hd d) ^
83.120 - "\" in left-hand side") eqn end;
83.121 - val _ = forall is_Free ctr_args orelse
83.122 - primrec_error_eqn "non-primitive pattern in left-hand side" eqn;
83.123 - val _ =
83.124 - let val b = fold_aterms (fn x as Free (v, _) =>
83.125 - if (not (member (op =) (left_args @ ctr_args @ right_args) x) andalso
83.126 - not (member (op =) fun_names v) andalso
83.127 - not (Variable.is_fixed lthy v)) then cons x else I | _ => I) rhs []
83.128 - in
83.129 - null b orelse
83.130 - primrec_error_eqn ("extra variable(s) in right-hand side: " ^
83.131 - commas (map (Syntax.string_of_term lthy) b)) eqn
83.132 - end;
83.133 - in
83.134 - {fun_name = fun_name,
83.135 - rec_type = body_type (type_of ctr),
83.136 - ctr = ctr,
83.137 - ctr_args = ctr_args,
83.138 - left_args = left_args,
83.139 - right_args = right_args,
83.140 - res_type = map fastype_of (left_args @ right_args) ---> fastype_of rhs,
83.141 - rhs_term = rhs,
83.142 - user_eqn = eqn'}
83.143 - end;
83.144 -
83.145 -fun rewrite_map_arg get_ctr_pos rec_type res_type =
83.146 - let
83.147 - val pT = HOLogic.mk_prodT (rec_type, res_type);
83.148 -
83.149 - val maybe_suc = Option.map (fn x => x + 1);
83.150 - fun subst d (t as Bound d') = t |> d = SOME d' ? curry (op $) (fst_const pT)
83.151 - | subst d (Abs (v, T, b)) = Abs (v, if d = SOME ~1 then pT else T, subst (maybe_suc d) b)
83.152 - | subst d t =
83.153 - let
83.154 - val (u, vs) = strip_comb t;
83.155 - val ctr_pos = try (get_ctr_pos o the) (free_name u) |> the_default ~1;
83.156 - in
83.157 - if ctr_pos >= 0 then
83.158 - if d = SOME ~1 andalso length vs = ctr_pos then
83.159 - list_comb (permute_args ctr_pos (snd_const pT), vs)
83.160 - else if length vs > ctr_pos andalso is_some d
83.161 - andalso d = try (fn Bound n => n) (nth vs ctr_pos) then
83.162 - list_comb (snd_const pT $ nth vs ctr_pos, map (subst d) (nth_drop ctr_pos vs))
83.163 - else
83.164 - primrec_error_eqn ("recursive call not directly applied to constructor argument") t
83.165 - else if d = SOME ~1 andalso const_name u = SOME @{const_name comp} then
83.166 - list_comb (map_types (K dummyT) u, map2 subst [NONE, d] vs)
83.167 - else
83.168 - list_comb (u, map (subst (d |> d = SOME ~1 ? K NONE)) vs)
83.169 - end
83.170 - in
83.171 - subst (SOME ~1)
83.172 - end;
83.173 -
83.174 -fun subst_rec_calls lthy get_ctr_pos has_call ctr_args direct_calls indirect_calls t =
83.175 - let
83.176 - fun subst bound_Ts (Abs (v, T, b)) = Abs (v, T, subst (T :: bound_Ts) b)
83.177 - | subst bound_Ts (t as g' $ y) =
83.178 - let
83.179 - val maybe_direct_y' = AList.lookup (op =) direct_calls y;
83.180 - val maybe_indirect_y' = AList.lookup (op =) indirect_calls y;
83.181 - val (g, g_args) = strip_comb g';
83.182 - val ctr_pos = try (get_ctr_pos o the) (free_name g) |> the_default ~1;
83.183 - val _ = ctr_pos < 0 orelse length g_args >= ctr_pos orelse
83.184 - primrec_error_eqn "too few arguments in recursive call" t;
83.185 - in
83.186 - if not (member (op =) ctr_args y) then
83.187 - pairself (subst bound_Ts) (g', y) |> (op $)
83.188 - else if ctr_pos >= 0 then
83.189 - list_comb (the maybe_direct_y', g_args)
83.190 - else if is_some maybe_indirect_y' then
83.191 - (if has_call g' then t else y)
83.192 - |> massage_indirect_rec_call lthy has_call
83.193 - (rewrite_map_arg get_ctr_pos) bound_Ts y (the maybe_indirect_y')
83.194 - |> (if has_call g' then I else curry (op $) g')
83.195 - else
83.196 - t
83.197 - end
83.198 - | subst _ t = t
83.199 - in
83.200 - subst [] t
83.201 - |> tap (fn u => has_call u andalso (* FIXME detect this case earlier *)
83.202 - primrec_error_eqn "recursive call not directly applied to constructor argument" t)
83.203 - end;
83.204 -
83.205 -fun build_rec_arg lthy (funs_data : eqn_data list list) has_call (ctr_spec : rec_ctr_spec)
83.206 - (maybe_eqn_data : eqn_data option) =
83.207 - if is_none maybe_eqn_data then undef_const else
83.208 - let
83.209 - val eqn_data = the maybe_eqn_data;
83.210 - val t = #rhs_term eqn_data;
83.211 - val ctr_args = #ctr_args eqn_data;
83.212 -
83.213 - val calls = #calls ctr_spec;
83.214 - val n_args = fold (curry (op +) o (fn Direct_Rec _ => 2 | _ => 1)) calls 0;
83.215 -
83.216 - val no_calls' = tag_list 0 calls
83.217 - |> map_filter (try (apsnd (fn No_Rec n => n | Direct_Rec (n, _) => n)));
83.218 - val direct_calls' = tag_list 0 calls
83.219 - |> map_filter (try (apsnd (fn Direct_Rec (_, n) => n)));
83.220 - val indirect_calls' = tag_list 0 calls
83.221 - |> map_filter (try (apsnd (fn Indirect_Rec n => n)));
83.222 -
83.223 - fun make_direct_type _ = dummyT; (* FIXME? *)
83.224 -
83.225 - val rec_res_type_list = map (fn (x :: _) => (#rec_type x, #res_type x)) funs_data;
83.226 -
83.227 - fun make_indirect_type (Type (Tname, Ts)) = Type (Tname, Ts |> map (fn T =>
83.228 - let val maybe_res_type = AList.lookup (op =) rec_res_type_list T in
83.229 - if is_some maybe_res_type
83.230 - then HOLogic.mk_prodT (T, the maybe_res_type)
83.231 - else make_indirect_type T end))
83.232 - | make_indirect_type T = T;
83.233 -
83.234 - val args = replicate n_args ("", dummyT)
83.235 - |> Term.rename_wrt_term t
83.236 - |> map Free
83.237 - |> fold (fn (ctr_arg_idx, arg_idx) =>
83.238 - nth_map arg_idx (K (nth ctr_args ctr_arg_idx)))
83.239 - no_calls'
83.240 - |> fold (fn (ctr_arg_idx, arg_idx) =>
83.241 - nth_map arg_idx (K (nth ctr_args ctr_arg_idx |> map_types make_direct_type)))
83.242 - direct_calls'
83.243 - |> fold (fn (ctr_arg_idx, arg_idx) =>
83.244 - nth_map arg_idx (K (nth ctr_args ctr_arg_idx |> map_types make_indirect_type)))
83.245 - indirect_calls';
83.246 -
83.247 - val fun_name_ctr_pos_list =
83.248 - map (fn (x :: _) => (#fun_name x, length (#left_args x))) funs_data;
83.249 - val get_ctr_pos = try (the o AList.lookup (op =) fun_name_ctr_pos_list) #> the_default ~1;
83.250 - val direct_calls = map (apfst (nth ctr_args) o apsnd (nth args)) direct_calls';
83.251 - val indirect_calls = map (apfst (nth ctr_args) o apsnd (nth args)) indirect_calls';
83.252 -
83.253 - val abstractions = args @ #left_args eqn_data @ #right_args eqn_data;
83.254 - in
83.255 - t
83.256 - |> subst_rec_calls lthy get_ctr_pos has_call ctr_args direct_calls indirect_calls
83.257 - |> fold_rev lambda abstractions
83.258 - end;
83.259 -
83.260 -fun build_defs lthy bs mxs (funs_data : eqn_data list list) (rec_specs : rec_spec list) has_call =
83.261 - let
83.262 - val n_funs = length funs_data;
83.263 -
83.264 - val ctr_spec_eqn_data_list' =
83.265 - (take n_funs rec_specs |> map #ctr_specs) ~~ funs_data
83.266 - |> maps (uncurry (finds (fn (x, y) => #ctr x = #ctr y))
83.267 - ##> (fn x => null x orelse
83.268 - primrec_error_eqns "excess equations in definition" (map #rhs_term x)) #> fst);
83.269 - val _ = ctr_spec_eqn_data_list' |> map (fn (_, x) => length x <= 1 orelse
83.270 - primrec_error_eqns ("multiple equations for constructor") (map #user_eqn x));
83.271 -
83.272 - val ctr_spec_eqn_data_list =
83.273 - ctr_spec_eqn_data_list' @ (drop n_funs rec_specs |> maps #ctr_specs |> map (rpair []));
83.274 -
83.275 - val recs = take n_funs rec_specs |> map #recx;
83.276 - val rec_args = ctr_spec_eqn_data_list
83.277 - |> sort ((op <) o pairself (#offset o fst) |> make_ord)
83.278 - |> map (uncurry (build_rec_arg lthy funs_data has_call) o apsnd (try the_single));
83.279 - val ctr_poss = map (fn x =>
83.280 - if length (distinct ((op =) o pairself (length o #left_args)) x) <> 1 then
83.281 - primrec_error ("inconstant constructor pattern position for function " ^
83.282 - quote (#fun_name (hd x)))
83.283 - else
83.284 - hd x |> #left_args |> length) funs_data;
83.285 - in
83.286 - (recs, ctr_poss)
83.287 - |-> map2 (fn recx => fn ctr_pos => list_comb (recx, rec_args) |> permute_args ctr_pos)
83.288 - |> Syntax.check_terms lthy
83.289 - |> map3 (fn b => fn mx => fn t => ((b, mx), ((Binding.map_name Thm.def_name b, []), t))) bs mxs
83.290 - end;
83.291 -
83.292 -fun find_rec_calls has_call (eqn_data : eqn_data) =
83.293 - let
83.294 - fun find (Abs (_, _, b)) ctr_arg = find b ctr_arg
83.295 - | find (t as _ $ _) ctr_arg =
83.296 - let
83.297 - val (f', args') = strip_comb t;
83.298 - val n = find_index (equal ctr_arg) args';
83.299 - in
83.300 - if n < 0 then
83.301 - find f' ctr_arg @ maps (fn x => find x ctr_arg) args'
83.302 - else
83.303 - let val (f, args) = chop n args' |>> curry list_comb f' in
83.304 - if has_call f then
83.305 - f :: maps (fn x => find x ctr_arg) args
83.306 - else
83.307 - find f ctr_arg @ maps (fn x => find x ctr_arg) args
83.308 - end
83.309 - end
83.310 - | find _ _ = [];
83.311 - in
83.312 - map (find (#rhs_term eqn_data)) (#ctr_args eqn_data)
83.313 - |> (fn [] => NONE | callss => SOME (#ctr eqn_data, callss))
83.314 - end;
83.315 -
83.316 -fun prepare_primrec fixes specs lthy =
83.317 - let
83.318 - val (bs, mxs) = map_split (apfst fst) fixes;
83.319 - val fun_names = map Binding.name_of bs;
83.320 - val eqns_data = map (dissect_eqn lthy fun_names) specs;
83.321 - val funs_data = eqns_data
83.322 - |> partition_eq ((op =) o pairself #fun_name)
83.323 - |> finds (fn (x, y) => x = #fun_name (hd y)) fun_names |> fst
83.324 - |> map (fn (x, y) => the_single y handle List.Empty =>
83.325 - primrec_error ("missing equations for function " ^ quote x));
83.326 -
83.327 - val has_call = exists_subterm (map (fst #>> Binding.name_of #> Free) fixes |> member (op =));
83.328 - val arg_Ts = map (#rec_type o hd) funs_data;
83.329 - val res_Ts = map (#res_type o hd) funs_data;
83.330 - val callssss = funs_data
83.331 - |> map (partition_eq ((op =) o pairself #ctr))
83.332 - |> map (maps (map_filter (find_rec_calls has_call)));
83.333 -
83.334 - val ((n2m, rec_specs, _, induct_thm, induct_thms), lthy') =
83.335 - rec_specs_of bs arg_Ts res_Ts (get_indices fixes) callssss lthy;
83.336 -
83.337 - val actual_nn = length funs_data;
83.338 -
83.339 - val _ = let val ctrs = (maps (map #ctr o #ctr_specs) rec_specs) in
83.340 - map (fn {ctr, user_eqn, ...} => member (op =) ctrs ctr orelse
83.341 - primrec_error_eqn ("argument " ^ quote (Syntax.string_of_term lthy' ctr) ^
83.342 - " is not a constructor in left-hand side") user_eqn) eqns_data end;
83.343 -
83.344 - val defs = build_defs lthy' bs mxs funs_data rec_specs has_call;
83.345 -
83.346 - fun prove lthy def_thms' ({ctr_specs, nested_map_idents, nested_map_comps, ...} : rec_spec)
83.347 - (fun_data : eqn_data list) =
83.348 - let
83.349 - val def_thms = map (snd o snd) def_thms';
83.350 - val simp_thmss = finds (fn (x, y) => #ctr x = #ctr y) fun_data ctr_specs
83.351 - |> fst
83.352 - |> map_filter (try (fn (x, [y]) =>
83.353 - (#user_eqn x, length (#left_args x) + length (#right_args x), #rec_thm y)))
83.354 - |> map (fn (user_eqn, num_extra_args, rec_thm) =>
83.355 - mk_primrec_tac lthy num_extra_args nested_map_idents nested_map_comps def_thms rec_thm
83.356 - |> K |> Goal.prove lthy [] [] user_eqn);
83.357 - val poss = find_indices (fn (x, y) => #ctr x = #ctr y) fun_data eqns_data;
83.358 - in
83.359 - (poss, simp_thmss)
83.360 - end;
83.361 -
83.362 - val notes =
83.363 - (if n2m then map2 (fn name => fn thm =>
83.364 - (name, inductN, [thm], [])) fun_names (take actual_nn induct_thms) else [])
83.365 - |> map (fn (prefix, thmN, thms, attrs) =>
83.366 - ((Binding.qualify true prefix (Binding.name thmN), attrs), [(thms, [])]));
83.367 -
83.368 - val common_name = mk_common_name fun_names;
83.369 -
83.370 - val common_notes =
83.371 - (if n2m then [(inductN, [induct_thm], [])] else [])
83.372 - |> map (fn (thmN, thms, attrs) =>
83.373 - ((Binding.qualify true common_name (Binding.name thmN), attrs), [(thms, [])]));
83.374 - in
83.375 - (((fun_names, defs),
83.376 - fn lthy => fn defs =>
83.377 - split_list (map2 (prove lthy defs) (take actual_nn rec_specs) funs_data)),
83.378 - lthy' |> Local_Theory.notes (notes @ common_notes) |> snd)
83.379 - end;
83.380 -
83.381 -(* primrec definition *)
83.382 -
83.383 -fun add_primrec_simple fixes ts lthy =
83.384 - let
83.385 - val (((names, defs), prove), lthy) = prepare_primrec fixes ts lthy
83.386 - handle ERROR str => primrec_error str;
83.387 - in
83.388 - lthy
83.389 - |> fold_map Local_Theory.define defs
83.390 - |-> (fn defs => `(fn lthy => (names, (map fst defs, prove lthy defs))))
83.391 - end
83.392 - handle Primrec_Error (str, eqns) =>
83.393 - if null eqns
83.394 - then error ("primrec_new error:\n " ^ str)
83.395 - else error ("primrec_new error:\n " ^ str ^ "\nin\n " ^
83.396 - space_implode "\n " (map (quote o Syntax.string_of_term lthy) eqns));
83.397 -
83.398 -local
83.399 -
83.400 -fun gen_primrec prep_spec (raw_fixes : (binding * 'a option * mixfix) list) raw_spec lthy =
83.401 - let
83.402 - val d = duplicates (op =) (map (Binding.name_of o #1) raw_fixes)
83.403 - val _ = null d orelse primrec_error ("duplicate function name(s): " ^ commas d);
83.404 -
83.405 - val (fixes, specs) = fst (prep_spec raw_fixes raw_spec lthy);
83.406 -
83.407 - val mk_notes =
83.408 - flat ooo map3 (fn poss => fn prefix => fn thms =>
83.409 - let
83.410 - val (bs, attrss) = map_split (fst o nth specs) poss;
83.411 - val notes =
83.412 - map3 (fn b => fn attrs => fn thm =>
83.413 - ((Binding.qualify false prefix b, code_nitpick_simp_attrs @ attrs), [([thm], [])]))
83.414 - bs attrss thms;
83.415 - in
83.416 - ((Binding.qualify true prefix (Binding.name simpsN), []), [(thms, [])]) :: notes
83.417 - end);
83.418 - in
83.419 - lthy
83.420 - |> add_primrec_simple fixes (map snd specs)
83.421 - |-> (fn (names, (ts, (posss, simpss))) =>
83.422 - Spec_Rules.add Spec_Rules.Equational (ts, flat simpss)
83.423 - #> Local_Theory.notes (mk_notes posss names simpss)
83.424 - #>> pair ts o map snd)
83.425 - end;
83.426 -
83.427 -in
83.428 -
83.429 -val add_primrec = gen_primrec Specification.check_spec;
83.430 -val add_primrec_cmd = gen_primrec Specification.read_spec;
83.431 -
83.432 -end;
83.433 -
83.434 -fun add_primrec_global fixes specs thy =
83.435 - let
83.436 - val lthy = Named_Target.theory_init thy;
83.437 - val ((ts, simps), lthy') = add_primrec fixes specs lthy;
83.438 - val simps' = burrow (Proof_Context.export lthy' lthy) simps;
83.439 - in ((ts, simps'), Local_Theory.exit_global lthy') end;
83.440 -
83.441 -fun add_primrec_overloaded ops fixes specs thy =
83.442 - let
83.443 - val lthy = Overloading.overloading ops thy;
83.444 - val ((ts, simps), lthy') = add_primrec fixes specs lthy;
83.445 - val simps' = burrow (Proof_Context.export lthy' lthy) simps;
83.446 - in ((ts, simps'), Local_Theory.exit_global lthy') end;
83.447 -
83.448 -
83.449 -
83.450 -(* Primcorec *)
83.451 -
83.452 -type co_eqn_data_disc = {
83.453 - fun_name: string,
83.454 - fun_T: typ,
83.455 - fun_args: term list,
83.456 - ctr: term,
83.457 - ctr_no: int, (*###*)
83.458 - disc: term,
83.459 - prems: term list,
83.460 - auto_gen: bool,
83.461 - user_eqn: term
83.462 -};
83.463 -
83.464 -type co_eqn_data_sel = {
83.465 - fun_name: string,
83.466 - fun_T: typ,
83.467 - fun_args: term list,
83.468 - ctr: term,
83.469 - sel: term,
83.470 - rhs_term: term,
83.471 - user_eqn: term
83.472 -};
83.473 -
83.474 -datatype co_eqn_data =
83.475 - Disc of co_eqn_data_disc |
83.476 - Sel of co_eqn_data_sel;
83.477 -
83.478 -fun co_dissect_eqn_disc sequential fun_names (corec_specs : corec_spec list) prems' concl
83.479 - matchedsss =
83.480 - let
83.481 - fun find_subterm p = let (* FIXME \<exists>? *)
83.482 - fun f (t as u $ v) = if p t then SOME t else merge_options (f u, f v)
83.483 - | f t = if p t then SOME t else NONE
83.484 - in f end;
83.485 -
83.486 - val applied_fun = concl
83.487 - |> find_subterm (member ((op =) o apsnd SOME) fun_names o try (fst o dest_Free o head_of))
83.488 - |> the
83.489 - handle Option.Option => primrec_error_eqn "malformed discriminator equation" concl;
83.490 - val ((fun_name, fun_T), fun_args) = strip_comb applied_fun |>> dest_Free;
83.491 - val {ctr_specs, ...} = the (AList.lookup (op =) (fun_names ~~ corec_specs) fun_name);
83.492 -
83.493 - val discs = map #disc ctr_specs;
83.494 - val ctrs = map #ctr ctr_specs;
83.495 - val not_disc = head_of concl = @{term Not};
83.496 - val _ = not_disc andalso length ctrs <> 2 andalso
83.497 - primrec_error_eqn "\<not>ed discriminator for a type with \<noteq> 2 constructors" concl;
83.498 - val disc = find_subterm (member (op =) discs o head_of) concl;
83.499 - val eq_ctr0 = concl |> perhaps (try (HOLogic.dest_not)) |> try (HOLogic.dest_eq #> snd)
83.500 - |> (fn SOME t => let val n = find_index (equal t) ctrs in
83.501 - if n >= 0 then SOME n else NONE end | _ => NONE);
83.502 - val _ = is_some disc orelse is_some eq_ctr0 orelse
83.503 - primrec_error_eqn "no discriminator in equation" concl;
83.504 - val ctr_no' =
83.505 - if is_none disc then the eq_ctr0 else find_index (equal (head_of (the disc))) discs;
83.506 - val ctr_no = if not_disc then 1 - ctr_no' else ctr_no';
83.507 - val ctr = #ctr (nth ctr_specs ctr_no);
83.508 -
83.509 - val catch_all = try (fst o dest_Free o the_single) prems' = SOME Name.uu_;
83.510 - val matchedss = AList.lookup (op =) matchedsss fun_name |> the_default [];
83.511 - val prems = map (abstract (List.rev fun_args)) prems';
83.512 - val real_prems =
83.513 - (if catch_all orelse sequential then maps negate_disj matchedss else []) @
83.514 - (if catch_all then [] else prems);
83.515 -
83.516 - val matchedsss' = AList.delete (op =) fun_name matchedsss
83.517 - |> cons (fun_name, if sequential then matchedss @ [prems] else matchedss @ [real_prems]);
83.518 -
83.519 - val user_eqn =
83.520 - (real_prems, betapply (#disc (nth ctr_specs ctr_no), applied_fun))
83.521 - |>> map HOLogic.mk_Trueprop ||> HOLogic.mk_Trueprop
83.522 - |> Logic.list_implies;
83.523 - in
83.524 - (Disc {
83.525 - fun_name = fun_name,
83.526 - fun_T = fun_T,
83.527 - fun_args = fun_args,
83.528 - ctr = ctr,
83.529 - ctr_no = ctr_no,
83.530 - disc = #disc (nth ctr_specs ctr_no),
83.531 - prems = real_prems,
83.532 - auto_gen = catch_all,
83.533 - user_eqn = user_eqn
83.534 - }, matchedsss')
83.535 - end;
83.536 -
83.537 -fun co_dissect_eqn_sel fun_names (corec_specs : corec_spec list) eqn' of_spec eqn =
83.538 - let
83.539 - val (lhs, rhs) = HOLogic.dest_eq eqn
83.540 - handle TERM _ =>
83.541 - primrec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn;
83.542 - val sel = head_of lhs;
83.543 - val ((fun_name, fun_T), fun_args) = dest_comb lhs |> snd |> strip_comb |> apfst dest_Free
83.544 - handle TERM _ =>
83.545 - primrec_error_eqn "malformed selector argument in left-hand side" eqn;
83.546 - val corec_spec = the (AList.lookup (op =) (fun_names ~~ corec_specs) fun_name)
83.547 - handle Option.Option => primrec_error_eqn "malformed selector argument in left-hand side" eqn;
83.548 - val ctr_spec =
83.549 - if is_some of_spec
83.550 - then the (find_first (equal (the of_spec) o #ctr) (#ctr_specs corec_spec))
83.551 - else #ctr_specs corec_spec |> filter (exists (equal sel) o #sels) |> the_single
83.552 - handle List.Empty => primrec_error_eqn "ambiguous selector - use \"of\"" eqn;
83.553 - val user_eqn = drop_All eqn';
83.554 - in
83.555 - Sel {
83.556 - fun_name = fun_name,
83.557 - fun_T = fun_T,
83.558 - fun_args = fun_args,
83.559 - ctr = #ctr ctr_spec,
83.560 - sel = sel,
83.561 - rhs_term = rhs,
83.562 - user_eqn = user_eqn
83.563 - }
83.564 - end;
83.565 -
83.566 -fun co_dissect_eqn_ctr sequential fun_names (corec_specs : corec_spec list) eqn' imp_prems imp_rhs
83.567 - matchedsss =
83.568 - let
83.569 - val (lhs, rhs) = HOLogic.dest_eq imp_rhs;
83.570 - val fun_name = head_of lhs |> fst o dest_Free;
83.571 - val {ctr_specs, ...} = the (AList.lookup (op =) (fun_names ~~ corec_specs) fun_name);
83.572 - val (ctr, ctr_args) = strip_comb rhs;
83.573 - val {disc, sels, ...} = the (find_first (equal ctr o #ctr) ctr_specs)
83.574 - handle Option.Option => primrec_error_eqn "not a constructor" ctr;
83.575 -
83.576 - val disc_imp_rhs = betapply (disc, lhs);
83.577 - val (maybe_eqn_data_disc, matchedsss') = if length ctr_specs = 1
83.578 - then (NONE, matchedsss)
83.579 - else apfst SOME (co_dissect_eqn_disc
83.580 - sequential fun_names corec_specs imp_prems disc_imp_rhs matchedsss);
83.581 -
83.582 - val sel_imp_rhss = (sels ~~ ctr_args)
83.583 - |> map (fn (sel, ctr_arg) => HOLogic.mk_eq (betapply (sel, lhs), ctr_arg));
83.584 -
83.585 -(*
83.586 -val _ = tracing ("reduced\n " ^ Syntax.string_of_term @{context} imp_rhs ^ "\nto\n \<cdot> " ^
83.587 - (is_some maybe_eqn_data_disc ? K (Syntax.string_of_term @{context} disc_imp_rhs ^ "\n \<cdot> ")) "" ^
83.588 - space_implode "\n \<cdot> " (map (Syntax.string_of_term @{context}) sel_imp_rhss));
83.589 -*)
83.590 -
83.591 - val eqns_data_sel =
83.592 - map (co_dissect_eqn_sel fun_names corec_specs eqn' (SOME ctr)) sel_imp_rhss;
83.593 - in
83.594 - (the_list maybe_eqn_data_disc @ eqns_data_sel, matchedsss')
83.595 - end;
83.596 -
83.597 -fun co_dissect_eqn sequential fun_names (corec_specs : corec_spec list) eqn' of_spec matchedsss =
83.598 - let
83.599 - val eqn = drop_All eqn'
83.600 - handle TERM _ => primrec_error_eqn "malformed function equation" eqn';
83.601 - val (imp_prems, imp_rhs) = Logic.strip_horn eqn
83.602 - |> apfst (map HOLogic.dest_Trueprop) o apsnd HOLogic.dest_Trueprop;
83.603 -
83.604 - val head = imp_rhs
83.605 - |> perhaps (try HOLogic.dest_not) |> perhaps (try (fst o HOLogic.dest_eq))
83.606 - |> head_of;
83.607 -
83.608 - val maybe_rhs = imp_rhs |> perhaps (try (HOLogic.dest_not)) |> try (snd o HOLogic.dest_eq);
83.609 -
83.610 - val discs = maps #ctr_specs corec_specs |> map #disc;
83.611 - val sels = maps #ctr_specs corec_specs |> maps #sels;
83.612 - val ctrs = maps #ctr_specs corec_specs |> map #ctr;
83.613 - in
83.614 - if member (op =) discs head orelse
83.615 - is_some maybe_rhs andalso
83.616 - member (op =) (filter (null o binder_types o fastype_of) ctrs) (the maybe_rhs) then
83.617 - co_dissect_eqn_disc sequential fun_names corec_specs imp_prems imp_rhs matchedsss
83.618 - |>> single
83.619 - else if member (op =) sels head then
83.620 - ([co_dissect_eqn_sel fun_names corec_specs eqn' of_spec imp_rhs], matchedsss)
83.621 - else if is_Free head andalso member (op =) fun_names (fst (dest_Free head)) then
83.622 - co_dissect_eqn_ctr sequential fun_names corec_specs eqn' imp_prems imp_rhs matchedsss
83.623 - else
83.624 - primrec_error_eqn "malformed function equation" eqn
83.625 - end;
83.626 -
83.627 -fun build_corec_arg_disc (ctr_specs : corec_ctr_spec list)
83.628 - ({fun_args, ctr_no, prems, ...} : co_eqn_data_disc) =
83.629 - if is_none (#pred (nth ctr_specs ctr_no)) then I else
83.630 - mk_conjs prems
83.631 - |> curry subst_bounds (List.rev fun_args)
83.632 - |> HOLogic.tupled_lambda (HOLogic.mk_tuple fun_args)
83.633 - |> K |> nth_map (the (#pred (nth ctr_specs ctr_no)));
83.634 -
83.635 -fun build_corec_arg_no_call (sel_eqns : co_eqn_data_sel list) sel =
83.636 - find_first (equal sel o #sel) sel_eqns
83.637 - |> try (fn SOME {fun_args, rhs_term, ...} => abs_tuple fun_args rhs_term)
83.638 - |> the_default undef_const
83.639 - |> K;
83.640 -
83.641 -fun build_corec_args_direct_call lthy has_call (sel_eqns : co_eqn_data_sel list) sel =
83.642 - let
83.643 - val maybe_sel_eqn = find_first (equal sel o #sel) sel_eqns;
83.644 - in
83.645 - if is_none maybe_sel_eqn then (I, I, I) else
83.646 - let
83.647 - val {fun_args, rhs_term, ... } = the maybe_sel_eqn;
83.648 - fun rewrite_q _ t = if has_call t then @{term False} else @{term True};
83.649 - fun rewrite_g _ t = if has_call t then undef_const else t;
83.650 - fun rewrite_h bound_Ts t =
83.651 - if has_call t then mk_tuple1 bound_Ts (snd (strip_comb t)) else undef_const;
83.652 - fun massage f t = massage_direct_corec_call lthy has_call f [] rhs_term |> abs_tuple fun_args;
83.653 - in
83.654 - (massage rewrite_q,
83.655 - massage rewrite_g,
83.656 - massage rewrite_h)
83.657 - end
83.658 - end;
83.659 -
83.660 -fun build_corec_arg_indirect_call lthy has_call (sel_eqns : co_eqn_data_sel list) sel =
83.661 - let
83.662 - val maybe_sel_eqn = find_first (equal sel o #sel) sel_eqns;
83.663 - in
83.664 - if is_none maybe_sel_eqn then I else
83.665 - let
83.666 - val {fun_args, rhs_term, ...} = the maybe_sel_eqn;
83.667 - fun rewrite bound_Ts U T (Abs (v, V, b)) = Abs (v, V, rewrite (V :: bound_Ts) U T b)
83.668 - | rewrite bound_Ts U T (t as _ $ _) =
83.669 - let val (u, vs) = strip_comb t in
83.670 - if is_Free u andalso has_call u then
83.671 - Inr_const U T $ mk_tuple1 bound_Ts vs
83.672 - else if try (fst o dest_Const) u = SOME @{const_name prod_case} then
83.673 - map (rewrite bound_Ts U T) vs |> chop 1 |>> HOLogic.mk_split o the_single |> list_comb
83.674 - else
83.675 - list_comb (rewrite bound_Ts U T u, map (rewrite bound_Ts U T) vs)
83.676 - end
83.677 - | rewrite _ U T t =
83.678 - if is_Free t andalso has_call t then Inr_const U T $ HOLogic.unit else t;
83.679 - fun massage t =
83.680 - massage_indirect_corec_call lthy has_call rewrite [] (range_type (fastype_of t)) rhs_term
83.681 - |> abs_tuple fun_args;
83.682 - in
83.683 - massage
83.684 - end
83.685 - end;
83.686 -
83.687 -fun build_corec_args_sel lthy has_call (all_sel_eqns : co_eqn_data_sel list)
83.688 - (ctr_spec : corec_ctr_spec) =
83.689 - let val sel_eqns = filter (equal (#ctr ctr_spec) o #ctr) all_sel_eqns in
83.690 - if null sel_eqns then I else
83.691 - let
83.692 - val sel_call_list = #sels ctr_spec ~~ #calls ctr_spec;
83.693 -
83.694 - val no_calls' = map_filter (try (apsnd (fn No_Corec n => n))) sel_call_list;
83.695 - val direct_calls' = map_filter (try (apsnd (fn Direct_Corec n => n))) sel_call_list;
83.696 - val indirect_calls' = map_filter (try (apsnd (fn Indirect_Corec n => n))) sel_call_list;
83.697 - in
83.698 - I
83.699 - #> fold (fn (sel, n) => nth_map n (build_corec_arg_no_call sel_eqns sel)) no_calls'
83.700 - #> fold (fn (sel, (q, g, h)) =>
83.701 - let val (fq, fg, fh) = build_corec_args_direct_call lthy has_call sel_eqns sel in
83.702 - nth_map q fq o nth_map g fg o nth_map h fh end) direct_calls'
83.703 - #> fold (fn (sel, n) => nth_map n
83.704 - (build_corec_arg_indirect_call lthy has_call sel_eqns sel)) indirect_calls'
83.705 - end
83.706 - end;
83.707 -
83.708 -fun co_build_defs lthy bs mxs has_call arg_Tss (corec_specs : corec_spec list)
83.709 - (disc_eqnss : co_eqn_data_disc list list) (sel_eqnss : co_eqn_data_sel list list) =
83.710 - let
83.711 - val corec_specs' = take (length bs) corec_specs;
83.712 - val corecs = map #corec corec_specs';
83.713 - val ctr_specss = map #ctr_specs corec_specs';
83.714 - val corec_args = hd corecs
83.715 - |> fst o split_last o binder_types o fastype_of
83.716 - |> map (Const o pair @{const_name undefined})
83.717 - |> fold2 (fold o build_corec_arg_disc) ctr_specss disc_eqnss
83.718 - |> fold2 (fold o build_corec_args_sel lthy has_call) sel_eqnss ctr_specss;
83.719 - fun currys [] t = t
83.720 - | currys Ts t = t $ mk_tuple1 (List.rev Ts) (map Bound (length Ts - 1 downto 0))
83.721 - |> fold_rev (Term.abs o pair Name.uu) Ts;
83.722 -
83.723 -(*
83.724 -val _ = tracing ("corecursor arguments:\n \<cdot> " ^
83.725 - space_implode "\n \<cdot> " (map (Syntax.string_of_term lthy) corec_args));
83.726 -*)
83.727 -
83.728 - val exclss' =
83.729 - disc_eqnss
83.730 - |> map (map (fn x => (#fun_args x, #ctr_no x, #prems x, #auto_gen x))
83.731 - #> fst o (fn xs => fold_map (fn x => fn ys => ((x, ys), ys @ [x])) xs [])
83.732 - #> maps (uncurry (map o pair)
83.733 - #> map (fn ((fun_args, c, x, a), (_, c', y, a')) =>
83.734 - ((c, c', a orelse a'), (x, s_not (mk_conjs y)))
83.735 - ||> apfst (map HOLogic.mk_Trueprop) o apsnd HOLogic.mk_Trueprop
83.736 - ||> Logic.list_implies
83.737 - ||> curry Logic.list_all (map dest_Free fun_args))))
83.738 - in
83.739 - map (list_comb o rpair corec_args) corecs
83.740 - |> map2 (fn Ts => fn t => if length Ts = 0 then t $ HOLogic.unit else t) arg_Tss
83.741 - |> map2 currys arg_Tss
83.742 - |> Syntax.check_terms lthy
83.743 - |> map3 (fn b => fn mx => fn t => ((b, mx), ((Binding.map_name Thm.def_name b, []), t))) bs mxs
83.744 - |> rpair exclss'
83.745 - end;
83.746 -
83.747 -fun mk_real_disc_eqns fun_binding arg_Ts ({ctr_specs, ...} : corec_spec)
83.748 - (sel_eqns : co_eqn_data_sel list) (disc_eqns : co_eqn_data_disc list) =
83.749 - if length disc_eqns <> length ctr_specs - 1 then disc_eqns else
83.750 - let
83.751 - val n = 0 upto length ctr_specs
83.752 - |> the o find_first (fn idx => not (exists (equal idx o #ctr_no) disc_eqns));
83.753 - val fun_args = (try (#fun_args o hd) disc_eqns, try (#fun_args o hd) sel_eqns)
83.754 - |> the_default (map (curry Free Name.uu) arg_Ts) o merge_options;
83.755 - val extra_disc_eqn = {
83.756 - fun_name = Binding.name_of fun_binding,
83.757 - fun_T = arg_Ts ---> body_type (fastype_of (#ctr (hd ctr_specs))),
83.758 - fun_args = fun_args,
83.759 - ctr = #ctr (nth ctr_specs n),
83.760 - ctr_no = n,
83.761 - disc = #disc (nth ctr_specs n),
83.762 - prems = maps (negate_conj o #prems) disc_eqns,
83.763 - auto_gen = true,
83.764 - user_eqn = undef_const};
83.765 - in
83.766 - chop n disc_eqns ||> cons extra_disc_eqn |> (op @)
83.767 - end;
83.768 -
83.769 -fun add_primcorec simple sequential fixes specs of_specs lthy =
83.770 - let
83.771 - val (bs, mxs) = map_split (apfst fst) fixes;
83.772 - val (arg_Ts, res_Ts) = map (strip_type o snd o fst #>> HOLogic.mk_tupleT) fixes |> split_list;
83.773 -
83.774 - val callssss = []; (* FIXME *)
83.775 -
83.776 - val ((n2m, corec_specs', _, coinduct_thm, strong_coinduct_thm, coinduct_thms,
83.777 - strong_coinduct_thms), lthy') =
83.778 - corec_specs_of bs arg_Ts res_Ts (get_indices fixes) callssss lthy;
83.779 -
83.780 - val actual_nn = length bs;
83.781 - val fun_names = map Binding.name_of bs;
83.782 - val corec_specs = take actual_nn corec_specs'; (*###*)
83.783 -
83.784 - val eqns_data =
83.785 - fold_map2 (co_dissect_eqn sequential fun_names corec_specs) (map snd specs) of_specs []
83.786 - |> flat o fst;
83.787 -
83.788 - val disc_eqnss' = map_filter (try (fn Disc x => x)) eqns_data
83.789 - |> partition_eq ((op =) o pairself #fun_name)
83.790 - |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names
83.791 - |> map (sort ((op <) o pairself #ctr_no |> make_ord) o flat o snd);
83.792 - val _ = disc_eqnss' |> map (fn x =>
83.793 - let val d = duplicates ((op =) o pairself #ctr_no) x in null d orelse
83.794 - primrec_error_eqns "excess discriminator equations in definition"
83.795 - (maps (fn t => filter (equal (#ctr_no t) o #ctr_no) x) d |> map #user_eqn) end);
83.796 -
83.797 - val sel_eqnss = map_filter (try (fn Sel x => x)) eqns_data
83.798 - |> partition_eq ((op =) o pairself #fun_name)
83.799 - |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names
83.800 - |> map (flat o snd);
83.801 -
83.802 - val has_call = exists_subterm (map (fst #>> Binding.name_of #> Free) fixes |> member (op =));
83.803 - val arg_Tss = map (binder_types o snd o fst) fixes;
83.804 - val disc_eqnss = map5 mk_real_disc_eqns bs arg_Tss corec_specs sel_eqnss disc_eqnss';
83.805 - val (defs, exclss') =
83.806 - co_build_defs lthy' bs mxs has_call arg_Tss corec_specs disc_eqnss sel_eqnss;
83.807 -
83.808 - fun excl_tac (c, c', a) =
83.809 - if a orelse c = c' orelse sequential then
83.810 - SOME (K (HEADGOAL (mk_primcorec_assumption_tac lthy [])))
83.811 - else if simple then
83.812 - SOME (K (auto_tac lthy))
83.813 - else
83.814 - NONE;
83.815 -
83.816 -(*
83.817 -val _ = tracing ("exclusiveness properties:\n \<cdot> " ^
83.818 - space_implode "\n \<cdot> " (maps (map (Syntax.string_of_term lthy o snd)) exclss'));
83.819 -*)
83.820 -
83.821 - val exclss'' = exclss' |> map (map (fn (idx, t) =>
83.822 - (idx, (Option.map (Goal.prove lthy [] [] t) (excl_tac idx), t))));
83.823 - val taut_thmss = map (map (apsnd (the o fst)) o filter (is_some o fst o snd)) exclss'';
83.824 - val (obligation_idxss, obligationss) = exclss''
83.825 - |> map (map (apsnd (rpair [] o snd)) o filter (is_none o fst o snd))
83.826 - |> split_list o map split_list;
83.827 -
83.828 - fun prove thmss' def_thms' lthy =
83.829 - let
83.830 - val def_thms = map (snd o snd) def_thms';
83.831 -
83.832 - val exclss' = map (op ~~) (obligation_idxss ~~ thmss');
83.833 - fun mk_exclsss excls n =
83.834 - (excls, map (fn k => replicate k [TrueI] @ replicate (n - k) []) (0 upto n - 1))
83.835 - |-> fold (fn ((c, c', _), thm) => nth_map c (nth_map c' (K [thm])));
83.836 - val exclssss = (exclss' ~~ taut_thmss |> map (op @), fun_names ~~ corec_specs)
83.837 - |-> map2 (fn excls => fn (_, {ctr_specs, ...}) => mk_exclsss excls (length ctr_specs));
83.838 -
83.839 - fun prove_disc ({ctr_specs, ...} : corec_spec) exclsss
83.840 - ({fun_name, fun_T, fun_args, ctr_no, prems, ...} : co_eqn_data_disc) =
83.841 - if Term.aconv_untyped (#disc (nth ctr_specs ctr_no), @{term "\<lambda>x. x = x"}) then [] else
83.842 - let
83.843 - val {disc_corec, ...} = nth ctr_specs ctr_no;
83.844 - val k = 1 + ctr_no;
83.845 - val m = length prems;
83.846 - val t =
83.847 - list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0))
83.848 - |> curry betapply (#disc (nth ctr_specs ctr_no)) (*###*)
83.849 - |> HOLogic.mk_Trueprop
83.850 - |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
83.851 - |> curry Logic.list_all (map dest_Free fun_args);
83.852 - in
83.853 - mk_primcorec_disc_tac lthy def_thms disc_corec k m exclsss
83.854 - |> K |> Goal.prove lthy [] [] t
83.855 - |> pair (#disc (nth ctr_specs ctr_no))
83.856 - |> single
83.857 - end;
83.858 -
83.859 - fun prove_sel ({nested_maps, nested_map_idents, nested_map_comps, ctr_specs, ...}
83.860 - : corec_spec) (disc_eqns : co_eqn_data_disc list) exclsss
83.861 - ({fun_name, fun_T, fun_args, ctr, sel, rhs_term, ...} : co_eqn_data_sel) =
83.862 - let
83.863 - val SOME ctr_spec = find_first (equal ctr o #ctr) ctr_specs;
83.864 - val ctr_no = find_index (equal ctr o #ctr) ctr_specs;
83.865 - val prems = the_default (maps (negate_conj o #prems) disc_eqns)
83.866 - (find_first (equal ctr_no o #ctr_no) disc_eqns |> Option.map #prems);
83.867 - val sel_corec = find_index (equal sel) (#sels ctr_spec)
83.868 - |> nth (#sel_corecs ctr_spec);
83.869 - val k = 1 + ctr_no;
83.870 - val m = length prems;
83.871 - val t =
83.872 - list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0))
83.873 - |> curry betapply sel
83.874 - |> rpair (abstract (List.rev fun_args) rhs_term)
83.875 - |> HOLogic.mk_Trueprop o HOLogic.mk_eq
83.876 - |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
83.877 - |> curry Logic.list_all (map dest_Free fun_args);
83.878 - val (distincts, _, sel_splits, sel_split_asms) = case_thms_of_term lthy [] rhs_term;
83.879 - in
83.880 - mk_primcorec_sel_tac lthy def_thms distincts sel_splits sel_split_asms nested_maps
83.881 - nested_map_idents nested_map_comps sel_corec k m exclsss
83.882 - |> K |> Goal.prove lthy [] [] t
83.883 - |> pair sel
83.884 - end;
83.885 -
83.886 - fun prove_ctr disc_alist sel_alist (disc_eqns : co_eqn_data_disc list)
83.887 - (sel_eqns : co_eqn_data_sel list) ({ctr, disc, sels, collapse, ...} : corec_ctr_spec) =
83.888 - if not (exists (equal ctr o #ctr) disc_eqns)
83.889 - andalso not (exists (equal ctr o #ctr) sel_eqns)
83.890 - orelse (* don't try to prove theorems when some sel_eqns are missing *)
83.891 - filter (equal ctr o #ctr) sel_eqns
83.892 - |> fst o finds ((op =) o apsnd #sel) sels
83.893 - |> exists (null o snd)
83.894 - then [] else
83.895 - let
83.896 - val (fun_name, fun_T, fun_args, prems) =
83.897 - (find_first (equal ctr o #ctr) disc_eqns, find_first (equal ctr o #ctr) sel_eqns)
83.898 - |>> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, #prems x))
83.899 - ||> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, []))
83.900 - |> the o merge_options;
83.901 - val m = length prems;
83.902 - val t = filter (equal ctr o #ctr) sel_eqns
83.903 - |> fst o finds ((op =) o apsnd #sel) sels
83.904 - |> map (snd #> (fn [x] => (List.rev (#fun_args x), #rhs_term x)) #-> abstract)
83.905 - |> curry list_comb ctr
83.906 - |> curry HOLogic.mk_eq (list_comb (Free (fun_name, fun_T),
83.907 - map Bound (length fun_args - 1 downto 0)))
83.908 - |> HOLogic.mk_Trueprop
83.909 - |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
83.910 - |> curry Logic.list_all (map dest_Free fun_args);
83.911 - val maybe_disc_thm = AList.lookup (op =) disc_alist disc;
83.912 - val sel_thms = map snd (filter (member (op =) sels o fst) sel_alist);
83.913 - in
83.914 - mk_primcorec_ctr_of_dtr_tac lthy m collapse maybe_disc_thm sel_thms
83.915 - |> K |> Goal.prove lthy [] [] t
83.916 - |> single
83.917 - end;
83.918 -
83.919 - val disc_alists = map3 (maps oo prove_disc) corec_specs exclssss disc_eqnss;
83.920 - val sel_alists = map4 (map ooo prove_sel) corec_specs disc_eqnss exclssss sel_eqnss;
83.921 -
83.922 - val disc_thmss = map (map snd) disc_alists;
83.923 - val sel_thmss = map (map snd) sel_alists;
83.924 - val ctr_thmss = map5 (maps oooo prove_ctr) disc_alists sel_alists disc_eqnss sel_eqnss
83.925 - (map #ctr_specs corec_specs);
83.926 -
83.927 - val simp_thmss = map2 append disc_thmss sel_thmss
83.928 -
83.929 - val common_name = mk_common_name fun_names;
83.930 -
83.931 - val notes =
83.932 - [(coinductN, map (if n2m then single else K []) coinduct_thms, []),
83.933 - (codeN, ctr_thmss(*FIXME*), code_nitpick_attrs),
83.934 - (ctrN, ctr_thmss, []),
83.935 - (discN, disc_thmss, simp_attrs),
83.936 - (selN, sel_thmss, simp_attrs),
83.937 - (simpsN, simp_thmss, []),
83.938 - (strong_coinductN, map (if n2m then single else K []) strong_coinduct_thms, [])]
83.939 - |> maps (fn (thmN, thmss, attrs) =>
83.940 - map2 (fn fun_name => fn thms =>
83.941 - ((Binding.qualify true fun_name (Binding.name thmN), attrs), [(thms, [])]))
83.942 - fun_names (take actual_nn thmss))
83.943 - |> filter_out (null o fst o hd o snd);
83.944 -
83.945 - val common_notes =
83.946 - [(coinductN, if n2m then [coinduct_thm] else [], []),
83.947 - (strong_coinductN, if n2m then [strong_coinduct_thm] else [], [])]
83.948 - |> filter_out (null o #2)
83.949 - |> map (fn (thmN, thms, attrs) =>
83.950 - ((Binding.qualify true common_name (Binding.name thmN), attrs), [(thms, [])]));
83.951 - in
83.952 - lthy |> Local_Theory.notes (notes @ common_notes) |> snd
83.953 - end;
83.954 -
83.955 - fun after_qed thmss' = fold_map Local_Theory.define defs #-> prove thmss';
83.956 -
83.957 - val _ = if not simple orelse forall null obligationss then () else
83.958 - primrec_error "need exclusiveness proofs - use primcorecursive instead of primcorec";
83.959 - in
83.960 - if simple then
83.961 - lthy'
83.962 - |> after_qed (map (fn [] => []) obligationss)
83.963 - |> pair NONE o SOME
83.964 - else
83.965 - lthy'
83.966 - |> Proof.theorem NONE after_qed obligationss
83.967 - |> Proof.refine (Method.primitive_text I)
83.968 - |> Seq.hd
83.969 - |> rpair NONE o SOME
83.970 - end;
83.971 -
83.972 -fun add_primcorec_ursive_cmd simple seq (raw_fixes, raw_specs') lthy =
83.973 - let
83.974 - val (raw_specs, of_specs) = split_list raw_specs' ||> map (Option.map (Syntax.read_term lthy));
83.975 - val ((fixes, specs), _) = Specification.read_spec raw_fixes raw_specs lthy;
83.976 - in
83.977 - add_primcorec simple seq fixes specs of_specs lthy
83.978 - handle ERROR str => primrec_error str
83.979 - end
83.980 - handle Primrec_Error (str, eqns) =>
83.981 - if null eqns
83.982 - then error ("primcorec error:\n " ^ str)
83.983 - else error ("primcorec error:\n " ^ str ^ "\nin\n " ^
83.984 - space_implode "\n " (map (quote o Syntax.string_of_term lthy) eqns));
83.985 -
83.986 -val add_primcorecursive_cmd = (the o fst) ooo add_primcorec_ursive_cmd false;
83.987 -val add_primcorec_cmd = (the o snd) ooo add_primcorec_ursive_cmd true;
83.988 -
83.989 -end;
84.1 --- a/src/HOL/BNF/Tools/bnf_fp_rec_sugar_tactics.ML Thu Dec 05 17:52:12 2013 +0100
84.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
84.3 @@ -1,116 +0,0 @@
84.4 -(* Title: HOL/BNF/Tools/bnf_fp_rec_sugar_tactics.ML
84.5 - Author: Jasmin Blanchette, TU Muenchen
84.6 - Copyright 2013
84.7 -
84.8 -Tactics for recursor and corecursor sugar.
84.9 -*)
84.10 -
84.11 -signature BNF_FP_REC_SUGAR_TACTICS =
84.12 -sig
84.13 - val mk_primcorec_assumption_tac: Proof.context -> thm list -> int -> tactic
84.14 - val mk_primcorec_code_of_raw_code_tac: thm list -> thm -> tactic
84.15 - val mk_primcorec_ctr_of_dtr_tac: Proof.context -> int -> thm -> thm option -> thm list -> tactic
84.16 - val mk_primcorec_disc_tac: Proof.context -> thm list -> thm -> int -> int -> thm list list list ->
84.17 - tactic
84.18 - val mk_primcorec_raw_code_of_ctr_tac: Proof.context -> thm list -> thm list -> thm list ->
84.19 - thm list -> int list -> thm list -> tactic
84.20 - val mk_primcorec_sel_tac: Proof.context -> thm list -> thm list -> thm list -> thm list ->
84.21 - thm list -> thm list -> thm list -> thm -> int -> int -> thm list list list -> tactic
84.22 - val mk_primrec_tac: Proof.context -> int -> thm list -> thm list -> thm list -> thm -> tactic
84.23 -end;
84.24 -
84.25 -structure BNF_FP_Rec_Sugar_Tactics : BNF_FP_REC_SUGAR_TACTICS =
84.26 -struct
84.27 -
84.28 -open BNF_Util
84.29 -open BNF_Tactics
84.30 -
84.31 -val falseEs = @{thms not_TrueE FalseE};
84.32 -val neq_eq_eq_contradict = @{thm neq_eq_eq_contradict};
84.33 -val split_if = @{thm split_if};
84.34 -val split_if_asm = @{thm split_if_asm};
84.35 -val split_connectI = @{thms allI impI conjI};
84.36 -
84.37 -fun mk_primrec_tac ctxt num_extra_args map_idents map_comps fun_defs recx =
84.38 - unfold_thms_tac ctxt fun_defs THEN
84.39 - HEADGOAL (rtac (funpow num_extra_args (fn thm => thm RS fun_cong) recx RS trans)) THEN
84.40 - unfold_thms_tac ctxt (@{thms id_def split o_def fst_conv snd_conv} @ map_comps @ map_idents) THEN
84.41 - HEADGOAL (rtac refl);
84.42 -
84.43 -fun mk_primcorec_assumption_tac ctxt discIs =
84.44 - SELECT_GOAL (unfold_thms_tac ctxt
84.45 - @{thms not_not not_False_eq_True de_Morgan_conj de_Morgan_disj} THEN
84.46 - SOLVE (HEADGOAL (REPEAT o (rtac refl ORELSE' atac ORELSE' etac conjE ORELSE'
84.47 - resolve_tac @{thms TrueI conjI disjI1 disjI2} ORELSE'
84.48 - dresolve_tac discIs THEN' atac ORELSE'
84.49 - etac notE THEN' atac ORELSE'
84.50 - etac disjE))));
84.51 -
84.52 -fun mk_primcorec_same_case_tac m =
84.53 - HEADGOAL (if m = 0 then rtac TrueI
84.54 - else REPEAT_DETERM_N (m - 1) o (rtac conjI THEN' atac) THEN' atac);
84.55 -
84.56 -fun mk_primcorec_different_case_tac ctxt excl =
84.57 - unfold_thms_tac ctxt @{thms not_not not_False_eq_True not_True_eq_False} THEN
84.58 - HEADGOAL (rtac excl THEN_ALL_NEW mk_primcorec_assumption_tac ctxt []);
84.59 -
84.60 -fun mk_primcorec_cases_tac ctxt k m exclsss =
84.61 - let val n = length exclsss in
84.62 - EVERY (map (fn [] => if k = n then all_tac else mk_primcorec_same_case_tac m
84.63 - | [excl] => mk_primcorec_different_case_tac ctxt excl)
84.64 - (take k (nth exclsss (k - 1))))
84.65 - end;
84.66 -
84.67 -fun mk_primcorec_prelude ctxt defs thm =
84.68 - unfold_thms_tac ctxt defs THEN HEADGOAL (rtac thm) THEN
84.69 - unfold_thms_tac ctxt @{thms Let_def split};
84.70 -
84.71 -fun mk_primcorec_disc_tac ctxt defs disc_corec k m exclsss =
84.72 - mk_primcorec_prelude ctxt defs disc_corec THEN mk_primcorec_cases_tac ctxt k m exclsss;
84.73 -
84.74 -fun mk_primcorec_sel_tac ctxt defs distincts splits split_asms maps map_idents map_comps f_sel k m
84.75 - exclsss =
84.76 - mk_primcorec_prelude ctxt defs (f_sel RS trans) THEN
84.77 - mk_primcorec_cases_tac ctxt k m exclsss THEN
84.78 - HEADGOAL (REPEAT_DETERM o (rtac refl ORELSE' rtac ext ORELSE'
84.79 - eresolve_tac falseEs ORELSE'
84.80 - resolve_tac split_connectI ORELSE'
84.81 - Splitter.split_asm_tac (split_if_asm :: split_asms) ORELSE'
84.82 - Splitter.split_tac (split_if :: splits) ORELSE'
84.83 - eresolve_tac (map (fn thm => thm RS neq_eq_eq_contradict) distincts) THEN' atac ORELSE'
84.84 - etac notE THEN' atac ORELSE'
84.85 - (CHANGED o SELECT_GOAL (unfold_thms_tac ctxt
84.86 - (@{thms id_apply o_def split_def sum.cases} @ maps @ map_comps @ map_idents)))));
84.87 -
84.88 -fun mk_primcorec_ctr_of_dtr_tac ctxt m collapse maybe_disc_f sel_fs =
84.89 - HEADGOAL (rtac ((if null sel_fs then collapse else collapse RS sym) RS trans) THEN'
84.90 - (the_default (K all_tac) (Option.map rtac maybe_disc_f)) THEN' REPEAT_DETERM_N m o atac) THEN
84.91 - unfold_thms_tac ctxt sel_fs THEN HEADGOAL (rtac refl);
84.92 -
84.93 -(* TODO: reduce code duplication with selector tactic above *)
84.94 -fun mk_primcorec_raw_code_of_ctr_single_tac ctxt distincts discIs splits split_asms m f_ctr =
84.95 - HEADGOAL (REPEAT o (resolve_tac split_connectI ORELSE' split_tac (split_if :: splits))) THEN
84.96 - mk_primcorec_prelude ctxt [] (f_ctr RS trans) THEN
84.97 - HEADGOAL ((REPEAT_DETERM_N m o mk_primcorec_assumption_tac ctxt discIs) THEN'
84.98 - SELECT_GOAL (SOLVE (HEADGOAL (REPEAT_DETERM o
84.99 - (rtac refl ORELSE' atac ORELSE'
84.100 - resolve_tac split_connectI ORELSE'
84.101 - Splitter.split_asm_tac (split_if_asm :: split_asms) ORELSE'
84.102 - Splitter.split_tac (split_if :: splits) ORELSE'
84.103 - mk_primcorec_assumption_tac ctxt discIs ORELSE'
84.104 - eresolve_tac (map (fn thm => thm RS neq_eq_eq_contradict) distincts) THEN' atac ORELSE'
84.105 - (TRY o dresolve_tac discIs) THEN' etac notE THEN' atac)))));
84.106 -
84.107 -fun mk_primcorec_raw_code_of_ctr_tac ctxt distincts discIs splits split_asms ms ctr_thms =
84.108 - EVERY (map2 (mk_primcorec_raw_code_of_ctr_single_tac ctxt distincts discIs splits split_asms)
84.109 - ms ctr_thms);
84.110 -
84.111 -fun mk_primcorec_code_of_raw_code_tac splits raw =
84.112 - HEADGOAL (rtac raw ORELSE' rtac (raw RS trans) THEN' REPEAT_DETERM o
84.113 - (rtac refl ORELSE'
84.114 - (TRY o rtac sym) THEN' atac ORELSE'
84.115 - resolve_tac split_connectI ORELSE'
84.116 - Splitter.split_tac (split_if :: splits) ORELSE'
84.117 - etac notE THEN' atac));
84.118 -
84.119 -end;
85.1 --- a/src/HOL/BNF/Tools/bnf_fp_rec_sugar_util.ML Thu Dec 05 17:52:12 2013 +0100
85.2 +++ b/src/HOL/BNF/Tools/bnf_fp_rec_sugar_util.ML Thu Dec 05 17:58:03 2013 +0100
85.3 @@ -8,616 +8,60 @@
85.4
85.5 signature BNF_FP_REC_SUGAR_UTIL =
85.6 sig
85.7 - datatype rec_call =
85.8 - No_Rec of int |
85.9 - Direct_Rec of int (*before*) * int (*after*) |
85.10 - Indirect_Rec of int
85.11 + val indexed: 'a list -> int -> int list * int
85.12 + val indexedd: 'a list list -> int -> int list list * int
85.13 + val indexeddd: 'a list list list -> int -> int list list list * int
85.14 + val indexedddd: 'a list list list list -> int -> int list list list list * int
85.15 + val find_index_eq: ''a list -> ''a -> int
85.16 + val finds: ('a * 'b -> bool) -> 'a list -> 'b list -> ('a * 'b list) list * 'b list
85.17
85.18 - datatype corec_call =
85.19 - Dummy_No_Corec of int |
85.20 - No_Corec of int |
85.21 - Direct_Corec of int (*stop?*) * int (*end*) * int (*continue*) |
85.22 - Indirect_Corec of int
85.23 + val drop_All: term -> term
85.24
85.25 - type rec_ctr_spec =
85.26 - {ctr: term,
85.27 - offset: int,
85.28 - calls: rec_call list,
85.29 - rec_thm: thm}
85.30 + val mk_partial_compN: int -> typ -> term -> term
85.31 + val mk_partial_comp: typ -> typ -> term -> term
85.32 + val mk_compN: int -> typ list -> term * term -> term
85.33 + val mk_comp: typ list -> term * term -> term
85.34
85.35 - type corec_ctr_spec =
85.36 - {ctr: term,
85.37 - disc: term,
85.38 - sels: term list,
85.39 - pred: int option,
85.40 - calls: corec_call list,
85.41 - discI: thm,
85.42 - sel_thms: thm list,
85.43 - collapse: thm,
85.44 - corec_thm: thm,
85.45 - disc_corec: thm,
85.46 - sel_corecs: thm list}
85.47 -
85.48 - type rec_spec =
85.49 - {recx: term,
85.50 - nested_map_idents: thm list,
85.51 - nested_map_comps: thm list,
85.52 - ctr_specs: rec_ctr_spec list}
85.53 -
85.54 - type corec_spec =
85.55 - {corec: term,
85.56 - nested_maps: thm list,
85.57 - nested_map_idents: thm list,
85.58 - nested_map_comps: thm list,
85.59 - ctr_specs: corec_ctr_spec list}
85.60 -
85.61 - val s_not: term -> term
85.62 - val mk_conjs: term list -> term
85.63 - val mk_disjs: term list -> term
85.64 - val s_not_disj: term -> term list
85.65 - val negate_conj: term list -> term list
85.66 - val negate_disj: term list -> term list
85.67 -
85.68 - val massage_indirect_rec_call: Proof.context -> (term -> bool) -> (typ -> typ -> term -> term) ->
85.69 - typ list -> term -> term -> term -> term
85.70 - val massage_direct_corec_call: Proof.context -> (term -> bool) -> (typ list -> term -> term) ->
85.71 - typ list -> term -> term
85.72 - val massage_indirect_corec_call: Proof.context -> (term -> bool) ->
85.73 - (typ list -> typ -> typ -> term -> term) -> typ list -> typ -> term -> term
85.74 - val expand_corec_code_rhs: Proof.context -> (term -> bool) -> typ list -> term -> term
85.75 - val massage_corec_code_rhs: Proof.context -> (typ list -> term -> term list -> term) ->
85.76 - typ list -> term -> term
85.77 - val fold_rev_corec_code_rhs: Proof.context -> (term list -> term -> term list -> 'a -> 'a) ->
85.78 - typ list -> term -> 'a -> 'a
85.79 - val case_thms_of_term: Proof.context -> typ list -> term ->
85.80 - thm list * thm list * thm list * thm list
85.81 -
85.82 - val rec_specs_of: binding list -> typ list -> typ list -> (term -> int list) ->
85.83 - ((term * term list list) list) list -> local_theory ->
85.84 - (bool * rec_spec list * typ list * thm * thm list) * local_theory
85.85 - val corec_specs_of: binding list -> typ list -> typ list -> (term -> int list) ->
85.86 - ((term * term list list) list) list -> local_theory ->
85.87 - (bool * corec_spec list * typ list * thm * thm * thm list * thm list) * local_theory
85.88 + val get_indices: ((binding * typ) * 'a) list -> term -> int list
85.89 end;
85.90
85.91 structure BNF_FP_Rec_Sugar_Util : BNF_FP_REC_SUGAR_UTIL =
85.92 struct
85.93
85.94 -open Ctr_Sugar
85.95 -open BNF_Util
85.96 -open BNF_Def
85.97 -open BNF_FP_Util
85.98 -open BNF_FP_Def_Sugar
85.99 -open BNF_FP_N2M_Sugar
85.100 -
85.101 -datatype rec_call =
85.102 - No_Rec of int |
85.103 - Direct_Rec of int * int |
85.104 - Indirect_Rec of int;
85.105 -
85.106 -datatype corec_call =
85.107 - Dummy_No_Corec of int |
85.108 - No_Corec of int |
85.109 - Direct_Corec of int * int * int |
85.110 - Indirect_Corec of int;
85.111 -
85.112 -type rec_ctr_spec =
85.113 - {ctr: term,
85.114 - offset: int,
85.115 - calls: rec_call list,
85.116 - rec_thm: thm};
85.117 -
85.118 -type corec_ctr_spec =
85.119 - {ctr: term,
85.120 - disc: term,
85.121 - sels: term list,
85.122 - pred: int option,
85.123 - calls: corec_call list,
85.124 - discI: thm,
85.125 - sel_thms: thm list,
85.126 - collapse: thm,
85.127 - corec_thm: thm,
85.128 - disc_corec: thm,
85.129 - sel_corecs: thm list};
85.130 -
85.131 -type rec_spec =
85.132 - {recx: term,
85.133 - nested_map_idents: thm list,
85.134 - nested_map_comps: thm list,
85.135 - ctr_specs: rec_ctr_spec list};
85.136 -
85.137 -type corec_spec =
85.138 - {corec: term,
85.139 - nested_maps: thm list,
85.140 - nested_map_idents: thm list,
85.141 - nested_map_comps: thm list,
85.142 - ctr_specs: corec_ctr_spec list};
85.143 -
85.144 -val id_def = @{thm id_def};
85.145 -
85.146 -exception AINT_NO_MAP of term;
85.147 -
85.148 -fun ill_formed_rec_call ctxt t =
85.149 - error ("Ill-formed recursive call: " ^ quote (Syntax.string_of_term ctxt t));
85.150 -fun ill_formed_corec_call ctxt t =
85.151 - error ("Ill-formed corecursive call: " ^ quote (Syntax.string_of_term ctxt t));
85.152 -fun invalid_map ctxt t =
85.153 - error ("Invalid map function in " ^ quote (Syntax.string_of_term ctxt t));
85.154 -fun unexpected_rec_call ctxt t =
85.155 - error ("Unexpected recursive call: " ^ quote (Syntax.string_of_term ctxt t));
85.156 -fun unexpected_corec_call ctxt t =
85.157 - error ("Unexpected corecursive call: " ^ quote (Syntax.string_of_term ctxt t));
85.158 -
85.159 -fun s_not @{const True} = @{const False}
85.160 - | s_not @{const False} = @{const True}
85.161 - | s_not (@{const Not} $ t) = t
85.162 - | s_not t = HOLogic.mk_not t
85.163 -
85.164 -val mk_conjs = try (foldr1 HOLogic.mk_conj) #> the_default @{const True};
85.165 -val mk_disjs = try (foldr1 HOLogic.mk_disj) #> the_default @{const False};
85.166 -
85.167 -val s_not_disj = map s_not o HOLogic.disjuncts;
85.168 -
85.169 -fun negate_conj [t] = s_not_disj t
85.170 - | negate_conj ts = [mk_disjs (map s_not ts)];
85.171 -
85.172 -fun negate_disj [t] = s_not_disj t
85.173 - | negate_disj ts = [mk_disjs (map (mk_conjs o s_not_disj) ts)];
85.174 -
85.175 -fun factor_out_types ctxt massage destU U T =
85.176 - (case try destU U of
85.177 - SOME (U1, U2) => if U1 = T then massage T U2 else invalid_map ctxt
85.178 - | NONE => invalid_map ctxt);
85.179 -
85.180 -fun map_flattened_map_args ctxt s map_args fs =
85.181 - let
85.182 - val flat_fs = flatten_type_args_of_bnf (the (bnf_of ctxt s)) Term.dummy fs;
85.183 - val flat_fs' = map_args flat_fs;
85.184 - in
85.185 - permute_like (op aconv) flat_fs fs flat_fs'
85.186 - end;
85.187 -
85.188 -fun massage_indirect_rec_call ctxt has_call raw_massage_fun bound_Ts y y' =
85.189 - let
85.190 - val typof = curry fastype_of1 bound_Ts;
85.191 - val build_map_fst = build_map ctxt (fst_const o fst);
85.192 -
85.193 - val yT = typof y;
85.194 - val yU = typof y';
85.195 -
85.196 - fun y_of_y' () = build_map_fst (yU, yT) $ y';
85.197 - val elim_y = Term.map_aterms (fn t => if t = y then y_of_y' () else t);
85.198 -
85.199 - fun massage_direct_fun U T t =
85.200 - if has_call t then factor_out_types ctxt raw_massage_fun HOLogic.dest_prodT U T t
85.201 - else HOLogic.mk_comp (t, build_map_fst (U, T));
85.202 -
85.203 - fun massage_map (Type (_, Us)) (Type (s, Ts)) t =
85.204 - (case try (dest_map ctxt s) t of
85.205 - SOME (map0, fs) =>
85.206 - let
85.207 - val Type (_, ran_Ts) = range_type (typof t);
85.208 - val map' = mk_map (length fs) Us ran_Ts map0;
85.209 - val fs' = map_flattened_map_args ctxt s (map3 massage_map_or_map_arg Us Ts) fs;
85.210 - in
85.211 - Term.list_comb (map', fs')
85.212 - end
85.213 - | NONE => raise AINT_NO_MAP t)
85.214 - | massage_map _ _ t = raise AINT_NO_MAP t
85.215 - and massage_map_or_map_arg U T t =
85.216 - if T = U then
85.217 - if has_call t then unexpected_rec_call ctxt t else t
85.218 - else
85.219 - massage_map U T t
85.220 - handle AINT_NO_MAP _ => massage_direct_fun U T t;
85.221 -
85.222 - fun massage_call (t as t1 $ t2) =
85.223 - if t2 = y then
85.224 - massage_map yU yT (elim_y t1) $ y'
85.225 - handle AINT_NO_MAP t' => invalid_map ctxt t'
85.226 - else
85.227 - ill_formed_rec_call ctxt t
85.228 - | massage_call t = if t = y then y_of_y' () else ill_formed_rec_call ctxt t;
85.229 - in
85.230 - massage_call
85.231 - end;
85.232 -
85.233 -fun fold_rev_let_if_case ctxt f bound_Ts t =
85.234 - let
85.235 - val thy = Proof_Context.theory_of ctxt;
85.236 -
85.237 - fun fld conds t =
85.238 - (case Term.strip_comb t of
85.239 - (Const (@{const_name Let}, _), [arg1, arg2]) => fld conds (betapply (arg2, arg1))
85.240 - | (Const (@{const_name If}, _), [cond, then_branch, else_branch]) =>
85.241 - fld (conds @ HOLogic.conjuncts cond) then_branch
85.242 - o fld (conds @ s_not_disj cond) else_branch
85.243 - | (Const (c, _), args as _ :: _ :: _) =>
85.244 - let val n = num_binder_types (Sign.the_const_type thy c) - 1 in
85.245 - if n >= 0 andalso n < length args then
85.246 - (case fastype_of1 (bound_Ts, nth args n) of
85.247 - Type (s, Ts) =>
85.248 - (case dest_case ctxt s Ts t of
85.249 - NONE => apsnd (f conds t)
85.250 - | SOME (conds', branches) =>
85.251 - apfst (cons s) o fold_rev (uncurry fld)
85.252 - (map (append conds o HOLogic.conjuncts) conds' ~~ branches))
85.253 - | _ => apsnd (f conds t))
85.254 - else
85.255 - apsnd (f conds t)
85.256 - end
85.257 - | _ => apsnd (f conds t))
85.258 - in
85.259 - fld [] t o pair []
85.260 - end;
85.261 -
85.262 -fun case_of ctxt = ctr_sugar_of ctxt #> Option.map (fst o dest_Const o #casex);
85.263 -
85.264 -fun massage_let_if_case ctxt has_call massage_leaf =
85.265 - let
85.266 - val thy = Proof_Context.theory_of ctxt;
85.267 -
85.268 - fun check_no_call t = if has_call t then unexpected_corec_call ctxt t else ();
85.269 -
85.270 - fun massage_abs bound_Ts (Abs (s, T, t)) = Abs (s, T, massage_abs (T :: bound_Ts) t)
85.271 - | massage_abs bound_Ts t = massage_rec bound_Ts t
85.272 - and massage_rec bound_Ts t =
85.273 - let val typof = curry fastype_of1 bound_Ts in
85.274 - (case Term.strip_comb t of
85.275 - (Const (@{const_name Let}, _), [arg1, arg2]) =>
85.276 - massage_rec bound_Ts (betapply (arg2, arg1))
85.277 - | (Const (@{const_name If}, _), obj :: (branches as [_, _])) =>
85.278 - let val branches' = map (massage_rec bound_Ts) branches in
85.279 - Term.list_comb (If_const (typof (hd branches')) $ tap check_no_call obj, branches')
85.280 - end
85.281 - | (Const (c, _), args as _ :: _ :: _) =>
85.282 - let
85.283 - val gen_T = Sign.the_const_type thy c;
85.284 - val (gen_branch_Ts, gen_body_fun_T) = strip_fun_type gen_T;
85.285 - val n = length gen_branch_Ts;
85.286 - in
85.287 - if n < length args then
85.288 - (case gen_body_fun_T of
85.289 - Type (_, [Type (T_name, _), _]) =>
85.290 - if case_of ctxt T_name = SOME c then
85.291 - let
85.292 - val (branches, obj_leftovers) = chop n args;
85.293 - val branches' = map (massage_abs bound_Ts o Envir.eta_long bound_Ts) branches;
85.294 - val branch_Ts' = map typof branches';
85.295 - val casex' = Const (c, branch_Ts' ---> map typof obj_leftovers --->
85.296 - snd (strip_typeN (num_binder_types (hd gen_branch_Ts)) (hd branch_Ts')));
85.297 - in
85.298 - Term.list_comb (casex', branches' @ tap (List.app check_no_call) obj_leftovers)
85.299 - end
85.300 - else
85.301 - massage_leaf bound_Ts t
85.302 - | _ => massage_leaf bound_Ts t)
85.303 - else
85.304 - massage_leaf bound_Ts t
85.305 - end
85.306 - | _ => massage_leaf bound_Ts t)
85.307 - end
85.308 - in
85.309 - massage_rec
85.310 - end;
85.311 -
85.312 -val massage_direct_corec_call = massage_let_if_case;
85.313 -
85.314 -fun curried_type (Type (@{type_name fun}, [Type (@{type_name prod}, Ts), T])) = Ts ---> T;
85.315 -
85.316 -fun massage_indirect_corec_call ctxt has_call raw_massage_call bound_Ts U t =
85.317 - let
85.318 - val build_map_Inl = build_map ctxt (uncurry Inl_const o dest_sumT o snd)
85.319 -
85.320 - fun massage_direct_call bound_Ts U T t =
85.321 - if has_call t then factor_out_types ctxt (raw_massage_call bound_Ts) dest_sumT U T t
85.322 - else build_map_Inl (T, U) $ t;
85.323 -
85.324 - fun massage_direct_fun bound_Ts U T t =
85.325 - let
85.326 - val var = Var ((Name.uu, Term.maxidx_of_term t + 1),
85.327 - domain_type (fastype_of1 (bound_Ts, t)));
85.328 - in
85.329 - Term.lambda var (massage_direct_call bound_Ts U T (t $ var))
85.330 - end;
85.331 -
85.332 - fun massage_map bound_Ts (Type (_, Us)) (Type (s, Ts)) t =
85.333 - (case try (dest_map ctxt s) t of
85.334 - SOME (map0, fs) =>
85.335 - let
85.336 - val Type (_, dom_Ts) = domain_type (fastype_of1 (bound_Ts, t));
85.337 - val map' = mk_map (length fs) dom_Ts Us map0;
85.338 - val fs' =
85.339 - map_flattened_map_args ctxt s (map3 (massage_map_or_map_arg bound_Ts) Us Ts) fs;
85.340 - in
85.341 - Term.list_comb (map', fs')
85.342 - end
85.343 - | NONE => raise AINT_NO_MAP t)
85.344 - | massage_map _ _ _ t = raise AINT_NO_MAP t
85.345 - and massage_map_or_map_arg bound_Ts U T t =
85.346 - if T = U then
85.347 - if has_call t then unexpected_corec_call ctxt t else t
85.348 - else
85.349 - massage_map bound_Ts U T t
85.350 - handle AINT_NO_MAP _ => massage_direct_fun bound_Ts U T t;
85.351 -
85.352 - fun massage_call bound_Ts U T =
85.353 - massage_let_if_case ctxt has_call (fn bound_Ts => fn t =>
85.354 - if has_call t then
85.355 - (case U of
85.356 - Type (s, Us) =>
85.357 - (case try (dest_ctr ctxt s) t of
85.358 - SOME (f, args) =>
85.359 - let
85.360 - val typof = curry fastype_of1 bound_Ts;
85.361 - val f' = mk_ctr Us f
85.362 - val f'_T = typof f';
85.363 - val arg_Ts = map typof args;
85.364 - in
85.365 - Term.list_comb (f', map3 (massage_call bound_Ts) (binder_types f'_T) arg_Ts args)
85.366 - end
85.367 - | NONE =>
85.368 - (case t of
85.369 - Const (@{const_name prod_case}, _) $ t' =>
85.370 - let
85.371 - val U' = curried_type U;
85.372 - val T' = curried_type T;
85.373 - in
85.374 - Const (@{const_name prod_case}, U' --> U) $ massage_call bound_Ts U' T' t'
85.375 - end
85.376 - | t1 $ t2 =>
85.377 - (if has_call t2 then
85.378 - massage_direct_call bound_Ts U T t
85.379 - else
85.380 - massage_map bound_Ts U T t1 $ t2
85.381 - handle AINT_NO_MAP _ => massage_direct_call bound_Ts U T t)
85.382 - | Abs (s, T', t') =>
85.383 - Abs (s, T', massage_call (T' :: bound_Ts) (range_type U) (range_type T) t')
85.384 - | _ => massage_direct_call bound_Ts U T t))
85.385 - | _ => ill_formed_corec_call ctxt t)
85.386 - else
85.387 - build_map_Inl (T, U) $ t) bound_Ts;
85.388 -
85.389 - val T = fastype_of1 (bound_Ts, t);
85.390 - in
85.391 - if has_call t then massage_call bound_Ts U T t else build_map_Inl (T, U) $ t
85.392 - end;
85.393 -
85.394 -fun expand_ctr_term ctxt s Ts t =
85.395 - (case ctr_sugar_of ctxt s of
85.396 - SOME {ctrs, casex, ...} =>
85.397 - Term.list_comb (mk_case Ts (Type (s, Ts)) casex, map (mk_ctr Ts) ctrs) $ t
85.398 - | NONE => raise Fail "expand_ctr_term");
85.399 -
85.400 -fun expand_corec_code_rhs ctxt has_call bound_Ts t =
85.401 - (case fastype_of1 (bound_Ts, t) of
85.402 - Type (s, Ts) =>
85.403 - massage_let_if_case ctxt has_call (fn _ => fn t =>
85.404 - if can (dest_ctr ctxt s) t then t else expand_ctr_term ctxt s Ts t) bound_Ts t
85.405 - | _ => raise Fail "expand_corec_code_rhs");
85.406 -
85.407 -fun massage_corec_code_rhs ctxt massage_ctr =
85.408 - massage_let_if_case ctxt (K false)
85.409 - (fn bound_Ts => uncurry (massage_ctr bound_Ts) o Term.strip_comb);
85.410 -
85.411 -fun fold_rev_corec_code_rhs ctxt f =
85.412 - snd ooo fold_rev_let_if_case ctxt (fn conds => uncurry (f conds) o Term.strip_comb);
85.413 -
85.414 -fun case_thms_of_term ctxt bound_Ts t =
85.415 - let
85.416 - val (caseT_names, _) = fold_rev_let_if_case ctxt (K (K I)) bound_Ts t ();
85.417 - val ctr_sugars = map (the o ctr_sugar_of ctxt) caseT_names;
85.418 - in
85.419 - (maps #distincts ctr_sugars, maps #discIs ctr_sugars, maps #sel_splits ctr_sugars,
85.420 - maps #sel_split_asms ctr_sugars)
85.421 - end;
85.422 -
85.423 -fun indexed xs h = let val h' = h + length xs in (h upto h' - 1, h') end;
85.424 +fun indexe _ h = (h, h + 1);
85.425 +fun indexed xs = fold_map indexe xs;
85.426 fun indexedd xss = fold_map indexed xss;
85.427 fun indexeddd xsss = fold_map indexedd xsss;
85.428 fun indexedddd xssss = fold_map indexeddd xssss;
85.429
85.430 fun find_index_eq hs h = find_index (curry (op =) h) hs;
85.431
85.432 -(*FIXME: remove special cases for products and sum once they are registered as datatypes*)
85.433 -fun map_thms_of_typ ctxt (Type (s, _)) =
85.434 - if s = @{type_name prod} then
85.435 - @{thms map_pair_simp}
85.436 - else if s = @{type_name sum} then
85.437 - @{thms sum_map.simps}
85.438 - else
85.439 - (case fp_sugar_of ctxt s of
85.440 - SOME {index, mapss, ...} => nth mapss index
85.441 - | NONE => [])
85.442 - | map_thms_of_typ _ _ = [];
85.443 +fun finds eq = fold_map (fn x => List.partition (curry eq x) #>> pair x);
85.444
85.445 -fun rec_specs_of bs arg_Ts res_Ts get_indices callssss0 lthy =
85.446 - let
85.447 - val thy = Proof_Context.theory_of lthy;
85.448 +fun drop_All t =
85.449 + subst_bounds (strip_qnt_vars @{const_name all} t |> map Free |> rev,
85.450 + strip_qnt_body @{const_name all} t);
85.451
85.452 - val ((missing_arg_Ts, perm0_kks,
85.453 - fp_sugars as {nested_bnfs, fp_res = {xtor_co_iterss = ctor_iters1 :: _, ...},
85.454 - co_inducts = [induct_thm], ...} :: _, (lfp_sugar_thms, _)), lthy') =
85.455 - nested_to_mutual_fps Least_FP bs arg_Ts get_indices callssss0 lthy;
85.456 -
85.457 - val perm_fp_sugars = sort (int_ord o pairself #index) fp_sugars;
85.458 -
85.459 - val indices = map #index fp_sugars;
85.460 - val perm_indices = map #index perm_fp_sugars;
85.461 -
85.462 - val perm_ctrss = map (#ctrs o of_fp_sugar #ctr_sugars) perm_fp_sugars;
85.463 - val perm_ctr_Tsss = map (map (binder_types o fastype_of)) perm_ctrss;
85.464 - val perm_fpTs = map (body_type o fastype_of o hd) perm_ctrss;
85.465 -
85.466 - val nn0 = length arg_Ts;
85.467 - val nn = length perm_fpTs;
85.468 - val kks = 0 upto nn - 1;
85.469 - val perm_ns = map length perm_ctr_Tsss;
85.470 - val perm_mss = map (map length) perm_ctr_Tsss;
85.471 -
85.472 - val perm_Cs = map (body_type o fastype_of o co_rec_of o of_fp_sugar (#xtor_co_iterss o #fp_res))
85.473 - perm_fp_sugars;
85.474 - val perm_fun_arg_Tssss =
85.475 - mk_iter_fun_arg_types perm_ctr_Tsss perm_ns perm_mss (co_rec_of ctor_iters1);
85.476 -
85.477 - fun unpermute0 perm0_xs = permute_like (op =) perm0_kks kks perm0_xs;
85.478 - fun unpermute perm_xs = permute_like (op =) perm_indices indices perm_xs;
85.479 -
85.480 - val induct_thms = unpermute0 (conj_dests nn induct_thm);
85.481 -
85.482 - val fpTs = unpermute perm_fpTs;
85.483 - val Cs = unpermute perm_Cs;
85.484 -
85.485 - val As_rho = tvar_subst thy (take nn0 fpTs) arg_Ts;
85.486 - val Cs_rho = map (fst o dest_TVar) Cs ~~ pad_list HOLogic.unitT nn res_Ts;
85.487 -
85.488 - val substA = Term.subst_TVars As_rho;
85.489 - val substAT = Term.typ_subst_TVars As_rho;
85.490 - val substCT = Term.typ_subst_TVars Cs_rho;
85.491 -
85.492 - val perm_Cs' = map substCT perm_Cs;
85.493 -
85.494 - fun offset_of_ctr 0 _ = 0
85.495 - | offset_of_ctr n (({ctrs, ...} : ctr_sugar) :: ctr_sugars) =
85.496 - length ctrs + offset_of_ctr (n - 1) ctr_sugars;
85.497 -
85.498 - fun call_of [i] [T] = (if exists_subtype_in Cs T then Indirect_Rec else No_Rec) i
85.499 - | call_of [i, i'] _ = Direct_Rec (i, i');
85.500 -
85.501 - fun mk_ctr_spec ctr offset fun_arg_Tss rec_thm =
85.502 - let
85.503 - val (fun_arg_hss, _) = indexedd fun_arg_Tss 0;
85.504 - val fun_arg_hs = flat_rec_arg_args fun_arg_hss;
85.505 - val fun_arg_iss = map (map (find_index_eq fun_arg_hs)) fun_arg_hss;
85.506 - in
85.507 - {ctr = substA ctr, offset = offset, calls = map2 call_of fun_arg_iss fun_arg_Tss,
85.508 - rec_thm = rec_thm}
85.509 - end;
85.510 -
85.511 - fun mk_ctr_specs index (ctr_sugars : ctr_sugar list) iter_thmsss =
85.512 - let
85.513 - val ctrs = #ctrs (nth ctr_sugars index);
85.514 - val rec_thmss = co_rec_of (nth iter_thmsss index);
85.515 - val k = offset_of_ctr index ctr_sugars;
85.516 - val n = length ctrs;
85.517 - in
85.518 - map4 mk_ctr_spec ctrs (k upto k + n - 1) (nth perm_fun_arg_Tssss index) rec_thmss
85.519 - end;
85.520 -
85.521 - fun mk_spec ({T, index, ctr_sugars, co_iterss = iterss, co_iter_thmsss = iter_thmsss, ...}
85.522 - : fp_sugar) =
85.523 - {recx = mk_co_iter thy Least_FP (substAT T) perm_Cs' (co_rec_of (nth iterss index)),
85.524 - nested_map_idents = map (unfold_thms lthy [id_def] o map_id0_of_bnf) nested_bnfs,
85.525 - nested_map_comps = map map_comp_of_bnf nested_bnfs,
85.526 - ctr_specs = mk_ctr_specs index ctr_sugars iter_thmsss};
85.527 - in
85.528 - ((is_some lfp_sugar_thms, map mk_spec fp_sugars, missing_arg_Ts, induct_thm, induct_thms),
85.529 - lthy')
85.530 +fun mk_partial_comp gT fT g =
85.531 + let val T = domain_type fT --> range_type gT in
85.532 + Const (@{const_name Fun.comp}, gT --> fT --> T) $ g
85.533 end;
85.534
85.535 -fun corec_specs_of bs arg_Ts res_Ts get_indices callssss0 lthy =
85.536 - let
85.537 - val thy = Proof_Context.theory_of lthy;
85.538 +fun mk_partial_compN 0 _ g = g
85.539 + | mk_partial_compN n fT g =
85.540 + let val g' = mk_partial_compN (n - 1) (range_type fT) g in
85.541 + mk_partial_comp (fastype_of g') fT g'
85.542 + end;
85.543
85.544 - val ((missing_res_Ts, perm0_kks,
85.545 - fp_sugars as {nested_bnfs, fp_res = {xtor_co_iterss = dtor_coiters1 :: _, ...},
85.546 - co_inducts = coinduct_thms, ...} :: _, (_, gfp_sugar_thms)), lthy') =
85.547 - nested_to_mutual_fps Greatest_FP bs res_Ts get_indices callssss0 lthy;
85.548 -
85.549 - val perm_fp_sugars = sort (int_ord o pairself #index) fp_sugars;
85.550 -
85.551 - val indices = map #index fp_sugars;
85.552 - val perm_indices = map #index perm_fp_sugars;
85.553 -
85.554 - val perm_ctrss = map (#ctrs o of_fp_sugar #ctr_sugars) perm_fp_sugars;
85.555 - val perm_ctr_Tsss = map (map (binder_types o fastype_of)) perm_ctrss;
85.556 - val perm_fpTs = map (body_type o fastype_of o hd) perm_ctrss;
85.557 -
85.558 - val nn0 = length res_Ts;
85.559 - val nn = length perm_fpTs;
85.560 - val kks = 0 upto nn - 1;
85.561 - val perm_ns = map length perm_ctr_Tsss;
85.562 -
85.563 - val perm_Cs = map (domain_type o body_fun_type o fastype_of o co_rec_of o
85.564 - of_fp_sugar (#xtor_co_iterss o #fp_res)) perm_fp_sugars;
85.565 - val (perm_p_Tss, (perm_q_Tssss, _, perm_f_Tssss, _)) =
85.566 - mk_coiter_fun_arg_types perm_ctr_Tsss perm_Cs perm_ns (co_rec_of dtor_coiters1);
85.567 -
85.568 - val (perm_p_hss, h) = indexedd perm_p_Tss 0;
85.569 - val (perm_q_hssss, h') = indexedddd perm_q_Tssss h;
85.570 - val (perm_f_hssss, _) = indexedddd perm_f_Tssss h';
85.571 -
85.572 - val fun_arg_hs =
85.573 - flat (map3 flat_corec_preds_predsss_gettersss perm_p_hss perm_q_hssss perm_f_hssss);
85.574 -
85.575 - fun unpermute0 perm0_xs = permute_like (op =) perm0_kks kks perm0_xs;
85.576 - fun unpermute perm_xs = permute_like (op =) perm_indices indices perm_xs;
85.577 -
85.578 - val coinduct_thmss = map (unpermute0 o conj_dests nn) coinduct_thms;
85.579 -
85.580 - val p_iss = map (map (find_index_eq fun_arg_hs)) (unpermute perm_p_hss);
85.581 - val q_issss = map (map (map (map (find_index_eq fun_arg_hs)))) (unpermute perm_q_hssss);
85.582 - val f_issss = map (map (map (map (find_index_eq fun_arg_hs)))) (unpermute perm_f_hssss);
85.583 -
85.584 - val f_Tssss = unpermute perm_f_Tssss;
85.585 - val fpTs = unpermute perm_fpTs;
85.586 - val Cs = unpermute perm_Cs;
85.587 -
85.588 - val As_rho = tvar_subst thy (take nn0 fpTs) res_Ts;
85.589 - val Cs_rho = map (fst o dest_TVar) Cs ~~ pad_list HOLogic.unitT nn arg_Ts;
85.590 -
85.591 - val substA = Term.subst_TVars As_rho;
85.592 - val substAT = Term.typ_subst_TVars As_rho;
85.593 - val substCT = Term.typ_subst_TVars Cs_rho;
85.594 -
85.595 - val perm_Cs' = map substCT perm_Cs;
85.596 -
85.597 - fun call_of nullary [] [g_i] [Type (@{type_name fun}, [_, T])] =
85.598 - (if exists_subtype_in Cs T then Indirect_Corec
85.599 - else if nullary then Dummy_No_Corec
85.600 - else No_Corec) g_i
85.601 - | call_of _ [q_i] [g_i, g_i'] _ = Direct_Corec (q_i, g_i, g_i');
85.602 -
85.603 - fun mk_ctr_spec ctr disc sels p_ho q_iss f_iss f_Tss discI sel_thms collapse corec_thm
85.604 - disc_corec sel_corecs =
85.605 - let val nullary = not (can dest_funT (fastype_of ctr)) in
85.606 - {ctr = substA ctr, disc = substA disc, sels = map substA sels, pred = p_ho,
85.607 - calls = map3 (call_of nullary) q_iss f_iss f_Tss, discI = discI, sel_thms = sel_thms,
85.608 - collapse = collapse, corec_thm = corec_thm, disc_corec = disc_corec,
85.609 - sel_corecs = sel_corecs}
85.610 - end;
85.611 -
85.612 - fun mk_ctr_specs index (ctr_sugars : ctr_sugar list) p_is q_isss f_isss f_Tsss
85.613 - coiter_thmsss disc_coitersss sel_coiterssss =
85.614 - let
85.615 - val ctrs = #ctrs (nth ctr_sugars index);
85.616 - val discs = #discs (nth ctr_sugars index);
85.617 - val selss = #selss (nth ctr_sugars index);
85.618 - val p_ios = map SOME p_is @ [NONE];
85.619 - val discIs = #discIs (nth ctr_sugars index);
85.620 - val sel_thmss = #sel_thmss (nth ctr_sugars index);
85.621 - val collapses = #collapses (nth ctr_sugars index);
85.622 - val corec_thms = co_rec_of (nth coiter_thmsss index);
85.623 - val disc_corecs = co_rec_of (nth disc_coitersss index);
85.624 - val sel_corecss = co_rec_of (nth sel_coiterssss index);
85.625 - in
85.626 - map13 mk_ctr_spec ctrs discs selss p_ios q_isss f_isss f_Tsss discIs sel_thmss collapses
85.627 - corec_thms disc_corecs sel_corecss
85.628 - end;
85.629 -
85.630 - fun mk_spec ({T, index, ctr_sugars, co_iterss = coiterss, co_iter_thmsss = coiter_thmsss,
85.631 - disc_co_itersss = disc_coitersss, sel_co_iterssss = sel_coiterssss, ...} : fp_sugar)
85.632 - p_is q_isss f_isss f_Tsss =
85.633 - {corec = mk_co_iter thy Greatest_FP (substAT T) perm_Cs' (co_rec_of (nth coiterss index)),
85.634 - nested_maps = maps (map_thms_of_typ lthy o T_of_bnf) nested_bnfs,
85.635 - nested_map_idents = map (unfold_thms lthy [id_def] o map_id0_of_bnf) nested_bnfs,
85.636 - nested_map_comps = map map_comp_of_bnf nested_bnfs,
85.637 - ctr_specs = mk_ctr_specs index ctr_sugars p_is q_isss f_isss f_Tsss coiter_thmsss
85.638 - disc_coitersss sel_coiterssss};
85.639 - in
85.640 - ((is_some gfp_sugar_thms, map5 mk_spec fp_sugars p_iss q_issss f_issss f_Tssss, missing_res_Ts,
85.641 - co_induct_of coinduct_thms, strong_co_induct_of coinduct_thms, co_induct_of coinduct_thmss,
85.642 - strong_co_induct_of coinduct_thmss), lthy')
85.643 +fun mk_compN n bound_Ts (g, f) =
85.644 + let val typof = curry fastype_of1 bound_Ts in
85.645 + mk_partial_compN n (typof f) g $ f
85.646 end;
85.647
85.648 +val mk_comp = mk_compN 1;
85.649 +
85.650 +fun get_indices fixes t = map (fst #>> Binding.name_of #> Free) fixes
85.651 + |> map_index (fn (i, v) => if exists_subterm (equal v) t then SOME i else NONE)
85.652 + |> map_filter I;
85.653 +
85.654 end;
86.1 --- a/src/HOL/BNF/Tools/bnf_gfp.ML Thu Dec 05 17:52:12 2013 +0100
86.2 +++ b/src/HOL/BNF/Tools/bnf_gfp.ML Thu Dec 05 17:58:03 2013 +0100
86.3 @@ -23,7 +23,7 @@
86.4 open BNF_Comp
86.5 open BNF_FP_Util
86.6 open BNF_FP_Def_Sugar
86.7 -open BNF_FP_Rec_Sugar
86.8 +open BNF_GFP_Rec_Sugar
86.9 open BNF_GFP_Util
86.10 open BNF_GFP_Tactics
86.11
86.12 @@ -56,7 +56,7 @@
86.13 ((i, I), nth (nth lwitss i) nwit) :: maps (tree_to_coind_wits lwitss) subtrees;
86.14
86.15 (*all BNFs have the same lives*)
86.16 -fun construct_gfp mixfixes map_bs rel_bs set_bss bs resBs (resDs, Dss) bnfs lthy =
86.17 +fun construct_gfp mixfixes map_bs rel_bs set_bss0 bs resBs (resDs, Dss) bnfs lthy =
86.18 let
86.19 val time = time lthy;
86.20 val timer = time (Timer.startRealTimer ());
86.21 @@ -74,7 +74,7 @@
86.22 val mk_internal_b = Binding.name #> Binding.prefix true b_name #> Binding.conceal;
86.23 fun mk_internal_bs name =
86.24 map (fn b =>
86.25 - Binding.prefix true b_name (Binding.suffix_name ("_" ^ name) b) |> Binding.conceal) bs;
86.26 + Binding.prefix true b_name (Binding.prefix_name (name ^ "_") b) |> Binding.conceal) bs;
86.27 val external_bs = map2 (Binding.prefix false) b_names bs
86.28 |> note_all = false ? map Binding.conceal;
86.29
86.30 @@ -1695,7 +1695,7 @@
86.31 ||>> mk_Frees "s" corec_sTs
86.32 ||>> mk_Frees "P" (map2 mk_pred2T Ts Ts);
86.33
86.34 - fun dtor_bind i = nth external_bs (i - 1) |> Binding.suffix_name ("_" ^ dtorN);
86.35 + fun dtor_bind i = nth external_bs (i - 1) |> Binding.prefix_name (dtorN ^ "_");
86.36 val dtor_name = Binding.name_of o dtor_bind;
86.37 val dtor_def_bind = rpair [] o Binding.conceal o Thm.def_binding o dtor_bind;
86.38
86.39 @@ -1747,7 +1747,7 @@
86.40
86.41 val timer = time (timer "dtor definitions & thms");
86.42
86.43 - fun unfold_bind i = nth external_bs (i - 1) |> Binding.suffix_name ("_" ^ dtor_unfoldN);
86.44 + fun unfold_bind i = nth external_bs (i - 1) |> Binding.prefix_name (dtor_unfoldN ^ "_");
86.45 val unfold_name = Binding.name_of o unfold_bind;
86.46 val unfold_def_bind = rpair [] o Binding.conceal o Thm.def_binding o unfold_bind;
86.47
86.48 @@ -1868,7 +1868,7 @@
86.49 Term.list_comb (mk_map_of_bnf Ds (passiveAs @ Ts) (passiveAs @ FTs) bnf,
86.50 map HOLogic.id_const passiveAs @ dtors)) Dss bnfs;
86.51
86.52 - fun ctor_bind i = nth external_bs (i - 1) |> Binding.suffix_name ("_" ^ ctorN);
86.53 + fun ctor_bind i = nth external_bs (i - 1) |> Binding.prefix_name (ctorN ^ "_");
86.54 val ctor_name = Binding.name_of o ctor_bind;
86.55 val ctor_def_bind = rpair [] o Binding.conceal o Thm.def_binding o ctor_bind;
86.56
86.57 @@ -1939,7 +1939,7 @@
86.58 trans OF [mor RS unique, unfold_dtor]) unfold_unique_mor_thms unfold_dtor_thms
86.59 end;
86.60
86.61 - fun corec_bind i = nth external_bs (i - 1) |> Binding.suffix_name ("_" ^ dtor_corecN);
86.62 + fun corec_bind i = nth external_bs (i - 1) |> Binding.prefix_name (dtor_corecN ^ "_");
86.63 val corec_name = Binding.name_of o corec_bind;
86.64 val corec_def_bind = rpair [] o Binding.conceal o Thm.def_binding o corec_bind;
86.65
86.66 @@ -2673,12 +2673,16 @@
86.67
86.68 val wit_tac = mk_wit_tac n dtor_ctor_thms (flat dtor_set_thmss) (maps wit_thms_of_bnf bnfs);
86.69
86.70 + val set_bss =
86.71 + map (flat o map2 (fn B => fn b =>
86.72 + if member (op =) resDs (TFree B) then [] else [b]) resBs) set_bss0;
86.73 +
86.74 val (Jbnfs, lthy) =
86.75 fold_map9 (fn tacs => fn b => fn map_b => fn rel_b => fn set_bs => fn mapx => fn sets =>
86.76 fn T => fn (thms, wits) => fn lthy =>
86.77 bnf_def Dont_Inline (user_policy Note_Some) I tacs (wit_tac thms) (SOME deads) map_b
86.78 rel_b set_bs
86.79 - (((((b, fold_rev Term.absfree fs' mapx), sets), absdummy T bd), wits), NONE) lthy
86.80 + ((((((b, T), fold_rev Term.absfree fs' mapx), sets), bd), wits), NONE) lthy
86.81 |> register_bnf (Local_Theory.full_name lthy b))
86.82 tacss bs map_bs rel_bs set_bss fs_maps setss_by_bnf Ts all_witss lthy;
86.83
86.84 @@ -2744,8 +2748,8 @@
86.85 ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]))
86.86 bs thmss)
86.87 in
86.88 - (timer, Jbnfs, (folded_dtor_map_o_thms, folded_dtor_map_thms), folded_dtor_set_thmss',
86.89 - dtor_set_induct_thms, dtor_Jrel_thms, Jbnf_common_notes @ Jbnf_notes, lthy)
86.90 + (timer, Jbnfs, (folded_dtor_map_o_thms, folded_dtor_map_thms), folded_dtor_set_thmss',
86.91 + dtor_set_induct_thms, dtor_Jrel_thms, Jbnf_common_notes @ Jbnf_notes, lthy)
86.92 end;
86.93
86.94 val dtor_unfold_o_map_thms = mk_xtor_un_fold_o_map_thms Greatest_FP false m
86.95 @@ -2917,19 +2921,23 @@
86.96 Outer_Syntax.local_theory @{command_spec "codatatype"} "define coinductive datatypes"
86.97 (parse_co_datatype_cmd Greatest_FP construct_gfp);
86.98
86.99 -val option_parser = Parse.group (fn () => "option") (Parse.reserved "sequential" >> K true);
86.100 +val option_parser = Parse.group (fn () => "option")
86.101 + ((Parse.reserved "sequential" >> K Option_Sequential)
86.102 + || (Parse.reserved "exhaustive" >> K Option_Exhaustive))
86.103
86.104 val where_alt_specs_of_parser = Parse.where_ |-- Parse.!!! (Parse.enum1 "|"
86.105 (Parse_Spec.spec -- Scan.option (Parse.reserved "of" |-- Parse.const)));
86.106
86.107 val _ = Outer_Syntax.local_theory_to_proof @{command_spec "primcorecursive"}
86.108 "define primitive corecursive functions"
86.109 - ((Scan.optional (@{keyword "("} |-- Parse.!!! option_parser --| @{keyword ")"}) false) --
86.110 + ((Scan.optional (@{keyword "("} |--
86.111 + Parse.!!! (Parse.list1 option_parser) --| @{keyword ")"}) []) --
86.112 (Parse.fixes -- where_alt_specs_of_parser) >> uncurry add_primcorecursive_cmd);
86.113
86.114 val _ = Outer_Syntax.local_theory @{command_spec "primcorec"}
86.115 "define primitive corecursive functions"
86.116 - ((Scan.optional (@{keyword "("} |-- Parse.!!! option_parser --| @{keyword ")"}) false) --
86.117 + ((Scan.optional (@{keyword "("} |--
86.118 + Parse.!!! (Parse.list1 option_parser) --| @{keyword ")"}) []) --
86.119 (Parse.fixes -- where_alt_specs_of_parser) >> uncurry add_primcorec_cmd);
86.120
86.121 end;
87.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
87.2 +++ b/src/HOL/BNF/Tools/bnf_gfp_rec_sugar.ML Thu Dec 05 17:58:03 2013 +0100
87.3 @@ -0,0 +1,1184 @@
87.4 +(* Title: HOL/BNF/Tools/bnf_gfp_rec_sugar.ML
87.5 + Author: Lorenz Panny, TU Muenchen
87.6 + Author: Jasmin Blanchette, TU Muenchen
87.7 + Copyright 2013
87.8 +
87.9 +Corecursor sugar.
87.10 +*)
87.11 +
87.12 +signature BNF_GFP_REC_SUGAR =
87.13 +sig
87.14 + datatype primcorec_option =
87.15 + Option_Sequential |
87.16 + Option_Exhaustive
87.17 + val add_primcorecursive_cmd: primcorec_option list ->
87.18 + (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list ->
87.19 + Proof.context -> Proof.state
87.20 + val add_primcorec_cmd: primcorec_option list ->
87.21 + (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list ->
87.22 + local_theory -> local_theory
87.23 +end;
87.24 +
87.25 +structure BNF_GFP_Rec_Sugar : BNF_GFP_REC_SUGAR =
87.26 +struct
87.27 +
87.28 +open Ctr_Sugar
87.29 +open BNF_Util
87.30 +open BNF_Def
87.31 +open BNF_FP_Util
87.32 +open BNF_FP_Def_Sugar
87.33 +open BNF_FP_N2M_Sugar
87.34 +open BNF_FP_Rec_Sugar_Util
87.35 +open BNF_GFP_Rec_Sugar_Tactics
87.36 +
87.37 +val codeN = "code"
87.38 +val ctrN = "ctr"
87.39 +val discN = "disc"
87.40 +val selN = "sel"
87.41 +
87.42 +val nitpicksimp_attrs = @{attributes [nitpick_simp]};
87.43 +val simp_attrs = @{attributes [simp]};
87.44 +val code_nitpicksimp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs;
87.45 +
87.46 +exception Primcorec_Error of string * term list;
87.47 +
87.48 +fun primcorec_error str = raise Primcorec_Error (str, []);
87.49 +fun primcorec_error_eqn str eqn = raise Primcorec_Error (str, [eqn]);
87.50 +fun primcorec_error_eqns str eqns = raise Primcorec_Error (str, eqns);
87.51 +
87.52 +datatype primcorec_option =
87.53 + Option_Sequential |
87.54 + Option_Exhaustive
87.55 +
87.56 +datatype corec_call =
87.57 + Dummy_No_Corec of int |
87.58 + No_Corec of int |
87.59 + Mutual_Corec of int * int * int |
87.60 + Nested_Corec of int;
87.61 +
87.62 +type basic_corec_ctr_spec =
87.63 + {ctr: term,
87.64 + disc: term,
87.65 + sels: term list};
87.66 +
87.67 +type corec_ctr_spec =
87.68 + {ctr: term,
87.69 + disc: term,
87.70 + sels: term list,
87.71 + pred: int option,
87.72 + calls: corec_call list,
87.73 + discI: thm,
87.74 + sel_thms: thm list,
87.75 + collapse: thm,
87.76 + corec_thm: thm,
87.77 + disc_corec: thm,
87.78 + sel_corecs: thm list};
87.79 +
87.80 +type corec_spec =
87.81 + {corec: term,
87.82 + nested_map_idents: thm list,
87.83 + nested_map_comps: thm list,
87.84 + ctr_specs: corec_ctr_spec list};
87.85 +
87.86 +exception AINT_NO_MAP of term;
87.87 +
87.88 +fun not_codatatype ctxt T =
87.89 + error ("Not a codatatype: " ^ Syntax.string_of_typ ctxt T);
87.90 +fun ill_formed_corec_call ctxt t =
87.91 + error ("Ill-formed corecursive call: " ^ quote (Syntax.string_of_term ctxt t));
87.92 +fun invalid_map ctxt t =
87.93 + error ("Invalid map function in " ^ quote (Syntax.string_of_term ctxt t));
87.94 +fun unexpected_corec_call ctxt t =
87.95 + error ("Unexpected corecursive call: " ^ quote (Syntax.string_of_term ctxt t));
87.96 +
87.97 +val mk_conjs = try (foldr1 HOLogic.mk_conj) #> the_default @{const True};
87.98 +val mk_disjs = try (foldr1 HOLogic.mk_disj) #> the_default @{const False};
87.99 +
87.100 +val conjuncts_s = filter_out (curry (op =) @{const True}) o HOLogic.conjuncts;
87.101 +
87.102 +fun s_not @{const True} = @{const False}
87.103 + | s_not @{const False} = @{const True}
87.104 + | s_not (@{const Not} $ t) = t
87.105 + | s_not (@{const conj} $ t $ u) = @{const disj} $ s_not t $ s_not u
87.106 + | s_not (@{const disj} $ t $ u) = @{const conj} $ s_not t $ s_not u
87.107 + | s_not t = @{const Not} $ t;
87.108 +
87.109 +val s_not_conj = conjuncts_s o s_not o mk_conjs;
87.110 +
87.111 +fun propagate_unit_pos u cs = if member (op aconv) cs u then [@{const False}] else cs;
87.112 +
87.113 +fun propagate_unit_neg not_u cs = remove (op aconv) not_u cs;
87.114 +
87.115 +fun propagate_units css =
87.116 + (case List.partition (can the_single) css of
87.117 + ([], _) => css
87.118 + | ([u] :: uss, css') =>
87.119 + [u] :: propagate_units (map (propagate_unit_neg (s_not u))
87.120 + (map (propagate_unit_pos u) (uss @ css'))));
87.121 +
87.122 +fun s_conjs cs =
87.123 + if member (op aconv) cs @{const False} then @{const False}
87.124 + else mk_conjs (remove (op aconv) @{const True} cs);
87.125 +
87.126 +fun s_disjs ds =
87.127 + if member (op aconv) ds @{const True} then @{const True}
87.128 + else mk_disjs (remove (op aconv) @{const False} ds);
87.129 +
87.130 +fun s_dnf css0 =
87.131 + let val css = propagate_units css0 in
87.132 + if null css then
87.133 + [@{const False}]
87.134 + else if exists null css then
87.135 + []
87.136 + else
87.137 + map (fn c :: cs => (c, cs)) css
87.138 + |> AList.coalesce (op =)
87.139 + |> map (fn (c, css) => c :: s_dnf css)
87.140 + |> (fn [cs] => cs | css => [s_disjs (map s_conjs css)])
87.141 + end;
87.142 +
87.143 +fun fold_rev_let_if_case ctxt f bound_Ts t =
87.144 + let
87.145 + val thy = Proof_Context.theory_of ctxt;
87.146 +
87.147 + fun fld conds t =
87.148 + (case Term.strip_comb t of
87.149 + (Const (@{const_name Let}, _), [_, _]) => fld conds (unfold_let t)
87.150 + | (Const (@{const_name If}, _), [cond, then_branch, else_branch]) =>
87.151 + fld (conds @ conjuncts_s cond) then_branch o fld (conds @ s_not_conj [cond]) else_branch
87.152 + | (Const (c, _), args as _ :: _ :: _) =>
87.153 + let val n = num_binder_types (Sign.the_const_type thy c) - 1 in
87.154 + if n >= 0 andalso n < length args then
87.155 + (case fastype_of1 (bound_Ts, nth args n) of
87.156 + Type (s, Ts) =>
87.157 + (case dest_case ctxt s Ts t of
87.158 + NONE => apsnd (f conds t)
87.159 + | SOME (conds', branches) =>
87.160 + apfst (cons s) o fold_rev (uncurry fld)
87.161 + (map (append conds o conjuncts_s) conds' ~~ branches))
87.162 + | _ => apsnd (f conds t))
87.163 + else
87.164 + apsnd (f conds t)
87.165 + end
87.166 + | _ => apsnd (f conds t))
87.167 + in
87.168 + fld [] t o pair []
87.169 + end;
87.170 +
87.171 +fun case_of ctxt = ctr_sugar_of ctxt #> Option.map (fst o dest_Const o #casex);
87.172 +
87.173 +fun massage_let_if_case ctxt has_call massage_leaf =
87.174 + let
87.175 + val thy = Proof_Context.theory_of ctxt;
87.176 +
87.177 + fun check_no_call t = if has_call t then unexpected_corec_call ctxt t else ();
87.178 +
87.179 + fun massage_abs bound_Ts 0 t = massage_rec bound_Ts t
87.180 + | massage_abs bound_Ts m (Abs (s, T, t)) = Abs (s, T, massage_abs (T :: bound_Ts) (m - 1) t)
87.181 + | massage_abs bound_Ts m t =
87.182 + let val T = domain_type (fastype_of1 (bound_Ts, t)) in
87.183 + Abs (Name.uu, T, massage_abs (T :: bound_Ts) (m - 1) (incr_boundvars 1 t $ Bound 0))
87.184 + end
87.185 + and massage_rec bound_Ts t =
87.186 + let val typof = curry fastype_of1 bound_Ts in
87.187 + (case Term.strip_comb t of
87.188 + (Const (@{const_name Let}, _), [_, _]) => massage_rec bound_Ts (unfold_let t)
87.189 + | (Const (@{const_name If}, _), obj :: (branches as [_, _])) =>
87.190 + let val branches' = map (massage_rec bound_Ts) branches in
87.191 + Term.list_comb (If_const (typof (hd branches')) $ tap check_no_call obj, branches')
87.192 + end
87.193 + | (Const (c, _), args as _ :: _ :: _) =>
87.194 + (case try strip_fun_type (Sign.the_const_type thy c) of
87.195 + SOME (gen_branch_Ts, gen_body_fun_T) =>
87.196 + let
87.197 + val gen_branch_ms = map num_binder_types gen_branch_Ts;
87.198 + val n = length gen_branch_ms;
87.199 + in
87.200 + if n < length args then
87.201 + (case gen_body_fun_T of
87.202 + Type (_, [Type (T_name, _), _]) =>
87.203 + if case_of ctxt T_name = SOME c then
87.204 + let
87.205 + val (branches, obj_leftovers) = chop n args;
87.206 + val branches' = map2 (massage_abs bound_Ts) gen_branch_ms branches;
87.207 + val branch_Ts' = map typof branches';
87.208 + val body_T' = snd (strip_typeN (hd gen_branch_ms) (hd branch_Ts'));
87.209 + val casex' = Const (c, branch_Ts' ---> map typof obj_leftovers ---> body_T');
87.210 + in
87.211 + Term.list_comb (casex',
87.212 + branches' @ tap (List.app check_no_call) obj_leftovers)
87.213 + end
87.214 + else
87.215 + massage_leaf bound_Ts t
87.216 + | _ => massage_leaf bound_Ts t)
87.217 + else
87.218 + massage_leaf bound_Ts t
87.219 + end
87.220 + | NONE => massage_leaf bound_Ts t)
87.221 + | _ => massage_leaf bound_Ts t)
87.222 + end
87.223 + in
87.224 + massage_rec
87.225 + end;
87.226 +
87.227 +val massage_mutual_corec_call = massage_let_if_case;
87.228 +
87.229 +fun curried_type (Type (@{type_name fun}, [Type (@{type_name prod}, Ts), T])) = Ts ---> T;
87.230 +
87.231 +fun massage_nested_corec_call ctxt has_call raw_massage_call bound_Ts U t =
87.232 + let
87.233 + fun check_no_call t = if has_call t then unexpected_corec_call ctxt t else ();
87.234 +
87.235 + val build_map_Inl = build_map ctxt (uncurry Inl_const o dest_sumT o snd);
87.236 +
87.237 + fun massage_mutual_call bound_Ts U T t =
87.238 + if has_call t then
87.239 + (case try dest_sumT U of
87.240 + SOME (U1, U2) => if U1 = T then raw_massage_call bound_Ts T U2 t else invalid_map ctxt t
87.241 + | NONE => invalid_map ctxt t)
87.242 + else
87.243 + build_map_Inl (T, U) $ t;
87.244 +
87.245 + fun massage_mutual_fun bound_Ts U T t =
87.246 + (case t of
87.247 + Const (@{const_name comp}, _) $ t1 $ t2 =>
87.248 + mk_comp bound_Ts (massage_mutual_fun bound_Ts U T t1, tap check_no_call t2)
87.249 + | _ =>
87.250 + let
87.251 + val var = Var ((Name.uu, Term.maxidx_of_term t + 1),
87.252 + domain_type (fastype_of1 (bound_Ts, t)));
87.253 + in
87.254 + Term.lambda var (massage_mutual_call bound_Ts U T (t $ var))
87.255 + end);
87.256 +
87.257 + fun massage_map bound_Ts (Type (_, Us)) (Type (s, Ts)) t =
87.258 + (case try (dest_map ctxt s) t of
87.259 + SOME (map0, fs) =>
87.260 + let
87.261 + val Type (_, dom_Ts) = domain_type (fastype_of1 (bound_Ts, t));
87.262 + val map' = mk_map (length fs) dom_Ts Us map0;
87.263 + val fs' =
87.264 + map_flattened_map_args ctxt s (map3 (massage_map_or_map_arg bound_Ts) Us Ts) fs;
87.265 + in
87.266 + Term.list_comb (map', fs')
87.267 + end
87.268 + | NONE => raise AINT_NO_MAP t)
87.269 + | massage_map _ _ _ t = raise AINT_NO_MAP t
87.270 + and massage_map_or_map_arg bound_Ts U T t =
87.271 + if T = U then
87.272 + tap check_no_call t
87.273 + else
87.274 + massage_map bound_Ts U T t
87.275 + handle AINT_NO_MAP _ => massage_mutual_fun bound_Ts U T t;
87.276 +
87.277 + fun massage_call bound_Ts U T =
87.278 + massage_let_if_case ctxt has_call (fn bound_Ts => fn t =>
87.279 + if has_call t then
87.280 + (case t of
87.281 + Const (@{const_name prod_case}, _) $ t' =>
87.282 + let
87.283 + val U' = curried_type U;
87.284 + val T' = curried_type T;
87.285 + in
87.286 + Const (@{const_name prod_case}, U' --> U) $ massage_call bound_Ts U' T' t'
87.287 + end
87.288 + | t1 $ t2 =>
87.289 + (if has_call t2 then
87.290 + massage_mutual_call bound_Ts U T t
87.291 + else
87.292 + massage_map bound_Ts U T t1 $ t2
87.293 + handle AINT_NO_MAP _ => massage_mutual_call bound_Ts U T t)
87.294 + | Abs (s, T', t') =>
87.295 + Abs (s, T', massage_call (T' :: bound_Ts) (range_type U) (range_type T) t')
87.296 + | _ => massage_mutual_call bound_Ts U T t)
87.297 + else
87.298 + build_map_Inl (T, U) $ t) bound_Ts;
87.299 +
87.300 + val T = fastype_of1 (bound_Ts, t);
87.301 + in
87.302 + if has_call t then massage_call bound_Ts U T t else build_map_Inl (T, U) $ t
87.303 + end;
87.304 +
87.305 +val fold_rev_corec_call = fold_rev_let_if_case;
87.306 +
87.307 +fun expand_to_ctr_term ctxt s Ts t =
87.308 + (case ctr_sugar_of ctxt s of
87.309 + SOME {ctrs, casex, ...} =>
87.310 + Term.list_comb (mk_case Ts (Type (s, Ts)) casex, map (mk_ctr Ts) ctrs) $ t
87.311 + | NONE => raise Fail "expand_to_ctr_term");
87.312 +
87.313 +fun expand_corec_code_rhs ctxt has_call bound_Ts t =
87.314 + (case fastype_of1 (bound_Ts, t) of
87.315 + Type (s, Ts) =>
87.316 + massage_let_if_case ctxt has_call (fn _ => fn t =>
87.317 + if can (dest_ctr ctxt s) t then t else expand_to_ctr_term ctxt s Ts t) bound_Ts t
87.318 + | _ => raise Fail "expand_corec_code_rhs");
87.319 +
87.320 +fun massage_corec_code_rhs ctxt massage_ctr =
87.321 + massage_let_if_case ctxt (K false)
87.322 + (fn bound_Ts => uncurry (massage_ctr bound_Ts) o Term.strip_comb);
87.323 +
87.324 +fun fold_rev_corec_code_rhs ctxt f =
87.325 + snd ooo fold_rev_let_if_case ctxt (fn conds => uncurry (f conds) o Term.strip_comb);
87.326 +
87.327 +fun case_thms_of_term ctxt bound_Ts t =
87.328 + let
87.329 + val (caseT_names, _) = fold_rev_let_if_case ctxt (K (K I)) bound_Ts t ();
87.330 + val ctr_sugars = map (the o ctr_sugar_of ctxt) caseT_names;
87.331 + in
87.332 + (maps #distincts ctr_sugars, maps #discIs ctr_sugars, maps #sel_splits ctr_sugars,
87.333 + maps #sel_split_asms ctr_sugars)
87.334 + end;
87.335 +
87.336 +fun basic_corec_specs_of ctxt res_T =
87.337 + (case res_T of
87.338 + Type (T_name, _) =>
87.339 + (case Ctr_Sugar.ctr_sugar_of ctxt T_name of
87.340 + NONE => not_codatatype ctxt res_T
87.341 + | SOME {ctrs, discs, selss, ...} =>
87.342 + let
87.343 + val thy = Proof_Context.theory_of ctxt;
87.344 +
87.345 + val gfpT = body_type (fastype_of (hd ctrs));
87.346 + val As_rho = tvar_subst thy [gfpT] [res_T];
87.347 + val substA = Term.subst_TVars As_rho;
87.348 +
87.349 + fun mk_spec ctr disc sels = {ctr = substA ctr, disc = substA disc, sels = map substA sels};
87.350 + in
87.351 + map3 mk_spec ctrs discs selss
87.352 + end)
87.353 + | _ => not_codatatype ctxt res_T);
87.354 +
87.355 +fun corec_specs_of bs arg_Ts res_Ts get_indices callssss0 lthy =
87.356 + let
87.357 + val thy = Proof_Context.theory_of lthy;
87.358 +
87.359 + val ((missing_res_Ts, perm0_kks,
87.360 + fp_sugars as {nested_bnfs, fp_res = {xtor_co_iterss = dtor_coiters1 :: _, ...},
87.361 + co_inducts = coinduct_thms, ...} :: _, (_, gfp_sugar_thms)), lthy') =
87.362 + nested_to_mutual_fps Greatest_FP bs res_Ts get_indices callssss0 lthy;
87.363 +
87.364 + val perm_fp_sugars = sort (int_ord o pairself #index) fp_sugars;
87.365 +
87.366 + val indices = map #index fp_sugars;
87.367 + val perm_indices = map #index perm_fp_sugars;
87.368 +
87.369 + val perm_ctrss = map (#ctrs o of_fp_sugar #ctr_sugars) perm_fp_sugars;
87.370 + val perm_ctr_Tsss = map (map (binder_types o fastype_of)) perm_ctrss;
87.371 + val perm_gfpTs = map (body_type o fastype_of o hd) perm_ctrss;
87.372 +
87.373 + val nn0 = length res_Ts;
87.374 + val nn = length perm_gfpTs;
87.375 + val kks = 0 upto nn - 1;
87.376 + val perm_ns = map length perm_ctr_Tsss;
87.377 +
87.378 + val perm_Cs = map (domain_type o body_fun_type o fastype_of o co_rec_of o
87.379 + of_fp_sugar (#xtor_co_iterss o #fp_res)) perm_fp_sugars;
87.380 + val (perm_p_Tss, (perm_q_Tssss, _, perm_f_Tssss, _)) =
87.381 + mk_coiter_fun_arg_types perm_ctr_Tsss perm_Cs perm_ns (co_rec_of dtor_coiters1);
87.382 +
87.383 + val (perm_p_hss, h) = indexedd perm_p_Tss 0;
87.384 + val (perm_q_hssss, h') = indexedddd perm_q_Tssss h;
87.385 + val (perm_f_hssss, _) = indexedddd perm_f_Tssss h';
87.386 +
87.387 + val fun_arg_hs =
87.388 + flat (map3 flat_corec_preds_predsss_gettersss perm_p_hss perm_q_hssss perm_f_hssss);
87.389 +
87.390 + fun unpermute0 perm0_xs = permute_like (op =) perm0_kks kks perm0_xs;
87.391 + fun unpermute perm_xs = permute_like (op =) perm_indices indices perm_xs;
87.392 +
87.393 + val coinduct_thmss = map (unpermute0 o conj_dests nn) coinduct_thms;
87.394 +
87.395 + val p_iss = map (map (find_index_eq fun_arg_hs)) (unpermute perm_p_hss);
87.396 + val q_issss = map (map (map (map (find_index_eq fun_arg_hs)))) (unpermute perm_q_hssss);
87.397 + val f_issss = map (map (map (map (find_index_eq fun_arg_hs)))) (unpermute perm_f_hssss);
87.398 +
87.399 + val f_Tssss = unpermute perm_f_Tssss;
87.400 + val gfpTs = unpermute perm_gfpTs;
87.401 + val Cs = unpermute perm_Cs;
87.402 +
87.403 + val As_rho = tvar_subst thy (take nn0 gfpTs) res_Ts;
87.404 + val Cs_rho = map (fst o dest_TVar) Cs ~~ pad_list HOLogic.unitT nn arg_Ts;
87.405 +
87.406 + val substA = Term.subst_TVars As_rho;
87.407 + val substAT = Term.typ_subst_TVars As_rho;
87.408 + val substCT = Term.typ_subst_TVars Cs_rho;
87.409 +
87.410 + val perm_Cs' = map substCT perm_Cs;
87.411 +
87.412 + fun call_of nullary [] [g_i] [Type (@{type_name fun}, [_, T])] =
87.413 + (if exists_subtype_in Cs T then Nested_Corec
87.414 + else if nullary then Dummy_No_Corec
87.415 + else No_Corec) g_i
87.416 + | call_of _ [q_i] [g_i, g_i'] _ = Mutual_Corec (q_i, g_i, g_i');
87.417 +
87.418 + fun mk_ctr_spec ctr disc sels p_ho q_iss f_iss f_Tss discI sel_thms collapse corec_thm
87.419 + disc_corec sel_corecs =
87.420 + let val nullary = not (can dest_funT (fastype_of ctr)) in
87.421 + {ctr = substA ctr, disc = substA disc, sels = map substA sels, pred = p_ho,
87.422 + calls = map3 (call_of nullary) q_iss f_iss f_Tss, discI = discI, sel_thms = sel_thms,
87.423 + collapse = collapse, corec_thm = corec_thm, disc_corec = disc_corec,
87.424 + sel_corecs = sel_corecs}
87.425 + end;
87.426 +
87.427 + fun mk_ctr_specs index (ctr_sugars : ctr_sugar list) p_is q_isss f_isss f_Tsss coiter_thmsss
87.428 + disc_coitersss sel_coiterssss =
87.429 + let
87.430 + val ctrs = #ctrs (nth ctr_sugars index);
87.431 + val discs = #discs (nth ctr_sugars index);
87.432 + val selss = #selss (nth ctr_sugars index);
87.433 + val p_ios = map SOME p_is @ [NONE];
87.434 + val discIs = #discIs (nth ctr_sugars index);
87.435 + val sel_thmss = #sel_thmss (nth ctr_sugars index);
87.436 + val collapses = #collapses (nth ctr_sugars index);
87.437 + val corec_thms = co_rec_of (nth coiter_thmsss index);
87.438 + val disc_corecs = co_rec_of (nth disc_coitersss index);
87.439 + val sel_corecss = co_rec_of (nth sel_coiterssss index);
87.440 + in
87.441 + map13 mk_ctr_spec ctrs discs selss p_ios q_isss f_isss f_Tsss discIs sel_thmss collapses
87.442 + corec_thms disc_corecs sel_corecss
87.443 + end;
87.444 +
87.445 + fun mk_spec ({T, index, ctr_sugars, co_iterss = coiterss, co_iter_thmsss = coiter_thmsss,
87.446 + disc_co_itersss = disc_coitersss, sel_co_iterssss = sel_coiterssss, ...} : fp_sugar)
87.447 + p_is q_isss f_isss f_Tsss =
87.448 + {corec = mk_co_iter thy Greatest_FP (substAT T) perm_Cs' (co_rec_of (nth coiterss index)),
87.449 + nested_map_idents = map (unfold_thms lthy @{thms id_def} o map_id0_of_bnf) nested_bnfs,
87.450 + nested_map_comps = map map_comp_of_bnf nested_bnfs,
87.451 + ctr_specs = mk_ctr_specs index ctr_sugars p_is q_isss f_isss f_Tsss coiter_thmsss
87.452 + disc_coitersss sel_coiterssss};
87.453 + in
87.454 + ((is_some gfp_sugar_thms, map5 mk_spec fp_sugars p_iss q_issss f_issss f_Tssss, missing_res_Ts,
87.455 + co_induct_of coinduct_thms, strong_co_induct_of coinduct_thms, co_induct_of coinduct_thmss,
87.456 + strong_co_induct_of coinduct_thmss), lthy')
87.457 + end;
87.458 +
87.459 +val undef_const = Const (@{const_name undefined}, dummyT);
87.460 +
87.461 +val abs_tuple = HOLogic.tupled_lambda o HOLogic.mk_tuple;
87.462 +fun abstract vs =
87.463 + let fun a n (t $ u) = a n t $ a n u
87.464 + | a n (Abs (v, T, b)) = Abs (v, T, a (n + 1) b)
87.465 + | a n t = let val idx = find_index (equal t) vs in
87.466 + if idx < 0 then t else Bound (n + idx) end
87.467 + in a 0 end;
87.468 +
87.469 +fun mk_prod1 bound_Ts (t, u) =
87.470 + HOLogic.pair_const (fastype_of1 (bound_Ts, t)) (fastype_of1 (bound_Ts, u)) $ t $ u;
87.471 +fun mk_tuple1 bound_Ts = the_default HOLogic.unit o try (foldr1 (mk_prod1 bound_Ts));
87.472 +
87.473 +type coeqn_data_disc = {
87.474 + fun_name: string,
87.475 + fun_T: typ,
87.476 + fun_args: term list,
87.477 + ctr: term,
87.478 + ctr_no: int, (*###*)
87.479 + disc: term,
87.480 + prems: term list,
87.481 + auto_gen: bool,
87.482 + maybe_ctr_rhs: term option,
87.483 + maybe_code_rhs: term option,
87.484 + user_eqn: term
87.485 +};
87.486 +
87.487 +type coeqn_data_sel = {
87.488 + fun_name: string,
87.489 + fun_T: typ,
87.490 + fun_args: term list,
87.491 + ctr: term,
87.492 + sel: term,
87.493 + rhs_term: term,
87.494 + user_eqn: term
87.495 +};
87.496 +
87.497 +datatype coeqn_data =
87.498 + Disc of coeqn_data_disc |
87.499 + Sel of coeqn_data_sel;
87.500 +
87.501 +fun dissect_coeqn_disc seq fun_names (basic_ctr_specss : basic_corec_ctr_spec list list)
87.502 + maybe_ctr_rhs maybe_code_rhs prems' concl matchedsss =
87.503 + let
87.504 + fun find_subterm p =
87.505 + let (* FIXME \<exists>? *)
87.506 + fun find (t as u $ v) = if p t then SOME t else merge_options (find u, find v)
87.507 + | find t = if p t then SOME t else NONE;
87.508 + in find end;
87.509 +
87.510 + val applied_fun = concl
87.511 + |> find_subterm (member ((op =) o apsnd SOME) fun_names o try (fst o dest_Free o head_of))
87.512 + |> the
87.513 + handle Option.Option => primcorec_error_eqn "malformed discriminator formula" concl;
87.514 + val ((fun_name, fun_T), fun_args) = strip_comb applied_fun |>> dest_Free;
87.515 + val SOME basic_ctr_specs = AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name;
87.516 +
87.517 + val discs = map #disc basic_ctr_specs;
87.518 + val ctrs = map #ctr basic_ctr_specs;
87.519 + val not_disc = head_of concl = @{term Not};
87.520 + val _ = not_disc andalso length ctrs <> 2 andalso
87.521 + primcorec_error_eqn "negated discriminator for a type with \<noteq> 2 constructors" concl;
87.522 + val disc' = find_subterm (member (op =) discs o head_of) concl;
87.523 + val eq_ctr0 = concl |> perhaps (try HOLogic.dest_not) |> try (HOLogic.dest_eq #> snd)
87.524 + |> (fn SOME t => let val n = find_index (equal t) ctrs in
87.525 + if n >= 0 then SOME n else NONE end | _ => NONE);
87.526 + val _ = is_some disc' orelse is_some eq_ctr0 orelse
87.527 + primcorec_error_eqn "no discriminator in equation" concl;
87.528 + val ctr_no' =
87.529 + if is_none disc' then the eq_ctr0 else find_index (equal (head_of (the disc'))) discs;
87.530 + val ctr_no = if not_disc then 1 - ctr_no' else ctr_no';
87.531 + val {ctr, disc, ...} = nth basic_ctr_specs ctr_no;
87.532 +
87.533 + val catch_all = try (fst o dest_Free o the_single) prems' = SOME Name.uu_;
87.534 + val matchedss = AList.lookup (op =) matchedsss fun_name |> the_default [];
87.535 + val prems = map (abstract (List.rev fun_args)) prems';
87.536 + val real_prems =
87.537 + (if catch_all orelse seq then maps s_not_conj matchedss else []) @
87.538 + (if catch_all then [] else prems);
87.539 +
87.540 + val matchedsss' = AList.delete (op =) fun_name matchedsss
87.541 + |> cons (fun_name, if seq then matchedss @ [prems] else matchedss @ [real_prems]);
87.542 +
87.543 + val user_eqn =
87.544 + (real_prems, concl)
87.545 + |>> map HOLogic.mk_Trueprop ||> HOLogic.mk_Trueprop o abstract (List.rev fun_args)
87.546 + |> curry Logic.list_all (map dest_Free fun_args) o Logic.list_implies;
87.547 + in
87.548 + (Disc {
87.549 + fun_name = fun_name,
87.550 + fun_T = fun_T,
87.551 + fun_args = fun_args,
87.552 + ctr = ctr,
87.553 + ctr_no = ctr_no,
87.554 + disc = disc,
87.555 + prems = real_prems,
87.556 + auto_gen = catch_all,
87.557 + maybe_ctr_rhs = maybe_ctr_rhs,
87.558 + maybe_code_rhs = maybe_code_rhs,
87.559 + user_eqn = user_eqn
87.560 + }, matchedsss')
87.561 + end;
87.562 +
87.563 +fun dissect_coeqn_sel fun_names (basic_ctr_specss : basic_corec_ctr_spec list list) eqn'
87.564 + maybe_of_spec eqn =
87.565 + let
87.566 + val (lhs, rhs) = HOLogic.dest_eq eqn
87.567 + handle TERM _ =>
87.568 + primcorec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn;
87.569 + val sel = head_of lhs;
87.570 + val ((fun_name, fun_T), fun_args) = dest_comb lhs |> snd |> strip_comb |> apfst dest_Free
87.571 + handle TERM _ =>
87.572 + primcorec_error_eqn "malformed selector argument in left-hand side" eqn;
87.573 + val basic_ctr_specs = the (AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name)
87.574 + handle Option.Option =>
87.575 + primcorec_error_eqn "malformed selector argument in left-hand side" eqn;
87.576 + val {ctr, ...} =
87.577 + (case maybe_of_spec of
87.578 + SOME of_spec => the (find_first (equal of_spec o #ctr) basic_ctr_specs)
87.579 + | NONE => filter (exists (equal sel) o #sels) basic_ctr_specs |> the_single
87.580 + handle List.Empty => primcorec_error_eqn "ambiguous selector - use \"of\"" eqn);
87.581 + val user_eqn = drop_All eqn';
87.582 + in
87.583 + Sel {
87.584 + fun_name = fun_name,
87.585 + fun_T = fun_T,
87.586 + fun_args = fun_args,
87.587 + ctr = ctr,
87.588 + sel = sel,
87.589 + rhs_term = rhs,
87.590 + user_eqn = user_eqn
87.591 + }
87.592 + end;
87.593 +
87.594 +fun dissect_coeqn_ctr seq fun_names (basic_ctr_specss : basic_corec_ctr_spec list list) eqn'
87.595 + maybe_code_rhs prems concl matchedsss =
87.596 + let
87.597 + val (lhs, rhs) = HOLogic.dest_eq concl;
87.598 + val (fun_name, fun_args) = strip_comb lhs |>> fst o dest_Free;
87.599 + val SOME basic_ctr_specs = AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name;
87.600 + val (ctr, ctr_args) = strip_comb (unfold_let rhs);
87.601 + val {disc, sels, ...} = the (find_first (equal ctr o #ctr) basic_ctr_specs)
87.602 + handle Option.Option => primcorec_error_eqn "not a constructor" ctr;
87.603 +
87.604 + val disc_concl = betapply (disc, lhs);
87.605 + val (maybe_eqn_data_disc, matchedsss') = if length basic_ctr_specs = 1
87.606 + then (NONE, matchedsss)
87.607 + else apfst SOME (dissect_coeqn_disc seq fun_names basic_ctr_specss
87.608 + (SOME (abstract (List.rev fun_args) rhs)) maybe_code_rhs prems disc_concl matchedsss);
87.609 +
87.610 + val sel_concls = sels ~~ ctr_args
87.611 + |> map (fn (sel, ctr_arg) => HOLogic.mk_eq (betapply (sel, lhs), ctr_arg));
87.612 +
87.613 +(*
87.614 +val _ = tracing ("reduced\n " ^ Syntax.string_of_term @{context} concl ^ "\nto\n \<cdot> " ^
87.615 + (is_some maybe_eqn_data_disc ? K (Syntax.string_of_term @{context} disc_concl ^ "\n \<cdot> ")) "" ^
87.616 + space_implode "\n \<cdot> " (map (Syntax.string_of_term @{context}) sel_concls) ^
87.617 + "\nfor premise(s)\n \<cdot> " ^
87.618 + space_implode "\n \<cdot> " (map (Syntax.string_of_term @{context}) prems));
87.619 +*)
87.620 +
87.621 + val eqns_data_sel =
87.622 + map (dissect_coeqn_sel fun_names basic_ctr_specss eqn' (SOME ctr)) sel_concls;
87.623 + in
87.624 + (the_list maybe_eqn_data_disc @ eqns_data_sel, matchedsss')
87.625 + end;
87.626 +
87.627 +fun dissect_coeqn_code lthy has_call fun_names basic_ctr_specss eqn' concl matchedsss =
87.628 + let
87.629 + val (lhs, (rhs', rhs)) = HOLogic.dest_eq concl ||> `(expand_corec_code_rhs lthy has_call []);
87.630 + val (fun_name, fun_args) = strip_comb lhs |>> fst o dest_Free;
87.631 + val SOME basic_ctr_specs = AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name;
87.632 +
87.633 + val cond_ctrs = fold_rev_corec_code_rhs lthy (fn cs => fn ctr => fn _ =>
87.634 + if member ((op =) o apsnd #ctr) basic_ctr_specs ctr
87.635 + then cons (ctr, cs)
87.636 + else primcorec_error_eqn "not a constructor" ctr) [] rhs' []
87.637 + |> AList.group (op =);
87.638 +
87.639 + val ctr_premss = (case cond_ctrs of [_] => [[]] | _ => map (s_dnf o snd) cond_ctrs);
87.640 + val ctr_concls = cond_ctrs |> map (fn (ctr, _) =>
87.641 + binder_types (fastype_of ctr)
87.642 + |> map_index (fn (n, T) => massage_corec_code_rhs lthy (fn _ => fn ctr' => fn args =>
87.643 + if ctr' = ctr then nth args n else Const (@{const_name undefined}, T)) [] rhs')
87.644 + |> curry list_comb ctr
87.645 + |> curry HOLogic.mk_eq lhs);
87.646 + in
87.647 + fold_map2 (dissect_coeqn_ctr false fun_names basic_ctr_specss eqn'
87.648 + (SOME (abstract (List.rev fun_args) rhs)))
87.649 + ctr_premss ctr_concls matchedsss
87.650 + end;
87.651 +
87.652 +fun dissect_coeqn lthy seq has_call fun_names (basic_ctr_specss : basic_corec_ctr_spec list list)
87.653 + eqn' maybe_of_spec matchedsss =
87.654 + let
87.655 + val eqn = drop_All eqn'
87.656 + handle TERM _ => primcorec_error_eqn "malformed function equation" eqn';
87.657 + val (prems, concl) = Logic.strip_horn eqn
87.658 + |> apfst (map HOLogic.dest_Trueprop) o apsnd HOLogic.dest_Trueprop;
87.659 +
87.660 + val head = concl
87.661 + |> perhaps (try HOLogic.dest_not) |> perhaps (try (fst o HOLogic.dest_eq))
87.662 + |> head_of;
87.663 +
87.664 + val maybe_rhs = concl |> perhaps (try HOLogic.dest_not) |> try (snd o HOLogic.dest_eq);
87.665 +
87.666 + val discs = maps (map #disc) basic_ctr_specss;
87.667 + val sels = maps (maps #sels) basic_ctr_specss;
87.668 + val ctrs = maps (map #ctr) basic_ctr_specss;
87.669 + in
87.670 + if member (op =) discs head orelse
87.671 + is_some maybe_rhs andalso
87.672 + member (op =) (filter (null o binder_types o fastype_of) ctrs) (the maybe_rhs) then
87.673 + dissect_coeqn_disc seq fun_names basic_ctr_specss NONE NONE prems concl matchedsss
87.674 + |>> single
87.675 + else if member (op =) sels head then
87.676 + ([dissect_coeqn_sel fun_names basic_ctr_specss eqn' maybe_of_spec concl], matchedsss)
87.677 + else if is_Free head andalso member (op =) fun_names (fst (dest_Free head)) andalso
87.678 + member (op =) ctrs (head_of (unfold_let (the maybe_rhs))) then
87.679 + dissect_coeqn_ctr seq fun_names basic_ctr_specss eqn' NONE prems concl matchedsss
87.680 + else if is_Free head andalso member (op =) fun_names (fst (dest_Free head)) andalso
87.681 + null prems then
87.682 + dissect_coeqn_code lthy has_call fun_names basic_ctr_specss eqn' concl matchedsss
87.683 + |>> flat
87.684 + else
87.685 + primcorec_error_eqn "malformed function equation" eqn
87.686 + end;
87.687 +
87.688 +fun build_corec_arg_disc (ctr_specs : corec_ctr_spec list)
87.689 + ({fun_args, ctr_no, prems, ...} : coeqn_data_disc) =
87.690 + if is_none (#pred (nth ctr_specs ctr_no)) then I else
87.691 + s_conjs prems
87.692 + |> curry subst_bounds (List.rev fun_args)
87.693 + |> HOLogic.tupled_lambda (HOLogic.mk_tuple fun_args)
87.694 + |> K |> nth_map (the (#pred (nth ctr_specs ctr_no)));
87.695 +
87.696 +fun build_corec_arg_no_call (sel_eqns : coeqn_data_sel list) sel =
87.697 + find_first (equal sel o #sel) sel_eqns
87.698 + |> try (fn SOME {fun_args, rhs_term, ...} => abs_tuple fun_args rhs_term)
87.699 + |> the_default undef_const
87.700 + |> K;
87.701 +
87.702 +fun build_corec_args_mutual_call lthy has_call (sel_eqns : coeqn_data_sel list) sel =
87.703 + (case find_first (equal sel o #sel) sel_eqns of
87.704 + NONE => (I, I, I)
87.705 + | SOME {fun_args, rhs_term, ... } =>
87.706 + let
87.707 + val bound_Ts = List.rev (map fastype_of fun_args);
87.708 + fun rewrite_stop _ t = if has_call t then @{term False} else @{term True};
87.709 + fun rewrite_end _ t = if has_call t then undef_const else t;
87.710 + fun rewrite_cont bound_Ts t =
87.711 + if has_call t then mk_tuple1 bound_Ts (snd (strip_comb t)) else undef_const;
87.712 + fun massage f _ = massage_mutual_corec_call lthy has_call f bound_Ts rhs_term
87.713 + |> abs_tuple fun_args;
87.714 + in
87.715 + (massage rewrite_stop, massage rewrite_end, massage rewrite_cont)
87.716 + end);
87.717 +
87.718 +fun build_corec_arg_nested_call lthy has_call (sel_eqns : coeqn_data_sel list) sel =
87.719 + (case find_first (equal sel o #sel) sel_eqns of
87.720 + NONE => I
87.721 + | SOME {fun_args, rhs_term, ...} =>
87.722 + let
87.723 + val bound_Ts = List.rev (map fastype_of fun_args);
87.724 + fun rewrite bound_Ts U T (Abs (v, V, b)) = Abs (v, V, rewrite (V :: bound_Ts) U T b)
87.725 + | rewrite bound_Ts U T (t as _ $ _) =
87.726 + let val (u, vs) = strip_comb t in
87.727 + if is_Free u andalso has_call u then
87.728 + Inr_const U T $ mk_tuple1 bound_Ts vs
87.729 + else if try (fst o dest_Const) u = SOME @{const_name prod_case} then
87.730 + map (rewrite bound_Ts U T) vs |> chop 1 |>> HOLogic.mk_split o the_single |> list_comb
87.731 + else
87.732 + list_comb (rewrite bound_Ts U T u, map (rewrite bound_Ts U T) vs)
87.733 + end
87.734 + | rewrite _ U T t =
87.735 + if is_Free t andalso has_call t then Inr_const U T $ HOLogic.unit else t;
87.736 + fun massage t =
87.737 + rhs_term
87.738 + |> massage_nested_corec_call lthy has_call rewrite bound_Ts (range_type (fastype_of t))
87.739 + |> abs_tuple fun_args;
87.740 + in
87.741 + massage
87.742 + end);
87.743 +
87.744 +fun build_corec_args_sel lthy has_call (all_sel_eqns : coeqn_data_sel list)
87.745 + (ctr_spec : corec_ctr_spec) =
87.746 + (case filter (equal (#ctr ctr_spec) o #ctr) all_sel_eqns of
87.747 + [] => I
87.748 + | sel_eqns =>
87.749 + let
87.750 + val sel_call_list = #sels ctr_spec ~~ #calls ctr_spec;
87.751 + val no_calls' = map_filter (try (apsnd (fn No_Corec n => n))) sel_call_list;
87.752 + val mutual_calls' = map_filter (try (apsnd (fn Mutual_Corec n => n))) sel_call_list;
87.753 + val nested_calls' = map_filter (try (apsnd (fn Nested_Corec n => n))) sel_call_list;
87.754 + in
87.755 + I
87.756 + #> fold (fn (sel, n) => nth_map n (build_corec_arg_no_call sel_eqns sel)) no_calls'
87.757 + #> fold (fn (sel, (q, g, h)) =>
87.758 + let val (fq, fg, fh) = build_corec_args_mutual_call lthy has_call sel_eqns sel in
87.759 + nth_map q fq o nth_map g fg o nth_map h fh end) mutual_calls'
87.760 + #> fold (fn (sel, n) => nth_map n
87.761 + (build_corec_arg_nested_call lthy has_call sel_eqns sel)) nested_calls'
87.762 + end);
87.763 +
87.764 +fun build_codefs lthy bs mxs has_call arg_Tss (corec_specs : corec_spec list)
87.765 + (disc_eqnss : coeqn_data_disc list list) (sel_eqnss : coeqn_data_sel list list) =
87.766 + let
87.767 + val corecs = map #corec corec_specs;
87.768 + val ctr_specss = map #ctr_specs corec_specs;
87.769 + val corec_args = hd corecs
87.770 + |> fst o split_last o binder_types o fastype_of
87.771 + |> map (Const o pair @{const_name undefined})
87.772 + |> fold2 (fold o build_corec_arg_disc) ctr_specss disc_eqnss
87.773 + |> fold2 (fold o build_corec_args_sel lthy has_call) sel_eqnss ctr_specss;
87.774 + fun currys [] t = t
87.775 + | currys Ts t = t $ mk_tuple1 (List.rev Ts) (map Bound (length Ts - 1 downto 0))
87.776 + |> fold_rev (Term.abs o pair Name.uu) Ts;
87.777 +
87.778 +(*
87.779 +val _ = tracing ("corecursor arguments:\n \<cdot> " ^
87.780 + space_implode "\n \<cdot> " (map (Syntax.string_of_term lthy) corec_args));
87.781 +*)
87.782 +
87.783 + val exclss' =
87.784 + disc_eqnss
87.785 + |> map (map (fn x => (#fun_args x, #ctr_no x, #prems x, #auto_gen x))
87.786 + #> fst o (fn xs => fold_map (fn x => fn ys => ((x, ys), ys @ [x])) xs [])
87.787 + #> maps (uncurry (map o pair)
87.788 + #> map (fn ((fun_args, c, x, a), (_, c', y, a')) =>
87.789 + ((c, c', a orelse a'), (x, s_not (s_conjs y)))
87.790 + ||> apfst (map HOLogic.mk_Trueprop) o apsnd HOLogic.mk_Trueprop
87.791 + ||> Logic.list_implies
87.792 + ||> curry Logic.list_all (map dest_Free fun_args))))
87.793 + in
87.794 + map (list_comb o rpair corec_args) corecs
87.795 + |> map2 (fn Ts => fn t => if length Ts = 0 then t $ HOLogic.unit else t) arg_Tss
87.796 + |> map2 currys arg_Tss
87.797 + |> Syntax.check_terms lthy
87.798 + |> map3 (fn b => fn mx => fn t => ((b, mx), ((Binding.conceal (Thm.def_binding b), []), t)))
87.799 + bs mxs
87.800 + |> rpair exclss'
87.801 + end;
87.802 +
87.803 +fun mk_real_disc_eqns fun_binding arg_Ts ({ctr_specs, ...} : corec_spec)
87.804 + (sel_eqns : coeqn_data_sel list) (disc_eqns : coeqn_data_disc list) =
87.805 + if length disc_eqns <> length ctr_specs - 1 then disc_eqns else
87.806 + let
87.807 + val n = 0 upto length ctr_specs
87.808 + |> the o find_first (fn idx => not (exists (equal idx o #ctr_no) disc_eqns));
87.809 + val fun_args = (try (#fun_args o hd) disc_eqns, try (#fun_args o hd) sel_eqns)
87.810 + |> the_default (map (curry Free Name.uu) arg_Ts) o merge_options;
87.811 + val extra_disc_eqn = {
87.812 + fun_name = Binding.name_of fun_binding,
87.813 + fun_T = arg_Ts ---> body_type (fastype_of (#ctr (hd ctr_specs))),
87.814 + fun_args = fun_args,
87.815 + ctr = #ctr (nth ctr_specs n),
87.816 + ctr_no = n,
87.817 + disc = #disc (nth ctr_specs n),
87.818 + prems = maps (s_not_conj o #prems) disc_eqns,
87.819 + auto_gen = true,
87.820 + maybe_ctr_rhs = NONE,
87.821 + maybe_code_rhs = NONE,
87.822 + user_eqn = undef_const};
87.823 + in
87.824 + chop n disc_eqns ||> cons extra_disc_eqn |> (op @)
87.825 + end;
87.826 +
87.827 +fun find_corec_calls ctxt has_call basic_ctr_specs ({ctr, sel, rhs_term, ...} : coeqn_data_sel) =
87.828 + let
87.829 + val sel_no = find_first (equal ctr o #ctr) basic_ctr_specs
87.830 + |> find_index (equal sel) o #sels o the;
87.831 + fun find t = if has_call t then snd (fold_rev_corec_call ctxt (K cons) [] t []) else [];
87.832 + in
87.833 + find rhs_term
87.834 + |> K |> nth_map sel_no |> AList.map_entry (op =) ctr
87.835 + end;
87.836 +
87.837 +fun add_primcorec_ursive maybe_tac opts fixes specs maybe_of_specs lthy =
87.838 + let
87.839 + val thy = Proof_Context.theory_of lthy;
87.840 +
87.841 + val (bs, mxs) = map_split (apfst fst) fixes;
87.842 + val (arg_Ts, res_Ts) = map (strip_type o snd o fst #>> HOLogic.mk_tupleT) fixes |> split_list;
87.843 +
87.844 + val _ = (case filter_out (fn (_, T) => Sign.of_sort thy (T, HOLogic.typeS)) (bs ~~ arg_Ts) of
87.845 + [] => ()
87.846 + | (b, _) :: _ => primcorec_error ("type of " ^ Binding.print b ^ " contains top sort"));
87.847 +
87.848 + val seq = member (op =) opts Option_Sequential;
87.849 + val exhaustive = member (op =) opts Option_Exhaustive;
87.850 +
87.851 + val fun_names = map Binding.name_of bs;
87.852 + val basic_ctr_specss = map (basic_corec_specs_of lthy) res_Ts;
87.853 + val has_call = exists_subterm (map (fst #>> Binding.name_of #> Free) fixes |> member (op =));
87.854 + val eqns_data =
87.855 + fold_map2 (dissect_coeqn lthy seq has_call fun_names basic_ctr_specss) (map snd specs)
87.856 + maybe_of_specs []
87.857 + |> flat o fst;
87.858 +
87.859 + val callssss =
87.860 + map_filter (try (fn Sel x => x)) eqns_data
87.861 + |> partition_eq ((op =) o pairself #fun_name)
87.862 + |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names
87.863 + |> map (flat o snd)
87.864 + |> map2 (fold o find_corec_calls lthy has_call) basic_ctr_specss
87.865 + |> map2 (curry (op |>)) (map (map (fn {ctr, sels, ...} =>
87.866 + (ctr, map (K []) sels))) basic_ctr_specss);
87.867 +
87.868 +(*
87.869 +val _ = tracing ("callssss = " ^ @{make_string} callssss);
87.870 +*)
87.871 +
87.872 + val ((n2m, corec_specs', _, coinduct_thm, strong_coinduct_thm, coinduct_thms,
87.873 + strong_coinduct_thms), lthy') =
87.874 + corec_specs_of bs arg_Ts res_Ts (get_indices fixes) callssss lthy;
87.875 + val actual_nn = length bs;
87.876 + val corec_specs = take actual_nn corec_specs'; (*###*)
87.877 + val ctr_specss = map #ctr_specs corec_specs;
87.878 +
87.879 + val disc_eqnss' = map_filter (try (fn Disc x => x)) eqns_data
87.880 + |> partition_eq ((op =) o pairself #fun_name)
87.881 + |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names
87.882 + |> map (sort ((op <) o pairself #ctr_no |> make_ord) o flat o snd);
87.883 + val _ = disc_eqnss' |> map (fn x =>
87.884 + let val d = duplicates ((op =) o pairself #ctr_no) x in null d orelse
87.885 + primcorec_error_eqns "excess discriminator formula in definition"
87.886 + (maps (fn t => filter (equal (#ctr_no t) o #ctr_no) x) d |> map #user_eqn) end);
87.887 +
87.888 + val sel_eqnss = map_filter (try (fn Sel x => x)) eqns_data
87.889 + |> partition_eq ((op =) o pairself #fun_name)
87.890 + |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names
87.891 + |> map (flat o snd);
87.892 +
87.893 + val arg_Tss = map (binder_types o snd o fst) fixes;
87.894 + val disc_eqnss = map5 mk_real_disc_eqns bs arg_Tss corec_specs sel_eqnss disc_eqnss';
87.895 + val (defs, exclss') =
87.896 + build_codefs lthy' bs mxs has_call arg_Tss corec_specs disc_eqnss sel_eqnss;
87.897 +
87.898 + fun excl_tac (c, c', a) =
87.899 + if a orelse c = c' orelse seq then SOME (K (HEADGOAL (mk_primcorec_assumption_tac lthy [])))
87.900 + else maybe_tac;
87.901 +
87.902 +(*
87.903 +val _ = tracing ("exclusiveness properties:\n \<cdot> " ^
87.904 + space_implode "\n \<cdot> " (maps (map (Syntax.string_of_term lthy o snd)) exclss'));
87.905 +*)
87.906 +
87.907 + val exclss'' = exclss' |> map (map (fn (idx, t) =>
87.908 + (idx, (Option.map (Goal.prove lthy [] [] t #> Thm.close_derivation) (excl_tac idx), t))));
87.909 + val taut_thmss = map (map (apsnd (the o fst)) o filter (is_some o fst o snd)) exclss'';
87.910 + val (goal_idxss, goalss') = exclss''
87.911 + |> map (map (apsnd (rpair [] o snd)) o filter (is_none o fst o snd))
87.912 + |> split_list o map split_list;
87.913 +
87.914 + val exh_props = if not exhaustive then [] else
87.915 + map (HOLogic.mk_Trueprop o mk_disjs o map (mk_conjs o #prems)) disc_eqnss
87.916 + |> map2 ((fn {fun_args, ...} =>
87.917 + curry Logic.list_all (map dest_Free fun_args)) o hd) disc_eqnss;
87.918 + val exh_taut_thms = if exhaustive andalso is_some maybe_tac then
87.919 + map (fn t => Goal.prove lthy [] [] t (the maybe_tac) |> Thm.close_derivation) exh_props
87.920 + else [];
87.921 + val goalss = if exhaustive andalso is_none maybe_tac then
87.922 + map (rpair []) exh_props :: goalss' else goalss';
87.923 +
87.924 + fun prove thmss'' def_thms' lthy =
87.925 + let
87.926 + val def_thms = map (snd o snd) def_thms';
87.927 +
87.928 + val maybe_exh_thms = if exhaustive andalso is_none maybe_tac then
87.929 + map SOME (hd thmss'') else map (K NONE) def_thms;
87.930 + val thmss' = if exhaustive andalso is_none maybe_tac then tl thmss'' else thmss'';
87.931 +
87.932 + val exclss' = map (op ~~) (goal_idxss ~~ thmss');
87.933 + fun mk_exclsss excls n =
87.934 + (excls, map (fn k => replicate k [TrueI] @ replicate (n - k) []) (0 upto n - 1))
87.935 + |-> fold (fn ((c, c', _), thm) => nth_map c (nth_map c' (K [thm])));
87.936 + val exclssss = (exclss' ~~ taut_thmss |> map (op @), fun_names ~~ corec_specs)
87.937 + |-> map2 (fn excls => fn (_, {ctr_specs, ...}) => mk_exclsss excls (length ctr_specs));
87.938 +
87.939 + fun prove_disc ({ctr_specs, ...} : corec_spec) exclsss
87.940 + ({fun_name, fun_T, fun_args, ctr_no, prems, ...} : coeqn_data_disc) =
87.941 + if Term.aconv_untyped (#disc (nth ctr_specs ctr_no), @{term "\<lambda>x. x = x"}) then
87.942 + []
87.943 + else
87.944 + let
87.945 + val {disc_corec, ...} = nth ctr_specs ctr_no;
87.946 + val k = 1 + ctr_no;
87.947 + val m = length prems;
87.948 + val t =
87.949 + list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0))
87.950 + |> curry betapply (#disc (nth ctr_specs ctr_no)) (*###*)
87.951 + |> HOLogic.mk_Trueprop
87.952 + |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
87.953 + |> curry Logic.list_all (map dest_Free fun_args);
87.954 + in
87.955 + if prems = [@{term False}] then [] else
87.956 + mk_primcorec_disc_tac lthy def_thms disc_corec k m exclsss
87.957 + |> K |> Goal.prove lthy [] [] t
87.958 + |> Thm.close_derivation
87.959 + |> pair (#disc (nth ctr_specs ctr_no))
87.960 + |> single
87.961 + end;
87.962 +
87.963 + fun prove_sel ({nested_map_idents, nested_map_comps, ctr_specs, ...} : corec_spec)
87.964 + (disc_eqns : coeqn_data_disc list) exclsss
87.965 + ({fun_name, fun_T, fun_args, ctr, sel, rhs_term, ...} : coeqn_data_sel) =
87.966 + let
87.967 + val SOME ctr_spec = find_first (equal ctr o #ctr) ctr_specs;
87.968 + val ctr_no = find_index (equal ctr o #ctr) ctr_specs;
87.969 + val prems = the_default (maps (s_not_conj o #prems) disc_eqns)
87.970 + (find_first (equal ctr_no o #ctr_no) disc_eqns |> Option.map #prems);
87.971 + val sel_corec = find_index (equal sel) (#sels ctr_spec)
87.972 + |> nth (#sel_corecs ctr_spec);
87.973 + val k = 1 + ctr_no;
87.974 + val m = length prems;
87.975 + val t =
87.976 + list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0))
87.977 + |> curry betapply sel
87.978 + |> rpair (abstract (List.rev fun_args) rhs_term)
87.979 + |> HOLogic.mk_Trueprop o HOLogic.mk_eq
87.980 + |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
87.981 + |> curry Logic.list_all (map dest_Free fun_args);
87.982 + val (distincts, _, sel_splits, sel_split_asms) = case_thms_of_term lthy [] rhs_term;
87.983 + in
87.984 + mk_primcorec_sel_tac lthy def_thms distincts sel_splits sel_split_asms nested_map_idents
87.985 + nested_map_comps sel_corec k m exclsss
87.986 + |> K |> Goal.prove lthy [] [] t
87.987 + |> Thm.close_derivation
87.988 + |> pair sel
87.989 + end;
87.990 +
87.991 + fun prove_ctr disc_alist sel_alist (disc_eqns : coeqn_data_disc list)
87.992 + (sel_eqns : coeqn_data_sel list) ({ctr, disc, sels, collapse, ...} : corec_ctr_spec) =
87.993 + (* don't try to prove theorems when some sel_eqns are missing *)
87.994 + if not (exists (equal ctr o #ctr) disc_eqns)
87.995 + andalso not (exists (equal ctr o #ctr) sel_eqns)
87.996 + orelse
87.997 + filter (equal ctr o #ctr) sel_eqns
87.998 + |> fst o finds ((op =) o apsnd #sel) sels
87.999 + |> exists (null o snd)
87.1000 + then [] else
87.1001 + let
87.1002 + val (fun_name, fun_T, fun_args, prems, maybe_rhs) =
87.1003 + (find_first (equal ctr o #ctr) disc_eqns, find_first (equal ctr o #ctr) sel_eqns)
87.1004 + |>> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, #prems x,
87.1005 + #maybe_ctr_rhs x))
87.1006 + ||> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, [], NONE))
87.1007 + |> the o merge_options;
87.1008 + val m = length prems;
87.1009 + val t = (if is_some maybe_rhs then the maybe_rhs else
87.1010 + filter (equal ctr o #ctr) sel_eqns
87.1011 + |> fst o finds ((op =) o apsnd #sel) sels
87.1012 + |> map (snd #> (fn [x] => (List.rev (#fun_args x), #rhs_term x)) #-> abstract)
87.1013 + |> curry list_comb ctr)
87.1014 + |> curry HOLogic.mk_eq (list_comb (Free (fun_name, fun_T),
87.1015 + map Bound (length fun_args - 1 downto 0)))
87.1016 + |> HOLogic.mk_Trueprop
87.1017 + |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
87.1018 + |> curry Logic.list_all (map dest_Free fun_args);
87.1019 + val maybe_disc_thm = AList.lookup (op =) disc_alist disc;
87.1020 + val sel_thms = map snd (filter (member (op =) sels o fst) sel_alist);
87.1021 + in
87.1022 + if prems = [@{term False}] then [] else
87.1023 + mk_primcorec_ctr_of_dtr_tac lthy m collapse maybe_disc_thm sel_thms
87.1024 + |> K |> Goal.prove lthy [] [] t
87.1025 + |> Thm.close_derivation
87.1026 + |> pair ctr
87.1027 + |> single
87.1028 + end;
87.1029 +
87.1030 + fun prove_code disc_eqns sel_eqns maybe_exh ctr_alist ctr_specs =
87.1031 + let
87.1032 + val maybe_fun_data =
87.1033 + (find_first (member (op =) (map #ctr ctr_specs) o #ctr) disc_eqns,
87.1034 + find_first (member (op =) (map #ctr ctr_specs) o #ctr) sel_eqns)
87.1035 + |>> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, #maybe_code_rhs x))
87.1036 + ||> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, NONE))
87.1037 + |> merge_options;
87.1038 + in
87.1039 + (case maybe_fun_data of
87.1040 + NONE => []
87.1041 + | SOME (fun_name, fun_T, fun_args, maybe_rhs) =>
87.1042 + let
87.1043 + val bound_Ts = List.rev (map fastype_of fun_args);
87.1044 +
87.1045 + val lhs =
87.1046 + list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0));
87.1047 + val maybe_rhs_info =
87.1048 + (case maybe_rhs of
87.1049 + SOME rhs =>
87.1050 + let
87.1051 + val raw_rhs = expand_corec_code_rhs lthy has_call bound_Ts rhs;
87.1052 + val cond_ctrs =
87.1053 + fold_rev_corec_code_rhs lthy (K oo (cons oo pair)) bound_Ts raw_rhs [];
87.1054 + val ctr_thms = map (the o AList.lookup (op =) ctr_alist o snd) cond_ctrs;
87.1055 + in SOME (rhs, raw_rhs, ctr_thms) end
87.1056 + | NONE =>
87.1057 + let
87.1058 + fun prove_code_ctr {ctr, sels, ...} =
87.1059 + if not (exists (equal ctr o fst) ctr_alist) then NONE else
87.1060 + let
87.1061 + val prems = find_first (equal ctr o #ctr) disc_eqns
87.1062 + |> Option.map #prems |> the_default [];
87.1063 + val t =
87.1064 + filter (equal ctr o #ctr) sel_eqns
87.1065 + |> fst o finds ((op =) o apsnd #sel) sels
87.1066 + |> map (snd #> (fn [x] => (List.rev (#fun_args x), #rhs_term x))
87.1067 + #-> abstract)
87.1068 + |> curry list_comb ctr;
87.1069 + in
87.1070 + SOME (prems, t)
87.1071 + end;
87.1072 + val maybe_ctr_conds_argss = map prove_code_ctr ctr_specs;
87.1073 + in
87.1074 + let
87.1075 + val rhs = (if exhaustive
87.1076 + orelse forall is_some maybe_ctr_conds_argss
87.1077 + andalso exists #auto_gen disc_eqns then
87.1078 + split_last (map_filter I maybe_ctr_conds_argss) ||> snd
87.1079 + else
87.1080 + Const (@{const_name Code.abort}, @{typ String.literal} -->
87.1081 + (@{typ unit} --> body_type fun_T) --> body_type fun_T) $
87.1082 + HOLogic.mk_literal fun_name $
87.1083 + absdummy @{typ unit} (incr_boundvars 1 lhs)
87.1084 + |> pair (map_filter I maybe_ctr_conds_argss))
87.1085 + |-> fold_rev (fn (prems, u) => mk_If (s_conjs prems) u)
87.1086 + in SOME (rhs, rhs, map snd ctr_alist) end
87.1087 + end);
87.1088 + in
87.1089 + (case maybe_rhs_info of
87.1090 + NONE => []
87.1091 + | SOME (rhs, raw_rhs, ctr_thms) =>
87.1092 + let
87.1093 + val ms = map (Logic.count_prems o prop_of) ctr_thms;
87.1094 + val (raw_t, t) = (raw_rhs, rhs)
87.1095 + |> pairself
87.1096 + (curry HOLogic.mk_eq (list_comb (Free (fun_name, fun_T),
87.1097 + map Bound (length fun_args - 1 downto 0)))
87.1098 + #> HOLogic.mk_Trueprop
87.1099 + #> curry Logic.list_all (map dest_Free fun_args));
87.1100 + val (distincts, discIs, sel_splits, sel_split_asms) =
87.1101 + case_thms_of_term lthy bound_Ts raw_rhs;
87.1102 +
87.1103 + val raw_code_thm = mk_primcorec_raw_code_of_ctr_tac lthy distincts discIs
87.1104 + sel_splits sel_split_asms ms ctr_thms maybe_exh
87.1105 + |> K |> Goal.prove lthy [] [] raw_t
87.1106 + |> Thm.close_derivation;
87.1107 + in
87.1108 + mk_primcorec_code_of_raw_code_tac lthy distincts sel_splits raw_code_thm
87.1109 + |> K |> Goal.prove lthy [] [] t
87.1110 + |> Thm.close_derivation
87.1111 + |> single
87.1112 + end)
87.1113 + end)
87.1114 + end;
87.1115 +
87.1116 + val disc_alists = map3 (maps oo prove_disc) corec_specs exclssss disc_eqnss;
87.1117 + val sel_alists = map4 (map ooo prove_sel) corec_specs disc_eqnss exclssss sel_eqnss;
87.1118 + val disc_thmss = map (map snd) disc_alists;
87.1119 + val sel_thmss = map (map snd) sel_alists;
87.1120 +
87.1121 + val ctr_alists = map5 (maps oooo prove_ctr) disc_alists sel_alists disc_eqnss sel_eqnss
87.1122 + ctr_specss;
87.1123 + val ctr_thmss = map (map snd) ctr_alists;
87.1124 +
87.1125 + val code_thmss = map5 prove_code disc_eqnss sel_eqnss maybe_exh_thms ctr_alists ctr_specss;
87.1126 +
87.1127 + val simp_thmss = map2 append disc_thmss sel_thmss
87.1128 +
87.1129 + val common_name = mk_common_name fun_names;
87.1130 +
87.1131 + val notes =
87.1132 + [(coinductN, map (if n2m then single else K []) coinduct_thms, []),
87.1133 + (codeN, code_thmss, code_nitpicksimp_attrs),
87.1134 + (ctrN, ctr_thmss, []),
87.1135 + (discN, disc_thmss, simp_attrs),
87.1136 + (selN, sel_thmss, simp_attrs),
87.1137 + (simpsN, simp_thmss, []),
87.1138 + (strong_coinductN, map (if n2m then single else K []) strong_coinduct_thms, [])]
87.1139 + |> maps (fn (thmN, thmss, attrs) =>
87.1140 + map2 (fn fun_name => fn thms =>
87.1141 + ((Binding.qualify true fun_name (Binding.name thmN), attrs), [(thms, [])]))
87.1142 + fun_names (take actual_nn thmss))
87.1143 + |> filter_out (null o fst o hd o snd);
87.1144 +
87.1145 + val common_notes =
87.1146 + [(coinductN, if n2m then [coinduct_thm] else [], []),
87.1147 + (strong_coinductN, if n2m then [strong_coinduct_thm] else [], [])]
87.1148 + |> filter_out (null o #2)
87.1149 + |> map (fn (thmN, thms, attrs) =>
87.1150 + ((Binding.qualify true common_name (Binding.name thmN), attrs), [(thms, [])]));
87.1151 + in
87.1152 + lthy |> Local_Theory.notes (notes @ common_notes) |> snd
87.1153 + end;
87.1154 +
87.1155 + fun after_qed thmss' = fold_map Local_Theory.define defs #-> prove thmss';
87.1156 + in
87.1157 + (goalss, after_qed, lthy')
87.1158 + end;
87.1159 +
87.1160 +fun add_primcorec_ursive_cmd maybe_tac opts (raw_fixes, raw_specs') lthy =
87.1161 + let
87.1162 + val (raw_specs, maybe_of_specs) =
87.1163 + split_list raw_specs' ||> map (Option.map (Syntax.read_term lthy));
87.1164 + val ((fixes, specs), _) = Specification.read_spec raw_fixes raw_specs lthy;
87.1165 + in
87.1166 + add_primcorec_ursive maybe_tac opts fixes specs maybe_of_specs lthy
87.1167 + handle ERROR str => primcorec_error str
87.1168 + end
87.1169 + handle Primcorec_Error (str, eqns) =>
87.1170 + if null eqns
87.1171 + then error ("primcorec error:\n " ^ str)
87.1172 + else error ("primcorec error:\n " ^ str ^ "\nin\n " ^
87.1173 + space_implode "\n " (map (quote o Syntax.string_of_term lthy) eqns));
87.1174 +
87.1175 +val add_primcorecursive_cmd = (fn (goalss, after_qed, lthy) =>
87.1176 + lthy
87.1177 + |> Proof.theorem NONE after_qed goalss
87.1178 + |> Proof.refine (Method.primitive_text I)
87.1179 + |> Seq.hd) ooo add_primcorec_ursive_cmd NONE;
87.1180 +
87.1181 +val add_primcorec_cmd = (fn (goalss, after_qed, lthy) =>
87.1182 + lthy
87.1183 + |> after_qed (map (fn [] => []
87.1184 + | _ => primcorec_error "need exclusiveness proofs - use primcorecursive instead of primcorec")
87.1185 + goalss)) ooo add_primcorec_ursive_cmd (SOME (fn {context = ctxt, ...} => auto_tac ctxt));
87.1186 +
87.1187 +end;
88.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
88.2 +++ b/src/HOL/BNF/Tools/bnf_gfp_rec_sugar_tactics.ML Thu Dec 05 17:58:03 2013 +0100
88.3 @@ -0,0 +1,136 @@
88.4 +(* Title: HOL/BNF/Tools/bnf_gfp_rec_sugar_tactics.ML
88.5 + Author: Jasmin Blanchette, TU Muenchen
88.6 + Copyright 2013
88.7 +
88.8 +Tactics for corecursor sugar.
88.9 +*)
88.10 +
88.11 +signature BNF_GFP_REC_SUGAR_TACTICS =
88.12 +sig
88.13 + val mk_primcorec_assumption_tac: Proof.context -> thm list -> int -> tactic
88.14 + val mk_primcorec_code_of_raw_code_tac: Proof.context -> thm list -> thm list -> thm -> tactic
88.15 + val mk_primcorec_ctr_of_dtr_tac: Proof.context -> int -> thm -> thm option -> thm list -> tactic
88.16 + val mk_primcorec_disc_tac: Proof.context -> thm list -> thm -> int -> int -> thm list list list ->
88.17 + tactic
88.18 + val mk_primcorec_raw_code_of_ctr_tac: Proof.context -> thm list -> thm list -> thm list ->
88.19 + thm list -> int list -> thm list -> thm option -> tactic
88.20 + val mk_primcorec_sel_tac: Proof.context -> thm list -> thm list -> thm list -> thm list ->
88.21 + thm list -> thm list -> thm -> int -> int -> thm list list list -> tactic
88.22 +end;
88.23 +
88.24 +structure BNF_GFP_Rec_Sugar_Tactics : BNF_GFP_REC_SUGAR_TACTICS =
88.25 +struct
88.26 +
88.27 +open BNF_Util
88.28 +open BNF_Tactics
88.29 +
88.30 +val falseEs = @{thms not_TrueE FalseE};
88.31 +val Let_def = @{thm Let_def};
88.32 +val neq_eq_eq_contradict = @{thm neq_eq_eq_contradict};
88.33 +val split_if = @{thm split_if};
88.34 +val split_if_asm = @{thm split_if_asm};
88.35 +val split_connectI = @{thms allI impI conjI};
88.36 +
88.37 +fun mk_primcorec_assumption_tac ctxt discIs =
88.38 + SELECT_GOAL (unfold_thms_tac ctxt
88.39 + @{thms not_not not_False_eq_True not_True_eq_False de_Morgan_conj de_Morgan_disj} THEN
88.40 + SOLVE (HEADGOAL (REPEAT o (rtac refl ORELSE' atac ORELSE' etac conjE ORELSE'
88.41 + eresolve_tac falseEs ORELSE'
88.42 + resolve_tac @{thms TrueI conjI disjI1 disjI2} ORELSE'
88.43 + dresolve_tac discIs THEN' atac ORELSE'
88.44 + etac notE THEN' atac ORELSE'
88.45 + etac disjE))));
88.46 +
88.47 +fun mk_primcorec_same_case_tac m =
88.48 + HEADGOAL (if m = 0 then rtac TrueI
88.49 + else REPEAT_DETERM_N (m - 1) o (rtac conjI THEN' atac) THEN' atac);
88.50 +
88.51 +fun mk_primcorec_different_case_tac ctxt m excl =
88.52 + HEADGOAL (if m = 0 then mk_primcorec_assumption_tac ctxt []
88.53 + else dtac excl THEN' (REPEAT_DETERM_N (m - 1) o atac) THEN' mk_primcorec_assumption_tac ctxt []);
88.54 +
88.55 +fun mk_primcorec_cases_tac ctxt k m exclsss =
88.56 + let val n = length exclsss in
88.57 + EVERY (map (fn [] => if k = n then all_tac else mk_primcorec_same_case_tac m
88.58 + | [excl] => mk_primcorec_different_case_tac ctxt m excl)
88.59 + (take k (nth exclsss (k - 1))))
88.60 + end;
88.61 +
88.62 +fun mk_primcorec_prelude ctxt defs thm =
88.63 + unfold_thms_tac ctxt defs THEN HEADGOAL (rtac thm) THEN
88.64 + unfold_thms_tac ctxt @{thms Let_def split};
88.65 +
88.66 +fun mk_primcorec_disc_tac ctxt defs disc_corec k m exclsss =
88.67 + mk_primcorec_prelude ctxt defs disc_corec THEN mk_primcorec_cases_tac ctxt k m exclsss;
88.68 +
88.69 +fun mk_primcorec_sel_tac ctxt defs distincts splits split_asms map_idents map_comps f_sel k m
88.70 + exclsss =
88.71 + mk_primcorec_prelude ctxt defs (f_sel RS trans) THEN
88.72 + mk_primcorec_cases_tac ctxt k m exclsss THEN
88.73 + HEADGOAL (REPEAT_DETERM o (rtac refl ORELSE' rtac ext ORELSE'
88.74 + eresolve_tac falseEs ORELSE'
88.75 + resolve_tac split_connectI ORELSE'
88.76 + Splitter.split_asm_tac (split_if_asm :: split_asms) ORELSE'
88.77 + Splitter.split_tac (split_if :: splits) ORELSE'
88.78 + eresolve_tac (map (fn thm => thm RS neq_eq_eq_contradict) distincts) THEN' atac ORELSE'
88.79 + etac notE THEN' atac ORELSE'
88.80 + (CHANGED o SELECT_GOAL (unfold_thms_tac ctxt
88.81 + (@{thms id_def o_def split_def sum.cases} @ map_comps @ map_idents)))));
88.82 +
88.83 +fun mk_primcorec_ctr_of_dtr_tac ctxt m collapse maybe_disc_f sel_fs =
88.84 + HEADGOAL (rtac ((if null sel_fs then collapse else collapse RS sym) RS trans) THEN'
88.85 + (the_default (K all_tac) (Option.map rtac maybe_disc_f)) THEN' REPEAT_DETERM_N m o atac) THEN
88.86 + unfold_thms_tac ctxt (Let_def :: sel_fs) THEN HEADGOAL (rtac refl);
88.87 +
88.88 +fun inst_split_eq ctxt split =
88.89 + (case prop_of split of
88.90 + @{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ (Var (_, Type (_, [T, _])) $ _) $ _) =>
88.91 + let
88.92 + val s = Name.uu;
88.93 + val eq = Abs (Name.uu, T, HOLogic.mk_eq (Free (s, T), Bound 0));
88.94 + val split' = Drule.instantiate' [] [SOME (certify ctxt eq)] split;
88.95 + in
88.96 + Thm.generalize ([], [s]) (Thm.maxidx_of split' + 1) split'
88.97 + end
88.98 + | _ => split);
88.99 +
88.100 +fun distinct_in_prems_tac distincts =
88.101 + eresolve_tac (map (fn thm => thm RS neq_eq_eq_contradict) distincts) THEN' atac;
88.102 +
88.103 +(* TODO: reduce code duplication with selector tactic above *)
88.104 +fun mk_primcorec_raw_code_of_ctr_single_tac ctxt distincts discIs splits split_asms m f_ctr =
88.105 + let
88.106 + val splits' =
88.107 + map (fn th => th RS iffD2) (@{thm split_if_eq2} :: map (inst_split_eq ctxt) splits)
88.108 + in
88.109 + HEADGOAL (REPEAT o (resolve_tac (splits' @ split_connectI))) THEN
88.110 + mk_primcorec_prelude ctxt [] (f_ctr RS trans) THEN
88.111 + HEADGOAL ((REPEAT_DETERM_N m o mk_primcorec_assumption_tac ctxt discIs) THEN'
88.112 + SELECT_GOAL (SOLVE (HEADGOAL (REPEAT_DETERM o
88.113 + (rtac refl ORELSE' atac ORELSE'
88.114 + resolve_tac (@{thm Code.abort_def} :: split_connectI) ORELSE'
88.115 + Splitter.split_tac (split_if :: splits) ORELSE'
88.116 + Splitter.split_asm_tac (split_if_asm :: split_asms) ORELSE'
88.117 + mk_primcorec_assumption_tac ctxt discIs ORELSE'
88.118 + distinct_in_prems_tac distincts ORELSE'
88.119 + (TRY o dresolve_tac discIs) THEN' etac notE THEN' atac)))))
88.120 + end;
88.121 +
88.122 +(* TODO: implement "exhaustive" (maybe_exh) *)
88.123 +fun mk_primcorec_raw_code_of_ctr_tac ctxt distincts discIs splits split_asms ms f_ctrs maybe_exh =
88.124 + EVERY (map2 (mk_primcorec_raw_code_of_ctr_single_tac ctxt distincts discIs splits split_asms) ms
88.125 + f_ctrs) THEN
88.126 + IF_UNSOLVED (unfold_thms_tac ctxt @{thms Code.abort_def} THEN
88.127 + HEADGOAL (REPEAT_DETERM o resolve_tac (refl :: split_connectI)));
88.128 +
88.129 +fun mk_primcorec_code_of_raw_code_tac ctxt distincts splits raw =
88.130 + HEADGOAL (rtac raw ORELSE' rtac (raw RS trans) THEN'
88.131 + SELECT_GOAL (unfold_thms_tac ctxt [Let_def]) THEN' REPEAT_DETERM o
88.132 + (rtac refl ORELSE' atac ORELSE'
88.133 + resolve_tac split_connectI ORELSE'
88.134 + Splitter.split_tac (split_if :: splits) ORELSE'
88.135 + distinct_in_prems_tac distincts ORELSE'
88.136 + rtac sym THEN' atac ORELSE'
88.137 + etac notE THEN' atac));
88.138 +
88.139 +end;
89.1 --- a/src/HOL/BNF/Tools/bnf_lfp.ML Thu Dec 05 17:52:12 2013 +0100
89.2 +++ b/src/HOL/BNF/Tools/bnf_lfp.ML Thu Dec 05 17:58:03 2013 +0100
89.3 @@ -22,12 +22,12 @@
89.4 open BNF_Comp
89.5 open BNF_FP_Util
89.6 open BNF_FP_Def_Sugar
89.7 -open BNF_FP_Rec_Sugar
89.8 +open BNF_LFP_Rec_Sugar
89.9 open BNF_LFP_Util
89.10 open BNF_LFP_Tactics
89.11
89.12 (*all BNFs have the same lives*)
89.13 -fun construct_lfp mixfixes map_bs rel_bs set_bss bs resBs (resDs, Dss) bnfs lthy =
89.14 +fun construct_lfp mixfixes map_bs rel_bs set_bss0 bs resBs (resDs, Dss) bnfs lthy =
89.15 let
89.16 val time = time lthy;
89.17 val timer = time (Timer.startRealTimer ());
89.18 @@ -44,7 +44,7 @@
89.19 val mk_internal_b = Binding.name #> Binding.prefix true b_name #> Binding.conceal;
89.20 fun mk_internal_bs name =
89.21 map (fn b =>
89.22 - Binding.prefix true b_name (Binding.suffix_name ("_" ^ name) b) |> Binding.conceal) bs;
89.23 + Binding.prefix true b_name (Binding.prefix_name (name ^ "_") b) |> Binding.conceal) bs;
89.24 val external_bs = map2 (Binding.prefix false) b_names bs
89.25 |> note_all = false ? map Binding.conceal;
89.26
89.27 @@ -1021,7 +1021,7 @@
89.28 val phis = map2 retype_free (map mk_pred1T Ts) init_phis;
89.29 val phi2s = map2 retype_free (map2 mk_pred2T Ts Ts') init_phis;
89.30
89.31 - fun ctor_bind i = nth external_bs (i - 1) |> Binding.suffix_name ("_" ^ ctorN);
89.32 + fun ctor_bind i = nth external_bs (i - 1) |> Binding.prefix_name (ctorN ^ "_");
89.33 val ctor_name = Binding.name_of o ctor_bind;
89.34 val ctor_def_bind = rpair [] o Binding.conceal o Thm.def_binding o ctor_bind;
89.35
89.36 @@ -1080,7 +1080,7 @@
89.37 (mk_mor UNIVs ctors active_UNIVs ss (map (mk_nthN n fold_f) ks));
89.38 val foldx = HOLogic.choice_const foldT $ fold_fun;
89.39
89.40 - fun fold_bind i = nth external_bs (i - 1) |> Binding.suffix_name ("_" ^ ctor_foldN);
89.41 + fun fold_bind i = nth external_bs (i - 1) |> Binding.prefix_name (ctor_foldN ^ "_");
89.42 val fold_name = Binding.name_of o fold_bind;
89.43 val fold_def_bind = rpair [] o Binding.conceal o Thm.def_binding o fold_bind;
89.44
89.45 @@ -1170,7 +1170,7 @@
89.46 Term.list_comb (mk_map_of_bnf Ds (passiveAs @ FTs) (passiveAs @ Ts) bnf,
89.47 map HOLogic.id_const passiveAs @ ctors)) Dss bnfs;
89.48
89.49 - fun dtor_bind i = nth external_bs (i - 1) |> Binding.suffix_name ("_" ^ dtorN);
89.50 + fun dtor_bind i = nth external_bs (i - 1) |> Binding.prefix_name (dtorN ^ "_");
89.51 val dtor_name = Binding.name_of o dtor_bind;
89.52 val dtor_def_bind = rpair [] o Binding.conceal o Thm.def_binding o dtor_bind;
89.53
89.54 @@ -1243,7 +1243,7 @@
89.55 trans OF [mor RS unique, fold_ctor]) fold_unique_mor_thms fold_ctor_thms
89.56 end;
89.57
89.58 - fun rec_bind i = nth external_bs (i - 1) |> Binding.suffix_name ("_" ^ ctor_recN);
89.59 + fun rec_bind i = nth external_bs (i - 1) |> Binding.prefix_name (ctor_recN ^ "_");
89.60 val rec_name = Binding.name_of o rec_bind;
89.61 val rec_def_bind = rpair [] o Binding.conceal o Thm.def_binding o rec_bind;
89.62
89.63 @@ -1354,7 +1354,7 @@
89.64 val cTs = map (SOME o certifyT lthy o TFree) induct_params;
89.65
89.66 val weak_ctor_induct_thms =
89.67 - let fun insts i = (replicate (i - 1) TrueI) @ (@{thm asm_rl} :: replicate (n - i) TrueI);
89.68 + let fun insts i = (replicate (i - 1) TrueI) @ (asm_rl :: replicate (n - i) TrueI);
89.69 in map (fn i => (ctor_induct_thm OF insts i) RS mk_conjunctN n i) ks end;
89.70
89.71 val (ctor_induct2_thm, induct2_params) =
89.72 @@ -1744,12 +1744,16 @@
89.73 fun wit_tac {context = ctxt, prems = _} =
89.74 mk_wit_tac ctxt n (flat ctor_set_thmss) (maps wit_thms_of_bnf bnfs);
89.75
89.76 + val set_bss =
89.77 + map (flat o map2 (fn B => fn b =>
89.78 + if member (op =) resDs (TFree B) then [] else [b]) resBs) set_bss0;
89.79 +
89.80 val (Ibnfs, lthy) =
89.81 fold_map9 (fn tacs => fn b => fn map_b => fn rel_b => fn set_bs => fn mapx => fn sets =>
89.82 fn T => fn wits => fn lthy =>
89.83 bnf_def Dont_Inline (user_policy Note_Some) I tacs wit_tac (SOME deads)
89.84 map_b rel_b set_bs
89.85 - (((((b, fold_rev Term.absfree fs' mapx), sets), absdummy T bd), wits), NONE)
89.86 + ((((((b, T), fold_rev Term.absfree fs' mapx), sets), bd), wits), NONE)
89.87 lthy
89.88 |> register_bnf (Local_Theory.full_name lthy b))
89.89 tacss bs map_bs rel_bs set_bss fs_maps setss_by_bnf Ts ctor_witss lthy;
90.1 --- a/src/HOL/BNF/Tools/bnf_lfp_compat.ML Thu Dec 05 17:52:12 2013 +0100
90.2 +++ b/src/HOL/BNF/Tools/bnf_lfp_compat.ML Thu Dec 05 17:58:03 2013 +0100
90.3 @@ -49,7 +49,7 @@
90.4 SOME (fp_sugar as {fp = Least_FP, ...}) => fp_sugar
90.5 | _ => not_datatype s);
90.6
90.7 - val fp_sugar0 as {fp_res = {Ts = fpTs0, ...}, ...} = lfp_sugar_of fpT_name1;
90.8 + val {fp_res = {Ts = fpTs0, ...}, ...} = lfp_sugar_of fpT_name1;
90.9 val fpT_names' = map (fst o dest_Type) fpTs0;
90.10
90.11 val _ = eq_set (op =) (fpT_names, fpT_names') orelse not_mutually_recursive fpT_names;
90.12 @@ -57,8 +57,10 @@
90.13 val fpTs as fpT1 :: _ = map (fn s => Type (s, As)) fpT_names';
90.14
90.15 fun add_nested_types_of (T as Type (s, _)) seen =
90.16 - if member (op =) seen T orelse s = @{type_name fun} then
90.17 + if member (op =) seen T then
90.18 seen
90.19 + else if s = @{type_name fun} then
90.20 + (warning "Partial support for recursion through functions -- 'primrec' will fail"; seen)
90.21 else
90.22 (case try lfp_sugar_of s of
90.23 SOME ({T = T0, fp_res = {Ts = mutual_Ts0, ...}, ctr_sugars, ...}) =>
90.24 @@ -80,7 +82,7 @@
90.25 fold add_nested_types_of subTs (seen @ mutual_Ts)
90.26 end
90.27 | NONE => error ("Unsupported recursion via type constructor " ^ quote s ^
90.28 - " not associated with new-style datatype (cf. \"datatype_new\")"));
90.29 + " not corresponding to new-style datatype (cf. \"datatype_new\")"));
90.30
90.31 val Ts = add_nested_types_of fpT1 [];
90.32 val b_names = map base_name_of_typ Ts;
90.33 @@ -90,26 +92,26 @@
90.34 val nn_fp = length fpTs;
90.35 val nn = length Ts;
90.36 val get_indices = K [];
90.37 - val fp_sugars0 = if nn = 1 then [fp_sugar0] else map (lfp_sugar_of o fst o dest_Type) Ts;
90.38 - val callssss = pad_and_indexify_calls fp_sugars0 nn [];
90.39 - val has_nested = nn > nn_fp;
90.40 + val fp_sugars0 = map (lfp_sugar_of o fst o dest_Type) Ts;
90.41 + val callssss = map (fn fp_sugar0 => indexify_callsss fp_sugar0 []) fp_sugars0;
90.42
90.43 val ((fp_sugars, (lfp_sugar_thms, _)), lthy) =
90.44 - mutualize_fp_sugars has_nested Least_FP compat_bs Ts get_indices callssss fp_sugars0 lthy;
90.45 + if nn > nn_fp then
90.46 + mutualize_fp_sugars Least_FP compat_bs Ts get_indices callssss fp_sugars0 lthy
90.47 + else
90.48 + ((fp_sugars0, (NONE, NONE)), lthy);
90.49
90.50 val {ctr_sugars, co_inducts = [induct], co_iterss, co_iter_thmsss = iter_thmsss, ...} :: _ =
90.51 fp_sugars;
90.52 val inducts = conj_dests nn induct;
90.53
90.54 - val frozen_Ts = map Type.legacy_freeze_type Ts;
90.55 - val mk_dtyp = dtyp_of_typ frozen_Ts;
90.56 + val mk_dtyp = dtyp_of_typ Ts;
90.57
90.58 - fun mk_ctr_descr (Const (s, T)) =
90.59 - (s, map mk_dtyp (binder_types (Type.legacy_freeze_type T)));
90.60 + fun mk_ctr_descr Ts = mk_ctr Ts #> dest_Const ##> (binder_types #> map mk_dtyp);
90.61 fun mk_typ_descr index (Type (T_name, Ts)) ({ctrs, ...} : ctr_sugar) =
90.62 - (index, (T_name, map mk_dtyp Ts, map mk_ctr_descr ctrs));
90.63 + (index, (T_name, map mk_dtyp Ts, map (mk_ctr_descr Ts) ctrs));
90.64
90.65 - val descr = map3 mk_typ_descr (0 upto nn - 1) frozen_Ts ctr_sugars;
90.66 + val descr = map3 mk_typ_descr (0 upto nn - 1) Ts ctr_sugars;
90.67 val recs = map (fst o dest_Const o co_rec_of) co_iterss;
90.68 val rec_thms = flat (map co_rec_of iter_thmsss);
90.69
91.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
91.2 +++ b/src/HOL/BNF/Tools/bnf_lfp_rec_sugar.ML Thu Dec 05 17:58:03 2013 +0100
91.3 @@ -0,0 +1,604 @@
91.4 +(* Title: HOL/BNF/Tools/bnf_lfp_rec_sugar.ML
91.5 + Author: Lorenz Panny, TU Muenchen
91.6 + Author: Jasmin Blanchette, TU Muenchen
91.7 + Copyright 2013
91.8 +
91.9 +Recursor sugar.
91.10 +*)
91.11 +
91.12 +signature BNF_LFP_REC_SUGAR =
91.13 +sig
91.14 + val add_primrec: (binding * typ option * mixfix) list ->
91.15 + (Attrib.binding * term) list -> local_theory -> (term list * thm list list) * local_theory
91.16 + val add_primrec_cmd: (binding * string option * mixfix) list ->
91.17 + (Attrib.binding * string) list -> local_theory -> (term list * thm list list) * local_theory
91.18 + val add_primrec_global: (binding * typ option * mixfix) list ->
91.19 + (Attrib.binding * term) list -> theory -> (term list * thm list list) * theory
91.20 + val add_primrec_overloaded: (string * (string * typ) * bool) list ->
91.21 + (binding * typ option * mixfix) list ->
91.22 + (Attrib.binding * term) list -> theory -> (term list * thm list list) * theory
91.23 + val add_primrec_simple: ((binding * typ) * mixfix) list -> term list ->
91.24 + local_theory -> (string list * (term list * (int list list * thm list list))) * local_theory
91.25 +end;
91.26 +
91.27 +structure BNF_LFP_Rec_Sugar : BNF_LFP_REC_SUGAR =
91.28 +struct
91.29 +
91.30 +open Ctr_Sugar
91.31 +open BNF_Util
91.32 +open BNF_Tactics
91.33 +open BNF_Def
91.34 +open BNF_FP_Util
91.35 +open BNF_FP_Def_Sugar
91.36 +open BNF_FP_N2M_Sugar
91.37 +open BNF_FP_Rec_Sugar_Util
91.38 +
91.39 +val nitpicksimp_attrs = @{attributes [nitpick_simp]};
91.40 +val simp_attrs = @{attributes [simp]};
91.41 +val code_nitpicksimp_simp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs @ simp_attrs;
91.42 +
91.43 +exception Primrec_Error of string * term list;
91.44 +
91.45 +fun primrec_error str = raise Primrec_Error (str, []);
91.46 +fun primrec_error_eqn str eqn = raise Primrec_Error (str, [eqn]);
91.47 +fun primrec_error_eqns str eqns = raise Primrec_Error (str, eqns);
91.48 +
91.49 +datatype rec_call =
91.50 + No_Rec of int * typ |
91.51 + Mutual_Rec of (int * typ) * (int * typ) |
91.52 + Nested_Rec of int * typ;
91.53 +
91.54 +type rec_ctr_spec =
91.55 + {ctr: term,
91.56 + offset: int,
91.57 + calls: rec_call list,
91.58 + rec_thm: thm};
91.59 +
91.60 +type rec_spec =
91.61 + {recx: term,
91.62 + nested_map_idents: thm list,
91.63 + nested_map_comps: thm list,
91.64 + ctr_specs: rec_ctr_spec list};
91.65 +
91.66 +exception AINT_NO_MAP of term;
91.67 +
91.68 +fun ill_formed_rec_call ctxt t =
91.69 + error ("Ill-formed recursive call: " ^ quote (Syntax.string_of_term ctxt t));
91.70 +fun invalid_map ctxt t =
91.71 + error ("Invalid map function in " ^ quote (Syntax.string_of_term ctxt t));
91.72 +fun unexpected_rec_call ctxt t =
91.73 + error ("Unexpected recursive call: " ^ quote (Syntax.string_of_term ctxt t));
91.74 +
91.75 +fun massage_nested_rec_call ctxt has_call raw_massage_fun bound_Ts y y' =
91.76 + let
91.77 + fun check_no_call t = if has_call t then unexpected_rec_call ctxt t else ();
91.78 +
91.79 + val typof = curry fastype_of1 bound_Ts;
91.80 + val build_map_fst = build_map ctxt (fst_const o fst);
91.81 +
91.82 + val yT = typof y;
91.83 + val yU = typof y';
91.84 +
91.85 + fun y_of_y' () = build_map_fst (yU, yT) $ y';
91.86 + val elim_y = Term.map_aterms (fn t => if t = y then y_of_y' () else t);
91.87 +
91.88 + fun massage_mutual_fun U T t =
91.89 + (case t of
91.90 + Const (@{const_name comp}, _) $ t1 $ t2 =>
91.91 + mk_comp bound_Ts (tap check_no_call t1, massage_mutual_fun U T t2)
91.92 + | _ =>
91.93 + if has_call t then
91.94 + (case try HOLogic.dest_prodT U of
91.95 + SOME (U1, U2) => if U1 = T then raw_massage_fun T U2 t else invalid_map ctxt t
91.96 + | NONE => invalid_map ctxt t)
91.97 + else
91.98 + mk_comp bound_Ts (t, build_map_fst (U, T)));
91.99 +
91.100 + fun massage_map (Type (_, Us)) (Type (s, Ts)) t =
91.101 + (case try (dest_map ctxt s) t of
91.102 + SOME (map0, fs) =>
91.103 + let
91.104 + val Type (_, ran_Ts) = range_type (typof t);
91.105 + val map' = mk_map (length fs) Us ran_Ts map0;
91.106 + val fs' = map_flattened_map_args ctxt s (map3 massage_map_or_map_arg Us Ts) fs;
91.107 + in
91.108 + Term.list_comb (map', fs')
91.109 + end
91.110 + | NONE => raise AINT_NO_MAP t)
91.111 + | massage_map _ _ t = raise AINT_NO_MAP t
91.112 + and massage_map_or_map_arg U T t =
91.113 + if T = U then
91.114 + tap check_no_call t
91.115 + else
91.116 + massage_map U T t
91.117 + handle AINT_NO_MAP _ => massage_mutual_fun U T t;
91.118 +
91.119 + fun massage_call (t as t1 $ t2) =
91.120 + if has_call t then
91.121 + if t2 = y then
91.122 + massage_map yU yT (elim_y t1) $ y'
91.123 + handle AINT_NO_MAP t' => invalid_map ctxt t'
91.124 + else
91.125 + let val (g, xs) = Term.strip_comb t2 in
91.126 + if g = y then
91.127 + if exists has_call xs then unexpected_rec_call ctxt t2
91.128 + else Term.list_comb (massage_call (mk_compN (length xs) bound_Ts (t1, y)), xs)
91.129 + else
91.130 + ill_formed_rec_call ctxt t
91.131 + end
91.132 + else
91.133 + elim_y t
91.134 + | massage_call t = if t = y then y_of_y' () else ill_formed_rec_call ctxt t;
91.135 + in
91.136 + massage_call
91.137 + end;
91.138 +
91.139 +fun rec_specs_of bs arg_Ts res_Ts get_indices callssss0 lthy =
91.140 + let
91.141 + val thy = Proof_Context.theory_of lthy;
91.142 +
91.143 + val ((missing_arg_Ts, perm0_kks,
91.144 + fp_sugars as {nested_bnfs, fp_res = {xtor_co_iterss = ctor_iters1 :: _, ...},
91.145 + co_inducts = [induct_thm], ...} :: _, (lfp_sugar_thms, _)), lthy') =
91.146 + nested_to_mutual_fps Least_FP bs arg_Ts get_indices callssss0 lthy;
91.147 +
91.148 + val perm_fp_sugars = sort (int_ord o pairself #index) fp_sugars;
91.149 +
91.150 + val indices = map #index fp_sugars;
91.151 + val perm_indices = map #index perm_fp_sugars;
91.152 +
91.153 + val perm_ctrss = map (#ctrs o of_fp_sugar #ctr_sugars) perm_fp_sugars;
91.154 + val perm_ctr_Tsss = map (map (binder_types o fastype_of)) perm_ctrss;
91.155 + val perm_lfpTs = map (body_type o fastype_of o hd) perm_ctrss;
91.156 +
91.157 + val nn0 = length arg_Ts;
91.158 + val nn = length perm_lfpTs;
91.159 + val kks = 0 upto nn - 1;
91.160 + val perm_ns = map length perm_ctr_Tsss;
91.161 + val perm_mss = map (map length) perm_ctr_Tsss;
91.162 +
91.163 + val perm_Cs = map (body_type o fastype_of o co_rec_of o of_fp_sugar (#xtor_co_iterss o #fp_res))
91.164 + perm_fp_sugars;
91.165 + val perm_fun_arg_Tssss =
91.166 + mk_iter_fun_arg_types perm_ctr_Tsss perm_ns perm_mss (co_rec_of ctor_iters1);
91.167 +
91.168 + fun unpermute0 perm0_xs = permute_like (op =) perm0_kks kks perm0_xs;
91.169 + fun unpermute perm_xs = permute_like (op =) perm_indices indices perm_xs;
91.170 +
91.171 + val induct_thms = unpermute0 (conj_dests nn induct_thm);
91.172 +
91.173 + val lfpTs = unpermute perm_lfpTs;
91.174 + val Cs = unpermute perm_Cs;
91.175 +
91.176 + val As_rho = tvar_subst thy (take nn0 lfpTs) arg_Ts;
91.177 + val Cs_rho = map (fst o dest_TVar) Cs ~~ pad_list HOLogic.unitT nn res_Ts;
91.178 +
91.179 + val substA = Term.subst_TVars As_rho;
91.180 + val substAT = Term.typ_subst_TVars As_rho;
91.181 + val substCT = Term.typ_subst_TVars Cs_rho;
91.182 + val substACT = substAT o substCT;
91.183 +
91.184 + val perm_Cs' = map substCT perm_Cs;
91.185 +
91.186 + fun offset_of_ctr 0 _ = 0
91.187 + | offset_of_ctr n (({ctrs, ...} : ctr_sugar) :: ctr_sugars) =
91.188 + length ctrs + offset_of_ctr (n - 1) ctr_sugars;
91.189 +
91.190 + fun call_of [i] [T] = (if exists_subtype_in Cs T then Nested_Rec else No_Rec) (i, substACT T)
91.191 + | call_of [i, i'] [T, T'] = Mutual_Rec ((i, substACT T), (i', substACT T'));
91.192 +
91.193 + fun mk_ctr_spec ctr offset fun_arg_Tss rec_thm =
91.194 + let
91.195 + val (fun_arg_hss, _) = indexedd fun_arg_Tss 0;
91.196 + val fun_arg_hs = flat_rec_arg_args fun_arg_hss;
91.197 + val fun_arg_iss = map (map (find_index_eq fun_arg_hs)) fun_arg_hss;
91.198 + in
91.199 + {ctr = substA ctr, offset = offset, calls = map2 call_of fun_arg_iss fun_arg_Tss,
91.200 + rec_thm = rec_thm}
91.201 + end;
91.202 +
91.203 + fun mk_ctr_specs index (ctr_sugars : ctr_sugar list) iter_thmsss =
91.204 + let
91.205 + val ctrs = #ctrs (nth ctr_sugars index);
91.206 + val rec_thms = co_rec_of (nth iter_thmsss index);
91.207 + val k = offset_of_ctr index ctr_sugars;
91.208 + val n = length ctrs;
91.209 + in
91.210 + map4 mk_ctr_spec ctrs (k upto k + n - 1) (nth perm_fun_arg_Tssss index) rec_thms
91.211 + end;
91.212 +
91.213 + fun mk_spec ({T, index, ctr_sugars, co_iterss = iterss, co_iter_thmsss = iter_thmsss, ...}
91.214 + : fp_sugar) =
91.215 + {recx = mk_co_iter thy Least_FP (substAT T) perm_Cs' (co_rec_of (nth iterss index)),
91.216 + nested_map_idents = map (unfold_thms lthy @{thms id_def} o map_id0_of_bnf) nested_bnfs,
91.217 + nested_map_comps = map map_comp_of_bnf nested_bnfs,
91.218 + ctr_specs = mk_ctr_specs index ctr_sugars iter_thmsss};
91.219 + in
91.220 + ((is_some lfp_sugar_thms, map mk_spec fp_sugars, missing_arg_Ts, induct_thm, induct_thms),
91.221 + lthy')
91.222 + end;
91.223 +
91.224 +val undef_const = Const (@{const_name undefined}, dummyT);
91.225 +
91.226 +fun permute_args n t =
91.227 + list_comb (t, map Bound (0 :: (n downto 1))) |> fold (K (Term.abs (Name.uu, dummyT))) (0 upto n);
91.228 +
91.229 +type eqn_data = {
91.230 + fun_name: string,
91.231 + rec_type: typ,
91.232 + ctr: term,
91.233 + ctr_args: term list,
91.234 + left_args: term list,
91.235 + right_args: term list,
91.236 + res_type: typ,
91.237 + rhs_term: term,
91.238 + user_eqn: term
91.239 +};
91.240 +
91.241 +fun dissect_eqn lthy fun_names eqn' =
91.242 + let
91.243 + val eqn = drop_All eqn' |> HOLogic.dest_Trueprop
91.244 + handle TERM _ =>
91.245 + primrec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn';
91.246 + val (lhs, rhs) = HOLogic.dest_eq eqn
91.247 + handle TERM _ =>
91.248 + primrec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn';
91.249 + val (fun_name, args) = strip_comb lhs
91.250 + |>> (fn x => if is_Free x then fst (dest_Free x)
91.251 + else primrec_error_eqn "malformed function equation (does not start with free)" eqn);
91.252 + val (left_args, rest) = take_prefix is_Free args;
91.253 + val (nonfrees, right_args) = take_suffix is_Free rest;
91.254 + val num_nonfrees = length nonfrees;
91.255 + val _ = num_nonfrees = 1 orelse if num_nonfrees = 0 then
91.256 + primrec_error_eqn "constructor pattern missing in left-hand side" eqn else
91.257 + primrec_error_eqn "more than one non-variable argument in left-hand side" eqn;
91.258 + val _ = member (op =) fun_names fun_name orelse
91.259 + primrec_error_eqn "malformed function equation (does not start with function name)" eqn
91.260 +
91.261 + val (ctr, ctr_args) = strip_comb (the_single nonfrees);
91.262 + val _ = try (num_binder_types o fastype_of) ctr = SOME (length ctr_args) orelse
91.263 + primrec_error_eqn "partially applied constructor in pattern" eqn;
91.264 + val _ = let val d = duplicates (op =) (left_args @ ctr_args @ right_args) in null d orelse
91.265 + primrec_error_eqn ("duplicate variable \"" ^ Syntax.string_of_term lthy (hd d) ^
91.266 + "\" in left-hand side") eqn end;
91.267 + val _ = forall is_Free ctr_args orelse
91.268 + primrec_error_eqn "non-primitive pattern in left-hand side" eqn;
91.269 + val _ =
91.270 + let val b = fold_aterms (fn x as Free (v, _) =>
91.271 + if (not (member (op =) (left_args @ ctr_args @ right_args) x) andalso
91.272 + not (member (op =) fun_names v) andalso
91.273 + not (Variable.is_fixed lthy v)) then cons x else I | _ => I) rhs []
91.274 + in
91.275 + null b orelse
91.276 + primrec_error_eqn ("extra variable(s) in right-hand side: " ^
91.277 + commas (map (Syntax.string_of_term lthy) b)) eqn
91.278 + end;
91.279 + in
91.280 + {fun_name = fun_name,
91.281 + rec_type = body_type (type_of ctr),
91.282 + ctr = ctr,
91.283 + ctr_args = ctr_args,
91.284 + left_args = left_args,
91.285 + right_args = right_args,
91.286 + res_type = map fastype_of (left_args @ right_args) ---> fastype_of rhs,
91.287 + rhs_term = rhs,
91.288 + user_eqn = eqn'}
91.289 + end;
91.290 +
91.291 +fun rewrite_map_arg get_ctr_pos rec_type res_type =
91.292 + let
91.293 + val pT = HOLogic.mk_prodT (rec_type, res_type);
91.294 +
91.295 + val maybe_suc = Option.map (fn x => x + 1);
91.296 + fun subst d (t as Bound d') = t |> d = SOME d' ? curry (op $) (fst_const pT)
91.297 + | subst d (Abs (v, T, b)) = Abs (v, if d = SOME ~1 then pT else T, subst (maybe_suc d) b)
91.298 + | subst d t =
91.299 + let
91.300 + val (u, vs) = strip_comb t;
91.301 + val ctr_pos = try (get_ctr_pos o fst o dest_Free) u |> the_default ~1;
91.302 + in
91.303 + if ctr_pos >= 0 then
91.304 + if d = SOME ~1 andalso length vs = ctr_pos then
91.305 + list_comb (permute_args ctr_pos (snd_const pT), vs)
91.306 + else if length vs > ctr_pos andalso is_some d
91.307 + andalso d = try (fn Bound n => n) (nth vs ctr_pos) then
91.308 + list_comb (snd_const pT $ nth vs ctr_pos, map (subst d) (nth_drop ctr_pos vs))
91.309 + else
91.310 + primrec_error_eqn ("recursive call not directly applied to constructor argument") t
91.311 + else
91.312 + list_comb (u, map (subst (d |> d = SOME ~1 ? K NONE)) vs)
91.313 + end
91.314 + in
91.315 + subst (SOME ~1)
91.316 + end;
91.317 +
91.318 +fun subst_rec_calls lthy get_ctr_pos has_call ctr_args mutual_calls nested_calls =
91.319 + let
91.320 + fun try_nested_rec bound_Ts y t =
91.321 + AList.lookup (op =) nested_calls y
91.322 + |> Option.map (fn y' =>
91.323 + massage_nested_rec_call lthy has_call (rewrite_map_arg get_ctr_pos) bound_Ts y y' t);
91.324 +
91.325 + fun subst bound_Ts (t as g' $ y) =
91.326 + let
91.327 + fun subst_rec () = subst bound_Ts g' $ subst bound_Ts y;
91.328 + val y_head = head_of y;
91.329 + in
91.330 + if not (member (op =) ctr_args y_head) then
91.331 + subst_rec ()
91.332 + else
91.333 + (case try_nested_rec bound_Ts y_head t of
91.334 + SOME t' => t'
91.335 + | NONE =>
91.336 + let val (g, g_args) = strip_comb g' in
91.337 + (case try (get_ctr_pos o fst o dest_Free) g of
91.338 + SOME ctr_pos =>
91.339 + (length g_args >= ctr_pos orelse
91.340 + primrec_error_eqn "too few arguments in recursive call" t;
91.341 + (case AList.lookup (op =) mutual_calls y of
91.342 + SOME y' => list_comb (y', g_args)
91.343 + | NONE => subst_rec ()))
91.344 + | NONE => subst_rec ())
91.345 + end)
91.346 + end
91.347 + | subst bound_Ts (Abs (v, T, b)) = Abs (v, T, subst (T :: bound_Ts) b)
91.348 + | subst _ t = t
91.349 +
91.350 + fun subst' t =
91.351 + if has_call t then
91.352 + (* FIXME detect this case earlier? *)
91.353 + primrec_error_eqn "recursive call not directly applied to constructor argument" t
91.354 + else
91.355 + try_nested_rec [] (head_of t) t |> the_default t
91.356 + in
91.357 + subst' o subst []
91.358 + end;
91.359 +
91.360 +fun build_rec_arg lthy (funs_data : eqn_data list list) has_call (ctr_spec : rec_ctr_spec)
91.361 + (maybe_eqn_data : eqn_data option) =
91.362 + (case maybe_eqn_data of
91.363 + NONE => undef_const
91.364 + | SOME {ctr_args, left_args, right_args, rhs_term = t, ...} =>
91.365 + let
91.366 + val calls = #calls ctr_spec;
91.367 + val n_args = fold (Integer.add o (fn Mutual_Rec _ => 2 | _ => 1)) calls 0;
91.368 +
91.369 + val no_calls' = tag_list 0 calls
91.370 + |> map_filter (try (apsnd (fn No_Rec p => p | Mutual_Rec (p, _) => p)));
91.371 + val mutual_calls' = tag_list 0 calls
91.372 + |> map_filter (try (apsnd (fn Mutual_Rec (_, p) => p)));
91.373 + val nested_calls' = tag_list 0 calls
91.374 + |> map_filter (try (apsnd (fn Nested_Rec p => p)));
91.375 +
91.376 + val args = replicate n_args ("", dummyT)
91.377 + |> Term.rename_wrt_term t
91.378 + |> map Free
91.379 + |> fold (fn (ctr_arg_idx, (arg_idx, _)) =>
91.380 + nth_map arg_idx (K (nth ctr_args ctr_arg_idx)))
91.381 + no_calls'
91.382 + |> fold (fn (ctr_arg_idx, (arg_idx, T)) =>
91.383 + nth_map arg_idx (K (retype_free T (nth ctr_args ctr_arg_idx))))
91.384 + mutual_calls'
91.385 + |> fold (fn (ctr_arg_idx, (arg_idx, T)) =>
91.386 + nth_map arg_idx (K (retype_free T (nth ctr_args ctr_arg_idx))))
91.387 + nested_calls';
91.388 +
91.389 + val fun_name_ctr_pos_list =
91.390 + map (fn (x :: _) => (#fun_name x, length (#left_args x))) funs_data;
91.391 + val get_ctr_pos = try (the o AList.lookup (op =) fun_name_ctr_pos_list) #> the_default ~1;
91.392 + val mutual_calls = map (apfst (nth ctr_args) o apsnd (nth args o fst)) mutual_calls';
91.393 + val nested_calls = map (apfst (nth ctr_args) o apsnd (nth args o fst)) nested_calls';
91.394 + in
91.395 + t
91.396 + |> subst_rec_calls lthy get_ctr_pos has_call ctr_args mutual_calls nested_calls
91.397 + |> fold_rev lambda (args @ left_args @ right_args)
91.398 + end);
91.399 +
91.400 +fun build_defs lthy bs mxs (funs_data : eqn_data list list) (rec_specs : rec_spec list) has_call =
91.401 + let
91.402 + val n_funs = length funs_data;
91.403 +
91.404 + val ctr_spec_eqn_data_list' =
91.405 + (take n_funs rec_specs |> map #ctr_specs) ~~ funs_data
91.406 + |> maps (uncurry (finds (fn (x, y) => #ctr x = #ctr y))
91.407 + ##> (fn x => null x orelse
91.408 + primrec_error_eqns "excess equations in definition" (map #rhs_term x)) #> fst);
91.409 + val _ = ctr_spec_eqn_data_list' |> map (fn (_, x) => length x <= 1 orelse
91.410 + primrec_error_eqns ("multiple equations for constructor") (map #user_eqn x));
91.411 +
91.412 + val ctr_spec_eqn_data_list =
91.413 + ctr_spec_eqn_data_list' @ (drop n_funs rec_specs |> maps #ctr_specs |> map (rpair []));
91.414 +
91.415 + val recs = take n_funs rec_specs |> map #recx;
91.416 + val rec_args = ctr_spec_eqn_data_list
91.417 + |> sort ((op <) o pairself (#offset o fst) |> make_ord)
91.418 + |> map (uncurry (build_rec_arg lthy funs_data has_call) o apsnd (try the_single));
91.419 + val ctr_poss = map (fn x =>
91.420 + if length (distinct ((op =) o pairself (length o #left_args)) x) <> 1 then
91.421 + primrec_error ("inconstant constructor pattern position for function " ^
91.422 + quote (#fun_name (hd x)))
91.423 + else
91.424 + hd x |> #left_args |> length) funs_data;
91.425 + in
91.426 + (recs, ctr_poss)
91.427 + |-> map2 (fn recx => fn ctr_pos => list_comb (recx, rec_args) |> permute_args ctr_pos)
91.428 + |> Syntax.check_terms lthy
91.429 + |> map3 (fn b => fn mx => fn t => ((b, mx), ((Binding.conceal (Thm.def_binding b), []), t)))
91.430 + bs mxs
91.431 + end;
91.432 +
91.433 +fun find_rec_calls has_call ({ctr, ctr_args, rhs_term, ...} : eqn_data) =
91.434 + let
91.435 + fun find bound_Ts (Abs (_, T, b)) ctr_arg = find (T :: bound_Ts) b ctr_arg
91.436 + | find bound_Ts (t as _ $ _) ctr_arg =
91.437 + let
91.438 + val typof = curry fastype_of1 bound_Ts;
91.439 + val (f', args') = strip_comb t;
91.440 + val n = find_index (equal ctr_arg o head_of) args';
91.441 + in
91.442 + if n < 0 then
91.443 + find bound_Ts f' ctr_arg @ maps (fn x => find bound_Ts x ctr_arg) args'
91.444 + else
91.445 + let
91.446 + val (f, args as arg :: _) = chop n args' |>> curry list_comb f'
91.447 + val (arg_head, arg_args) = Term.strip_comb arg;
91.448 + in
91.449 + if has_call f then
91.450 + mk_partial_compN (length arg_args) (typof arg_head) f ::
91.451 + maps (fn x => find bound_Ts x ctr_arg) args
91.452 + else
91.453 + find bound_Ts f ctr_arg @ maps (fn x => find bound_Ts x ctr_arg) args
91.454 + end
91.455 + end
91.456 + | find _ _ _ = [];
91.457 + in
91.458 + map (find [] rhs_term) ctr_args
91.459 + |> (fn [] => NONE | callss => SOME (ctr, callss))
91.460 + end;
91.461 +
91.462 +fun mk_primrec_tac ctxt num_extra_args map_idents map_comps fun_defs recx =
91.463 + unfold_thms_tac ctxt fun_defs THEN
91.464 + HEADGOAL (rtac (funpow num_extra_args (fn thm => thm RS fun_cong) recx RS trans)) THEN
91.465 + unfold_thms_tac ctxt (@{thms id_def split o_def fst_conv snd_conv} @ map_comps @ map_idents) THEN
91.466 + HEADGOAL (rtac refl);
91.467 +
91.468 +fun prepare_primrec fixes specs lthy =
91.469 + let
91.470 + val thy = Proof_Context.theory_of lthy;
91.471 +
91.472 + val (bs, mxs) = map_split (apfst fst) fixes;
91.473 + val fun_names = map Binding.name_of bs;
91.474 + val eqns_data = map (dissect_eqn lthy fun_names) specs;
91.475 + val funs_data = eqns_data
91.476 + |> partition_eq ((op =) o pairself #fun_name)
91.477 + |> finds (fn (x, y) => x = #fun_name (hd y)) fun_names |> fst
91.478 + |> map (fn (x, y) => the_single y handle List.Empty =>
91.479 + primrec_error ("missing equations for function " ^ quote x));
91.480 +
91.481 + val has_call = exists_subterm (map (fst #>> Binding.name_of #> Free) fixes |> member (op =));
91.482 + val arg_Ts = map (#rec_type o hd) funs_data;
91.483 + val res_Ts = map (#res_type o hd) funs_data;
91.484 + val callssss = funs_data
91.485 + |> map (partition_eq ((op =) o pairself #ctr))
91.486 + |> map (maps (map_filter (find_rec_calls has_call)));
91.487 +
91.488 + val _ = (case filter_out (fn (_, T) => Sign.of_sort thy (T, HOLogic.typeS)) (bs ~~ res_Ts) of
91.489 + [] => ()
91.490 + | (b, _) :: _ => primrec_error ("type of " ^ Binding.print b ^ " contains top sort"));
91.491 +
91.492 + val ((n2m, rec_specs, _, induct_thm, induct_thms), lthy') =
91.493 + rec_specs_of bs arg_Ts res_Ts (get_indices fixes) callssss lthy;
91.494 +
91.495 + val actual_nn = length funs_data;
91.496 +
91.497 + val _ = let val ctrs = (maps (map #ctr o #ctr_specs) rec_specs) in
91.498 + map (fn {ctr, user_eqn, ...} => member (op =) ctrs ctr orelse
91.499 + primrec_error_eqn ("argument " ^ quote (Syntax.string_of_term lthy' ctr) ^
91.500 + " is not a constructor in left-hand side") user_eqn) eqns_data end;
91.501 +
91.502 + val defs = build_defs lthy' bs mxs funs_data rec_specs has_call;
91.503 +
91.504 + fun prove lthy def_thms' ({ctr_specs, nested_map_idents, nested_map_comps, ...} : rec_spec)
91.505 + (fun_data : eqn_data list) =
91.506 + let
91.507 + val def_thms = map (snd o snd) def_thms';
91.508 + val simp_thmss = finds (fn (x, y) => #ctr x = #ctr y) fun_data ctr_specs
91.509 + |> fst
91.510 + |> map_filter (try (fn (x, [y]) =>
91.511 + (#user_eqn x, length (#left_args x) + length (#right_args x), #rec_thm y)))
91.512 + |> map (fn (user_eqn, num_extra_args, rec_thm) =>
91.513 + mk_primrec_tac lthy num_extra_args nested_map_idents nested_map_comps def_thms rec_thm
91.514 + |> K |> Goal.prove lthy [] [] user_eqn
91.515 + |> Thm.close_derivation);
91.516 + val poss = find_indices (fn (x, y) => #ctr x = #ctr y) fun_data eqns_data;
91.517 + in
91.518 + (poss, simp_thmss)
91.519 + end;
91.520 +
91.521 + val notes =
91.522 + (if n2m then map2 (fn name => fn thm =>
91.523 + (name, inductN, [thm], [])) fun_names (take actual_nn induct_thms) else [])
91.524 + |> map (fn (prefix, thmN, thms, attrs) =>
91.525 + ((Binding.qualify true prefix (Binding.name thmN), attrs), [(thms, [])]));
91.526 +
91.527 + val common_name = mk_common_name fun_names;
91.528 +
91.529 + val common_notes =
91.530 + (if n2m then [(inductN, [induct_thm], [])] else [])
91.531 + |> map (fn (thmN, thms, attrs) =>
91.532 + ((Binding.qualify true common_name (Binding.name thmN), attrs), [(thms, [])]));
91.533 + in
91.534 + (((fun_names, defs),
91.535 + fn lthy => fn defs =>
91.536 + split_list (map2 (prove lthy defs) (take actual_nn rec_specs) funs_data)),
91.537 + lthy' |> Local_Theory.notes (notes @ common_notes) |> snd)
91.538 + end;
91.539 +
91.540 +(* primrec definition *)
91.541 +
91.542 +fun add_primrec_simple fixes ts lthy =
91.543 + let
91.544 + val (((names, defs), prove), lthy) = prepare_primrec fixes ts lthy
91.545 + handle ERROR str => primrec_error str;
91.546 + in
91.547 + lthy
91.548 + |> fold_map Local_Theory.define defs
91.549 + |-> (fn defs => `(fn lthy => (names, (map fst defs, prove lthy defs))))
91.550 + end
91.551 + handle Primrec_Error (str, eqns) =>
91.552 + if null eqns
91.553 + then error ("primrec_new error:\n " ^ str)
91.554 + else error ("primrec_new error:\n " ^ str ^ "\nin\n " ^
91.555 + space_implode "\n " (map (quote o Syntax.string_of_term lthy) eqns));
91.556 +
91.557 +local
91.558 +
91.559 +fun gen_primrec prep_spec (raw_fixes : (binding * 'a option * mixfix) list) raw_spec lthy =
91.560 + let
91.561 + val d = duplicates (op =) (map (Binding.name_of o #1) raw_fixes)
91.562 + val _ = null d orelse primrec_error ("duplicate function name(s): " ^ commas d);
91.563 +
91.564 + val (fixes, specs) = fst (prep_spec raw_fixes raw_spec lthy);
91.565 +
91.566 + val mk_notes =
91.567 + flat ooo map3 (fn poss => fn prefix => fn thms =>
91.568 + let
91.569 + val (bs, attrss) = map_split (fst o nth specs) poss;
91.570 + val notes =
91.571 + map3 (fn b => fn attrs => fn thm =>
91.572 + ((Binding.qualify false prefix b, code_nitpicksimp_simp_attrs @ attrs), [([thm], [])]))
91.573 + bs attrss thms;
91.574 + in
91.575 + ((Binding.qualify true prefix (Binding.name simpsN), []), [(thms, [])]) :: notes
91.576 + end);
91.577 + in
91.578 + lthy
91.579 + |> add_primrec_simple fixes (map snd specs)
91.580 + |-> (fn (names, (ts, (posss, simpss))) =>
91.581 + Spec_Rules.add Spec_Rules.Equational (ts, flat simpss)
91.582 + #> Local_Theory.notes (mk_notes posss names simpss)
91.583 + #>> pair ts o map snd)
91.584 + end;
91.585 +
91.586 +in
91.587 +
91.588 +val add_primrec = gen_primrec Specification.check_spec;
91.589 +val add_primrec_cmd = gen_primrec Specification.read_spec;
91.590 +
91.591 +end;
91.592 +
91.593 +fun add_primrec_global fixes specs thy =
91.594 + let
91.595 + val lthy = Named_Target.theory_init thy;
91.596 + val ((ts, simps), lthy') = add_primrec fixes specs lthy;
91.597 + val simps' = burrow (Proof_Context.export lthy' lthy) simps;
91.598 + in ((ts, simps'), Local_Theory.exit_global lthy') end;
91.599 +
91.600 +fun add_primrec_overloaded ops fixes specs thy =
91.601 + let
91.602 + val lthy = Overloading.overloading ops thy;
91.603 + val ((ts, simps), lthy') = add_primrec fixes specs lthy;
91.604 + val simps' = burrow (Proof_Context.export lthy' lthy) simps;
91.605 + in ((ts, simps'), Local_Theory.exit_global lthy') end;
91.606 +
91.607 +end;
92.1 --- a/src/HOL/BNF/Tools/bnf_tactics.ML Thu Dec 05 17:52:12 2013 +0100
92.2 +++ b/src/HOL/BNF/Tools/bnf_tactics.ML Thu Dec 05 17:58:03 2013 +0100
92.3 @@ -91,7 +91,7 @@
92.4 fun mk_ctor_or_dtor_rel_tac srel_def IJrel_defs IJsrel_defs dtor_srel {context = ctxt, prems = _} =
92.5 unfold_thms_tac ctxt IJrel_defs THEN
92.6 rtac (unfold_thms ctxt (IJrel_defs @ IJsrel_defs @
92.7 - @{thms Collect_pair_mem_eq mem_Collect_eq fst_conv snd_conv}) dtor_srel RS trans) 1 THEN
92.8 + @{thms Collect_mem_eq mem_Collect_eq fst_conv snd_conv}) dtor_srel RS trans) 1 THEN
92.9 unfold_thms_tac ctxt (srel_def ::
92.10 @{thms pair_collapse Collect_mem_eq mem_Collect_eq prod.cases fst_conv snd_conv
92.11 split_conv}) THEN
93.1 --- a/src/HOL/BNF/Tools/bnf_util.ML Thu Dec 05 17:52:12 2013 +0100
93.2 +++ b/src/HOL/BNF/Tools/bnf_util.ML Thu Dec 05 17:58:03 2013 +0100
93.3 @@ -54,7 +54,6 @@
93.4 term list list list list * Proof.context
93.5 val nonzero_string_of_int: int -> string
93.6 val retype_free: typ -> term -> term
93.7 - val typ_subst_nonatomic: (typ * typ) list -> typ -> typ
93.8
93.9 val binder_fun_types: typ -> typ list
93.10 val body_fun_type: typ -> typ
93.11 @@ -133,22 +132,15 @@
93.12 val no_refl: thm list -> thm list
93.13 val no_reflexive: thm list -> thm list
93.14
93.15 - val cterm_instantiate_pos: cterm option list -> thm -> thm
93.16 val fold_thms: Proof.context -> thm list -> thm -> thm
93.17
93.18 val parse_binding_colon: binding parser
93.19 val parse_opt_binding_colon: binding parser
93.20 + val parse_type_args_named_constrained: (binding option * (string * string option)) list parser
93.21 + val parse_map_rel_bindings: (binding * binding) parser
93.22
93.23 val typedef: binding * (string * sort) list * mixfix -> term ->
93.24 (binding * binding) option -> tactic -> local_theory -> (string * Typedef.info) * local_theory
93.25 -
93.26 - val WRAP: ('a -> tactic) -> ('a -> tactic) -> 'a list -> tactic -> tactic
93.27 - val WRAP': ('a -> int -> tactic) -> ('a -> int -> tactic) -> 'a list -> (int -> tactic) -> int ->
93.28 - tactic
93.29 - val CONJ_WRAP_GEN: tactic -> ('a -> tactic) -> 'a list -> tactic
93.30 - val CONJ_WRAP_GEN': (int -> tactic) -> ('a -> int -> tactic) -> 'a list -> int -> tactic
93.31 - val CONJ_WRAP: ('a -> tactic) -> 'a list -> tactic
93.32 - val CONJ_WRAP': ('a -> int -> tactic) -> 'a list -> int -> tactic
93.33 end;
93.34
93.35 structure BNF_Util : BNF_UTIL =
93.36 @@ -263,6 +255,32 @@
93.37 val parse_binding_colon = parse_binding --| @{keyword ":"};
93.38 val parse_opt_binding_colon = Scan.optional parse_binding_colon Binding.empty;
93.39
93.40 +val parse_type_arg_constrained =
93.41 + Parse.type_ident -- Scan.option (@{keyword "::"} |-- Parse.!!! Parse.sort);
93.42 +
93.43 +val parse_type_arg_named_constrained =
93.44 + (Parse.minus --| @{keyword ":"} >> K NONE || parse_opt_binding_colon >> SOME) --
93.45 + parse_type_arg_constrained;
93.46 +
93.47 +val parse_type_args_named_constrained =
93.48 + parse_type_arg_constrained >> (single o pair (SOME Binding.empty)) ||
93.49 + @{keyword "("} |-- Parse.!!! (Parse.list1 parse_type_arg_named_constrained --| @{keyword ")"}) ||
93.50 + Scan.succeed [];
93.51 +
93.52 +val parse_map_rel_binding = Parse.short_ident --| @{keyword ":"} -- parse_binding;
93.53 +
93.54 +val no_map_rel = (Binding.empty, Binding.empty);
93.55 +
93.56 +fun extract_map_rel ("map", b) = apfst (K b)
93.57 + | extract_map_rel ("rel", b) = apsnd (K b)
93.58 + | extract_map_rel (s, _) = error ("Unknown label " ^ quote s ^ " (expected \"map\" or \"rel\")");
93.59 +
93.60 +val parse_map_rel_bindings =
93.61 + @{keyword "("} |-- Scan.repeat parse_map_rel_binding --| @{keyword ")"}
93.62 + >> (fn ps => fold extract_map_rel ps no_map_rel) ||
93.63 + Scan.succeed no_map_rel;
93.64 +
93.65 +
93.66 (*TODO: is this really different from Typedef.add_typedef_global?*)
93.67 fun typedef (b, Ts, mx) set opt_morphs tac lthy =
93.68 let
93.69 @@ -277,25 +295,6 @@
93.70 ((name, Typedef.transform_info phi info), lthy)
93.71 end;
93.72
93.73 -(*Tactical WRAP surrounds a static given tactic (core) with two deterministic chains of tactics*)
93.74 -fun WRAP gen_before gen_after xs core_tac =
93.75 - fold_rev (fn x => fn tac => gen_before x THEN tac THEN gen_after x) xs core_tac;
93.76 -
93.77 -fun WRAP' gen_before gen_after xs core_tac =
93.78 - fold_rev (fn x => fn tac => gen_before x THEN' tac THEN' gen_after x) xs core_tac;
93.79 -
93.80 -fun CONJ_WRAP_GEN conj_tac gen_tac xs =
93.81 - let val (butlast, last) = split_last xs;
93.82 - in WRAP (fn thm => conj_tac THEN gen_tac thm) (K all_tac) butlast (gen_tac last) end;
93.83 -
93.84 -fun CONJ_WRAP_GEN' conj_tac gen_tac xs =
93.85 - let val (butlast, last) = split_last xs;
93.86 - in WRAP' (fn thm => conj_tac THEN' gen_tac thm) (K (K all_tac)) butlast (gen_tac last) end;
93.87 -
93.88 -(*not eta-converted because of monotype restriction*)
93.89 -fun CONJ_WRAP gen_tac = CONJ_WRAP_GEN (rtac conjI 1) gen_tac;
93.90 -fun CONJ_WRAP' gen_tac = CONJ_WRAP_GEN' (rtac conjI) gen_tac;
93.91 -
93.92
93.93
93.94 (* Term construction *)
93.95 @@ -307,14 +306,6 @@
93.96
93.97 val mk_TFreess = fold_map mk_TFrees;
93.98
93.99 -(*Replace each Ti by Ui (starting from the leaves); inst = [(T1, U1), ..., (Tn, Un)].*)
93.100 -fun typ_subst_nonatomic [] = I
93.101 - | typ_subst_nonatomic inst =
93.102 - let
93.103 - fun subst (Type (s, Ts)) = perhaps (AList.lookup (op =) inst) (Type (s, map subst Ts))
93.104 - | subst T = perhaps (AList.lookup (op =) inst) T;
93.105 - in subst end;
93.106 -
93.107 fun mk_Freesss x Tsss = fold_map2 mk_Freess (mk_names (length Tsss) x) Tsss;
93.108 fun mk_Freessss x Tssss = fold_map2 mk_Freesss (mk_names (length Tssss) x) Tssss;
93.109
93.110 @@ -547,7 +538,7 @@
93.111
93.112 fun mk_nth_conv n m =
93.113 let
93.114 - fun thm b = if b then @{thm fst_snd} else @{thm snd_snd}
93.115 + fun thm b = if b then @{thm fstI} else @{thm sndI}
93.116 fun mk_nth_conv _ 1 1 = refl
93.117 | mk_nth_conv _ _ 1 = @{thm fst_conv}
93.118 | mk_nth_conv _ 2 2 = @{thm snd_conv}
93.119 @@ -609,17 +600,6 @@
93.120 val no_refl = filter_out is_refl;
93.121 val no_reflexive = filter_out Thm.is_reflexive;
93.122
93.123 -fun cterm_instantiate_pos cts thm =
93.124 - let
93.125 - val cert = Thm.cterm_of (Thm.theory_of_thm thm);
93.126 - val vars = Term.add_vars (prop_of thm) [];
93.127 - val vars' = rev (drop (length vars - length cts) vars);
93.128 - val ps = map_filter (fn (_, NONE) => NONE
93.129 - | (var, SOME ct) => SOME (cert (Var var), ct)) (vars' ~~ cts);
93.130 - in
93.131 - Drule.cterm_instantiate ps thm
93.132 - end;
93.133 -
93.134 fun fold_thms ctxt thms = Local_Defs.fold ctxt (distinct Thm.eq_thm_prop thms);
93.135
93.136 end;
94.1 --- a/src/HOL/BNF/Tools/coinduction.ML Thu Dec 05 17:52:12 2013 +0100
94.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
94.3 @@ -1,159 +0,0 @@
94.4 -(* Title: HOL/BNF/Tools/coinduction.ML
94.5 - Author: Johannes Hölzl, TU Muenchen
94.6 - Author: Dmitriy Traytel, TU Muenchen
94.7 - Copyright 2013
94.8 -
94.9 -Coinduction method that avoids some boilerplate compared to coinduct.
94.10 -*)
94.11 -
94.12 -signature COINDUCTION =
94.13 -sig
94.14 - val coinduction_tac: Proof.context -> term list -> thm option -> thm list -> cases_tactic
94.15 - val setup: theory -> theory
94.16 -end;
94.17 -
94.18 -structure Coinduction : COINDUCTION =
94.19 -struct
94.20 -
94.21 -open BNF_Util
94.22 -open BNF_Tactics
94.23 -
94.24 -fun filter_in_out _ [] = ([], [])
94.25 - | filter_in_out P (x :: xs) = (let
94.26 - val (ins, outs) = filter_in_out P xs;
94.27 - in
94.28 - if P x then (x :: ins, outs) else (ins, x :: outs)
94.29 - end);
94.30 -
94.31 -fun ALLGOALS_SKIP skip tac st =
94.32 - let fun doall n = if n = skip then all_tac else tac n THEN doall (n - 1)
94.33 - in doall (nprems_of st) st end;
94.34 -
94.35 -fun THEN_ALL_NEW_SKIP skip tac1 tac2 i st =
94.36 - st |> (tac1 i THEN (fn st' =>
94.37 - Seq.INTERVAL tac2 (i + skip) (i + nprems_of st' - nprems_of st) st'));
94.38 -
94.39 -fun DELETE_PREMS_AFTER skip tac i st =
94.40 - let
94.41 - val n = nth (prems_of st) (i - 1) |> Logic.strip_assums_hyp |> length;
94.42 - in
94.43 - (THEN_ALL_NEW_SKIP skip tac (REPEAT_DETERM_N n o etac thin_rl)) i st
94.44 - end;
94.45 -
94.46 -fun coinduction_tac ctxt raw_vars opt_raw_thm prems st =
94.47 - let
94.48 - val lhs_of_eq = HOLogic.dest_Trueprop #> HOLogic.dest_eq #> fst;
94.49 - fun find_coinduct t =
94.50 - Induct.find_coinductP ctxt t @
94.51 - (try (Induct.find_coinductT ctxt o fastype_of o lhs_of_eq) t |> the_default [])
94.52 - val raw_thm = case opt_raw_thm
94.53 - of SOME raw_thm => raw_thm
94.54 - | NONE => st |> prems_of |> hd |> Logic.strip_assums_concl |> find_coinduct |> hd;
94.55 - val skip = Integer.max 1 (Rule_Cases.get_consumes raw_thm) - 1
94.56 - val cases = Rule_Cases.get raw_thm |> fst
94.57 - in
94.58 - NO_CASES (HEADGOAL (
94.59 - Object_Logic.rulify_tac THEN'
94.60 - Method.insert_tac prems THEN'
94.61 - Object_Logic.atomize_prems_tac THEN'
94.62 - DELETE_PREMS_AFTER skip (Subgoal.FOCUS (fn {concl, context = ctxt, params, prems, ...} =>
94.63 - let
94.64 - val vars = raw_vars @ map (term_of o snd) params;
94.65 - val names_ctxt = ctxt
94.66 - |> fold Variable.declare_names vars
94.67 - |> fold Variable.declare_thm (raw_thm :: prems);
94.68 - val thm_concl = Thm.cprop_of raw_thm |> strip_imp_concl;
94.69 - val (rhoTs, rhots) = Thm.match (thm_concl, concl)
94.70 - |>> map (pairself typ_of)
94.71 - ||> map (pairself term_of);
94.72 - val xs = hd (Thm.prems_of raw_thm) |> HOLogic.dest_Trueprop |> strip_comb |> snd
94.73 - |> map (subst_atomic_types rhoTs);
94.74 - val raw_eqs = map (fn x => (x, AList.lookup op aconv rhots x |> the)) xs;
94.75 - val ((names, ctxt), Ts) = map_split (apfst fst o dest_Var o fst) raw_eqs
94.76 - |>> (fn names => Variable.variant_fixes names names_ctxt) ;
94.77 - val eqs =
94.78 - map3 (fn name => fn T => fn (_, rhs) =>
94.79 - HOLogic.mk_eq (Free (name, T), rhs))
94.80 - names Ts raw_eqs;
94.81 - val phi = eqs @ map (HOLogic.dest_Trueprop o prop_of) prems
94.82 - |> try (Library.foldr1 HOLogic.mk_conj)
94.83 - |> the_default @{term True}
94.84 - |> list_exists_free vars
94.85 - |> Term.map_abs_vars (Variable.revert_fixed ctxt)
94.86 - |> fold_rev Term.absfree (names ~~ Ts)
94.87 - |> certify ctxt;
94.88 - val thm = cterm_instantiate_pos [SOME phi] raw_thm;
94.89 - val e = length eqs;
94.90 - val p = length prems;
94.91 - in
94.92 - HEADGOAL (EVERY' [rtac thm,
94.93 - EVERY' (map (fn var =>
94.94 - rtac (cterm_instantiate_pos [NONE, SOME (certify ctxt var)] exI)) vars),
94.95 - if p = 0 then CONJ_WRAP' (K (rtac refl)) eqs
94.96 - else REPEAT_DETERM_N e o (rtac conjI THEN' rtac refl) THEN' CONJ_WRAP' rtac prems,
94.97 - K (ALLGOALS_SKIP skip
94.98 - (REPEAT_DETERM_N (length vars) o (etac exE THEN' rotate_tac ~1) THEN'
94.99 - DELETE_PREMS_AFTER 0 (Subgoal.FOCUS (fn {prems, params, context = ctxt, ...} =>
94.100 - (case prems of
94.101 - [] => all_tac
94.102 - | inv::case_prems =>
94.103 - let
94.104 - val (init, last) = funpow_yield (p + e - 1) HOLogic.conj_elim inv;
94.105 - val inv_thms = init @ [last];
94.106 - val eqs = take e inv_thms;
94.107 - fun is_local_var t =
94.108 - member (fn (t, (_, t')) => t aconv (term_of t')) params t;
94.109 - val (eqs, assms') = filter_in_out (is_local_var o lhs_of_eq o prop_of) eqs;
94.110 - val assms = assms' @ drop e inv_thms
94.111 - in
94.112 - HEADGOAL (Method.insert_tac (assms @ case_prems)) THEN
94.113 - unfold_thms_tac ctxt eqs
94.114 - end)) ctxt)))])
94.115 - end) ctxt) THEN'
94.116 - K (prune_params_tac))) st
94.117 - |> Seq.maps (fn (_, st) =>
94.118 - CASES (Rule_Cases.make_common (Proof_Context.theory_of ctxt, prop_of st) cases) all_tac st)
94.119 - end;
94.120 -
94.121 -local
94.122 -
94.123 -val ruleN = "rule"
94.124 -val arbitraryN = "arbitrary"
94.125 -fun single_rule [rule] = rule
94.126 - | single_rule _ = error "Single rule expected";
94.127 -
94.128 -fun named_rule k arg get =
94.129 - Scan.lift (Args.$$$ k -- Args.colon) |-- Scan.repeat arg :|--
94.130 - (fn names => Scan.peek (fn context => Scan.succeed (names |> map (fn name =>
94.131 - (case get (Context.proof_of context) name of SOME x => x
94.132 - | NONE => error ("No rule for " ^ k ^ " " ^ quote name))))));
94.133 -
94.134 -fun rule get_type get_pred =
94.135 - named_rule Induct.typeN (Args.type_name false) get_type ||
94.136 - named_rule Induct.predN (Args.const false) get_pred ||
94.137 - named_rule Induct.setN (Args.const false) get_pred ||
94.138 - Scan.lift (Args.$$$ ruleN -- Args.colon) |-- Attrib.thms;
94.139 -
94.140 -val coinduct_rule = rule Induct.lookup_coinductT Induct.lookup_coinductP >> single_rule;
94.141 -
94.142 -fun unless_more_args scan = Scan.unless (Scan.lift
94.143 - ((Args.$$$ arbitraryN || Args.$$$ Induct.typeN ||
94.144 - Args.$$$ Induct.predN || Args.$$$ Induct.setN || Args.$$$ ruleN) -- Args.colon)) scan;
94.145 -
94.146 -val arbitrary = Scan.optional (Scan.lift (Args.$$$ arbitraryN -- Args.colon) |--
94.147 - Scan.repeat1 (unless_more_args Args.term)) [];
94.148 -
94.149 -in
94.150 -
94.151 -val setup =
94.152 - Method.setup @{binding coinduction}
94.153 - (arbitrary -- Scan.option coinduct_rule >>
94.154 - (fn (arbitrary, opt_rule) => fn ctxt =>
94.155 - RAW_METHOD_CASES (fn facts =>
94.156 - Seq.DETERM (coinduction_tac ctxt arbitrary opt_rule facts))))
94.157 - "coinduction on types or predicates/sets";
94.158 -
94.159 -end;
94.160 -
94.161 -end;
94.162 -
95.1 --- a/src/HOL/BNF/Tools/ctr_sugar.ML Thu Dec 05 17:52:12 2013 +0100
95.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
95.3 @@ -1,956 +0,0 @@
95.4 -(* Title: HOL/BNF/Tools/ctr_sugar.ML
95.5 - Author: Jasmin Blanchette, TU Muenchen
95.6 - Copyright 2012
95.7 -
95.8 -Wrapping existing freely generated type's constructors.
95.9 -*)
95.10 -
95.11 -signature CTR_SUGAR =
95.12 -sig
95.13 - type ctr_sugar =
95.14 - {ctrs: term list,
95.15 - casex: term,
95.16 - discs: term list,
95.17 - selss: term list list,
95.18 - exhaust: thm,
95.19 - nchotomy: thm,
95.20 - injects: thm list,
95.21 - distincts: thm list,
95.22 - case_thms: thm list,
95.23 - case_cong: thm,
95.24 - weak_case_cong: thm,
95.25 - split: thm,
95.26 - split_asm: thm,
95.27 - disc_thmss: thm list list,
95.28 - discIs: thm list,
95.29 - sel_thmss: thm list list,
95.30 - disc_exhausts: thm list,
95.31 - sel_exhausts: thm list,
95.32 - collapses: thm list,
95.33 - expands: thm list,
95.34 - sel_splits: thm list,
95.35 - sel_split_asms: thm list,
95.36 - case_conv_ifs: thm list};
95.37 -
95.38 - val morph_ctr_sugar: morphism -> ctr_sugar -> ctr_sugar
95.39 - val ctr_sugar_of: Proof.context -> string -> ctr_sugar option
95.40 - val ctr_sugars_of: Proof.context -> ctr_sugar list
95.41 -
95.42 - val rep_compat_prefix: string
95.43 -
95.44 - val mk_half_pairss: 'a list * 'a list -> ('a * 'a) list list
95.45 - val join_halves: int -> 'a list list -> 'a list list -> 'a list * 'a list list list
95.46 -
95.47 - val mk_ctr: typ list -> term -> term
95.48 - val mk_case: typ list -> typ -> term -> term
95.49 - val mk_disc_or_sel: typ list -> term -> term
95.50 - val name_of_ctr: term -> string
95.51 - val name_of_disc: term -> string
95.52 - val dest_ctr: Proof.context -> string -> term -> term * term list
95.53 - val dest_case: Proof.context -> string -> typ list -> term -> (term list * term list) option
95.54 -
95.55 - val wrap_free_constructors: ({prems: thm list, context: Proof.context} -> tactic) list list ->
95.56 - (((bool * bool) * term list) * binding) *
95.57 - (binding list * (binding list list * (binding * term) list list)) -> local_theory ->
95.58 - ctr_sugar * local_theory
95.59 - val parse_wrap_free_constructors_options: (bool * bool) parser
95.60 - val parse_bound_term: (binding * string) parser
95.61 -end;
95.62 -
95.63 -structure Ctr_Sugar : CTR_SUGAR =
95.64 -struct
95.65 -
95.66 -open Ctr_Sugar_Util
95.67 -open Ctr_Sugar_Tactics
95.68 -
95.69 -type ctr_sugar =
95.70 - {ctrs: term list,
95.71 - casex: term,
95.72 - discs: term list,
95.73 - selss: term list list,
95.74 - exhaust: thm,
95.75 - nchotomy: thm,
95.76 - injects: thm list,
95.77 - distincts: thm list,
95.78 - case_thms: thm list,
95.79 - case_cong: thm,
95.80 - weak_case_cong: thm,
95.81 - split: thm,
95.82 - split_asm: thm,
95.83 - disc_thmss: thm list list,
95.84 - discIs: thm list,
95.85 - sel_thmss: thm list list,
95.86 - disc_exhausts: thm list,
95.87 - sel_exhausts: thm list,
95.88 - collapses: thm list,
95.89 - expands: thm list,
95.90 - sel_splits: thm list,
95.91 - sel_split_asms: thm list,
95.92 - case_conv_ifs: thm list};
95.93 -
95.94 -fun eq_ctr_sugar ({ctrs = ctrs1, casex = case1, discs = discs1, selss = selss1, ...} : ctr_sugar,
95.95 - {ctrs = ctrs2, casex = case2, discs = discs2, selss = selss2, ...} : ctr_sugar) =
95.96 - ctrs1 = ctrs2 andalso case1 = case2 andalso discs1 = discs2 andalso selss1 = selss2;
95.97 -
95.98 -fun morph_ctr_sugar phi {ctrs, casex, discs, selss, exhaust, nchotomy, injects, distincts,
95.99 - case_thms, case_cong, weak_case_cong, split, split_asm, disc_thmss, discIs, sel_thmss,
95.100 - disc_exhausts, sel_exhausts, collapses, expands, sel_splits, sel_split_asms, case_conv_ifs} =
95.101 - {ctrs = map (Morphism.term phi) ctrs,
95.102 - casex = Morphism.term phi casex,
95.103 - discs = map (Morphism.term phi) discs,
95.104 - selss = map (map (Morphism.term phi)) selss,
95.105 - exhaust = Morphism.thm phi exhaust,
95.106 - nchotomy = Morphism.thm phi nchotomy,
95.107 - injects = map (Morphism.thm phi) injects,
95.108 - distincts = map (Morphism.thm phi) distincts,
95.109 - case_thms = map (Morphism.thm phi) case_thms,
95.110 - case_cong = Morphism.thm phi case_cong,
95.111 - weak_case_cong = Morphism.thm phi weak_case_cong,
95.112 - split = Morphism.thm phi split,
95.113 - split_asm = Morphism.thm phi split_asm,
95.114 - disc_thmss = map (map (Morphism.thm phi)) disc_thmss,
95.115 - discIs = map (Morphism.thm phi) discIs,
95.116 - sel_thmss = map (map (Morphism.thm phi)) sel_thmss,
95.117 - disc_exhausts = map (Morphism.thm phi) disc_exhausts,
95.118 - sel_exhausts = map (Morphism.thm phi) sel_exhausts,
95.119 - collapses = map (Morphism.thm phi) collapses,
95.120 - expands = map (Morphism.thm phi) expands,
95.121 - sel_splits = map (Morphism.thm phi) sel_splits,
95.122 - sel_split_asms = map (Morphism.thm phi) sel_split_asms,
95.123 - case_conv_ifs = map (Morphism.thm phi) case_conv_ifs};
95.124 -
95.125 -val transfer_ctr_sugar =
95.126 - morph_ctr_sugar o Morphism.thm_morphism o Thm.transfer o Proof_Context.theory_of;
95.127 -
95.128 -structure Data = Generic_Data
95.129 -(
95.130 - type T = ctr_sugar Symtab.table;
95.131 - val empty = Symtab.empty;
95.132 - val extend = I;
95.133 - val merge = Symtab.merge eq_ctr_sugar;
95.134 -);
95.135 -
95.136 -fun ctr_sugar_of ctxt =
95.137 - Symtab.lookup (Data.get (Context.Proof ctxt))
95.138 - #> Option.map (transfer_ctr_sugar ctxt);
95.139 -
95.140 -fun ctr_sugars_of ctxt =
95.141 - Symtab.fold (cons o transfer_ctr_sugar ctxt o snd) (Data.get (Context.Proof ctxt)) [];
95.142 -
95.143 -fun register_ctr_sugar key ctr_sugar =
95.144 - Local_Theory.declaration {syntax = false, pervasive = true}
95.145 - (fn phi => Data.map (Symtab.default (key, morph_ctr_sugar phi ctr_sugar)));
95.146 -
95.147 -val rep_compat_prefix = "new";
95.148 -
95.149 -val isN = "is_";
95.150 -val unN = "un_";
95.151 -fun mk_unN 1 1 suf = unN ^ suf
95.152 - | mk_unN _ l suf = unN ^ suf ^ string_of_int l;
95.153 -
95.154 -val caseN = "case";
95.155 -val case_congN = "case_cong";
95.156 -val case_conv_ifN = "case_conv_if";
95.157 -val collapseN = "collapse";
95.158 -val disc_excludeN = "disc_exclude";
95.159 -val disc_exhaustN = "disc_exhaust";
95.160 -val discN = "disc";
95.161 -val discIN = "discI";
95.162 -val distinctN = "distinct";
95.163 -val exhaustN = "exhaust";
95.164 -val expandN = "expand";
95.165 -val injectN = "inject";
95.166 -val nchotomyN = "nchotomy";
95.167 -val selN = "sel";
95.168 -val sel_exhaustN = "sel_exhaust";
95.169 -val sel_splitN = "sel_split";
95.170 -val sel_split_asmN = "sel_split_asm";
95.171 -val splitN = "split";
95.172 -val splitsN = "splits";
95.173 -val split_asmN = "split_asm";
95.174 -val weak_case_cong_thmsN = "weak_case_cong";
95.175 -
95.176 -val cong_attrs = @{attributes [cong]};
95.177 -val dest_attrs = @{attributes [dest]};
95.178 -val safe_elim_attrs = @{attributes [elim!]};
95.179 -val iff_attrs = @{attributes [iff]};
95.180 -val induct_simp_attrs = @{attributes [induct_simp]};
95.181 -val nitpick_attrs = @{attributes [nitpick_simp]};
95.182 -val simp_attrs = @{attributes [simp]};
95.183 -val code_nitpick_simp_simp_attrs = Code.add_default_eqn_attrib :: nitpick_attrs @ simp_attrs;
95.184 -
95.185 -fun unflat_lookup eq xs ys = map (fn xs' => permute_like eq xs xs' ys);
95.186 -
95.187 -fun mk_half_pairss' _ ([], []) = []
95.188 - | mk_half_pairss' indent (x :: xs, _ :: ys) =
95.189 - indent @ fold_rev (cons o single o pair x) ys (mk_half_pairss' ([] :: indent) (xs, ys));
95.190 -
95.191 -fun mk_half_pairss p = mk_half_pairss' [[]] p;
95.192 -
95.193 -fun join_halves n half_xss other_half_xss =
95.194 - let
95.195 - val xsss =
95.196 - map2 (map2 append) (Library.chop_groups n half_xss)
95.197 - (transpose (Library.chop_groups n other_half_xss))
95.198 - val xs = splice (flat half_xss) (flat other_half_xss);
95.199 - in (xs, xsss) end;
95.200 -
95.201 -fun mk_undefined T = Const (@{const_name undefined}, T);
95.202 -
95.203 -fun mk_ctr Ts t =
95.204 - let val Type (_, Ts0) = body_type (fastype_of t) in
95.205 - Term.subst_atomic_types (Ts0 ~~ Ts) t
95.206 - end;
95.207 -
95.208 -fun mk_case Ts T t =
95.209 - let val (Type (_, Ts0), body) = strip_type (fastype_of t) |>> List.last in
95.210 - Term.subst_atomic_types ((body, T) :: (Ts0 ~~ Ts)) t
95.211 - end;
95.212 -
95.213 -fun mk_disc_or_sel Ts t =
95.214 - Term.subst_atomic_types (snd (Term.dest_Type (domain_type (fastype_of t))) ~~ Ts) t;
95.215 -
95.216 -fun name_of_const what t =
95.217 - (case head_of t of
95.218 - Const (s, _) => s
95.219 - | Free (s, _) => s
95.220 - | _ => error ("Cannot extract name of " ^ what));
95.221 -
95.222 -val name_of_ctr = name_of_const "constructor";
95.223 -
95.224 -val notN = "not_";
95.225 -val eqN = "eq_";
95.226 -val neqN = "neq_";
95.227 -
95.228 -fun name_of_disc t =
95.229 - (case head_of t of
95.230 - Abs (_, _, @{const Not} $ (t' $ Bound 0)) =>
95.231 - Long_Name.map_base_name (prefix notN) (name_of_disc t')
95.232 - | Abs (_, _, Const (@{const_name HOL.eq}, _) $ Bound 0 $ t') =>
95.233 - Long_Name.map_base_name (prefix eqN) (name_of_disc t')
95.234 - | Abs (_, _, @{const Not} $ (Const (@{const_name HOL.eq}, _) $ Bound 0 $ t')) =>
95.235 - Long_Name.map_base_name (prefix neqN) (name_of_disc t')
95.236 - | t' => name_of_const "destructor" t');
95.237 -
95.238 -val base_name_of_ctr = Long_Name.base_name o name_of_ctr;
95.239 -
95.240 -fun dest_ctr ctxt s t =
95.241 - let
95.242 - val (f, args) = Term.strip_comb t;
95.243 - in
95.244 - (case ctr_sugar_of ctxt s of
95.245 - SOME {ctrs, ...} =>
95.246 - (case find_first (can (fo_match ctxt f)) ctrs of
95.247 - SOME f' => (f', args)
95.248 - | NONE => raise Fail "dest_ctr")
95.249 - | NONE => raise Fail "dest_ctr")
95.250 - end;
95.251 -
95.252 -fun dest_case ctxt s Ts t =
95.253 - (case Term.strip_comb t of
95.254 - (Const (c, _), args as _ :: _) =>
95.255 - (case ctr_sugar_of ctxt s of
95.256 - SOME {casex = Const (case_name, _), discs = discs0, selss = selss0, ...} =>
95.257 - if case_name = c then
95.258 - let val n = length discs0 in
95.259 - if n < length args then
95.260 - let
95.261 - val (branches, obj :: leftovers) = chop n args;
95.262 - val discs = map (mk_disc_or_sel Ts) discs0;
95.263 - val selss = map (map (mk_disc_or_sel Ts)) selss0;
95.264 - val conds = map (rapp obj) discs;
95.265 - val branch_argss = map (fn sels => map (rapp obj) sels @ leftovers) selss;
95.266 - val branches' = map2 (curry Term.betapplys) branches branch_argss;
95.267 - in
95.268 - SOME (conds, branches')
95.269 - end
95.270 - else
95.271 - NONE
95.272 - end
95.273 - else
95.274 - NONE
95.275 - | _ => NONE)
95.276 - | _ => NONE);
95.277 -
95.278 -fun eta_expand_arg xs f_xs = fold_rev Term.lambda xs f_xs;
95.279 -
95.280 -fun prepare_wrap_free_constructors prep_term ((((no_discs_sels, rep_compat), raw_ctrs),
95.281 - raw_case_binding), (raw_disc_bindings, (raw_sel_bindingss, raw_sel_defaultss))) no_defs_lthy =
95.282 - let
95.283 - (* TODO: sanity checks on arguments *)
95.284 -
95.285 - val n = length raw_ctrs;
95.286 - val ks = 1 upto n;
95.287 -
95.288 - val _ = if n > 0 then () else error "No constructors specified";
95.289 -
95.290 - val ctrs0 = map (prep_term no_defs_lthy) raw_ctrs;
95.291 - val sel_defaultss =
95.292 - pad_list [] n (map (map (apsnd (prep_term no_defs_lthy))) raw_sel_defaultss);
95.293 -
95.294 - val Type (fcT_name, As0) = body_type (fastype_of (hd ctrs0));
95.295 - val fc_b_name = Long_Name.base_name fcT_name;
95.296 - val fc_b = Binding.name fc_b_name;
95.297 -
95.298 - fun qualify mandatory =
95.299 - Binding.qualify mandatory fc_b_name o (rep_compat ? Binding.qualify false rep_compat_prefix);
95.300 -
95.301 - fun dest_TFree_or_TVar (TFree p) = p
95.302 - | dest_TFree_or_TVar (TVar ((s, _), S)) = (s, S)
95.303 - | dest_TFree_or_TVar _ = error "Invalid type argument";
95.304 -
95.305 - val (unsorted_As, B) =
95.306 - no_defs_lthy
95.307 - |> variant_tfrees (map (fst o dest_TFree_or_TVar) As0)
95.308 - ||> the_single o fst o mk_TFrees 1;
95.309 -
95.310 - val As = map2 (resort_tfree o snd o dest_TFree_or_TVar) As0 unsorted_As;
95.311 -
95.312 - val fcT = Type (fcT_name, As);
95.313 - val ctrs = map (mk_ctr As) ctrs0;
95.314 - val ctr_Tss = map (binder_types o fastype_of) ctrs;
95.315 -
95.316 - val ms = map length ctr_Tss;
95.317 -
95.318 - val raw_disc_bindings' = pad_list Binding.empty n raw_disc_bindings;
95.319 -
95.320 - fun can_definitely_rely_on_disc k = not (Binding.is_empty (nth raw_disc_bindings' (k - 1)));
95.321 - fun can_rely_on_disc k =
95.322 - can_definitely_rely_on_disc k orelse (k = 1 andalso not (can_definitely_rely_on_disc 2));
95.323 - fun should_omit_disc_binding k = n = 1 orelse (n = 2 andalso can_rely_on_disc (3 - k));
95.324 -
95.325 - fun is_disc_binding_valid b =
95.326 - not (Binding.is_empty b orelse Binding.eq_name (b, equal_binding));
95.327 -
95.328 - val standard_disc_binding = Binding.name o prefix isN o base_name_of_ctr;
95.329 -
95.330 - val disc_bindings =
95.331 - raw_disc_bindings'
95.332 - |> map4 (fn k => fn m => fn ctr => fn disc =>
95.333 - qualify false
95.334 - (if Binding.is_empty disc then
95.335 - if should_omit_disc_binding k then disc else standard_disc_binding ctr
95.336 - else if Binding.eq_name (disc, equal_binding) then
95.337 - if m = 0 then disc
95.338 - else error "Cannot use \"=\" syntax for discriminating nonnullary constructor"
95.339 - else if Binding.eq_name (disc, standard_binding) then
95.340 - standard_disc_binding ctr
95.341 - else
95.342 - disc)) ks ms ctrs0;
95.343 -
95.344 - fun standard_sel_binding m l = Binding.name o mk_unN m l o base_name_of_ctr;
95.345 -
95.346 - val sel_bindingss =
95.347 - pad_list [] n raw_sel_bindingss
95.348 - |> map3 (fn ctr => fn m => map2 (fn l => fn sel =>
95.349 - qualify false
95.350 - (if Binding.is_empty sel orelse Binding.eq_name (sel, standard_binding) then
95.351 - standard_sel_binding m l ctr
95.352 - else
95.353 - sel)) (1 upto m) o pad_list Binding.empty m) ctrs0 ms;
95.354 -
95.355 - val case_Ts = map (fn Ts => Ts ---> B) ctr_Tss;
95.356 -
95.357 - val ((((((((xss, xss'), yss), fs), gs), [u', v']), [w]), (p, p')), names_lthy) = no_defs_lthy |>
95.358 - mk_Freess' "x" ctr_Tss
95.359 - ||>> mk_Freess "y" ctr_Tss
95.360 - ||>> mk_Frees "f" case_Ts
95.361 - ||>> mk_Frees "g" case_Ts
95.362 - ||>> (apfst (map (rpair fcT)) oo Variable.variant_fixes) [fc_b_name, fc_b_name ^ "'"]
95.363 - ||>> mk_Frees "z" [B]
95.364 - ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "P") HOLogic.boolT;
95.365 -
95.366 - val u = Free u';
95.367 - val v = Free v';
95.368 - val q = Free (fst p', mk_pred1T B);
95.369 -
95.370 - val xctrs = map2 (curry Term.list_comb) ctrs xss;
95.371 - val yctrs = map2 (curry Term.list_comb) ctrs yss;
95.372 -
95.373 - val xfs = map2 (curry Term.list_comb) fs xss;
95.374 - val xgs = map2 (curry Term.list_comb) gs xss;
95.375 -
95.376 - (* TODO: Eta-expension is for compatibility with the old datatype package (but it also provides
95.377 - nicer names). Consider removing. *)
95.378 - val eta_fs = map2 eta_expand_arg xss xfs;
95.379 - val eta_gs = map2 eta_expand_arg xss xgs;
95.380 -
95.381 - val case_binding =
95.382 - qualify false
95.383 - (if Binding.is_empty raw_case_binding orelse
95.384 - Binding.eq_name (raw_case_binding, standard_binding) then
95.385 - Binding.suffix_name ("_" ^ caseN) fc_b
95.386 - else
95.387 - raw_case_binding);
95.388 -
95.389 - fun mk_case_disj xctr xf xs =
95.390 - list_exists_free xs (HOLogic.mk_conj (HOLogic.mk_eq (u, xctr), HOLogic.mk_eq (w, xf)));
95.391 -
95.392 - val case_rhs = fold_rev (fold_rev Term.lambda) [fs, [u]]
95.393 - (Const (@{const_name The}, (B --> HOLogic.boolT) --> B) $
95.394 - Term.lambda w (Library.foldr1 HOLogic.mk_disj (map3 mk_case_disj xctrs xfs xss)));
95.395 -
95.396 - val ((raw_case, (_, raw_case_def)), (lthy', lthy)) = no_defs_lthy
95.397 - |> Local_Theory.define ((case_binding, NoSyn), ((Thm.def_binding case_binding, []), case_rhs))
95.398 - ||> `Local_Theory.restore;
95.399 -
95.400 - val phi = Proof_Context.export_morphism lthy lthy';
95.401 -
95.402 - val case_def = Morphism.thm phi raw_case_def;
95.403 -
95.404 - val case0 = Morphism.term phi raw_case;
95.405 - val casex = mk_case As B case0;
95.406 -
95.407 - val fcase = Term.list_comb (casex, fs);
95.408 -
95.409 - val ufcase = fcase $ u;
95.410 - val vfcase = fcase $ v;
95.411 -
95.412 - val eta_fcase = Term.list_comb (casex, eta_fs);
95.413 - val eta_gcase = Term.list_comb (casex, eta_gs);
95.414 -
95.415 - val eta_ufcase = eta_fcase $ u;
95.416 - val eta_vgcase = eta_gcase $ v;
95.417 -
95.418 - fun mk_uu_eq () = HOLogic.mk_eq (u, u);
95.419 -
95.420 - val uv_eq = mk_Trueprop_eq (u, v);
95.421 -
95.422 - val exist_xs_u_eq_ctrs =
95.423 - map2 (fn xctr => fn xs => list_exists_free xs (HOLogic.mk_eq (u, xctr))) xctrs xss;
95.424 -
95.425 - val unique_disc_no_def = TrueI; (*arbitrary marker*)
95.426 - val alternate_disc_no_def = FalseE; (*arbitrary marker*)
95.427 -
95.428 - fun alternate_disc_lhs get_udisc k =
95.429 - HOLogic.mk_not
95.430 - (let val b = nth disc_bindings (k - 1) in
95.431 - if is_disc_binding_valid b then get_udisc b (k - 1) else nth exist_xs_u_eq_ctrs (k - 1)
95.432 - end);
95.433 -
95.434 - val (all_sels_distinct, discs, selss, disc_defs, sel_defs, sel_defss, lthy') =
95.435 - if no_discs_sels then
95.436 - (true, [], [], [], [], [], lthy)
95.437 - else
95.438 - let
95.439 - fun disc_free b = Free (Binding.name_of b, mk_pred1T fcT);
95.440 -
95.441 - fun disc_spec b exist_xs_u_eq_ctr = mk_Trueprop_eq (disc_free b $ u, exist_xs_u_eq_ctr);
95.442 -
95.443 - fun alternate_disc k =
95.444 - Term.lambda u (alternate_disc_lhs (K o rapp u o disc_free) (3 - k));
95.445 -
95.446 - fun mk_sel_case_args b proto_sels T =
95.447 - map2 (fn Ts => fn k =>
95.448 - (case AList.lookup (op =) proto_sels k of
95.449 - NONE =>
95.450 - (case AList.lookup Binding.eq_name (rev (nth sel_defaultss (k - 1))) b of
95.451 - NONE => fold_rev (Term.lambda o curry Free Name.uu) Ts (mk_undefined T)
95.452 - | SOME t => t |> Type.constraint (Ts ---> T) |> Syntax.check_term lthy)
95.453 - | SOME (xs, x) => fold_rev Term.lambda xs x)) ctr_Tss ks;
95.454 -
95.455 - fun sel_spec b proto_sels =
95.456 - let
95.457 - val _ =
95.458 - (case duplicates (op =) (map fst proto_sels) of
95.459 - k :: _ => error ("Duplicate selector name " ^ quote (Binding.name_of b) ^
95.460 - " for constructor " ^
95.461 - quote (Syntax.string_of_term lthy (nth ctrs (k - 1))))
95.462 - | [] => ())
95.463 - val T =
95.464 - (case distinct (op =) (map (fastype_of o snd o snd) proto_sels) of
95.465 - [T] => T
95.466 - | T :: T' :: _ => error ("Inconsistent range type for selector " ^
95.467 - quote (Binding.name_of b) ^ ": " ^ quote (Syntax.string_of_typ lthy T) ^ " vs. "
95.468 - ^ quote (Syntax.string_of_typ lthy T')));
95.469 - in
95.470 - mk_Trueprop_eq (Free (Binding.name_of b, fcT --> T) $ u,
95.471 - Term.list_comb (mk_case As T case0, mk_sel_case_args b proto_sels T) $ u)
95.472 - end;
95.473 -
95.474 - val sel_bindings = flat sel_bindingss;
95.475 - val uniq_sel_bindings = distinct Binding.eq_name sel_bindings;
95.476 - val all_sels_distinct = (length uniq_sel_bindings = length sel_bindings);
95.477 -
95.478 - val sel_binding_index =
95.479 - if all_sels_distinct then 1 upto length sel_bindings
95.480 - else map (fn b => find_index (curry Binding.eq_name b) uniq_sel_bindings) sel_bindings;
95.481 -
95.482 - val proto_sels = flat (map3 (fn k => fn xs => map (fn x => (k, (xs, x)))) ks xss xss);
95.483 - val sel_infos =
95.484 - AList.group (op =) (sel_binding_index ~~ proto_sels)
95.485 - |> sort (int_ord o pairself fst)
95.486 - |> map snd |> curry (op ~~) uniq_sel_bindings;
95.487 - val sel_bindings = map fst sel_infos;
95.488 -
95.489 - fun unflat_selss xs = unflat_lookup Binding.eq_name sel_bindings xs sel_bindingss;
95.490 -
95.491 - val (((raw_discs, raw_disc_defs), (raw_sels, raw_sel_defs)), (lthy', lthy)) =
95.492 - lthy
95.493 - |> apfst split_list o fold_map3 (fn k => fn exist_xs_u_eq_ctr => fn b =>
95.494 - if Binding.is_empty b then
95.495 - if n = 1 then pair (Term.lambda u (mk_uu_eq ()), unique_disc_no_def)
95.496 - else pair (alternate_disc k, alternate_disc_no_def)
95.497 - else if Binding.eq_name (b, equal_binding) then
95.498 - pair (Term.lambda u exist_xs_u_eq_ctr, refl)
95.499 - else
95.500 - Specification.definition (SOME (b, NONE, NoSyn),
95.501 - ((Thm.def_binding b, []), disc_spec b exist_xs_u_eq_ctr)) #>> apsnd snd)
95.502 - ks exist_xs_u_eq_ctrs disc_bindings
95.503 - ||>> apfst split_list o fold_map (fn (b, proto_sels) =>
95.504 - Specification.definition (SOME (b, NONE, NoSyn),
95.505 - ((Thm.def_binding b, []), sel_spec b proto_sels)) #>> apsnd snd) sel_infos
95.506 - ||> `Local_Theory.restore;
95.507 -
95.508 - val phi = Proof_Context.export_morphism lthy lthy';
95.509 -
95.510 - val disc_defs = map (Morphism.thm phi) raw_disc_defs;
95.511 - val sel_defs = map (Morphism.thm phi) raw_sel_defs;
95.512 - val sel_defss = unflat_selss sel_defs;
95.513 -
95.514 - val discs0 = map (Morphism.term phi) raw_discs;
95.515 - val selss0 = unflat_selss (map (Morphism.term phi) raw_sels);
95.516 -
95.517 - val discs = map (mk_disc_or_sel As) discs0;
95.518 - val selss = map (map (mk_disc_or_sel As)) selss0;
95.519 - in
95.520 - (all_sels_distinct, discs, selss, disc_defs, sel_defs, sel_defss, lthy')
95.521 - end;
95.522 -
95.523 - fun mk_imp_p Qs = Logic.list_implies (Qs, HOLogic.mk_Trueprop p);
95.524 -
95.525 - val exhaust_goal =
95.526 - let fun mk_prem xctr xs = fold_rev Logic.all xs (mk_imp_p [mk_Trueprop_eq (u, xctr)]) in
95.527 - fold_rev Logic.all [p, u] (mk_imp_p (map2 mk_prem xctrs xss))
95.528 - end;
95.529 -
95.530 - val inject_goalss =
95.531 - let
95.532 - fun mk_goal _ _ [] [] = []
95.533 - | mk_goal xctr yctr xs ys =
95.534 - [fold_rev Logic.all (xs @ ys) (mk_Trueprop_eq (HOLogic.mk_eq (xctr, yctr),
95.535 - Library.foldr1 HOLogic.mk_conj (map2 (curry HOLogic.mk_eq) xs ys)))];
95.536 - in
95.537 - map4 mk_goal xctrs yctrs xss yss
95.538 - end;
95.539 -
95.540 - val half_distinct_goalss =
95.541 - let
95.542 - fun mk_goal ((xs, xc), (xs', xc')) =
95.543 - fold_rev Logic.all (xs @ xs')
95.544 - (HOLogic.mk_Trueprop (HOLogic.mk_not (HOLogic.mk_eq (xc, xc'))));
95.545 - in
95.546 - map (map mk_goal) (mk_half_pairss (`I (xss ~~ xctrs)))
95.547 - end;
95.548 -
95.549 - val goalss = [exhaust_goal] :: inject_goalss @ half_distinct_goalss;
95.550 -
95.551 - fun after_qed thmss lthy =
95.552 - let
95.553 - val ([exhaust_thm], (inject_thmss, half_distinct_thmss)) = (hd thmss, chop n (tl thmss));
95.554 -
95.555 - val inject_thms = flat inject_thmss;
95.556 -
95.557 - val rho_As = map (pairself (certifyT lthy)) (map Logic.varifyT_global As ~~ As);
95.558 -
95.559 - fun inst_thm t thm =
95.560 - Drule.instantiate' [] [SOME (certify lthy t)]
95.561 - (Thm.instantiate (rho_As, []) (Drule.zero_var_indexes thm));
95.562 -
95.563 - val uexhaust_thm = inst_thm u exhaust_thm;
95.564 -
95.565 - val exhaust_cases = map base_name_of_ctr ctrs;
95.566 -
95.567 - val other_half_distinct_thmss = map (map (fn thm => thm RS not_sym)) half_distinct_thmss;
95.568 -
95.569 - val (distinct_thms, (distinct_thmsss', distinct_thmsss)) =
95.570 - join_halves n half_distinct_thmss other_half_distinct_thmss ||> `transpose;
95.571 -
95.572 - val nchotomy_thm =
95.573 - let
95.574 - val goal =
95.575 - HOLogic.mk_Trueprop (HOLogic.mk_all (fst u', snd u',
95.576 - Library.foldr1 HOLogic.mk_disj exist_xs_u_eq_ctrs));
95.577 - in
95.578 - Goal.prove_sorry lthy [] [] goal (fn _ => mk_nchotomy_tac n exhaust_thm)
95.579 - |> Thm.close_derivation
95.580 - end;
95.581 -
95.582 - val case_thms =
95.583 - let
95.584 - val goals =
95.585 - map3 (fn xctr => fn xf => fn xs =>
95.586 - fold_rev Logic.all (fs @ xs) (mk_Trueprop_eq (fcase $ xctr, xf))) xctrs xfs xss;
95.587 - in
95.588 - map4 (fn k => fn goal => fn injects => fn distinctss =>
95.589 - Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
95.590 - mk_case_tac ctxt n k case_def injects distinctss)
95.591 - |> Thm.close_derivation)
95.592 - ks goals inject_thmss distinct_thmsss
95.593 - end;
95.594 -
95.595 - val (case_cong_thm, weak_case_cong_thm) =
95.596 - let
95.597 - fun mk_prem xctr xs xf xg =
95.598 - fold_rev Logic.all xs (Logic.mk_implies (mk_Trueprop_eq (v, xctr),
95.599 - mk_Trueprop_eq (xf, xg)));
95.600 -
95.601 - val goal =
95.602 - Logic.list_implies (uv_eq :: map4 mk_prem xctrs xss xfs xgs,
95.603 - mk_Trueprop_eq (eta_ufcase, eta_vgcase));
95.604 - val weak_goal = Logic.mk_implies (uv_eq, mk_Trueprop_eq (ufcase, vfcase));
95.605 - in
95.606 - (Goal.prove_sorry lthy [] [] goal (fn _ => mk_case_cong_tac lthy uexhaust_thm case_thms),
95.607 - Goal.prove_sorry lthy [] [] weak_goal (K (etac arg_cong 1)))
95.608 - |> pairself (Thm.close_derivation #> singleton (Proof_Context.export names_lthy lthy))
95.609 - end;
95.610 -
95.611 - val split_lhs = q $ ufcase;
95.612 -
95.613 - fun mk_split_conjunct xctr xs f_xs =
95.614 - list_all_free xs (HOLogic.mk_imp (HOLogic.mk_eq (u, xctr), q $ f_xs));
95.615 - fun mk_split_disjunct xctr xs f_xs =
95.616 - list_exists_free xs (HOLogic.mk_conj (HOLogic.mk_eq (u, xctr),
95.617 - HOLogic.mk_not (q $ f_xs)));
95.618 -
95.619 - fun mk_split_goal xctrs xss xfs =
95.620 - mk_Trueprop_eq (split_lhs, Library.foldr1 HOLogic.mk_conj
95.621 - (map3 mk_split_conjunct xctrs xss xfs));
95.622 - fun mk_split_asm_goal xctrs xss xfs =
95.623 - mk_Trueprop_eq (split_lhs, HOLogic.mk_not (Library.foldr1 HOLogic.mk_disj
95.624 - (map3 mk_split_disjunct xctrs xss xfs)));
95.625 -
95.626 - fun prove_split selss goal =
95.627 - Goal.prove_sorry lthy [] [] goal (fn _ =>
95.628 - mk_split_tac lthy uexhaust_thm case_thms selss inject_thmss distinct_thmsss)
95.629 - |> Thm.close_derivation
95.630 - |> singleton (Proof_Context.export names_lthy lthy);
95.631 -
95.632 - fun prove_split_asm asm_goal split_thm =
95.633 - Goal.prove_sorry lthy [] [] asm_goal (fn {context = ctxt, ...} =>
95.634 - mk_split_asm_tac ctxt split_thm)
95.635 - |> Thm.close_derivation
95.636 - |> singleton (Proof_Context.export names_lthy lthy);
95.637 -
95.638 - val (split_thm, split_asm_thm) =
95.639 - let
95.640 - val goal = mk_split_goal xctrs xss xfs;
95.641 - val asm_goal = mk_split_asm_goal xctrs xss xfs;
95.642 -
95.643 - val thm = prove_split (replicate n []) goal;
95.644 - val asm_thm = prove_split_asm asm_goal thm;
95.645 - in
95.646 - (thm, asm_thm)
95.647 - end;
95.648 -
95.649 - val (all_sel_thms, sel_thmss, disc_thmss, nontriv_disc_thms, discI_thms, nontriv_discI_thms,
95.650 - disc_exclude_thms, disc_exhaust_thms, sel_exhaust_thms, all_collapse_thms,
95.651 - safe_collapse_thms, expand_thms, sel_split_thms, sel_split_asm_thms,
95.652 - case_conv_if_thms) =
95.653 - if no_discs_sels then
95.654 - ([], [], [], [], [], [], [], [], [], [], [], [], [], [], [])
95.655 - else
95.656 - let
95.657 - val udiscs = map (rapp u) discs;
95.658 - val uselss = map (map (rapp u)) selss;
95.659 - val usel_ctrs = map2 (curry Term.list_comb) ctrs uselss;
95.660 - val usel_fs = map2 (curry Term.list_comb) fs uselss;
95.661 -
95.662 - val vdiscs = map (rapp v) discs;
95.663 - val vselss = map (map (rapp v)) selss;
95.664 -
95.665 - fun make_sel_thm xs' case_thm sel_def =
95.666 - zero_var_indexes (Drule.gen_all (Drule.rename_bvars' (map (SOME o fst) xs')
95.667 - (Drule.forall_intr_vars (case_thm RS (sel_def RS trans)))));
95.668 -
95.669 - val sel_thmss = map3 (map oo make_sel_thm) xss' case_thms sel_defss;
95.670 -
95.671 - fun has_undefined_rhs thm =
95.672 - (case snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (prop_of thm))) of
95.673 - Const (@{const_name undefined}, _) => true
95.674 - | _ => false);
95.675 -
95.676 - val all_sel_thms =
95.677 - (if all_sels_distinct andalso forall null sel_defaultss then
95.678 - flat sel_thmss
95.679 - else
95.680 - map_product (fn s => fn (xs', c) => make_sel_thm xs' c s) sel_defs
95.681 - (xss' ~~ case_thms))
95.682 - |> filter_out has_undefined_rhs;
95.683 -
95.684 - fun mk_unique_disc_def () =
95.685 - let
95.686 - val m = the_single ms;
95.687 - val goal = mk_Trueprop_eq (mk_uu_eq (), the_single exist_xs_u_eq_ctrs);
95.688 - in
95.689 - Goal.prove_sorry lthy [] [] goal (fn _ => mk_unique_disc_def_tac m uexhaust_thm)
95.690 - |> Thm.close_derivation
95.691 - |> singleton (Proof_Context.export names_lthy lthy)
95.692 - end;
95.693 -
95.694 - fun mk_alternate_disc_def k =
95.695 - let
95.696 - val goal =
95.697 - mk_Trueprop_eq (alternate_disc_lhs (K (nth udiscs)) (3 - k),
95.698 - nth exist_xs_u_eq_ctrs (k - 1));
95.699 - in
95.700 - Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
95.701 - mk_alternate_disc_def_tac ctxt k (nth disc_defs (2 - k))
95.702 - (nth distinct_thms (2 - k)) uexhaust_thm)
95.703 - |> Thm.close_derivation
95.704 - |> singleton (Proof_Context.export names_lthy lthy)
95.705 - end;
95.706 -
95.707 - val has_alternate_disc_def =
95.708 - exists (fn def => Thm.eq_thm_prop (def, alternate_disc_no_def)) disc_defs;
95.709 -
95.710 - val disc_defs' =
95.711 - map2 (fn k => fn def =>
95.712 - if Thm.eq_thm_prop (def, unique_disc_no_def) then mk_unique_disc_def ()
95.713 - else if Thm.eq_thm_prop (def, alternate_disc_no_def) then mk_alternate_disc_def k
95.714 - else def) ks disc_defs;
95.715 -
95.716 - val discD_thms = map (fn def => def RS iffD1) disc_defs';
95.717 - val discI_thms =
95.718 - map2 (fn m => fn def => funpow m (fn thm => exI RS thm) (def RS iffD2)) ms
95.719 - disc_defs';
95.720 - val not_discI_thms =
95.721 - map2 (fn m => fn def => funpow m (fn thm => allI RS thm)
95.722 - (unfold_thms lthy @{thms not_ex} (def RS @{thm ssubst[of _ _ Not]})))
95.723 - ms disc_defs';
95.724 -
95.725 - val (disc_thmss', disc_thmss) =
95.726 - let
95.727 - fun mk_thm discI _ [] = refl RS discI
95.728 - | mk_thm _ not_discI [distinct] = distinct RS not_discI;
95.729 - fun mk_thms discI not_discI distinctss = map (mk_thm discI not_discI) distinctss;
95.730 - in
95.731 - map3 mk_thms discI_thms not_discI_thms distinct_thmsss' |> `transpose
95.732 - end;
95.733 -
95.734 - val nontriv_disc_thms =
95.735 - flat (map2 (fn b => if is_disc_binding_valid b then I else K [])
95.736 - disc_bindings disc_thmss);
95.737 -
95.738 - fun is_discI_boring b =
95.739 - (n = 1 andalso Binding.is_empty b) orelse Binding.eq_name (b, equal_binding);
95.740 -
95.741 - val nontriv_discI_thms =
95.742 - flat (map2 (fn b => if is_discI_boring b then K [] else single) disc_bindings
95.743 - discI_thms);
95.744 -
95.745 - val (disc_exclude_thms, (disc_exclude_thmsss', disc_exclude_thmsss)) =
95.746 - let
95.747 - fun mk_goal [] = []
95.748 - | mk_goal [((_, udisc), (_, udisc'))] =
95.749 - [Logic.all u (Logic.mk_implies (HOLogic.mk_Trueprop udisc,
95.750 - HOLogic.mk_Trueprop (HOLogic.mk_not udisc')))];
95.751 -
95.752 - fun prove tac goal =
95.753 - Goal.prove_sorry lthy [] [] goal (K tac)
95.754 - |> Thm.close_derivation;
95.755 -
95.756 - val half_pairss = mk_half_pairss (`I (ms ~~ discD_thms ~~ udiscs));
95.757 -
95.758 - val half_goalss = map mk_goal half_pairss;
95.759 - val half_thmss =
95.760 - map3 (fn [] => K (K []) | [goal] => fn [(((m, discD), _), _)] =>
95.761 - fn disc_thm => [prove (mk_half_disc_exclude_tac lthy m discD disc_thm) goal])
95.762 - half_goalss half_pairss (flat disc_thmss');
95.763 -
95.764 - val other_half_goalss = map (mk_goal o map swap) half_pairss;
95.765 - val other_half_thmss =
95.766 - map2 (map2 (prove o mk_other_half_disc_exclude_tac)) half_thmss
95.767 - other_half_goalss;
95.768 - in
95.769 - join_halves n half_thmss other_half_thmss ||> `transpose
95.770 - |>> has_alternate_disc_def ? K []
95.771 - end;
95.772 -
95.773 - val disc_exhaust_thm =
95.774 - let
95.775 - fun mk_prem udisc = mk_imp_p [HOLogic.mk_Trueprop udisc];
95.776 - val goal = fold_rev Logic.all [p, u] (mk_imp_p (map mk_prem udiscs));
95.777 - in
95.778 - Goal.prove_sorry lthy [] [] goal (fn _ =>
95.779 - mk_disc_exhaust_tac n exhaust_thm discI_thms)
95.780 - |> Thm.close_derivation
95.781 - end;
95.782 -
95.783 - val (safe_collapse_thms, all_collapse_thms) =
95.784 - let
95.785 - fun mk_goal m udisc usel_ctr =
95.786 - let
95.787 - val prem = HOLogic.mk_Trueprop udisc;
95.788 - val concl = mk_Trueprop_eq ((usel_ctr, u) |> m = 0 ? swap);
95.789 - in
95.790 - (prem aconv concl, Logic.all u (Logic.mk_implies (prem, concl)))
95.791 - end;
95.792 - val (trivs, goals) = map3 mk_goal ms udiscs usel_ctrs |> split_list;
95.793 - val thms =
95.794 - map5 (fn m => fn discD => fn sel_thms => fn triv => fn goal =>
95.795 - Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
95.796 - mk_collapse_tac ctxt m discD sel_thms ORELSE HEADGOAL atac)
95.797 - |> Thm.close_derivation
95.798 - |> not triv ? perhaps (try (fn thm => refl RS thm)))
95.799 - ms discD_thms sel_thmss trivs goals;
95.800 - in
95.801 - (map_filter (fn (true, _) => NONE | (false, thm) => SOME thm) (trivs ~~ thms),
95.802 - thms)
95.803 - end;
95.804 -
95.805 - val swapped_all_collapse_thms =
95.806 - map2 (fn m => fn thm => if m = 0 then thm else thm RS sym) ms all_collapse_thms;
95.807 -
95.808 - val sel_exhaust_thm =
95.809 - let
95.810 - fun mk_prem usel_ctr = mk_imp_p [mk_Trueprop_eq (u, usel_ctr)];
95.811 - val goal = fold_rev Logic.all [p, u] (mk_imp_p (map mk_prem usel_ctrs));
95.812 - in
95.813 - Goal.prove_sorry lthy [] [] goal (fn _ =>
95.814 - mk_sel_exhaust_tac n disc_exhaust_thm swapped_all_collapse_thms)
95.815 - |> Thm.close_derivation
95.816 - end;
95.817 -
95.818 - val expand_thm =
95.819 - let
95.820 - fun mk_prems k udisc usels vdisc vsels =
95.821 - (if k = n then [] else [mk_Trueprop_eq (udisc, vdisc)]) @
95.822 - (if null usels then
95.823 - []
95.824 - else
95.825 - [Logic.list_implies
95.826 - (if n = 1 then [] else map HOLogic.mk_Trueprop [udisc, vdisc],
95.827 - HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
95.828 - (map2 (curry HOLogic.mk_eq) usels vsels)))]);
95.829 -
95.830 - val goal =
95.831 - Library.foldr Logic.list_implies
95.832 - (map5 mk_prems ks udiscs uselss vdiscs vselss, uv_eq);
95.833 - val uncollapse_thms =
95.834 - map2 (fn thm => fn [] => thm | _ => thm RS sym) all_collapse_thms uselss;
95.835 - in
95.836 - Goal.prove_sorry lthy [] [] goal (fn _ =>
95.837 - mk_expand_tac lthy n ms (inst_thm u disc_exhaust_thm)
95.838 - (inst_thm v disc_exhaust_thm) uncollapse_thms disc_exclude_thmsss
95.839 - disc_exclude_thmsss')
95.840 - |> Thm.close_derivation
95.841 - |> singleton (Proof_Context.export names_lthy lthy)
95.842 - end;
95.843 -
95.844 - val (sel_split_thm, sel_split_asm_thm) =
95.845 - let
95.846 - val zss = map (K []) xss;
95.847 - val goal = mk_split_goal usel_ctrs zss usel_fs;
95.848 - val asm_goal = mk_split_asm_goal usel_ctrs zss usel_fs;
95.849 -
95.850 - val thm = prove_split sel_thmss goal;
95.851 - val asm_thm = prove_split_asm asm_goal thm;
95.852 - in
95.853 - (thm, asm_thm)
95.854 - end;
95.855 -
95.856 - val case_conv_if_thm =
95.857 - let
95.858 - val goal = mk_Trueprop_eq (ufcase, mk_IfN B udiscs usel_fs);
95.859 - in
95.860 - Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
95.861 - mk_case_conv_if_tac ctxt n uexhaust_thm case_thms disc_thmss' sel_thmss)
95.862 - |> Thm.close_derivation
95.863 - |> singleton (Proof_Context.export names_lthy lthy)
95.864 - end;
95.865 - in
95.866 - (all_sel_thms, sel_thmss, disc_thmss, nontriv_disc_thms, discI_thms,
95.867 - nontriv_discI_thms, disc_exclude_thms, [disc_exhaust_thm], [sel_exhaust_thm],
95.868 - all_collapse_thms, safe_collapse_thms, [expand_thm], [sel_split_thm],
95.869 - [sel_split_asm_thm], [case_conv_if_thm])
95.870 - end;
95.871 -
95.872 - val exhaust_case_names_attr = Attrib.internal (K (Rule_Cases.case_names exhaust_cases));
95.873 - val cases_type_attr = Attrib.internal (K (Induct.cases_type fcT_name));
95.874 -
95.875 - val notes =
95.876 - [(caseN, case_thms, code_nitpick_simp_simp_attrs),
95.877 - (case_congN, [case_cong_thm], []),
95.878 - (case_conv_ifN, case_conv_if_thms, []),
95.879 - (collapseN, safe_collapse_thms, simp_attrs),
95.880 - (discN, nontriv_disc_thms, simp_attrs),
95.881 - (discIN, nontriv_discI_thms, []),
95.882 - (disc_excludeN, disc_exclude_thms, dest_attrs),
95.883 - (disc_exhaustN, disc_exhaust_thms, [exhaust_case_names_attr]),
95.884 - (distinctN, distinct_thms, simp_attrs @ induct_simp_attrs),
95.885 - (exhaustN, [exhaust_thm], [exhaust_case_names_attr, cases_type_attr]),
95.886 - (expandN, expand_thms, []),
95.887 - (injectN, inject_thms, iff_attrs @ induct_simp_attrs),
95.888 - (nchotomyN, [nchotomy_thm], []),
95.889 - (selN, all_sel_thms, code_nitpick_simp_simp_attrs),
95.890 - (sel_exhaustN, sel_exhaust_thms, [exhaust_case_names_attr]),
95.891 - (sel_splitN, sel_split_thms, []),
95.892 - (sel_split_asmN, sel_split_asm_thms, []),
95.893 - (splitN, [split_thm], []),
95.894 - (split_asmN, [split_asm_thm], []),
95.895 - (splitsN, [split_thm, split_asm_thm], []),
95.896 - (weak_case_cong_thmsN, [weak_case_cong_thm], cong_attrs)]
95.897 - |> filter_out (null o #2)
95.898 - |> map (fn (thmN, thms, attrs) =>
95.899 - ((qualify true (Binding.name thmN), attrs), [(thms, [])]));
95.900 -
95.901 - val notes' =
95.902 - [(map (fn th => th RS notE) distinct_thms, safe_elim_attrs)]
95.903 - |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
95.904 -
95.905 - val ctr_sugar =
95.906 - {ctrs = ctrs, casex = casex, discs = discs, selss = selss, exhaust = exhaust_thm,
95.907 - nchotomy = nchotomy_thm, injects = inject_thms, distincts = distinct_thms,
95.908 - case_thms = case_thms, case_cong = case_cong_thm, weak_case_cong = weak_case_cong_thm,
95.909 - split = split_thm, split_asm = split_asm_thm, disc_thmss = disc_thmss,
95.910 - discIs = discI_thms, sel_thmss = sel_thmss, disc_exhausts = disc_exhaust_thms,
95.911 - sel_exhausts = sel_exhaust_thms, collapses = all_collapse_thms, expands = expand_thms,
95.912 - sel_splits = sel_split_thms, sel_split_asms = sel_split_asm_thms,
95.913 - case_conv_ifs = case_conv_if_thms};
95.914 - in
95.915 - (ctr_sugar,
95.916 - lthy
95.917 - |> not rep_compat ?
95.918 - (Local_Theory.declaration {syntax = false, pervasive = true}
95.919 - (fn phi => Case_Translation.register
95.920 - (Morphism.term phi casex) (map (Morphism.term phi) ctrs)))
95.921 - |> Local_Theory.notes (notes' @ notes) |> snd
95.922 - |> register_ctr_sugar fcT_name ctr_sugar)
95.923 - end;
95.924 - in
95.925 - (goalss, after_qed, lthy')
95.926 - end;
95.927 -
95.928 -fun wrap_free_constructors tacss = (fn (goalss, after_qed, lthy) =>
95.929 - map2 (map2 (Thm.close_derivation oo Goal.prove_sorry lthy [] [])) goalss tacss
95.930 - |> (fn thms => after_qed thms lthy)) oo prepare_wrap_free_constructors (K I);
95.931 -
95.932 -val wrap_free_constructors_cmd = (fn (goalss, after_qed, lthy) =>
95.933 - Proof.theorem NONE (snd oo after_qed) (map (map (rpair [])) goalss) lthy) oo
95.934 - prepare_wrap_free_constructors Syntax.read_term;
95.935 -
95.936 -fun parse_bracket_list parser = @{keyword "["} |-- Parse.list parser --| @{keyword "]"};
95.937 -
95.938 -val parse_bindings = parse_bracket_list parse_binding;
95.939 -val parse_bindingss = parse_bracket_list parse_bindings;
95.940 -
95.941 -val parse_bound_term = (parse_binding --| @{keyword ":"}) -- Parse.term;
95.942 -val parse_bound_terms = parse_bracket_list parse_bound_term;
95.943 -val parse_bound_termss = parse_bracket_list parse_bound_terms;
95.944 -
95.945 -val parse_wrap_free_constructors_options =
95.946 - Scan.optional (@{keyword "("} |-- Parse.list1 ((@{keyword "no_discs_sels"} >> K (true, false)) ||
95.947 - (@{keyword "rep_compat"} >> K (false, true))) --| @{keyword ")"}
95.948 - >> (pairself (exists I) o split_list)) (false, false);
95.949 -
95.950 -val _ =
95.951 - Outer_Syntax.local_theory_to_proof @{command_spec "wrap_free_constructors"}
95.952 - "wrap an existing freely generated type's constructors"
95.953 - ((parse_wrap_free_constructors_options -- (@{keyword "["} |-- Parse.list Parse.term --|
95.954 - @{keyword "]"}) --
95.955 - parse_binding -- Scan.optional (parse_bindings -- Scan.optional (parse_bindingss --
95.956 - Scan.optional parse_bound_termss []) ([], [])) ([], ([], [])))
95.957 - >> wrap_free_constructors_cmd);
95.958 -
95.959 -end;
96.1 --- a/src/HOL/BNF/Tools/ctr_sugar_tactics.ML Thu Dec 05 17:52:12 2013 +0100
96.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
96.3 @@ -1,172 +0,0 @@
96.4 -(* Title: HOL/BNF/Tools/ctr_sugar_tactics.ML
96.5 - Author: Jasmin Blanchette, TU Muenchen
96.6 - Copyright 2012
96.7 -
96.8 -Tactics for wrapping existing freely generated type's constructors.
96.9 -*)
96.10 -
96.11 -signature CTR_SUGAR_GENERAL_TACTICS =
96.12 -sig
96.13 - val select_prem_tac: int -> (int -> tactic) -> int -> int -> tactic
96.14 - val unfold_thms_tac: Proof.context -> thm list -> tactic
96.15 -end;
96.16 -
96.17 -signature CTR_SUGAR_TACTICS =
96.18 -sig
96.19 - include CTR_SUGAR_GENERAL_TACTICS
96.20 -
96.21 - val mk_alternate_disc_def_tac: Proof.context -> int -> thm -> thm -> thm -> tactic
96.22 - val mk_case_tac: Proof.context -> int -> int -> thm -> thm list -> thm list list -> tactic
96.23 - val mk_case_cong_tac: Proof.context -> thm -> thm list -> tactic
96.24 - val mk_case_conv_if_tac: Proof.context -> int -> thm -> thm list -> thm list list ->
96.25 - thm list list -> tactic
96.26 - val mk_collapse_tac: Proof.context -> int -> thm -> thm list -> tactic
96.27 - val mk_disc_exhaust_tac: int -> thm -> thm list -> tactic
96.28 - val mk_expand_tac: Proof.context -> int -> int list -> thm -> thm -> thm list ->
96.29 - thm list list list -> thm list list list -> tactic
96.30 - val mk_half_disc_exclude_tac: Proof.context -> int -> thm -> thm -> tactic
96.31 - val mk_nchotomy_tac: int -> thm -> tactic
96.32 - val mk_other_half_disc_exclude_tac: thm -> tactic
96.33 - val mk_sel_exhaust_tac: int -> thm -> thm list -> tactic
96.34 - val mk_split_tac: Proof.context -> thm -> thm list -> thm list list -> thm list list -> thm list
96.35 - list list -> tactic
96.36 - val mk_split_asm_tac: Proof.context -> thm -> tactic
96.37 - val mk_unique_disc_def_tac: int -> thm -> tactic
96.38 -end;
96.39 -
96.40 -structure Ctr_Sugar_Tactics : CTR_SUGAR_TACTICS =
96.41 -struct
96.42 -
96.43 -open Ctr_Sugar_Util
96.44 -
96.45 -val meta_mp = @{thm meta_mp};
96.46 -
96.47 -fun select_prem_tac n tac k = DETERM o (EVERY' [REPEAT_DETERM_N (k - 1) o etac thin_rl,
96.48 - tac, REPEAT_DETERM_N (n - k) o etac thin_rl]);
96.49 -
96.50 -fun unfold_thms_tac _ [] = all_tac
96.51 - | unfold_thms_tac ctxt thms = Local_Defs.unfold_tac ctxt (distinct Thm.eq_thm_prop thms);
96.52 -
96.53 -fun if_P_or_not_P_OF pos thm = thm RS (if pos then @{thm if_P} else @{thm if_not_P});
96.54 -
96.55 -fun mk_nchotomy_tac n exhaust =
96.56 - HEADGOAL (rtac allI THEN' rtac exhaust THEN'
96.57 - EVERY' (maps (fn k => [rtac (mk_disjIN n k), REPEAT_DETERM o rtac exI, atac]) (1 upto n)));
96.58 -
96.59 -fun mk_unique_disc_def_tac m uexhaust =
96.60 - HEADGOAL (EVERY' [rtac iffI, rtac uexhaust, REPEAT_DETERM_N m o rtac exI, atac, rtac refl]);
96.61 -
96.62 -fun mk_alternate_disc_def_tac ctxt k other_disc_def distinct uexhaust =
96.63 - HEADGOAL (EVERY' ([rtac (other_disc_def RS @{thm arg_cong[of _ _ Not]} RS trans),
96.64 - rtac @{thm iffI_np}, REPEAT_DETERM o etac exE,
96.65 - hyp_subst_tac ctxt, SELECT_GOAL (unfold_thms_tac ctxt [not_ex]), REPEAT_DETERM o rtac allI,
96.66 - rtac distinct, rtac uexhaust] @
96.67 - (([etac notE, REPEAT_DETERM o rtac exI, atac], [REPEAT_DETERM o rtac exI, atac])
96.68 - |> k = 1 ? swap |> op @)));
96.69 -
96.70 -fun mk_half_disc_exclude_tac ctxt m discD disc' =
96.71 - HEADGOAL (dtac discD THEN' REPEAT_DETERM_N m o etac exE THEN' hyp_subst_tac ctxt THEN'
96.72 - rtac disc');
96.73 -
96.74 -fun mk_other_half_disc_exclude_tac half = HEADGOAL (etac @{thm contrapos_pn} THEN' etac half);
96.75 -
96.76 -fun mk_disc_or_sel_exhaust_tac n exhaust destIs =
96.77 - HEADGOAL (rtac exhaust THEN'
96.78 - EVERY' (map2 (fn k => fn destI => dtac destI THEN'
96.79 - select_prem_tac n (etac meta_mp) k THEN' atac) (1 upto n) destIs));
96.80 -
96.81 -val mk_disc_exhaust_tac = mk_disc_or_sel_exhaust_tac;
96.82 -
96.83 -fun mk_sel_exhaust_tac n disc_exhaust collapses =
96.84 - mk_disc_or_sel_exhaust_tac n disc_exhaust collapses ORELSE
96.85 - HEADGOAL (etac meta_mp THEN' resolve_tac collapses);
96.86 -
96.87 -fun mk_collapse_tac ctxt m discD sels =
96.88 - HEADGOAL (dtac discD THEN'
96.89 - (if m = 0 then
96.90 - atac
96.91 - else
96.92 - REPEAT_DETERM_N m o etac exE THEN' hyp_subst_tac ctxt THEN'
96.93 - SELECT_GOAL (unfold_thms_tac ctxt sels) THEN' rtac refl));
96.94 -
96.95 -fun mk_expand_tac ctxt n ms udisc_exhaust vdisc_exhaust uncollapses disc_excludesss
96.96 - disc_excludesss' =
96.97 - if ms = [0] then
96.98 - HEADGOAL (rtac (@{thm trans_sym} OF (replicate 2 (the_single uncollapses))) THEN'
96.99 - TRY o EVERY' [rtac udisc_exhaust, atac, rtac vdisc_exhaust, atac])
96.100 - else
96.101 - let val ks = 1 upto n in
96.102 - HEADGOAL (rtac udisc_exhaust THEN'
96.103 - EVERY' (map5 (fn k => fn m => fn disc_excludess => fn disc_excludess' =>
96.104 - fn uuncollapse =>
96.105 - EVERY' [rtac (uuncollapse RS trans) THEN' TRY o atac,
96.106 - rtac sym, rtac vdisc_exhaust,
96.107 - EVERY' (map4 (fn k' => fn disc_excludes => fn disc_excludes' => fn vuncollapse =>
96.108 - EVERY'
96.109 - (if k' = k then
96.110 - [rtac (vuncollapse RS trans), TRY o atac] @
96.111 - (if m = 0 then
96.112 - [rtac refl]
96.113 - else
96.114 - [if n = 1 then K all_tac else EVERY' [dtac meta_mp, atac, dtac meta_mp, atac],
96.115 - REPEAT_DETERM_N (Int.max (0, m - 1)) o etac conjE,
96.116 - asm_simp_tac (ss_only [] ctxt)])
96.117 - else
96.118 - [dtac (the_single (if k = n then disc_excludes else disc_excludes')),
96.119 - etac (if k = n then @{thm iff_contradict(1)} else @{thm iff_contradict(2)}),
96.120 - atac, atac]))
96.121 - ks disc_excludess disc_excludess' uncollapses)])
96.122 - ks ms disc_excludesss disc_excludesss' uncollapses))
96.123 - end;
96.124 -
96.125 -fun mk_case_same_ctr_tac ctxt injects =
96.126 - REPEAT_DETERM o etac exE THEN' etac conjE THEN'
96.127 - (case injects of
96.128 - [] => atac
96.129 - | [inject] => dtac (inject RS iffD1) THEN' REPEAT_DETERM o etac conjE THEN'
96.130 - hyp_subst_tac ctxt THEN' rtac refl);
96.131 -
96.132 -fun mk_case_distinct_ctrs_tac ctxt distincts =
96.133 - REPEAT_DETERM o etac exE THEN' etac conjE THEN' full_simp_tac (ss_only distincts ctxt);
96.134 -
96.135 -fun mk_case_tac ctxt n k case_def injects distinctss =
96.136 - let
96.137 - val case_def' = mk_unabs_def (n + 1) (case_def RS meta_eq_to_obj_eq);
96.138 - val ks = 1 upto n;
96.139 - in
96.140 - HEADGOAL (rtac (case_def' RS trans) THEN' rtac @{thm the_equality} THEN'
96.141 - rtac (mk_disjIN n k) THEN' REPEAT_DETERM o rtac exI THEN' rtac conjI THEN' rtac refl THEN'
96.142 - rtac refl THEN'
96.143 - EVERY' (map2 (fn k' => fn distincts =>
96.144 - (if k' < n then etac disjE else K all_tac) THEN'
96.145 - (if k' = k then mk_case_same_ctr_tac ctxt injects
96.146 - else mk_case_distinct_ctrs_tac ctxt distincts)) ks distinctss))
96.147 - end;
96.148 -
96.149 -fun mk_case_conv_if_tac ctxt n uexhaust cases discss' selss =
96.150 - HEADGOAL (rtac uexhaust THEN'
96.151 - EVERY' (map3 (fn casex => fn if_discs => fn sels =>
96.152 - EVERY' [hyp_subst_tac ctxt, SELECT_GOAL (unfold_thms_tac ctxt (if_discs @ sels)),
96.153 - rtac casex])
96.154 - cases (map2 (seq_conds if_P_or_not_P_OF n) (1 upto n) discss') selss));
96.155 -
96.156 -fun mk_case_cong_tac ctxt uexhaust cases =
96.157 - HEADGOAL (rtac uexhaust THEN'
96.158 - EVERY' (maps (fn casex => [dtac sym, asm_simp_tac (ss_only [casex] ctxt)]) cases));
96.159 -
96.160 -fun mk_split_tac ctxt uexhaust cases selss injectss distinctsss =
96.161 - HEADGOAL (rtac uexhaust) THEN
96.162 - ALLGOALS (fn k => (hyp_subst_tac ctxt THEN'
96.163 - simp_tac (ss_only (@{thms simp_thms} @ cases @ nth selss (k - 1) @ nth injectss (k - 1) @
96.164 - flat (nth distinctsss (k - 1))) ctxt)) k) THEN
96.165 - ALLGOALS (blast_tac (put_claset (claset_of @{theory_context HOL}) ctxt));
96.166 -
96.167 -val split_asm_thms = @{thms imp_conv_disj de_Morgan_conj de_Morgan_disj not_not not_ex};
96.168 -
96.169 -fun mk_split_asm_tac ctxt split =
96.170 - HEADGOAL (rtac (split RS trans)) THEN unfold_thms_tac ctxt split_asm_thms THEN
96.171 - HEADGOAL (rtac refl);
96.172 -
96.173 -end;
96.174 -
96.175 -structure Ctr_Sugar_General_Tactics: CTR_SUGAR_GENERAL_TACTICS = Ctr_Sugar_Tactics;
97.1 --- a/src/HOL/BNF/Tools/ctr_sugar_util.ML Thu Dec 05 17:52:12 2013 +0100
97.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
97.3 @@ -1,192 +0,0 @@
97.4 -(* Title: HOL/BNF/Tools/ctr_sugar_util.ML
97.5 - Author: Jasmin Blanchette, TU Muenchen
97.6 - Copyright 2012
97.7 -
97.8 -Library for wrapping existing freely generated type's constructors.
97.9 -*)
97.10 -
97.11 -signature CTR_SUGAR_UTIL =
97.12 -sig
97.13 - val map3: ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
97.14 - val map4: ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list
97.15 - val map5: ('a -> 'b -> 'c -> 'd -> 'e -> 'f) ->
97.16 - 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list
97.17 - val fold_map2: ('a -> 'b -> 'c -> 'd * 'c) -> 'a list -> 'b list -> 'c -> 'd list * 'c
97.18 - val fold_map3: ('a -> 'b -> 'c -> 'd -> 'e * 'd) ->
97.19 - 'a list -> 'b list -> 'c list -> 'd -> 'e list * 'd
97.20 - val seq_conds: (bool -> 'a -> 'b) -> int -> int -> 'a list -> 'b list
97.21 - val transpose: 'a list list -> 'a list list
97.22 - val pad_list: 'a -> int -> 'a list -> 'a list
97.23 - val splice: 'a list -> 'a list -> 'a list
97.24 - val permute_like: ('a * 'b -> bool) -> 'a list -> 'b list -> 'c list -> 'c list
97.25 -
97.26 - val mk_names: int -> string -> string list
97.27 - val mk_fresh_names: Proof.context -> int -> string -> string list * Proof.context
97.28 - val mk_TFrees': sort list -> Proof.context -> typ list * Proof.context
97.29 - val mk_TFrees: int -> Proof.context -> typ list * Proof.context
97.30 - val mk_Frees': string -> typ list -> Proof.context ->
97.31 - (term list * (string * typ) list) * Proof.context
97.32 - val mk_Freess': string -> typ list list -> Proof.context ->
97.33 - (term list list * (string * typ) list list) * Proof.context
97.34 - val mk_Frees: string -> typ list -> Proof.context -> term list * Proof.context
97.35 - val mk_Freess: string -> typ list list -> Proof.context -> term list list * Proof.context
97.36 - val resort_tfree: sort -> typ -> typ
97.37 - val variant_types: string list -> sort list -> Proof.context ->
97.38 - (string * sort) list * Proof.context
97.39 - val variant_tfrees: string list -> Proof.context -> typ list * Proof.context
97.40 -
97.41 - val mk_predT: typ list -> typ
97.42 - val mk_pred1T: typ -> typ
97.43 -
97.44 - val mk_disjIN: int -> int -> thm
97.45 -
97.46 - val mk_unabs_def: int -> thm -> thm
97.47 -
97.48 - val mk_IfN: typ -> term list -> term list -> term
97.49 - val mk_Trueprop_eq: term * term -> term
97.50 -
97.51 - val rapp: term -> term -> term
97.52 -
97.53 - val list_all_free: term list -> term -> term
97.54 - val list_exists_free: term list -> term -> term
97.55 -
97.56 - val fo_match: Proof.context -> term -> term -> Type.tyenv * Envir.tenv
97.57 -
97.58 - val unfold_thms: Proof.context -> thm list -> thm -> thm
97.59 -
97.60 - val certifyT: Proof.context -> typ -> ctyp
97.61 - val certify: Proof.context -> term -> cterm
97.62 -
97.63 - val standard_binding: binding
97.64 - val equal_binding: binding
97.65 - val parse_binding: binding parser
97.66 -
97.67 - val ss_only: thm list -> Proof.context -> Proof.context
97.68 -end;
97.69 -
97.70 -structure Ctr_Sugar_Util : CTR_SUGAR_UTIL =
97.71 -struct
97.72 -
97.73 -fun map3 _ [] [] [] = []
97.74 - | map3 f (x1::x1s) (x2::x2s) (x3::x3s) = f x1 x2 x3 :: map3 f x1s x2s x3s
97.75 - | map3 _ _ _ _ = raise ListPair.UnequalLengths;
97.76 -
97.77 -fun map4 _ [] [] [] [] = []
97.78 - | map4 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) = f x1 x2 x3 x4 :: map4 f x1s x2s x3s x4s
97.79 - | map4 _ _ _ _ _ = raise ListPair.UnequalLengths;
97.80 -
97.81 -fun map5 _ [] [] [] [] [] = []
97.82 - | map5 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) =
97.83 - f x1 x2 x3 x4 x5 :: map5 f x1s x2s x3s x4s x5s
97.84 - | map5 _ _ _ _ _ _ = raise ListPair.UnequalLengths;
97.85 -
97.86 -fun fold_map2 _ [] [] acc = ([], acc)
97.87 - | fold_map2 f (x1::x1s) (x2::x2s) acc =
97.88 - let
97.89 - val (x, acc') = f x1 x2 acc;
97.90 - val (xs, acc'') = fold_map2 f x1s x2s acc';
97.91 - in (x :: xs, acc'') end
97.92 - | fold_map2 _ _ _ _ = raise ListPair.UnequalLengths;
97.93 -
97.94 -fun fold_map3 _ [] [] [] acc = ([], acc)
97.95 - | fold_map3 f (x1::x1s) (x2::x2s) (x3::x3s) acc =
97.96 - let
97.97 - val (x, acc') = f x1 x2 x3 acc;
97.98 - val (xs, acc'') = fold_map3 f x1s x2s x3s acc';
97.99 - in (x :: xs, acc'') end
97.100 - | fold_map3 _ _ _ _ _ = raise ListPair.UnequalLengths;
97.101 -
97.102 -fun seq_conds f n k xs =
97.103 - if k = n then
97.104 - map (f false) (take (k - 1) xs)
97.105 - else
97.106 - let val (negs, pos) = split_last (take k xs) in
97.107 - map (f false) negs @ [f true pos]
97.108 - end;
97.109 -
97.110 -fun transpose [] = []
97.111 - | transpose ([] :: xss) = transpose xss
97.112 - | transpose xss = map hd xss :: transpose (map tl xss);
97.113 -
97.114 -fun pad_list x n xs = xs @ replicate (n - length xs) x;
97.115 -
97.116 -fun splice xs ys = flat (map2 (fn x => fn y => [x, y]) xs ys);
97.117 -
97.118 -fun permute_like eq xs xs' ys = map (nth ys o (fn y => find_index (fn x => eq (x, y)) xs)) xs';
97.119 -
97.120 -fun mk_names n x = if n = 1 then [x] else map (fn i => x ^ string_of_int i) (1 upto n);
97.121 -fun mk_fresh_names ctxt = (fn xs => Variable.variant_fixes xs ctxt) oo mk_names;
97.122 -
97.123 -val mk_TFrees' = apfst (map TFree) oo Variable.invent_types;
97.124 -
97.125 -fun mk_TFrees n = mk_TFrees' (replicate n HOLogic.typeS);
97.126 -
97.127 -fun mk_Frees' x Ts ctxt = mk_fresh_names ctxt (length Ts) x |>> (fn xs => `(map Free) (xs ~~ Ts));
97.128 -fun mk_Freess' x Tss = fold_map2 mk_Frees' (mk_names (length Tss) x) Tss #>> split_list;
97.129 -
97.130 -fun mk_Frees x Ts ctxt = mk_fresh_names ctxt (length Ts) x |>> (fn xs => map2 (curry Free) xs Ts);
97.131 -fun mk_Freess x Tss = fold_map2 mk_Frees (mk_names (length Tss) x) Tss;
97.132 -
97.133 -fun resort_tfree S (TFree (s, _)) = TFree (s, S);
97.134 -
97.135 -fun ensure_prefix pre s = s |> not (String.isPrefix pre s) ? prefix pre;
97.136 -
97.137 -fun variant_types ss Ss ctxt =
97.138 - let
97.139 - val (tfrees, _) =
97.140 - fold_map2 (fn s => fn S => Name.variant s #> apfst (rpair S)) ss Ss (Variable.names_of ctxt);
97.141 - val ctxt' = fold (Variable.declare_constraints o Logic.mk_type o TFree) tfrees ctxt;
97.142 - in (tfrees, ctxt') end;
97.143 -
97.144 -fun variant_tfrees ss =
97.145 - apfst (map TFree) o
97.146 - variant_types (map (ensure_prefix "'") ss) (replicate (length ss) HOLogic.typeS);
97.147 -
97.148 -fun mk_predT Ts = Ts ---> HOLogic.boolT;
97.149 -fun mk_pred1T T = mk_predT [T];
97.150 -
97.151 -fun mk_disjIN 1 1 = @{thm TrueE[OF TrueI]}
97.152 - | mk_disjIN _ 1 = disjI1
97.153 - | mk_disjIN 2 2 = disjI2
97.154 - | mk_disjIN n m = (mk_disjIN (n - 1) (m - 1)) RS disjI2;
97.155 -
97.156 -fun mk_unabs_def n = funpow n (fn thm => thm RS fun_cong);
97.157 -
97.158 -fun mk_IfN _ _ [t] = t
97.159 - | mk_IfN T (c :: cs) (t :: ts) =
97.160 - Const (@{const_name If}, HOLogic.boolT --> T --> T --> T) $ c $ t $ mk_IfN T cs ts;
97.161 -
97.162 -val mk_Trueprop_eq = HOLogic.mk_Trueprop o HOLogic.mk_eq;
97.163 -
97.164 -fun rapp u t = betapply (t, u);
97.165 -
97.166 -fun list_quant_free quant_const =
97.167 - fold_rev (fn free => fn P =>
97.168 - let val (x, T) = Term.dest_Free free;
97.169 - in quant_const T $ Term.absfree (x, T) P end);
97.170 -
97.171 -val list_all_free = list_quant_free HOLogic.all_const;
97.172 -val list_exists_free = list_quant_free HOLogic.exists_const;
97.173 -
97.174 -fun fo_match ctxt t pat =
97.175 - let val thy = Proof_Context.theory_of ctxt in
97.176 - Pattern.first_order_match thy (pat, t) (Vartab.empty, Vartab.empty)
97.177 - end;
97.178 -
97.179 -fun unfold_thms ctxt thms = Local_Defs.unfold ctxt (distinct Thm.eq_thm_prop thms);
97.180 -
97.181 -(*stolen from ~~/src/HOL/Tools/SMT/smt_utils.ML*)
97.182 -fun certifyT ctxt = Thm.ctyp_of (Proof_Context.theory_of ctxt);
97.183 -fun certify ctxt = Thm.cterm_of (Proof_Context.theory_of ctxt);
97.184 -
97.185 -(* The standard binding stands for a name generated following the canonical convention (e.g.,
97.186 - "is_Nil" from "Nil"). In contrast, the empty binding is either the standard binding or no
97.187 - binding at all, depending on the context. *)
97.188 -val standard_binding = @{binding _};
97.189 -val equal_binding = @{binding "="};
97.190 -
97.191 -val parse_binding = Parse.binding || @{keyword "="} >> K equal_binding;
97.192 -
97.193 -fun ss_only thms ctxt = clear_simpset (put_simpset HOL_basic_ss ctxt) addsimps thms;
97.194 -
97.195 -end;
98.1 --- a/src/HOL/Big_Operators.thy Thu Dec 05 17:52:12 2013 +0100
98.2 +++ b/src/HOL/Big_Operators.thy Thu Dec 05 17:58:03 2013 +0100
98.3 @@ -6,7 +6,7 @@
98.4 header {* Big operators and finite (non-empty) sets *}
98.5
98.6 theory Big_Operators
98.7 -imports Finite_Set Option Metis
98.8 +imports Finite_Set Metis
98.9 begin
98.10
98.11 subsection {* Generic monoid operation over a set *}
98.12 @@ -696,11 +696,7 @@
98.13 lemma setsum_subtractf:
98.14 "setsum (%x. ((f x)::'a::ab_group_add) - g x) A =
98.15 setsum f A - setsum g A"
98.16 -proof (cases "finite A")
98.17 - case True thus ?thesis by (simp add: diff_minus setsum_addf setsum_negf)
98.18 -next
98.19 - case False thus ?thesis by simp
98.20 -qed
98.21 + using setsum_addf [of f "- g" A] by (simp add: setsum_negf)
98.22
98.23 lemma setsum_nonneg:
98.24 assumes nn: "\<forall>x\<in>A. (0::'a::{ordered_ab_semigroup_add,comm_monoid_add}) \<le> f x"
98.25 @@ -1999,35 +1995,35 @@
98.26 assumes fin_nonempty: "finite A" "A \<noteq> {}"
98.27 begin
98.28
98.29 -lemma Min_ge_iff [simp, no_atp]:
98.30 +lemma Min_ge_iff [simp]:
98.31 "x \<le> Min A \<longleftrightarrow> (\<forall>a\<in>A. x \<le> a)"
98.32 using fin_nonempty by (fact Min.bounded_iff)
98.33
98.34 -lemma Max_le_iff [simp, no_atp]:
98.35 +lemma Max_le_iff [simp]:
98.36 "Max A \<le> x \<longleftrightarrow> (\<forall>a\<in>A. a \<le> x)"
98.37 using fin_nonempty by (fact Max.bounded_iff)
98.38
98.39 -lemma Min_gr_iff [simp, no_atp]:
98.40 +lemma Min_gr_iff [simp]:
98.41 "x < Min A \<longleftrightarrow> (\<forall>a\<in>A. x < a)"
98.42 using fin_nonempty by (induct rule: finite_ne_induct) simp_all
98.43
98.44 -lemma Max_less_iff [simp, no_atp]:
98.45 +lemma Max_less_iff [simp]:
98.46 "Max A < x \<longleftrightarrow> (\<forall>a\<in>A. a < x)"
98.47 using fin_nonempty by (induct rule: finite_ne_induct) simp_all
98.48
98.49 -lemma Min_le_iff [no_atp]:
98.50 +lemma Min_le_iff:
98.51 "Min A \<le> x \<longleftrightarrow> (\<exists>a\<in>A. a \<le> x)"
98.52 using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: min_le_iff_disj)
98.53
98.54 -lemma Max_ge_iff [no_atp]:
98.55 +lemma Max_ge_iff:
98.56 "x \<le> Max A \<longleftrightarrow> (\<exists>a\<in>A. x \<le> a)"
98.57 using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: le_max_iff_disj)
98.58
98.59 -lemma Min_less_iff [no_atp]:
98.60 +lemma Min_less_iff:
98.61 "Min A < x \<longleftrightarrow> (\<exists>a\<in>A. a < x)"
98.62 using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: min_less_iff_disj)
98.63
98.64 -lemma Max_gr_iff [no_atp]:
98.65 +lemma Max_gr_iff:
98.66 "x < Max A \<longleftrightarrow> (\<exists>a\<in>A. x < a)"
98.67 using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: less_max_iff_disj)
98.68
99.1 --- a/src/HOL/Cardinals/Cardinal_Arithmetic.thy Thu Dec 05 17:52:12 2013 +0100
99.2 +++ b/src/HOL/Cardinals/Cardinal_Arithmetic.thy Thu Dec 05 17:58:03 2013 +0100
99.3 @@ -8,270 +8,17 @@
99.4 header {* Cardinal Arithmetic *}
99.5
99.6 theory Cardinal_Arithmetic
99.7 -imports Cardinal_Order_Relation_Base
99.8 +imports Cardinal_Arithmetic_FP Cardinal_Order_Relation
99.9 begin
99.10
99.11 -text {*
99.12 - The following collection of lemmas should be seen as an user interface to the HOL Theory
99.13 - of cardinals. It is not expected to be complete in any sense, since its
99.14 - development was driven by demand arising from the development of the (co)datatype package.
99.15 -*}
99.16 -
99.17 -(*library candidate*)
99.18 -lemma dir_image: "\<lbrakk>\<And>x y. (f x = f y) = (x = y); Card_order r\<rbrakk> \<Longrightarrow> r =o dir_image r f"
99.19 -by (rule dir_image_ordIso) (auto simp add: inj_on_def card_order_on_def)
99.20 -
99.21 -(*should supersede a weaker lemma from the library*)
99.22 -lemma dir_image_Field: "Field (dir_image r f) = f ` Field r"
99.23 -unfolding dir_image_def Field_def Range_def Domain_def by fastforce
99.24 -
99.25 -lemma card_order_dir_image:
99.26 - assumes bij: "bij f" and co: "card_order r"
99.27 - shows "card_order (dir_image r f)"
99.28 -proof -
99.29 - from assms have "Field (dir_image r f) = UNIV"
99.30 - using card_order_on_Card_order[of UNIV r] unfolding bij_def dir_image_Field by auto
99.31 - moreover from bij have "\<And>x y. (f x = f y) = (x = y)" unfolding bij_def inj_on_def by auto
99.32 - with co have "Card_order (dir_image r f)"
99.33 - using card_order_on_Card_order[of UNIV r] Card_order_ordIso2[OF _ dir_image] by blast
99.34 - ultimately show ?thesis by auto
99.35 -qed
99.36 -
99.37 -(*library candidate*)
99.38 -lemma ordIso_refl: "Card_order r \<Longrightarrow> r =o r"
99.39 -by (rule card_order_on_ordIso)
99.40 -
99.41 -(*library candidate*)
99.42 -lemma ordLeq_refl: "Card_order r \<Longrightarrow> r \<le>o r"
99.43 -by (rule ordIso_imp_ordLeq, rule card_order_on_ordIso)
99.44 -
99.45 -(*library candidate*)
99.46 -lemma card_of_ordIso_subst: "A = B \<Longrightarrow> |A| =o |B|"
99.47 -by (simp only: ordIso_refl card_of_Card_order)
99.48 -
99.49 -(*library candidate*)
99.50 -lemma Field_card_order: "card_order r \<Longrightarrow> Field r = UNIV"
99.51 -using card_order_on_Card_order[of UNIV r] by simp
99.52 -
99.53 -(*library candidate*)
99.54 -lemma card_of_Times_Plus_distrib:
99.55 - "|A <*> (B <+> C)| =o |A <*> B <+> A <*> C|" (is "|?RHS| =o |?LHS|")
99.56 -proof -
99.57 - let ?f = "\<lambda>(a, bc). case bc of Inl b \<Rightarrow> Inl (a, b) | Inr c \<Rightarrow> Inr (a, c)"
99.58 - have "bij_betw ?f ?RHS ?LHS" unfolding bij_betw_def inj_on_def by force
99.59 - thus ?thesis using card_of_ordIso by blast
99.60 -qed
99.61 -
99.62 -(*library candidate*)
99.63 -lemma Func_Times_Range:
99.64 - "|Func A (B <*> C)| =o |Func A B <*> Func A C|" (is "|?LHS| =o |?RHS|")
99.65 -proof -
99.66 - let ?F = "\<lambda>fg. (\<lambda>x. if x \<in> A then fst (fg x) else undefined,
99.67 - \<lambda>x. if x \<in> A then snd (fg x) else undefined)"
99.68 - let ?G = "\<lambda>(f, g) x. if x \<in> A then (f x, g x) else undefined"
99.69 - have "bij_betw ?F ?LHS ?RHS" unfolding bij_betw_def inj_on_def
99.70 - proof safe
99.71 - fix f g assume "f \<in> Func A B" "g \<in> Func A C"
99.72 - thus "(f, g) \<in> ?F ` Func A (B \<times> C)"
99.73 - by (intro image_eqI[of _ _ "?G (f, g)"]) (auto simp: Func_def)
99.74 - qed (auto simp: Func_def fun_eq_iff, metis pair_collapse)
99.75 - thus ?thesis using card_of_ordIso by blast
99.76 -qed
99.77 -
99.78 -
99.79 -subsection {* Zero *}
99.80 -
99.81 -definition czero where
99.82 - "czero = card_of {}"
99.83 -
99.84 -lemma czero_ordIso:
99.85 - "czero =o czero"
99.86 -using card_of_empty_ordIso by (simp add: czero_def)
99.87 -
99.88 -lemma card_of_ordIso_czero_iff_empty:
99.89 - "|A| =o (czero :: 'b rel) \<longleftrightarrow> A = ({} :: 'a set)"
99.90 -unfolding czero_def by (rule iffI[OF card_of_empty2]) (auto simp: card_of_refl card_of_empty_ordIso)
99.91 -
99.92 -(* A "not czero" Cardinal predicate *)
99.93 -abbreviation Cnotzero where
99.94 - "Cnotzero (r :: 'a rel) \<equiv> \<not>(r =o (czero :: 'a rel)) \<and> Card_order r"
99.95 -
99.96 -(*helper*)
99.97 -lemma Cnotzero_imp_not_empty: "Cnotzero r \<Longrightarrow> Field r \<noteq> {}"
99.98 -by (metis Card_order_iff_ordIso_card_of czero_def)
99.99 -
99.100 -lemma czeroI:
99.101 - "\<lbrakk>Card_order r; Field r = {}\<rbrakk> \<Longrightarrow> r =o czero"
99.102 -using Cnotzero_imp_not_empty ordIso_transitive[OF _ czero_ordIso] by blast
99.103 -
99.104 -lemma czeroE:
99.105 - "r =o czero \<Longrightarrow> Field r = {}"
99.106 -unfolding czero_def
99.107 -by (drule card_of_cong) (simp only: Field_card_of card_of_empty2)
99.108 -
99.109 -lemma Cnotzero_mono:
99.110 - "\<lbrakk>Cnotzero r; Card_order q; r \<le>o q\<rbrakk> \<Longrightarrow> Cnotzero q"
99.111 -apply (rule ccontr)
99.112 -apply auto
99.113 -apply (drule czeroE)
99.114 -apply (erule notE)
99.115 -apply (erule czeroI)
99.116 -apply (drule card_of_mono2)
99.117 -apply (simp only: card_of_empty3)
99.118 -done
99.119 -
99.120 -subsection {* (In)finite cardinals *}
99.121 -
99.122 -definition cinfinite where
99.123 - "cinfinite r = infinite (Field r)"
99.124 -
99.125 -abbreviation Cinfinite where
99.126 - "Cinfinite r \<equiv> cinfinite r \<and> Card_order r"
99.127 -
99.128 -definition cfinite where
99.129 - "cfinite r = finite (Field r)"
99.130 -
99.131 -abbreviation Cfinite where
99.132 - "Cfinite r \<equiv> cfinite r \<and> Card_order r"
99.133 -
99.134 -lemma Cfinite_ordLess_Cinfinite: "\<lbrakk>Cfinite r; Cinfinite s\<rbrakk> \<Longrightarrow> r <o s"
99.135 - unfolding cfinite_def cinfinite_def
99.136 - by (metis card_order_on_well_order_on finite_ordLess_infinite)
99.137 -
99.138 -lemma natLeq_ordLeq_cinfinite:
99.139 - assumes inf: "Cinfinite r"
99.140 - shows "natLeq \<le>o r"
99.141 -proof -
99.142 - from inf have "natLeq \<le>o |Field r|" by (simp add: cinfinite_def infinite_iff_natLeq_ordLeq)
99.143 - also from inf have "|Field r| =o r" by (simp add: card_of_unique ordIso_symmetric)
99.144 - finally show ?thesis .
99.145 -qed
99.146 -
99.147 -lemma cinfinite_not_czero: "cinfinite r \<Longrightarrow> \<not> (r =o (czero :: 'a rel))"
99.148 -unfolding cinfinite_def by (metis czeroE finite.emptyI)
99.149 -
99.150 -lemma Cinfinite_Cnotzero: "Cinfinite r \<Longrightarrow> Cnotzero r"
99.151 -by (metis cinfinite_not_czero)
99.152 -
99.153 -lemma Cinfinite_cong: "\<lbrakk>r1 =o r2; Cinfinite r1\<rbrakk> \<Longrightarrow> Cinfinite r2"
99.154 -by (metis Card_order_ordIso2 card_of_mono2 card_of_ordLeq_infinite cinfinite_def ordIso_iff_ordLeq)
99.155 -
99.156 -lemma cinfinite_mono: "\<lbrakk>r1 \<le>o r2; cinfinite r1\<rbrakk> \<Longrightarrow> cinfinite r2"
99.157 -by (metis card_of_mono2 card_of_ordLeq_infinite cinfinite_def)
99.158 -
99.159
99.160 subsection {* Binary sum *}
99.161
99.162 -definition csum (infixr "+c" 65) where
99.163 - "r1 +c r2 \<equiv> |Field r1 <+> Field r2|"
99.164 -
99.165 -lemma Field_csum: "Field (r +c s) = Inl ` Field r \<union> Inr ` Field s"
99.166 - unfolding csum_def Field_card_of by auto
99.167 -
99.168 -lemma Card_order_csum:
99.169 - "Card_order (r1 +c r2)"
99.170 -unfolding csum_def by (simp add: card_of_Card_order)
99.171 -
99.172 -lemma csum_Cnotzero1:
99.173 - "Cnotzero r1 \<Longrightarrow> Cnotzero (r1 +c r2)"
99.174 -unfolding csum_def
99.175 -by (metis Cnotzero_imp_not_empty Field_card_of Plus_eq_empty_conv card_of_card_order_on czeroE)
99.176 -
99.177 lemma csum_Cnotzero2:
99.178 "Cnotzero r2 \<Longrightarrow> Cnotzero (r1 +c r2)"
99.179 unfolding csum_def
99.180 by (metis Cnotzero_imp_not_empty Field_card_of Plus_eq_empty_conv card_of_card_order_on czeroE)
99.181
99.182 -lemma card_order_csum:
99.183 - assumes "card_order r1" "card_order r2"
99.184 - shows "card_order (r1 +c r2)"
99.185 -proof -
99.186 - have "Field r1 = UNIV" "Field r2 = UNIV" using assms card_order_on_Card_order by auto
99.187 - thus ?thesis unfolding csum_def by (auto simp: card_of_card_order_on)
99.188 -qed
99.189 -
99.190 -lemma cinfinite_csum:
99.191 - "cinfinite r1 \<or> cinfinite r2 \<Longrightarrow> cinfinite (r1 +c r2)"
99.192 -unfolding cinfinite_def csum_def by (auto simp: Field_card_of)
99.193 -
99.194 -lemma Cinfinite_csum:
99.195 - "Cinfinite r1 \<or> Cinfinite r2 \<Longrightarrow> Cinfinite (r1 +c r2)"
99.196 -unfolding cinfinite_def csum_def by (metis Field_card_of card_of_Card_order finite_Plus_iff)
99.197 -
99.198 -lemma Cinfinite_csum_strong:
99.199 - "\<lbrakk>Cinfinite r1; Cinfinite r2\<rbrakk> \<Longrightarrow> Cinfinite (r1 +c r2)"
99.200 -by (metis Cinfinite_csum)
99.201 -
99.202 -lemma Cinfinite_csum1:
99.203 - "Cinfinite r1 \<Longrightarrow> Cinfinite (r1 +c r2)"
99.204 -unfolding cinfinite_def csum_def by (metis Field_card_of card_of_Card_order finite_Plus_iff)
99.205 -
99.206 -lemma csum_cong: "\<lbrakk>p1 =o r1; p2 =o r2\<rbrakk> \<Longrightarrow> p1 +c p2 =o r1 +c r2"
99.207 -by (simp only: csum_def ordIso_Plus_cong)
99.208 -
99.209 -lemma csum_cong1: "p1 =o r1 \<Longrightarrow> p1 +c q =o r1 +c q"
99.210 -by (simp only: csum_def ordIso_Plus_cong1)
99.211 -
99.212 -lemma csum_cong2: "p2 =o r2 \<Longrightarrow> q +c p2 =o q +c r2"
99.213 -by (simp only: csum_def ordIso_Plus_cong2)
99.214 -
99.215 -lemma csum_mono: "\<lbrakk>p1 \<le>o r1; p2 \<le>o r2\<rbrakk> \<Longrightarrow> p1 +c p2 \<le>o r1 +c r2"
99.216 -by (simp only: csum_def ordLeq_Plus_mono)
99.217 -
99.218 -lemma csum_mono1: "p1 \<le>o r1 \<Longrightarrow> p1 +c q \<le>o r1 +c q"
99.219 -by (simp only: csum_def ordLeq_Plus_mono1)
99.220 -
99.221 -lemma csum_mono2: "p2 \<le>o r2 \<Longrightarrow> q +c p2 \<le>o q +c r2"
99.222 -by (simp only: csum_def ordLeq_Plus_mono2)
99.223 -
99.224 -lemma ordLeq_csum1: "Card_order p1 \<Longrightarrow> p1 \<le>o p1 +c p2"
99.225 -by (simp only: csum_def Card_order_Plus1)
99.226 -
99.227 -lemma ordLeq_csum2: "Card_order p2 \<Longrightarrow> p2 \<le>o p1 +c p2"
99.228 -by (simp only: csum_def Card_order_Plus2)
99.229 -
99.230 -lemma csum_com: "p1 +c p2 =o p2 +c p1"
99.231 -by (simp only: csum_def card_of_Plus_commute)
99.232 -
99.233 -lemma csum_assoc: "(p1 +c p2) +c p3 =o p1 +c p2 +c p3"
99.234 -by (simp only: csum_def Field_card_of card_of_Plus_assoc)
99.235 -
99.236 -lemma Cfinite_csum: "\<lbrakk>Cfinite r; Cfinite s\<rbrakk> \<Longrightarrow> Cfinite (r +c s)"
99.237 - unfolding cfinite_def csum_def Field_card_of using card_of_card_order_on by simp
99.238 -
99.239 -lemma csum_csum: "(r1 +c r2) +c (r3 +c r4) =o (r1 +c r3) +c (r2 +c r4)"
99.240 -proof -
99.241 - have "(r1 +c r2) +c (r3 +c r4) =o r1 +c r2 +c (r3 +c r4)"
99.242 - by (metis csum_assoc)
99.243 - also have "r1 +c r2 +c (r3 +c r4) =o r1 +c (r2 +c r3) +c r4"
99.244 - by (metis csum_assoc csum_cong2 ordIso_symmetric)
99.245 - also have "r1 +c (r2 +c r3) +c r4 =o r1 +c (r3 +c r2) +c r4"
99.246 - by (metis csum_com csum_cong1 csum_cong2)
99.247 - also have "r1 +c (r3 +c r2) +c r4 =o r1 +c r3 +c r2 +c r4"
99.248 - by (metis csum_assoc csum_cong2 ordIso_symmetric)
99.249 - also have "r1 +c r3 +c r2 +c r4 =o (r1 +c r3) +c (r2 +c r4)"
99.250 - by (metis csum_assoc ordIso_symmetric)
99.251 - finally show ?thesis .
99.252 -qed
99.253 -
99.254 -lemma Plus_csum: "|A <+> B| =o |A| +c |B|"
99.255 -by (simp only: csum_def Field_card_of card_of_refl)
99.256 -
99.257 -lemma Un_csum: "|A \<union> B| \<le>o |A| +c |B|"
99.258 -using ordLeq_ordIso_trans[OF card_of_Un_Plus_ordLeq Plus_csum] by blast
99.259 -
99.260 -
99.261 -subsection {* One *}
99.262 -
99.263 -definition cone where
99.264 - "cone = card_of {()}"
99.265 -
99.266 -lemma Card_order_cone: "Card_order cone"
99.267 -unfolding cone_def by (rule card_of_Card_order)
99.268 -
99.269 -lemma Cfinite_cone: "Cfinite cone"
99.270 - unfolding cfinite_def by (simp add: Card_order_cone)
99.271 -
99.272 lemma single_cone:
99.273 "|{x}| =o cone"
99.274 proof -
99.275 @@ -280,349 +27,37 @@
99.276 thus ?thesis unfolding cone_def using card_of_ordIso by blast
99.277 qed
99.278
99.279 -lemma cone_not_czero: "\<not> (cone =o czero)"
99.280 -unfolding czero_def cone_def by (metis empty_not_insert card_of_empty3[of "{()}"] ordIso_iff_ordLeq)
99.281 -
99.282 lemma cone_Cnotzero: "Cnotzero cone"
99.283 by (simp add: cone_not_czero Card_order_cone)
99.284
99.285 -lemma cone_ordLeq_Cnotzero: "Cnotzero r \<Longrightarrow> cone \<le>o r"
99.286 -unfolding cone_def by (metis Card_order_singl_ordLeq czeroI)
99.287 -
99.288 -
99.289 -subsection{* Two *}
99.290 -
99.291 -definition ctwo where
99.292 - "ctwo = |UNIV :: bool set|"
99.293 -
99.294 -lemma Card_order_ctwo: "Card_order ctwo"
99.295 -unfolding ctwo_def by (rule card_of_Card_order)
99.296 -
99.297 lemma cone_ordLeq_ctwo: "cone \<le>o ctwo"
99.298 unfolding cone_def ctwo_def card_of_ordLeq[symmetric] by auto
99.299
99.300 -lemma ctwo_not_czero: "\<not> (ctwo =o czero)"
99.301 -using card_of_empty3[of "UNIV :: bool set"] ordIso_iff_ordLeq
99.302 -unfolding czero_def ctwo_def by (metis UNIV_not_empty)
99.303 -
99.304 -lemma ctwo_Cnotzero: "Cnotzero ctwo"
99.305 -by (simp add: ctwo_not_czero Card_order_ctwo)
99.306 -
99.307 -
99.308 -subsection {* Family sum *}
99.309 -
99.310 -definition Csum where
99.311 - "Csum r rs \<equiv> |SIGMA i : Field r. Field (rs i)|"
99.312 -
99.313 -(* Similar setup to the one for SIGMA from theory Big_Operators: *)
99.314 -syntax "_Csum" ::
99.315 - "pttrn => ('a * 'a) set => 'b * 'b set => (('a * 'b) * ('a * 'b)) set"
99.316 - ("(3CSUM _:_. _)" [0, 51, 10] 10)
99.317 -
99.318 -translations
99.319 - "CSUM i:r. rs" == "CONST Csum r (%i. rs)"
99.320 -
99.321 -lemma SIGMA_CSUM: "|SIGMA i : I. As i| = (CSUM i : |I|. |As i| )"
99.322 -by (auto simp: Csum_def Field_card_of)
99.323 -
99.324 -(* NB: Always, under the cardinal operator,
99.325 -operations on sets are reduced automatically to operations on cardinals.
99.326 -This should make cardinal reasoning more direct and natural. *)
99.327 -
99.328
99.329 subsection {* Product *}
99.330
99.331 -definition cprod (infixr "*c" 80) where
99.332 - "r1 *c r2 = |Field r1 <*> Field r2|"
99.333 -
99.334 lemma Times_cprod: "|A \<times> B| =o |A| *c |B|"
99.335 by (simp only: cprod_def Field_card_of card_of_refl)
99.336
99.337 -lemma card_order_cprod:
99.338 - assumes "card_order r1" "card_order r2"
99.339 - shows "card_order (r1 *c r2)"
99.340 -proof -
99.341 - have "Field r1 = UNIV" "Field r2 = UNIV" using assms card_order_on_Card_order by auto
99.342 - thus ?thesis by (auto simp: cprod_def card_of_card_order_on)
99.343 -qed
99.344 -
99.345 -lemma Card_order_cprod: "Card_order (r1 *c r2)"
99.346 -by (simp only: cprod_def Field_card_of card_of_card_order_on)
99.347 -
99.348 lemma cprod_cong2: "p2 =o r2 \<Longrightarrow> q *c p2 =o q *c r2"
99.349 by (simp only: cprod_def ordIso_Times_cong2)
99.350
99.351 -lemma cprod_mono1: "p1 \<le>o r1 \<Longrightarrow> p1 *c q \<le>o r1 *c q"
99.352 -by (simp only: cprod_def ordLeq_Times_mono1)
99.353 -
99.354 -lemma cprod_mono2: "p2 \<le>o r2 \<Longrightarrow> q *c p2 \<le>o q *c r2"
99.355 -by (simp only: cprod_def ordLeq_Times_mono2)
99.356 -
99.357 lemma ordLeq_cprod1: "\<lbrakk>Card_order p1; Cnotzero p2\<rbrakk> \<Longrightarrow> p1 \<le>o p1 *c p2"
99.358 unfolding cprod_def by (metis Card_order_Times1 czeroI)
99.359
99.360 -lemma ordLeq_cprod2: "\<lbrakk>Cnotzero p1; Card_order p2\<rbrakk> \<Longrightarrow> p2 \<le>o p1 *c p2"
99.361 -unfolding cprod_def by (metis Card_order_Times2 czeroI)
99.362 -
99.363 -lemma cinfinite_cprod: "\<lbrakk>cinfinite r1; cinfinite r2\<rbrakk> \<Longrightarrow> cinfinite (r1 *c r2)"
99.364 -by (simp add: cinfinite_def cprod_def Field_card_of infinite_cartesian_product)
99.365 -
99.366 -lemma cinfinite_cprod2: "\<lbrakk>Cnotzero r1; Cinfinite r2\<rbrakk> \<Longrightarrow> cinfinite (r1 *c r2)"
99.367 -by (metis cinfinite_mono ordLeq_cprod2)
99.368 -
99.369 -lemma Cinfinite_cprod2: "\<lbrakk>Cnotzero r1; Cinfinite r2\<rbrakk> \<Longrightarrow> Cinfinite (r1 *c r2)"
99.370 -by (blast intro: cinfinite_cprod2 Card_order_cprod)
99.371 -
99.372 -lemma cprod_com: "p1 *c p2 =o p2 *c p1"
99.373 -by (simp only: cprod_def card_of_Times_commute)
99.374 -
99.375 -lemma card_of_Csum_Times:
99.376 - "\<forall>i \<in> I. |A i| \<le>o |B| \<Longrightarrow> (CSUM i : |I|. |A i| ) \<le>o |I| *c |B|"
99.377 -by (simp only: Csum_def cprod_def Field_card_of card_of_Sigma_Times)
99.378 -
99.379 -lemma card_of_Csum_Times':
99.380 - assumes "Card_order r" "\<forall>i \<in> I. |A i| \<le>o r"
99.381 - shows "(CSUM i : |I|. |A i| ) \<le>o |I| *c r"
99.382 -proof -
99.383 - from assms(1) have *: "r =o |Field r|" by (simp add: card_of_unique)
99.384 - with assms(2) have "\<forall>i \<in> I. |A i| \<le>o |Field r|" by (blast intro: ordLeq_ordIso_trans)
99.385 - hence "(CSUM i : |I|. |A i| ) \<le>o |I| *c |Field r|" by (simp only: card_of_Csum_Times)
99.386 - also from * have "|I| *c |Field r| \<le>o |I| *c r"
99.387 - by (simp only: Field_card_of card_of_refl cprod_def ordIso_imp_ordLeq)
99.388 - finally show ?thesis .
99.389 -qed
99.390 -
99.391 -lemma cprod_csum_distrib1: "r1 *c r2 +c r1 *c r3 =o r1 *c (r2 +c r3)"
99.392 -unfolding csum_def cprod_def by (simp add: Field_card_of card_of_Times_Plus_distrib ordIso_symmetric)
99.393 -
99.394 -lemma csum_absorb2': "\<lbrakk>Card_order r2; r1 \<le>o r2; cinfinite r1 \<or> cinfinite r2\<rbrakk> \<Longrightarrow> r1 +c r2 =o r2"
99.395 -unfolding csum_def by (metis Card_order_Plus_infinite cinfinite_def cinfinite_mono)
99.396 -
99.397 -lemma csum_absorb1':
99.398 - assumes card: "Card_order r2"
99.399 - and r12: "r1 \<le>o r2" and cr12: "cinfinite r1 \<or> cinfinite r2"
99.400 - shows "r2 +c r1 =o r2"
99.401 -by (rule ordIso_transitive, rule csum_com, rule csum_absorb2', (simp only: assms)+)
99.402 -
99.403 -lemma csum_absorb1: "\<lbrakk>Cinfinite r2; r1 \<le>o r2\<rbrakk> \<Longrightarrow> r2 +c r1 =o r2"
99.404 -by (rule csum_absorb1') auto
99.405 -
99.406 -lemma cprod_infinite1': "\<lbrakk>Cinfinite r; Cnotzero p; p \<le>o r\<rbrakk> \<Longrightarrow> r *c p =o r"
99.407 -unfolding cinfinite_def cprod_def
99.408 -by (rule Card_order_Times_infinite[THEN conjunct1]) (blast intro: czeroI)+
99.409 -
99.410 lemma cprod_infinite: "Cinfinite r \<Longrightarrow> r *c r =o r"
99.411 using cprod_infinite1' Cinfinite_Cnotzero ordLeq_refl by blast
99.412
99.413
99.414 subsection {* Exponentiation *}
99.415
99.416 -definition cexp (infixr "^c" 90) where
99.417 - "r1 ^c r2 \<equiv> |Func (Field r2) (Field r1)|"
99.418 -
99.419 -lemma card_order_cexp:
99.420 - assumes "card_order r1" "card_order r2"
99.421 - shows "card_order (r1 ^c r2)"
99.422 -proof -
99.423 - have "Field r1 = UNIV" "Field r2 = UNIV" using assms card_order_on_Card_order by auto
99.424 - thus ?thesis unfolding cexp_def Func_def by (simp add: card_of_card_order_on)
99.425 -qed
99.426 -
99.427 -lemma Card_order_cexp: "Card_order (r1 ^c r2)"
99.428 -unfolding cexp_def by (rule card_of_Card_order)
99.429 -
99.430 -lemma cexp_mono':
99.431 - assumes 1: "p1 \<le>o r1" and 2: "p2 \<le>o r2"
99.432 - and n: "Field p2 = {} \<Longrightarrow> Field r2 = {}"
99.433 - shows "p1 ^c p2 \<le>o r1 ^c r2"
99.434 -proof(cases "Field p1 = {}")
99.435 - case True
99.436 - hence "|Field |Func (Field p2) (Field p1)|| \<le>o cone"
99.437 - unfolding cone_def Field_card_of
99.438 - by (cases "Field p2 = {}", auto intro: card_of_ordLeqI2 simp: Func_empty)
99.439 - (metis Func_is_emp card_of_empty ex_in_conv)
99.440 - hence "|Func (Field p2) (Field p1)| \<le>o cone" by (simp add: Field_card_of cexp_def)
99.441 - hence "p1 ^c p2 \<le>o cone" unfolding cexp_def .
99.442 - thus ?thesis
99.443 - proof (cases "Field p2 = {}")
99.444 - case True
99.445 - with n have "Field r2 = {}" .
99.446 - hence "cone \<le>o r1 ^c r2" unfolding cone_def cexp_def Func_def by (auto intro: card_of_ordLeqI)
99.447 - thus ?thesis using `p1 ^c p2 \<le>o cone` ordLeq_transitive by auto
99.448 - next
99.449 - case False with True have "|Field (p1 ^c p2)| =o czero"
99.450 - unfolding card_of_ordIso_czero_iff_empty cexp_def Field_card_of Func_def by auto
99.451 - thus ?thesis unfolding cexp_def card_of_ordIso_czero_iff_empty Field_card_of
99.452 - by (simp add: card_of_empty)
99.453 - qed
99.454 -next
99.455 - case False
99.456 - have 1: "|Field p1| \<le>o |Field r1|" and 2: "|Field p2| \<le>o |Field r2|"
99.457 - using 1 2 by (auto simp: card_of_mono2)
99.458 - obtain f1 where f1: "f1 ` Field r1 = Field p1"
99.459 - using 1 unfolding card_of_ordLeq2[OF False, symmetric] by auto
99.460 - obtain f2 where f2: "inj_on f2 (Field p2)" "f2 ` Field p2 \<subseteq> Field r2"
99.461 - using 2 unfolding card_of_ordLeq[symmetric] by blast
99.462 - have 0: "Func_map (Field p2) f1 f2 ` (Field (r1 ^c r2)) = Field (p1 ^c p2)"
99.463 - unfolding cexp_def Field_card_of using Func_map_surj[OF f1 f2 n, symmetric] .
99.464 - have 00: "Field (p1 ^c p2) \<noteq> {}" unfolding cexp_def Field_card_of Func_is_emp
99.465 - using False by simp
99.466 - show ?thesis
99.467 - using 0 card_of_ordLeq2[OF 00] unfolding cexp_def Field_card_of by blast
99.468 -qed
99.469 -
99.470 -lemma cexp_mono:
99.471 - assumes 1: "p1 \<le>o r1" and 2: "p2 \<le>o r2"
99.472 - and n: "p2 =o czero \<Longrightarrow> r2 =o czero" and card: "Card_order p2"
99.473 - shows "p1 ^c p2 \<le>o r1 ^c r2"
99.474 - by (metis (full_types) "1" "2" card cexp_mono' czeroE czeroI n)
99.475 -
99.476 -lemma cexp_mono1:
99.477 - assumes 1: "p1 \<le>o r1" and q: "Card_order q"
99.478 - shows "p1 ^c q \<le>o r1 ^c q"
99.479 -using ordLeq_refl[OF q] by (rule cexp_mono[OF 1]) (auto simp: q)
99.480 -
99.481 -lemma cexp_mono2':
99.482 - assumes 2: "p2 \<le>o r2" and q: "Card_order q"
99.483 - and n: "Field p2 = {} \<Longrightarrow> Field r2 = {}"
99.484 - shows "q ^c p2 \<le>o q ^c r2"
99.485 -using ordLeq_refl[OF q] by (rule cexp_mono'[OF _ 2 n]) auto
99.486 -
99.487 -lemma cexp_mono2:
99.488 - assumes 2: "p2 \<le>o r2" and q: "Card_order q"
99.489 - and n: "p2 =o czero \<Longrightarrow> r2 =o czero" and card: "Card_order p2"
99.490 - shows "q ^c p2 \<le>o q ^c r2"
99.491 -using ordLeq_refl[OF q] by (rule cexp_mono[OF _ 2 n card]) auto
99.492 -
99.493 -lemma cexp_mono2_Cnotzero:
99.494 - assumes "p2 \<le>o r2" "Card_order q" "Cnotzero p2"
99.495 - shows "q ^c p2 \<le>o q ^c r2"
99.496 -by (metis assms cexp_mono2' czeroI)
99.497 -
99.498 -lemma cexp_cong:
99.499 - assumes 1: "p1 =o r1" and 2: "p2 =o r2"
99.500 - and Cr: "Card_order r2"
99.501 - and Cp: "Card_order p2"
99.502 - shows "p1 ^c p2 =o r1 ^c r2"
99.503 -proof -
99.504 - obtain f where "bij_betw f (Field p2) (Field r2)"
99.505 - using 2 card_of_ordIso[of "Field p2" "Field r2"] card_of_cong by auto
99.506 - hence 0: "Field p2 = {} \<longleftrightarrow> Field r2 = {}" unfolding bij_betw_def by auto
99.507 - have r: "p2 =o czero \<Longrightarrow> r2 =o czero"
99.508 - and p: "r2 =o czero \<Longrightarrow> p2 =o czero"
99.509 - using 0 Cr Cp czeroE czeroI by auto
99.510 - show ?thesis using 0 1 2 unfolding ordIso_iff_ordLeq
99.511 - using r p cexp_mono[OF _ _ _ Cp] cexp_mono[OF _ _ _ Cr] by blast
99.512 -qed
99.513 -
99.514 -lemma cexp_cong1:
99.515 - assumes 1: "p1 =o r1" and q: "Card_order q"
99.516 - shows "p1 ^c q =o r1 ^c q"
99.517 -by (rule cexp_cong[OF 1 _ q q]) (rule ordIso_refl[OF q])
99.518 -
99.519 -lemma cexp_cong2:
99.520 - assumes 2: "p2 =o r2" and q: "Card_order q" and p: "Card_order p2"
99.521 - shows "q ^c p2 =o q ^c r2"
99.522 -by (rule cexp_cong[OF _ 2]) (auto simp only: ordIso_refl Card_order_ordIso2[OF p 2] q p)
99.523 -
99.524 lemma cexp_czero: "r ^c czero =o cone"
99.525 unfolding cexp_def czero_def Field_card_of Func_empty by (rule single_cone)
99.526
99.527 -lemma cexp_cone:
99.528 - assumes "Card_order r"
99.529 - shows "r ^c cone =o r"
99.530 -proof -
99.531 - have "r ^c cone =o |Field r|"
99.532 - unfolding cexp_def cone_def Field_card_of Func_empty
99.533 - card_of_ordIso[symmetric] bij_betw_def Func_def inj_on_def image_def
99.534 - by (rule exI[of _ "\<lambda>f. f ()"]) auto
99.535 - also have "|Field r| =o r" by (rule card_of_Field_ordIso[OF assms])
99.536 - finally show ?thesis .
99.537 -qed
99.538 -
99.539 -lemma cexp_cprod:
99.540 - assumes r1: "Card_order r1"
99.541 - shows "(r1 ^c r2) ^c r3 =o r1 ^c (r2 *c r3)" (is "?L =o ?R")
99.542 -proof -
99.543 - have "?L =o r1 ^c (r3 *c r2)"
99.544 - unfolding cprod_def cexp_def Field_card_of
99.545 - using card_of_Func_Times by(rule ordIso_symmetric)
99.546 - also have "r1 ^c (r3 *c r2) =o ?R"
99.547 - apply(rule cexp_cong2) using cprod_com r1 by (auto simp: Card_order_cprod)
99.548 - finally show ?thesis .
99.549 -qed
99.550 -
99.551 -lemma cexp_cprod_ordLeq:
99.552 - assumes r1: "Card_order r1" and r2: "Cinfinite r2"
99.553 - and r3: "Cnotzero r3" "r3 \<le>o r2"
99.554 - shows "(r1 ^c r2) ^c r3 =o r1 ^c r2" (is "?L =o ?R")
99.555 -proof-
99.556 - have "?L =o r1 ^c (r2 *c r3)" using cexp_cprod[OF r1] .
99.557 - also have "r1 ^c (r2 *c r3) =o ?R"
99.558 - apply(rule cexp_cong2)
99.559 - apply(rule cprod_infinite1'[OF r2 r3]) using r1 r2 by (fastforce simp: Card_order_cprod)+
99.560 - finally show ?thesis .
99.561 -qed
99.562 -
99.563 -lemma Cnotzero_UNIV: "Cnotzero |UNIV|"
99.564 -by (auto simp: card_of_Card_order card_of_ordIso_czero_iff_empty)
99.565 -
99.566 lemma Pow_cexp_ctwo:
99.567 "|Pow A| =o ctwo ^c |A|"
99.568 unfolding ctwo_def cexp_def Field_card_of by (rule card_of_Pow_Func)
99.569
99.570 -lemma ordLess_ctwo_cexp:
99.571 - assumes "Card_order r"
99.572 - shows "r <o ctwo ^c r"
99.573 -proof -
99.574 - have "r <o |Pow (Field r)|" using assms by (rule Card_order_Pow)
99.575 - also have "|Pow (Field r)| =o ctwo ^c r"
99.576 - unfolding ctwo_def cexp_def Field_card_of by (rule card_of_Pow_Func)
99.577 - finally show ?thesis .
99.578 -qed
99.579 -
99.580 -lemma ordLeq_cexp1:
99.581 - assumes "Cnotzero r" "Card_order q"
99.582 - shows "q \<le>o q ^c r"
99.583 -proof (cases "q =o (czero :: 'a rel)")
99.584 - case True thus ?thesis by (simp only: card_of_empty cexp_def czero_def ordIso_ordLeq_trans)
99.585 -next
99.586 - case False
99.587 - thus ?thesis
99.588 - apply -
99.589 - apply (rule ordIso_ordLeq_trans)
99.590 - apply (rule ordIso_symmetric)
99.591 - apply (rule cexp_cone)
99.592 - apply (rule assms(2))
99.593 - apply (rule cexp_mono2)
99.594 - apply (rule cone_ordLeq_Cnotzero)
99.595 - apply (rule assms(1))
99.596 - apply (rule assms(2))
99.597 - apply (rule notE)
99.598 - apply (rule cone_not_czero)
99.599 - apply assumption
99.600 - apply (rule Card_order_cone)
99.601 - done
99.602 -qed
99.603 -
99.604 -lemma ordLeq_cexp2:
99.605 - assumes "ctwo \<le>o q" "Card_order r"
99.606 - shows "r \<le>o q ^c r"
99.607 -proof (cases "r =o (czero :: 'a rel)")
99.608 - case True thus ?thesis by (simp only: card_of_empty cexp_def czero_def ordIso_ordLeq_trans)
99.609 -next
99.610 - case False thus ?thesis
99.611 - apply -
99.612 - apply (rule ordLess_imp_ordLeq)
99.613 - apply (rule ordLess_ordLeq_trans)
99.614 - apply (rule ordLess_ctwo_cexp)
99.615 - apply (rule assms(2))
99.616 - apply (rule cexp_mono1)
99.617 - apply (rule assms(1))
99.618 - apply (rule assms(2))
99.619 - done
99.620 -qed
99.621 -
99.622 lemma Cnotzero_cexp:
99.623 assumes "Cnotzero q" "Card_order r"
99.624 shows "Cnotzero (q ^c r)"
99.625 @@ -664,41 +99,7 @@
99.626 lemma Cinfinite_ctwo_cexp:
99.627 "Cinfinite r \<Longrightarrow> Cinfinite (ctwo ^c r)"
99.628 unfolding ctwo_def cexp_def cinfinite_def Field_card_of
99.629 -by (rule conjI, rule infinite_Func, auto, rule card_of_card_order_on)
99.630 -
99.631 -lemma cinfinite_cexp: "\<lbrakk>ctwo \<le>o q; Cinfinite r\<rbrakk> \<Longrightarrow> cinfinite (q ^c r)"
99.632 -by (metis assms cinfinite_mono ordLeq_cexp2)
99.633 -
99.634 -lemma Cinfinite_cexp:
99.635 - "\<lbrakk>ctwo \<le>o q; Cinfinite r\<rbrakk> \<Longrightarrow> Cinfinite (q ^c r)"
99.636 -by (simp add: cinfinite_cexp Card_order_cexp)
99.637 -
99.638 -lemma ctwo_ordLess_natLeq:
99.639 - "ctwo <o natLeq"
99.640 -unfolding ctwo_def using finite_iff_ordLess_natLeq finite_UNIV by fast
99.641 -
99.642 -lemma ctwo_ordLess_Cinfinite: "Cinfinite r \<Longrightarrow> ctwo <o r"
99.643 -by (metis ctwo_ordLess_natLeq natLeq_ordLeq_cinfinite ordLess_ordLeq_trans)
99.644 -
99.645 -lemma ctwo_ordLeq_Cinfinite:
99.646 - assumes "Cinfinite r"
99.647 - shows "ctwo \<le>o r"
99.648 -by (rule ordLess_imp_ordLeq[OF ctwo_ordLess_Cinfinite[OF assms]])
99.649 -
99.650 -lemma Cinfinite_ordLess_cexp:
99.651 - assumes r: "Cinfinite r"
99.652 - shows "r <o r ^c r"
99.653 -proof -
99.654 - have "r <o ctwo ^c r" using r by (simp only: ordLess_ctwo_cexp)
99.655 - also have "ctwo ^c r \<le>o r ^c r"
99.656 - by (rule cexp_mono1[OF ctwo_ordLeq_Cinfinite]) (auto simp: r ctwo_not_czero Card_order_ctwo)
99.657 - finally show ?thesis .
99.658 -qed
99.659 -
99.660 -lemma infinite_ordLeq_cexp:
99.661 - assumes "Cinfinite r"
99.662 - shows "r \<le>o r ^c r"
99.663 -by (rule ordLess_imp_ordLeq[OF Cinfinite_ordLess_cexp[OF assms]])
99.664 +by (rule conjI, rule infinite_Func, auto)
99.665
99.666 lemma cone_ordLeq_iff_Field:
99.667 assumes "cone \<le>o r"
99.668 @@ -731,22 +132,6 @@
99.669 case False thus ?thesis using assms cexp_mono2' czeroI by metis
99.670 qed
99.671
99.672 -lemma Un_Cinfinite_bound: "\<lbrakk>|A| \<le>o r; |B| \<le>o r; Cinfinite r\<rbrakk> \<Longrightarrow> |A \<union> B| \<le>o r"
99.673 -by (auto simp add: cinfinite_def card_of_Un_ordLeq_infinite_Field)
99.674 -
99.675 -lemma UNION_Cinfinite_bound: "\<lbrakk>|I| \<le>o r; \<forall>i \<in> I. |A i| \<le>o r; Cinfinite r\<rbrakk> \<Longrightarrow> |\<Union>i \<in> I. A i| \<le>o r"
99.676 -by (auto simp add: card_of_UNION_ordLeq_infinite_Field cinfinite_def)
99.677 -
99.678 -lemma csum_cinfinite_bound:
99.679 - assumes "p \<le>o r" "q \<le>o r" "Card_order p" "Card_order q" "Cinfinite r"
99.680 - shows "p +c q \<le>o r"
99.681 -proof -
99.682 - from assms(1-4) have "|Field p| \<le>o r" "|Field q| \<le>o r"
99.683 - unfolding card_order_on_def using card_of_least ordLeq_transitive by blast+
99.684 - with assms show ?thesis unfolding cinfinite_def csum_def
99.685 - by (blast intro: card_of_Plus_ordLeq_infinite_Field)
99.686 -qed
99.687 -
99.688 lemma csum_cexp: "\<lbrakk>Cinfinite r1; Cinfinite r2; Card_order q; ctwo \<le>o q\<rbrakk> \<Longrightarrow>
99.689 q ^c r1 +c q ^c r2 \<le>o q ^c (r1 +c r2)"
99.690 apply (rule csum_cinfinite_bound)
99.691 @@ -782,139 +167,20 @@
99.692 apply blast+
99.693 by (metis Cinfinite_cexp)
99.694
99.695 -lemma cprod_cinfinite_bound:
99.696 - assumes "p \<le>o r" "q \<le>o r" "Card_order p" "Card_order q" "Cinfinite r"
99.697 - shows "p *c q \<le>o r"
99.698 -proof -
99.699 - from assms(1-4) have "|Field p| \<le>o r" "|Field q| \<le>o r"
99.700 - unfolding card_order_on_def using card_of_least ordLeq_transitive by blast+
99.701 - with assms show ?thesis unfolding cinfinite_def cprod_def
99.702 - by (blast intro: card_of_Times_ordLeq_infinite_Field)
99.703 -qed
99.704 -
99.705 -lemma cprod_csum_cexp:
99.706 - "r1 *c r2 \<le>o (r1 +c r2) ^c ctwo"
99.707 -unfolding cprod_def csum_def cexp_def ctwo_def Field_card_of
99.708 -proof -
99.709 - let ?f = "\<lambda>(a, b). %x. if x then Inl a else Inr b"
99.710 - have "inj_on ?f (Field r1 \<times> Field r2)" (is "inj_on _ ?LHS")
99.711 - by (auto simp: inj_on_def fun_eq_iff split: bool.split)
99.712 - moreover
99.713 - have "?f ` ?LHS \<subseteq> Func (UNIV :: bool set) (Field r1 <+> Field r2)" (is "_ \<subseteq> ?RHS")
99.714 - by (auto simp: Func_def)
99.715 - ultimately show "|?LHS| \<le>o |?RHS|" using card_of_ordLeq by blast
99.716 -qed
99.717 -
99.718 -lemma Cfinite_cprod_Cinfinite: "\<lbrakk>Cfinite r; Cinfinite s\<rbrakk> \<Longrightarrow> r *c s \<le>o s"
99.719 -by (intro cprod_cinfinite_bound)
99.720 - (auto intro: ordLeq_refl ordLess_imp_ordLeq[OF Cfinite_ordLess_Cinfinite])
99.721 -
99.722 -lemma cprod_cexp: "(r *c s) ^c t =o r ^c t *c s ^c t"
99.723 - unfolding cprod_def cexp_def Field_card_of by (rule Func_Times_Range)
99.724 -
99.725 -lemma cprod_cexp_csum_cexp_Cinfinite:
99.726 - assumes t: "Cinfinite t"
99.727 - shows "(r *c s) ^c t \<le>o (r +c s) ^c t"
99.728 -proof -
99.729 - have "(r *c s) ^c t \<le>o ((r +c s) ^c ctwo) ^c t"
99.730 - by (rule cexp_mono1[OF cprod_csum_cexp conjunct2[OF t]])
99.731 - also have "((r +c s) ^c ctwo) ^c t =o (r +c s) ^c (ctwo *c t)"
99.732 - by (rule cexp_cprod[OF Card_order_csum])
99.733 - also have "(r +c s) ^c (ctwo *c t) =o (r +c s) ^c (t *c ctwo)"
99.734 - by (rule cexp_cong2[OF cprod_com Card_order_csum Card_order_cprod])
99.735 - also have "(r +c s) ^c (t *c ctwo) =o ((r +c s) ^c t) ^c ctwo"
99.736 - by (rule ordIso_symmetric[OF cexp_cprod[OF Card_order_csum]])
99.737 - also have "((r +c s) ^c t) ^c ctwo =o (r +c s) ^c t"
99.738 - by (rule cexp_cprod_ordLeq[OF Card_order_csum t ctwo_Cnotzero ctwo_ordLeq_Cinfinite[OF t]])
99.739 - finally show ?thesis .
99.740 -qed
99.741 -
99.742 -lemma Cfinite_cexp_Cinfinite:
99.743 - assumes s: "Cfinite s" and t: "Cinfinite t"
99.744 - shows "s ^c t \<le>o ctwo ^c t"
99.745 -proof (cases "s \<le>o ctwo")
99.746 - case True thus ?thesis using t by (blast intro: cexp_mono1)
99.747 -next
99.748 - case False
99.749 - hence "ctwo \<le>o s" by (metis card_order_on_well_order_on ctwo_Cnotzero ordLeq_total s)
99.750 - hence "Cnotzero s" by (metis Cnotzero_mono ctwo_Cnotzero s)
99.751 - hence st: "Cnotzero (s *c t)" by (metis Cinfinite_cprod2 cinfinite_not_czero t)
99.752 - have "s ^c t \<le>o (ctwo ^c s) ^c t"
99.753 - using assms by (blast intro: cexp_mono1 ordLess_imp_ordLeq[OF ordLess_ctwo_cexp])
99.754 - also have "(ctwo ^c s) ^c t =o ctwo ^c (s *c t)"
99.755 - by (blast intro: Card_order_ctwo cexp_cprod)
99.756 - also have "ctwo ^c (s *c t) \<le>o ctwo ^c t"
99.757 - using assms st by (intro cexp_mono2_Cnotzero Cfinite_cprod_Cinfinite Card_order_ctwo)
99.758 - finally show ?thesis .
99.759 -qed
99.760 -
99.761 -lemma csum_Cfinite_cexp_Cinfinite:
99.762 - assumes r: "Card_order r" and s: "Cfinite s" and t: "Cinfinite t"
99.763 - shows "(r +c s) ^c t \<le>o (r +c ctwo) ^c t"
99.764 -proof (cases "Cinfinite r")
99.765 - case True
99.766 - hence "r +c s =o r" by (intro csum_absorb1 ordLess_imp_ordLeq[OF Cfinite_ordLess_Cinfinite] s)
99.767 - hence "(r +c s) ^c t =o r ^c t" using t by (blast intro: cexp_cong1)
99.768 - also have "r ^c t \<le>o (r +c ctwo) ^c t" using t by (blast intro: cexp_mono1 ordLeq_csum1 r)
99.769 - finally show ?thesis .
99.770 -next
99.771 - case False
99.772 - with r have "Cfinite r" unfolding cinfinite_def cfinite_def by auto
99.773 - hence "Cfinite (r +c s)" by (intro Cfinite_csum s)
99.774 - hence "(r +c s) ^c t \<le>o ctwo ^c t" by (intro Cfinite_cexp_Cinfinite t)
99.775 - also have "ctwo ^c t \<le>o (r +c ctwo) ^c t" using t
99.776 - by (blast intro: cexp_mono1 ordLeq_csum2 Card_order_ctwo)
99.777 - finally show ?thesis .
99.778 -qed
99.779 -
99.780 lemma card_of_Sigma_ordLeq_Cinfinite:
99.781 "\<lbrakk>Cinfinite r; |I| \<le>o r; \<forall>i \<in> I. |A i| \<le>o r\<rbrakk> \<Longrightarrow> |SIGMA i : I. A i| \<le>o r"
99.782 unfolding cinfinite_def by (blast intro: card_of_Sigma_ordLeq_infinite_Field)
99.783
99.784
99.785 -(* cardSuc *)
99.786 -
99.787 -lemma Cinfinite_cardSuc: "Cinfinite r \<Longrightarrow> Cinfinite (cardSuc r)"
99.788 -by (simp add: cinfinite_def cardSuc_Card_order cardSuc_finite)
99.789 -
99.790 -lemma cardSuc_UNION_Cinfinite:
99.791 - assumes "Cinfinite r" "relChain (cardSuc r) As" "B \<le> (UN i : Field (cardSuc r). As i)" "|B| <=o r"
99.792 - shows "EX i : Field (cardSuc r). B \<le> As i"
99.793 -using cardSuc_UNION assms unfolding cinfinite_def by blast
99.794 -
99.795 subsection {* Powerset *}
99.796
99.797 -definition cpow where "cpow r = |Pow (Field r)|"
99.798 -
99.799 -lemma card_order_cpow: "card_order r \<Longrightarrow> card_order (cpow r)"
99.800 -by (simp only: cpow_def Field_card_order Pow_UNIV card_of_card_order_on)
99.801 -
99.802 -lemma cpow_greater_eq: "Card_order r \<Longrightarrow> r \<le>o cpow r"
99.803 -by (rule ordLess_imp_ordLeq) (simp only: cpow_def Card_order_Pow)
99.804 -
99.805 lemma Card_order_cpow: "Card_order (cpow r)"
99.806 unfolding cpow_def by (rule card_of_Card_order)
99.807
99.808 -lemma Cinfinite_cpow: "Cinfinite r \<Longrightarrow> Cinfinite (cpow r)"
99.809 -unfolding cpow_def cinfinite_def by (metis Field_card_of card_of_Card_order infinite_Pow)
99.810 -
99.811 lemma cardSuc_ordLeq_cpow: "Card_order r \<Longrightarrow> cardSuc r \<le>o cpow r"
99.812 unfolding cpow_def by (metis Card_order_Pow cardSuc_ordLess_ordLeq card_of_Card_order)
99.813
99.814 lemma cpow_cexp_ctwo: "cpow r =o ctwo ^c r"
99.815 unfolding cpow_def ctwo_def cexp_def Field_card_of by (rule card_of_Pow_Func)
99.816
99.817 -subsection {* Lists *}
99.818 -
99.819 -definition clists where "clists r = |lists (Field r)|"
99.820 -
99.821 -lemma clists_Cinfinite: "Cinfinite r \<Longrightarrow> clists r =o r"
99.822 -unfolding cinfinite_def clists_def by (blast intro: Card_order_lists_infinite)
99.823 -
99.824 -lemma Card_order_clists: "Card_order (clists r)"
99.825 -unfolding clists_def by (rule card_of_Card_order)
99.826 -
99.827 -lemma Cnotzero_clists: "Cnotzero (clists r)"
99.828 -by (simp add: clists_def card_of_ordIso_czero_iff_empty lists_not_empty) (rule card_of_Card_order)
99.829 -
99.830 end
100.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
100.2 +++ b/src/HOL/Cardinals/Cardinal_Arithmetic_FP.thy Thu Dec 05 17:58:03 2013 +0100
100.3 @@ -0,0 +1,749 @@
100.4 +(* Title: HOL/Cardinals/Cardinal_Arithmetic_FP.thy
100.5 + Author: Dmitriy Traytel, TU Muenchen
100.6 + Copyright 2012
100.7 +
100.8 +Cardinal arithmetic (FP).
100.9 +*)
100.10 +
100.11 +header {* Cardinal Arithmetic (FP) *}
100.12 +
100.13 +theory Cardinal_Arithmetic_FP
100.14 +imports Cardinal_Order_Relation_FP
100.15 +begin
100.16 +
100.17 +(*library candidate*)
100.18 +lemma dir_image: "\<lbrakk>\<And>x y. (f x = f y) = (x = y); Card_order r\<rbrakk> \<Longrightarrow> r =o dir_image r f"
100.19 +by (rule dir_image_ordIso) (auto simp add: inj_on_def card_order_on_def)
100.20 +
100.21 +(*should supersede a weaker lemma from the library*)
100.22 +lemma dir_image_Field: "Field (dir_image r f) = f ` Field r"
100.23 +unfolding dir_image_def Field_def Range_def Domain_def by fast
100.24 +
100.25 +lemma card_order_dir_image:
100.26 + assumes bij: "bij f" and co: "card_order r"
100.27 + shows "card_order (dir_image r f)"
100.28 +proof -
100.29 + from assms have "Field (dir_image r f) = UNIV"
100.30 + using card_order_on_Card_order[of UNIV r] unfolding bij_def dir_image_Field by auto
100.31 + moreover from bij have "\<And>x y. (f x = f y) = (x = y)" unfolding bij_def inj_on_def by auto
100.32 + with co have "Card_order (dir_image r f)"
100.33 + using card_order_on_Card_order[of UNIV r] Card_order_ordIso2[OF _ dir_image] by blast
100.34 + ultimately show ?thesis by auto
100.35 +qed
100.36 +
100.37 +(*library candidate*)
100.38 +lemma ordIso_refl: "Card_order r \<Longrightarrow> r =o r"
100.39 +by (rule card_order_on_ordIso)
100.40 +
100.41 +(*library candidate*)
100.42 +lemma ordLeq_refl: "Card_order r \<Longrightarrow> r \<le>o r"
100.43 +by (rule ordIso_imp_ordLeq, rule card_order_on_ordIso)
100.44 +
100.45 +(*library candidate*)
100.46 +lemma card_of_ordIso_subst: "A = B \<Longrightarrow> |A| =o |B|"
100.47 +by (simp only: ordIso_refl card_of_Card_order)
100.48 +
100.49 +(*library candidate*)
100.50 +lemma Field_card_order: "card_order r \<Longrightarrow> Field r = UNIV"
100.51 +using card_order_on_Card_order[of UNIV r] by simp
100.52 +
100.53 +(*library candidate*)
100.54 +lemma card_of_Times_Plus_distrib:
100.55 + "|A <*> (B <+> C)| =o |A <*> B <+> A <*> C|" (is "|?RHS| =o |?LHS|")
100.56 +proof -
100.57 + let ?f = "\<lambda>(a, bc). case bc of Inl b \<Rightarrow> Inl (a, b) | Inr c \<Rightarrow> Inr (a, c)"
100.58 + have "bij_betw ?f ?RHS ?LHS" unfolding bij_betw_def inj_on_def by force
100.59 + thus ?thesis using card_of_ordIso by blast
100.60 +qed
100.61 +
100.62 +(*library candidate*)
100.63 +lemma Func_Times_Range:
100.64 + "|Func A (B <*> C)| =o |Func A B <*> Func A C|" (is "|?LHS| =o |?RHS|")
100.65 +proof -
100.66 + let ?F = "\<lambda>fg. (\<lambda>x. if x \<in> A then fst (fg x) else undefined,
100.67 + \<lambda>x. if x \<in> A then snd (fg x) else undefined)"
100.68 + let ?G = "\<lambda>(f, g) x. if x \<in> A then (f x, g x) else undefined"
100.69 + have "bij_betw ?F ?LHS ?RHS" unfolding bij_betw_def inj_on_def
100.70 + apply safe
100.71 + apply (simp add: Func_def fun_eq_iff)
100.72 + apply (metis (no_types) pair_collapse)
100.73 + apply (auto simp: Func_def fun_eq_iff)[2]
100.74 + proof -
100.75 + fix f g assume "f \<in> Func A B" "g \<in> Func A C"
100.76 + thus "(f, g) \<in> ?F ` Func A (B \<times> C)"
100.77 + by (intro image_eqI[of _ _ "?G (f, g)"]) (auto simp: Func_def)
100.78 + qed
100.79 + thus ?thesis using card_of_ordIso by blast
100.80 +qed
100.81 +
100.82 +
100.83 +subsection {* Zero *}
100.84 +
100.85 +definition czero where
100.86 + "czero = card_of {}"
100.87 +
100.88 +lemma czero_ordIso:
100.89 + "czero =o czero"
100.90 +using card_of_empty_ordIso by (simp add: czero_def)
100.91 +
100.92 +lemma card_of_ordIso_czero_iff_empty:
100.93 + "|A| =o (czero :: 'b rel) \<longleftrightarrow> A = ({} :: 'a set)"
100.94 +unfolding czero_def by (rule iffI[OF card_of_empty2]) (auto simp: card_of_refl card_of_empty_ordIso)
100.95 +
100.96 +(* A "not czero" Cardinal predicate *)
100.97 +abbreviation Cnotzero where
100.98 + "Cnotzero (r :: 'a rel) \<equiv> \<not>(r =o (czero :: 'a rel)) \<and> Card_order r"
100.99 +
100.100 +(*helper*)
100.101 +lemma Cnotzero_imp_not_empty: "Cnotzero r \<Longrightarrow> Field r \<noteq> {}"
100.102 +by (metis Card_order_iff_ordIso_card_of czero_def)
100.103 +
100.104 +lemma czeroI:
100.105 + "\<lbrakk>Card_order r; Field r = {}\<rbrakk> \<Longrightarrow> r =o czero"
100.106 +using Cnotzero_imp_not_empty ordIso_transitive[OF _ czero_ordIso] by blast
100.107 +
100.108 +lemma czeroE:
100.109 + "r =o czero \<Longrightarrow> Field r = {}"
100.110 +unfolding czero_def
100.111 +by (drule card_of_cong) (simp only: Field_card_of card_of_empty2)
100.112 +
100.113 +lemma Cnotzero_mono:
100.114 + "\<lbrakk>Cnotzero r; Card_order q; r \<le>o q\<rbrakk> \<Longrightarrow> Cnotzero q"
100.115 +apply (rule ccontr)
100.116 +apply auto
100.117 +apply (drule czeroE)
100.118 +apply (erule notE)
100.119 +apply (erule czeroI)
100.120 +apply (drule card_of_mono2)
100.121 +apply (simp only: card_of_empty3)
100.122 +done
100.123 +
100.124 +subsection {* (In)finite cardinals *}
100.125 +
100.126 +definition cinfinite where
100.127 + "cinfinite r = (\<not> finite (Field r))"
100.128 +
100.129 +abbreviation Cinfinite where
100.130 + "Cinfinite r \<equiv> cinfinite r \<and> Card_order r"
100.131 +
100.132 +definition cfinite where
100.133 + "cfinite r = finite (Field r)"
100.134 +
100.135 +abbreviation Cfinite where
100.136 + "Cfinite r \<equiv> cfinite r \<and> Card_order r"
100.137 +
100.138 +lemma Cfinite_ordLess_Cinfinite: "\<lbrakk>Cfinite r; Cinfinite s\<rbrakk> \<Longrightarrow> r <o s"
100.139 + unfolding cfinite_def cinfinite_def
100.140 + by (metis card_order_on_well_order_on finite_ordLess_infinite)
100.141 +
100.142 +lemmas natLeq_card_order = natLeq_Card_order[unfolded Field_natLeq]
100.143 +
100.144 +lemma natLeq_cinfinite: "cinfinite natLeq"
100.145 +unfolding cinfinite_def Field_natLeq by (metis infinite_UNIV_nat)
100.146 +
100.147 +lemma natLeq_ordLeq_cinfinite:
100.148 + assumes inf: "Cinfinite r"
100.149 + shows "natLeq \<le>o r"
100.150 +proof -
100.151 + from inf have "natLeq \<le>o |Field r|" by (metis cinfinite_def infinite_iff_natLeq_ordLeq)
100.152 + also from inf have "|Field r| =o r" by (simp add: card_of_unique ordIso_symmetric)
100.153 + finally show ?thesis .
100.154 +qed
100.155 +
100.156 +lemma cinfinite_not_czero: "cinfinite r \<Longrightarrow> \<not> (r =o (czero :: 'a rel))"
100.157 +unfolding cinfinite_def by (metis czeroE finite.emptyI)
100.158 +
100.159 +lemma Cinfinite_Cnotzero: "Cinfinite r \<Longrightarrow> Cnotzero r"
100.160 +by (metis cinfinite_not_czero)
100.161 +
100.162 +lemma Cinfinite_cong: "\<lbrakk>r1 =o r2; Cinfinite r1\<rbrakk> \<Longrightarrow> Cinfinite r2"
100.163 +by (metis Card_order_ordIso2 card_of_mono2 card_of_ordLeq_infinite cinfinite_def ordIso_iff_ordLeq)
100.164 +
100.165 +lemma cinfinite_mono: "\<lbrakk>r1 \<le>o r2; cinfinite r1\<rbrakk> \<Longrightarrow> cinfinite r2"
100.166 +by (metis card_of_mono2 card_of_ordLeq_infinite cinfinite_def)
100.167 +
100.168 +
100.169 +subsection {* Binary sum *}
100.170 +
100.171 +definition csum (infixr "+c" 65) where
100.172 + "r1 +c r2 \<equiv> |Field r1 <+> Field r2|"
100.173 +
100.174 +lemma Field_csum: "Field (r +c s) = Inl ` Field r \<union> Inr ` Field s"
100.175 + unfolding csum_def Field_card_of by auto
100.176 +
100.177 +lemma Card_order_csum:
100.178 + "Card_order (r1 +c r2)"
100.179 +unfolding csum_def by (simp add: card_of_Card_order)
100.180 +
100.181 +lemma csum_Cnotzero1:
100.182 + "Cnotzero r1 \<Longrightarrow> Cnotzero (r1 +c r2)"
100.183 +unfolding csum_def
100.184 +by (metis Cnotzero_imp_not_empty Plus_eq_empty_conv card_of_Card_order card_of_ordIso_czero_iff_empty)
100.185 +
100.186 +lemma card_order_csum:
100.187 + assumes "card_order r1" "card_order r2"
100.188 + shows "card_order (r1 +c r2)"
100.189 +proof -
100.190 + have "Field r1 = UNIV" "Field r2 = UNIV" using assms card_order_on_Card_order by auto
100.191 + thus ?thesis unfolding csum_def by (auto simp: card_of_card_order_on)
100.192 +qed
100.193 +
100.194 +lemma cinfinite_csum:
100.195 + "cinfinite r1 \<or> cinfinite r2 \<Longrightarrow> cinfinite (r1 +c r2)"
100.196 +unfolding cinfinite_def csum_def by (auto simp: Field_card_of)
100.197 +
100.198 +lemma Cinfinite_csum1:
100.199 + "Cinfinite r1 \<Longrightarrow> Cinfinite (r1 +c r2)"
100.200 +unfolding cinfinite_def csum_def by (metis Field_card_of card_of_Card_order finite_Plus_iff)
100.201 +
100.202 +lemma Cinfinite_csum:
100.203 + "Cinfinite r1 \<or> Cinfinite r2 \<Longrightarrow> Cinfinite (r1 +c r2)"
100.204 +unfolding cinfinite_def csum_def by (metis Field_card_of card_of_Card_order finite_Plus_iff)
100.205 +
100.206 +lemma Cinfinite_csum_strong:
100.207 + "\<lbrakk>Cinfinite r1; Cinfinite r2\<rbrakk> \<Longrightarrow> Cinfinite (r1 +c r2)"
100.208 +by (metis Cinfinite_csum)
100.209 +
100.210 +lemma csum_cong: "\<lbrakk>p1 =o r1; p2 =o r2\<rbrakk> \<Longrightarrow> p1 +c p2 =o r1 +c r2"
100.211 +by (simp only: csum_def ordIso_Plus_cong)
100.212 +
100.213 +lemma csum_cong1: "p1 =o r1 \<Longrightarrow> p1 +c q =o r1 +c q"
100.214 +by (simp only: csum_def ordIso_Plus_cong1)
100.215 +
100.216 +lemma csum_cong2: "p2 =o r2 \<Longrightarrow> q +c p2 =o q +c r2"
100.217 +by (simp only: csum_def ordIso_Plus_cong2)
100.218 +
100.219 +lemma csum_mono: "\<lbrakk>p1 \<le>o r1; p2 \<le>o r2\<rbrakk> \<Longrightarrow> p1 +c p2 \<le>o r1 +c r2"
100.220 +by (simp only: csum_def ordLeq_Plus_mono)
100.221 +
100.222 +lemma csum_mono1: "p1 \<le>o r1 \<Longrightarrow> p1 +c q \<le>o r1 +c q"
100.223 +by (simp only: csum_def ordLeq_Plus_mono1)
100.224 +
100.225 +lemma csum_mono2: "p2 \<le>o r2 \<Longrightarrow> q +c p2 \<le>o q +c r2"
100.226 +by (simp only: csum_def ordLeq_Plus_mono2)
100.227 +
100.228 +lemma ordLeq_csum1: "Card_order p1 \<Longrightarrow> p1 \<le>o p1 +c p2"
100.229 +by (simp only: csum_def Card_order_Plus1)
100.230 +
100.231 +lemma ordLeq_csum2: "Card_order p2 \<Longrightarrow> p2 \<le>o p1 +c p2"
100.232 +by (simp only: csum_def Card_order_Plus2)
100.233 +
100.234 +lemma csum_com: "p1 +c p2 =o p2 +c p1"
100.235 +by (simp only: csum_def card_of_Plus_commute)
100.236 +
100.237 +lemma csum_assoc: "(p1 +c p2) +c p3 =o p1 +c p2 +c p3"
100.238 +by (simp only: csum_def Field_card_of card_of_Plus_assoc)
100.239 +
100.240 +lemma Cfinite_csum: "\<lbrakk>Cfinite r; Cfinite s\<rbrakk> \<Longrightarrow> Cfinite (r +c s)"
100.241 + unfolding cfinite_def csum_def Field_card_of using card_of_card_order_on by simp
100.242 +
100.243 +lemma csum_csum: "(r1 +c r2) +c (r3 +c r4) =o (r1 +c r3) +c (r2 +c r4)"
100.244 +proof -
100.245 + have "(r1 +c r2) +c (r3 +c r4) =o r1 +c r2 +c (r3 +c r4)"
100.246 + by (metis csum_assoc)
100.247 + also have "r1 +c r2 +c (r3 +c r4) =o r1 +c (r2 +c r3) +c r4"
100.248 + by (metis csum_assoc csum_cong2 ordIso_symmetric)
100.249 + also have "r1 +c (r2 +c r3) +c r4 =o r1 +c (r3 +c r2) +c r4"
100.250 + by (metis csum_com csum_cong1 csum_cong2)
100.251 + also have "r1 +c (r3 +c r2) +c r4 =o r1 +c r3 +c r2 +c r4"
100.252 + by (metis csum_assoc csum_cong2 ordIso_symmetric)
100.253 + also have "r1 +c r3 +c r2 +c r4 =o (r1 +c r3) +c (r2 +c r4)"
100.254 + by (metis csum_assoc ordIso_symmetric)
100.255 + finally show ?thesis .
100.256 +qed
100.257 +
100.258 +lemma Plus_csum: "|A <+> B| =o |A| +c |B|"
100.259 +by (simp only: csum_def Field_card_of card_of_refl)
100.260 +
100.261 +lemma Un_csum: "|A \<union> B| \<le>o |A| +c |B|"
100.262 +using ordLeq_ordIso_trans[OF card_of_Un_Plus_ordLeq Plus_csum] by blast
100.263 +
100.264 +
100.265 +subsection {* One *}
100.266 +
100.267 +definition cone where
100.268 + "cone = card_of {()}"
100.269 +
100.270 +lemma Card_order_cone: "Card_order cone"
100.271 +unfolding cone_def by (rule card_of_Card_order)
100.272 +
100.273 +lemma Cfinite_cone: "Cfinite cone"
100.274 + unfolding cfinite_def by (simp add: Card_order_cone)
100.275 +
100.276 +lemma cone_not_czero: "\<not> (cone =o czero)"
100.277 +unfolding czero_def cone_def by (metis empty_not_insert card_of_empty3[of "{()}"] ordIso_iff_ordLeq)
100.278 +
100.279 +lemma cone_ordLeq_Cnotzero: "Cnotzero r \<Longrightarrow> cone \<le>o r"
100.280 +unfolding cone_def by (metis Card_order_singl_ordLeq czeroI)
100.281 +
100.282 +
100.283 +subsection{* Two *}
100.284 +
100.285 +definition ctwo where
100.286 + "ctwo = |UNIV :: bool set|"
100.287 +
100.288 +lemma Card_order_ctwo: "Card_order ctwo"
100.289 +unfolding ctwo_def by (rule card_of_Card_order)
100.290 +
100.291 +lemma ctwo_not_czero: "\<not> (ctwo =o czero)"
100.292 +using card_of_empty3[of "UNIV :: bool set"] ordIso_iff_ordLeq
100.293 +unfolding czero_def ctwo_def by (metis UNIV_not_empty)
100.294 +
100.295 +lemma ctwo_Cnotzero: "Cnotzero ctwo"
100.296 +by (simp add: ctwo_not_czero Card_order_ctwo)
100.297 +
100.298 +
100.299 +subsection {* Family sum *}
100.300 +
100.301 +definition Csum where
100.302 + "Csum r rs \<equiv> |SIGMA i : Field r. Field (rs i)|"
100.303 +
100.304 +(* Similar setup to the one for SIGMA from theory Big_Operators: *)
100.305 +syntax "_Csum" ::
100.306 + "pttrn => ('a * 'a) set => 'b * 'b set => (('a * 'b) * ('a * 'b)) set"
100.307 + ("(3CSUM _:_. _)" [0, 51, 10] 10)
100.308 +
100.309 +translations
100.310 + "CSUM i:r. rs" == "CONST Csum r (%i. rs)"
100.311 +
100.312 +lemma SIGMA_CSUM: "|SIGMA i : I. As i| = (CSUM i : |I|. |As i| )"
100.313 +by (auto simp: Csum_def Field_card_of)
100.314 +
100.315 +(* NB: Always, under the cardinal operator,
100.316 +operations on sets are reduced automatically to operations on cardinals.
100.317 +This should make cardinal reasoning more direct and natural. *)
100.318 +
100.319 +
100.320 +subsection {* Product *}
100.321 +
100.322 +definition cprod (infixr "*c" 80) where
100.323 + "r1 *c r2 = |Field r1 <*> Field r2|"
100.324 +
100.325 +lemma card_order_cprod:
100.326 + assumes "card_order r1" "card_order r2"
100.327 + shows "card_order (r1 *c r2)"
100.328 +proof -
100.329 + have "Field r1 = UNIV" "Field r2 = UNIV" using assms card_order_on_Card_order by auto
100.330 + thus ?thesis by (auto simp: cprod_def card_of_card_order_on)
100.331 +qed
100.332 +
100.333 +lemma Card_order_cprod: "Card_order (r1 *c r2)"
100.334 +by (simp only: cprod_def Field_card_of card_of_card_order_on)
100.335 +
100.336 +lemma cprod_mono1: "p1 \<le>o r1 \<Longrightarrow> p1 *c q \<le>o r1 *c q"
100.337 +by (simp only: cprod_def ordLeq_Times_mono1)
100.338 +
100.339 +lemma cprod_mono2: "p2 \<le>o r2 \<Longrightarrow> q *c p2 \<le>o q *c r2"
100.340 +by (simp only: cprod_def ordLeq_Times_mono2)
100.341 +
100.342 +lemma ordLeq_cprod2: "\<lbrakk>Cnotzero p1; Card_order p2\<rbrakk> \<Longrightarrow> p2 \<le>o p1 *c p2"
100.343 +unfolding cprod_def by (metis Card_order_Times2 czeroI)
100.344 +
100.345 +lemma cinfinite_cprod: "\<lbrakk>cinfinite r1; cinfinite r2\<rbrakk> \<Longrightarrow> cinfinite (r1 *c r2)"
100.346 +by (simp add: cinfinite_def cprod_def Field_card_of infinite_cartesian_product)
100.347 +
100.348 +lemma cinfinite_cprod2: "\<lbrakk>Cnotzero r1; Cinfinite r2\<rbrakk> \<Longrightarrow> cinfinite (r1 *c r2)"
100.349 +by (metis cinfinite_mono ordLeq_cprod2)
100.350 +
100.351 +lemma Cinfinite_cprod2: "\<lbrakk>Cnotzero r1; Cinfinite r2\<rbrakk> \<Longrightarrow> Cinfinite (r1 *c r2)"
100.352 +by (blast intro: cinfinite_cprod2 Card_order_cprod)
100.353 +
100.354 +lemma cprod_com: "p1 *c p2 =o p2 *c p1"
100.355 +by (simp only: cprod_def card_of_Times_commute)
100.356 +
100.357 +lemma card_of_Csum_Times:
100.358 + "\<forall>i \<in> I. |A i| \<le>o |B| \<Longrightarrow> (CSUM i : |I|. |A i| ) \<le>o |I| *c |B|"
100.359 +by (simp only: Csum_def cprod_def Field_card_of card_of_Sigma_Times)
100.360 +
100.361 +lemma card_of_Csum_Times':
100.362 + assumes "Card_order r" "\<forall>i \<in> I. |A i| \<le>o r"
100.363 + shows "(CSUM i : |I|. |A i| ) \<le>o |I| *c r"
100.364 +proof -
100.365 + from assms(1) have *: "r =o |Field r|" by (simp add: card_of_unique)
100.366 + with assms(2) have "\<forall>i \<in> I. |A i| \<le>o |Field r|" by (blast intro: ordLeq_ordIso_trans)
100.367 + hence "(CSUM i : |I|. |A i| ) \<le>o |I| *c |Field r|" by (simp only: card_of_Csum_Times)
100.368 + also from * have "|I| *c |Field r| \<le>o |I| *c r"
100.369 + by (simp only: Field_card_of card_of_refl cprod_def ordIso_imp_ordLeq)
100.370 + finally show ?thesis .
100.371 +qed
100.372 +
100.373 +lemma cprod_csum_distrib1: "r1 *c r2 +c r1 *c r3 =o r1 *c (r2 +c r3)"
100.374 +unfolding csum_def cprod_def by (simp add: Field_card_of card_of_Times_Plus_distrib ordIso_symmetric)
100.375 +
100.376 +lemma csum_absorb2': "\<lbrakk>Card_order r2; r1 \<le>o r2; cinfinite r1 \<or> cinfinite r2\<rbrakk> \<Longrightarrow> r1 +c r2 =o r2"
100.377 +unfolding csum_def by (metis Card_order_Plus_infinite cinfinite_def cinfinite_mono)
100.378 +
100.379 +lemma csum_absorb1':
100.380 + assumes card: "Card_order r2"
100.381 + and r12: "r1 \<le>o r2" and cr12: "cinfinite r1 \<or> cinfinite r2"
100.382 + shows "r2 +c r1 =o r2"
100.383 +by (rule ordIso_transitive, rule csum_com, rule csum_absorb2', (simp only: assms)+)
100.384 +
100.385 +lemma csum_absorb1: "\<lbrakk>Cinfinite r2; r1 \<le>o r2\<rbrakk> \<Longrightarrow> r2 +c r1 =o r2"
100.386 +by (rule csum_absorb1') auto
100.387 +
100.388 +
100.389 +subsection {* Exponentiation *}
100.390 +
100.391 +definition cexp (infixr "^c" 90) where
100.392 + "r1 ^c r2 \<equiv> |Func (Field r2) (Field r1)|"
100.393 +
100.394 +lemma Card_order_cexp: "Card_order (r1 ^c r2)"
100.395 +unfolding cexp_def by (rule card_of_Card_order)
100.396 +
100.397 +lemma cexp_mono':
100.398 + assumes 1: "p1 \<le>o r1" and 2: "p2 \<le>o r2"
100.399 + and n: "Field p2 = {} \<Longrightarrow> Field r2 = {}"
100.400 + shows "p1 ^c p2 \<le>o r1 ^c r2"
100.401 +proof(cases "Field p1 = {}")
100.402 + case True
100.403 + hence "|Field |Func (Field p2) (Field p1)|| \<le>o cone"
100.404 + unfolding cone_def Field_card_of
100.405 + by (cases "Field p2 = {}", auto intro: card_of_ordLeqI2 simp: Func_empty)
100.406 + (metis Func_is_emp card_of_empty ex_in_conv)
100.407 + hence "|Func (Field p2) (Field p1)| \<le>o cone" by (simp add: Field_card_of cexp_def)
100.408 + hence "p1 ^c p2 \<le>o cone" unfolding cexp_def .
100.409 + thus ?thesis
100.410 + proof (cases "Field p2 = {}")
100.411 + case True
100.412 + with n have "Field r2 = {}" .
100.413 + hence "cone \<le>o r1 ^c r2" unfolding cone_def cexp_def Func_def by (auto intro: card_of_ordLeqI)
100.414 + thus ?thesis using `p1 ^c p2 \<le>o cone` ordLeq_transitive by auto
100.415 + next
100.416 + case False with True have "|Field (p1 ^c p2)| =o czero"
100.417 + unfolding card_of_ordIso_czero_iff_empty cexp_def Field_card_of Func_def by auto
100.418 + thus ?thesis unfolding cexp_def card_of_ordIso_czero_iff_empty Field_card_of
100.419 + by (simp add: card_of_empty)
100.420 + qed
100.421 +next
100.422 + case False
100.423 + have 1: "|Field p1| \<le>o |Field r1|" and 2: "|Field p2| \<le>o |Field r2|"
100.424 + using 1 2 by (auto simp: card_of_mono2)
100.425 + obtain f1 where f1: "f1 ` Field r1 = Field p1"
100.426 + using 1 unfolding card_of_ordLeq2[OF False, symmetric] by auto
100.427 + obtain f2 where f2: "inj_on f2 (Field p2)" "f2 ` Field p2 \<subseteq> Field r2"
100.428 + using 2 unfolding card_of_ordLeq[symmetric] by blast
100.429 + have 0: "Func_map (Field p2) f1 f2 ` (Field (r1 ^c r2)) = Field (p1 ^c p2)"
100.430 + unfolding cexp_def Field_card_of using Func_map_surj[OF f1 f2 n, symmetric] .
100.431 + have 00: "Field (p1 ^c p2) \<noteq> {}" unfolding cexp_def Field_card_of Func_is_emp
100.432 + using False by simp
100.433 + show ?thesis
100.434 + using 0 card_of_ordLeq2[OF 00] unfolding cexp_def Field_card_of by blast
100.435 +qed
100.436 +
100.437 +lemma cexp_mono:
100.438 + assumes 1: "p1 \<le>o r1" and 2: "p2 \<le>o r2"
100.439 + and n: "p2 =o czero \<Longrightarrow> r2 =o czero" and card: "Card_order p2"
100.440 + shows "p1 ^c p2 \<le>o r1 ^c r2"
100.441 + by (metis (full_types) "1" "2" card cexp_mono' czeroE czeroI n)
100.442 +
100.443 +lemma cexp_mono1:
100.444 + assumes 1: "p1 \<le>o r1" and q: "Card_order q"
100.445 + shows "p1 ^c q \<le>o r1 ^c q"
100.446 +using ordLeq_refl[OF q] by (rule cexp_mono[OF 1]) (auto simp: q)
100.447 +
100.448 +lemma cexp_mono2':
100.449 + assumes 2: "p2 \<le>o r2" and q: "Card_order q"
100.450 + and n: "Field p2 = {} \<Longrightarrow> Field r2 = {}"
100.451 + shows "q ^c p2 \<le>o q ^c r2"
100.452 +using ordLeq_refl[OF q] by (rule cexp_mono'[OF _ 2 n]) auto
100.453 +
100.454 +lemma cexp_mono2:
100.455 + assumes 2: "p2 \<le>o r2" and q: "Card_order q"
100.456 + and n: "p2 =o czero \<Longrightarrow> r2 =o czero" and card: "Card_order p2"
100.457 + shows "q ^c p2 \<le>o q ^c r2"
100.458 +using ordLeq_refl[OF q] by (rule cexp_mono[OF _ 2 n card]) auto
100.459 +
100.460 +lemma cexp_mono2_Cnotzero:
100.461 + assumes "p2 \<le>o r2" "Card_order q" "Cnotzero p2"
100.462 + shows "q ^c p2 \<le>o q ^c r2"
100.463 +by (metis assms cexp_mono2' czeroI)
100.464 +
100.465 +lemma cexp_cong:
100.466 + assumes 1: "p1 =o r1" and 2: "p2 =o r2"
100.467 + and Cr: "Card_order r2"
100.468 + and Cp: "Card_order p2"
100.469 + shows "p1 ^c p2 =o r1 ^c r2"
100.470 +proof -
100.471 + obtain f where "bij_betw f (Field p2) (Field r2)"
100.472 + using 2 card_of_ordIso[of "Field p2" "Field r2"] card_of_cong by auto
100.473 + hence 0: "Field p2 = {} \<longleftrightarrow> Field r2 = {}" unfolding bij_betw_def by auto
100.474 + have r: "p2 =o czero \<Longrightarrow> r2 =o czero"
100.475 + and p: "r2 =o czero \<Longrightarrow> p2 =o czero"
100.476 + using 0 Cr Cp czeroE czeroI by auto
100.477 + show ?thesis using 0 1 2 unfolding ordIso_iff_ordLeq
100.478 + using r p cexp_mono[OF _ _ _ Cp] cexp_mono[OF _ _ _ Cr] by metis
100.479 +qed
100.480 +
100.481 +lemma cexp_cong1:
100.482 + assumes 1: "p1 =o r1" and q: "Card_order q"
100.483 + shows "p1 ^c q =o r1 ^c q"
100.484 +by (rule cexp_cong[OF 1 _ q q]) (rule ordIso_refl[OF q])
100.485 +
100.486 +lemma cexp_cong2:
100.487 + assumes 2: "p2 =o r2" and q: "Card_order q" and p: "Card_order p2"
100.488 + shows "q ^c p2 =o q ^c r2"
100.489 +by (rule cexp_cong[OF _ 2]) (auto simp only: ordIso_refl Card_order_ordIso2[OF p 2] q p)
100.490 +
100.491 +lemma cexp_cone:
100.492 + assumes "Card_order r"
100.493 + shows "r ^c cone =o r"
100.494 +proof -
100.495 + have "r ^c cone =o |Field r|"
100.496 + unfolding cexp_def cone_def Field_card_of Func_empty
100.497 + card_of_ordIso[symmetric] bij_betw_def Func_def inj_on_def image_def
100.498 + by (rule exI[of _ "\<lambda>f. f ()"]) auto
100.499 + also have "|Field r| =o r" by (rule card_of_Field_ordIso[OF assms])
100.500 + finally show ?thesis .
100.501 +qed
100.502 +
100.503 +lemma cexp_cprod:
100.504 + assumes r1: "Card_order r1"
100.505 + shows "(r1 ^c r2) ^c r3 =o r1 ^c (r2 *c r3)" (is "?L =o ?R")
100.506 +proof -
100.507 + have "?L =o r1 ^c (r3 *c r2)"
100.508 + unfolding cprod_def cexp_def Field_card_of
100.509 + using card_of_Func_Times by(rule ordIso_symmetric)
100.510 + also have "r1 ^c (r3 *c r2) =o ?R"
100.511 + apply(rule cexp_cong2) using cprod_com r1 by (auto simp: Card_order_cprod)
100.512 + finally show ?thesis .
100.513 +qed
100.514 +
100.515 +lemma cprod_infinite1': "\<lbrakk>Cinfinite r; Cnotzero p; p \<le>o r\<rbrakk> \<Longrightarrow> r *c p =o r"
100.516 +unfolding cinfinite_def cprod_def
100.517 +by (rule Card_order_Times_infinite[THEN conjunct1]) (blast intro: czeroI)+
100.518 +
100.519 +lemma cexp_cprod_ordLeq:
100.520 + assumes r1: "Card_order r1" and r2: "Cinfinite r2"
100.521 + and r3: "Cnotzero r3" "r3 \<le>o r2"
100.522 + shows "(r1 ^c r2) ^c r3 =o r1 ^c r2" (is "?L =o ?R")
100.523 +proof-
100.524 + have "?L =o r1 ^c (r2 *c r3)" using cexp_cprod[OF r1] .
100.525 + also have "r1 ^c (r2 *c r3) =o ?R"
100.526 + apply(rule cexp_cong2)
100.527 + apply(rule cprod_infinite1'[OF r2 r3]) using r1 r2 by (fastforce simp: Card_order_cprod)+
100.528 + finally show ?thesis .
100.529 +qed
100.530 +
100.531 +lemma Cnotzero_UNIV: "Cnotzero |UNIV|"
100.532 +by (auto simp: card_of_Card_order card_of_ordIso_czero_iff_empty)
100.533 +
100.534 +lemma ordLess_ctwo_cexp:
100.535 + assumes "Card_order r"
100.536 + shows "r <o ctwo ^c r"
100.537 +proof -
100.538 + have "r <o |Pow (Field r)|" using assms by (rule Card_order_Pow)
100.539 + also have "|Pow (Field r)| =o ctwo ^c r"
100.540 + unfolding ctwo_def cexp_def Field_card_of by (rule card_of_Pow_Func)
100.541 + finally show ?thesis .
100.542 +qed
100.543 +
100.544 +lemma ordLeq_cexp1:
100.545 + assumes "Cnotzero r" "Card_order q"
100.546 + shows "q \<le>o q ^c r"
100.547 +proof (cases "q =o (czero :: 'a rel)")
100.548 + case True thus ?thesis by (simp only: card_of_empty cexp_def czero_def ordIso_ordLeq_trans)
100.549 +next
100.550 + case False
100.551 + thus ?thesis
100.552 + apply -
100.553 + apply (rule ordIso_ordLeq_trans)
100.554 + apply (rule ordIso_symmetric)
100.555 + apply (rule cexp_cone)
100.556 + apply (rule assms(2))
100.557 + apply (rule cexp_mono2)
100.558 + apply (rule cone_ordLeq_Cnotzero)
100.559 + apply (rule assms(1))
100.560 + apply (rule assms(2))
100.561 + apply (rule notE)
100.562 + apply (rule cone_not_czero)
100.563 + apply assumption
100.564 + apply (rule Card_order_cone)
100.565 + done
100.566 +qed
100.567 +
100.568 +lemma ordLeq_cexp2:
100.569 + assumes "ctwo \<le>o q" "Card_order r"
100.570 + shows "r \<le>o q ^c r"
100.571 +proof (cases "r =o (czero :: 'a rel)")
100.572 + case True thus ?thesis by (simp only: card_of_empty cexp_def czero_def ordIso_ordLeq_trans)
100.573 +next
100.574 + case False thus ?thesis
100.575 + apply -
100.576 + apply (rule ordLess_imp_ordLeq)
100.577 + apply (rule ordLess_ordLeq_trans)
100.578 + apply (rule ordLess_ctwo_cexp)
100.579 + apply (rule assms(2))
100.580 + apply (rule cexp_mono1)
100.581 + apply (rule assms(1))
100.582 + apply (rule assms(2))
100.583 + done
100.584 +qed
100.585 +
100.586 +lemma cinfinite_cexp: "\<lbrakk>ctwo \<le>o q; Cinfinite r\<rbrakk> \<Longrightarrow> cinfinite (q ^c r)"
100.587 +by (metis assms cinfinite_mono ordLeq_cexp2)
100.588 +
100.589 +lemma Cinfinite_cexp:
100.590 + "\<lbrakk>ctwo \<le>o q; Cinfinite r\<rbrakk> \<Longrightarrow> Cinfinite (q ^c r)"
100.591 +by (simp add: cinfinite_cexp Card_order_cexp)
100.592 +
100.593 +lemma ctwo_ordLess_natLeq: "ctwo <o natLeq"
100.594 +unfolding ctwo_def using finite_UNIV natLeq_cinfinite natLeq_Card_order
100.595 +by (intro Cfinite_ordLess_Cinfinite) (auto simp: cfinite_def card_of_Card_order)
100.596 +
100.597 +lemma ctwo_ordLess_Cinfinite: "Cinfinite r \<Longrightarrow> ctwo <o r"
100.598 +by (metis ctwo_ordLess_natLeq natLeq_ordLeq_cinfinite ordLess_ordLeq_trans)
100.599 +
100.600 +lemma ctwo_ordLeq_Cinfinite:
100.601 + assumes "Cinfinite r"
100.602 + shows "ctwo \<le>o r"
100.603 +by (rule ordLess_imp_ordLeq[OF ctwo_ordLess_Cinfinite[OF assms]])
100.604 +
100.605 +lemma Un_Cinfinite_bound: "\<lbrakk>|A| \<le>o r; |B| \<le>o r; Cinfinite r\<rbrakk> \<Longrightarrow> |A \<union> B| \<le>o r"
100.606 +by (auto simp add: cinfinite_def card_of_Un_ordLeq_infinite_Field)
100.607 +
100.608 +lemma UNION_Cinfinite_bound: "\<lbrakk>|I| \<le>o r; \<forall>i \<in> I. |A i| \<le>o r; Cinfinite r\<rbrakk> \<Longrightarrow> |\<Union>i \<in> I. A i| \<le>o r"
100.609 +by (auto simp add: card_of_UNION_ordLeq_infinite_Field cinfinite_def)
100.610 +
100.611 +lemma csum_cinfinite_bound:
100.612 + assumes "p \<le>o r" "q \<le>o r" "Card_order p" "Card_order q" "Cinfinite r"
100.613 + shows "p +c q \<le>o r"
100.614 +proof -
100.615 + from assms(1-4) have "|Field p| \<le>o r" "|Field q| \<le>o r"
100.616 + unfolding card_order_on_def using card_of_least ordLeq_transitive by blast+
100.617 + with assms show ?thesis unfolding cinfinite_def csum_def
100.618 + by (blast intro: card_of_Plus_ordLeq_infinite_Field)
100.619 +qed
100.620 +
100.621 +lemma cprod_cinfinite_bound:
100.622 + assumes "p \<le>o r" "q \<le>o r" "Card_order p" "Card_order q" "Cinfinite r"
100.623 + shows "p *c q \<le>o r"
100.624 +proof -
100.625 + from assms(1-4) have "|Field p| \<le>o r" "|Field q| \<le>o r"
100.626 + unfolding card_order_on_def using card_of_least ordLeq_transitive by blast+
100.627 + with assms show ?thesis unfolding cinfinite_def cprod_def
100.628 + by (blast intro: card_of_Times_ordLeq_infinite_Field)
100.629 +qed
100.630 +
100.631 +lemma cprod_csum_cexp:
100.632 + "r1 *c r2 \<le>o (r1 +c r2) ^c ctwo"
100.633 +unfolding cprod_def csum_def cexp_def ctwo_def Field_card_of
100.634 +proof -
100.635 + let ?f = "\<lambda>(a, b). %x. if x then Inl a else Inr b"
100.636 + have "inj_on ?f (Field r1 \<times> Field r2)" (is "inj_on _ ?LHS")
100.637 + by (auto simp: inj_on_def fun_eq_iff split: bool.split)
100.638 + moreover
100.639 + have "?f ` ?LHS \<subseteq> Func (UNIV :: bool set) (Field r1 <+> Field r2)" (is "_ \<subseteq> ?RHS")
100.640 + by (auto simp: Func_def)
100.641 + ultimately show "|?LHS| \<le>o |?RHS|" using card_of_ordLeq by blast
100.642 +qed
100.643 +
100.644 +lemma Cfinite_cprod_Cinfinite: "\<lbrakk>Cfinite r; Cinfinite s\<rbrakk> \<Longrightarrow> r *c s \<le>o s"
100.645 +by (intro cprod_cinfinite_bound)
100.646 + (auto intro: ordLeq_refl ordLess_imp_ordLeq[OF Cfinite_ordLess_Cinfinite])
100.647 +
100.648 +lemma cprod_cexp: "(r *c s) ^c t =o r ^c t *c s ^c t"
100.649 + unfolding cprod_def cexp_def Field_card_of by (rule Func_Times_Range)
100.650 +
100.651 +lemma cprod_cexp_csum_cexp_Cinfinite:
100.652 + assumes t: "Cinfinite t"
100.653 + shows "(r *c s) ^c t \<le>o (r +c s) ^c t"
100.654 +proof -
100.655 + have "(r *c s) ^c t \<le>o ((r +c s) ^c ctwo) ^c t"
100.656 + by (rule cexp_mono1[OF cprod_csum_cexp conjunct2[OF t]])
100.657 + also have "((r +c s) ^c ctwo) ^c t =o (r +c s) ^c (ctwo *c t)"
100.658 + by (rule cexp_cprod[OF Card_order_csum])
100.659 + also have "(r +c s) ^c (ctwo *c t) =o (r +c s) ^c (t *c ctwo)"
100.660 + by (rule cexp_cong2[OF cprod_com Card_order_csum Card_order_cprod])
100.661 + also have "(r +c s) ^c (t *c ctwo) =o ((r +c s) ^c t) ^c ctwo"
100.662 + by (rule ordIso_symmetric[OF cexp_cprod[OF Card_order_csum]])
100.663 + also have "((r +c s) ^c t) ^c ctwo =o (r +c s) ^c t"
100.664 + by (rule cexp_cprod_ordLeq[OF Card_order_csum t ctwo_Cnotzero ctwo_ordLeq_Cinfinite[OF t]])
100.665 + finally show ?thesis .
100.666 +qed
100.667 +
100.668 +lemma Cfinite_cexp_Cinfinite:
100.669 + assumes s: "Cfinite s" and t: "Cinfinite t"
100.670 + shows "s ^c t \<le>o ctwo ^c t"
100.671 +proof (cases "s \<le>o ctwo")
100.672 + case True thus ?thesis using t by (blast intro: cexp_mono1)
100.673 +next
100.674 + case False
100.675 + hence "ctwo \<le>o s" by (metis card_order_on_well_order_on ctwo_Cnotzero ordLeq_total s)
100.676 + hence "Cnotzero s" by (metis Cnotzero_mono ctwo_Cnotzero s)
100.677 + hence st: "Cnotzero (s *c t)" by (metis Cinfinite_cprod2 cinfinite_not_czero t)
100.678 + have "s ^c t \<le>o (ctwo ^c s) ^c t"
100.679 + using assms by (blast intro: cexp_mono1 ordLess_imp_ordLeq[OF ordLess_ctwo_cexp])
100.680 + also have "(ctwo ^c s) ^c t =o ctwo ^c (s *c t)"
100.681 + by (blast intro: Card_order_ctwo cexp_cprod)
100.682 + also have "ctwo ^c (s *c t) \<le>o ctwo ^c t"
100.683 + using assms st by (intro cexp_mono2_Cnotzero Cfinite_cprod_Cinfinite Card_order_ctwo)
100.684 + finally show ?thesis .
100.685 +qed
100.686 +
100.687 +lemma csum_Cfinite_cexp_Cinfinite:
100.688 + assumes r: "Card_order r" and s: "Cfinite s" and t: "Cinfinite t"
100.689 + shows "(r +c s) ^c t \<le>o (r +c ctwo) ^c t"
100.690 +proof (cases "Cinfinite r")
100.691 + case True
100.692 + hence "r +c s =o r" by (intro csum_absorb1 ordLess_imp_ordLeq[OF Cfinite_ordLess_Cinfinite] s)
100.693 + hence "(r +c s) ^c t =o r ^c t" using t by (blast intro: cexp_cong1)
100.694 + also have "r ^c t \<le>o (r +c ctwo) ^c t" using t by (blast intro: cexp_mono1 ordLeq_csum1 r)
100.695 + finally show ?thesis .
100.696 +next
100.697 + case False
100.698 + with r have "Cfinite r" unfolding cinfinite_def cfinite_def by auto
100.699 + hence "Cfinite (r +c s)" by (intro Cfinite_csum s)
100.700 + hence "(r +c s) ^c t \<le>o ctwo ^c t" by (intro Cfinite_cexp_Cinfinite t)
100.701 + also have "ctwo ^c t \<le>o (r +c ctwo) ^c t" using t
100.702 + by (blast intro: cexp_mono1 ordLeq_csum2 Card_order_ctwo)
100.703 + finally show ?thesis .
100.704 +qed
100.705 +
100.706 +lemma card_order_cexp:
100.707 + assumes "card_order r1" "card_order r2"
100.708 + shows "card_order (r1 ^c r2)"
100.709 +proof -
100.710 + have "Field r1 = UNIV" "Field r2 = UNIV" using assms card_order_on_Card_order by auto
100.711 + thus ?thesis unfolding cexp_def Func_def by (simp add: card_of_card_order_on)
100.712 +qed
100.713 +
100.714 +lemma Cinfinite_ordLess_cexp:
100.715 + assumes r: "Cinfinite r"
100.716 + shows "r <o r ^c r"
100.717 +proof -
100.718 + have "r <o ctwo ^c r" using r by (simp only: ordLess_ctwo_cexp)
100.719 + also have "ctwo ^c r \<le>o r ^c r"
100.720 + by (rule cexp_mono1[OF ctwo_ordLeq_Cinfinite]) (auto simp: r ctwo_not_czero Card_order_ctwo)
100.721 + finally show ?thesis .
100.722 +qed
100.723 +
100.724 +lemma infinite_ordLeq_cexp:
100.725 + assumes "Cinfinite r"
100.726 + shows "r \<le>o r ^c r"
100.727 +by (rule ordLess_imp_ordLeq[OF Cinfinite_ordLess_cexp[OF assms]])
100.728 +
100.729 +(* cardSuc *)
100.730 +
100.731 +lemma Cinfinite_cardSuc: "Cinfinite r \<Longrightarrow> Cinfinite (cardSuc r)"
100.732 +by (simp add: cinfinite_def cardSuc_Card_order cardSuc_finite)
100.733 +
100.734 +lemma cardSuc_UNION_Cinfinite:
100.735 + assumes "Cinfinite r" "relChain (cardSuc r) As" "B \<le> (UN i : Field (cardSuc r). As i)" "|B| <=o r"
100.736 + shows "EX i : Field (cardSuc r). B \<le> As i"
100.737 +using cardSuc_UNION assms unfolding cinfinite_def by blast
100.738 +
100.739 +subsection {* Powerset *}
100.740 +
100.741 +definition cpow where "cpow r = |Pow (Field r)|"
100.742 +
100.743 +lemma card_order_cpow: "card_order r \<Longrightarrow> card_order (cpow r)"
100.744 +by (simp only: cpow_def Field_card_order Pow_UNIV card_of_card_order_on)
100.745 +
100.746 +lemma cpow_greater_eq: "Card_order r \<Longrightarrow> r \<le>o cpow r"
100.747 +by (rule ordLess_imp_ordLeq) (simp only: cpow_def Card_order_Pow)
100.748 +
100.749 +lemma Cinfinite_cpow: "Cinfinite r \<Longrightarrow> Cinfinite (cpow r)"
100.750 +unfolding cpow_def cinfinite_def by (metis Field_card_of card_of_Card_order infinite_Pow)
100.751 +
100.752 +end
101.1 --- a/src/HOL/Cardinals/Cardinal_Order_Relation.thy Thu Dec 05 17:52:12 2013 +0100
101.2 +++ b/src/HOL/Cardinals/Cardinal_Order_Relation.thy Thu Dec 05 17:58:03 2013 +0100
101.3 @@ -8,7 +8,7 @@
101.4 header {* Cardinal-Order Relations *}
101.5
101.6 theory Cardinal_Order_Relation
101.7 -imports Cardinal_Order_Relation_Base Constructions_on_Wellorders
101.8 +imports Cardinal_Order_Relation_FP Constructions_on_Wellorders
101.9 begin
101.10
101.11 declare
101.12 @@ -34,7 +34,6 @@
101.13 Card_order_singl_ordLeq[simp]
101.14 card_of_Pow[simp]
101.15 Card_order_Pow[simp]
101.16 - card_of_set_type[simp]
101.17 card_of_Plus1[simp]
101.18 Card_order_Plus1[simp]
101.19 card_of_Plus2[simp]
101.20 @@ -44,25 +43,19 @@
101.21 card_of_Plus_mono[simp]
101.22 card_of_Plus_cong2[simp]
101.23 card_of_Plus_cong[simp]
101.24 - card_of_Un1[simp]
101.25 - card_of_diff[simp]
101.26 card_of_Un_Plus_ordLeq[simp]
101.27 card_of_Times1[simp]
101.28 card_of_Times2[simp]
101.29 card_of_Times3[simp]
101.30 card_of_Times_mono1[simp]
101.31 card_of_Times_mono2[simp]
101.32 - card_of_Times_cong1[simp]
101.33 - card_of_Times_cong2[simp]
101.34 card_of_ordIso_finite[simp]
101.35 - finite_ordLess_infinite2[simp]
101.36 card_of_Times_same_infinite[simp]
101.37 card_of_Times_infinite_simps[simp]
101.38 card_of_Plus_infinite1[simp]
101.39 card_of_Plus_infinite2[simp]
101.40 card_of_Plus_ordLess_infinite[simp]
101.41 card_of_Plus_ordLess_infinite_Field[simp]
101.42 - card_of_lists_infinite[simp]
101.43 infinite_cartesian_product[simp]
101.44 cardSuc_Card_order[simp]
101.45 cardSuc_greater[simp]
101.46 @@ -143,6 +136,17 @@
101.47
101.48 subsection {* Cardinals versus set operations on arbitrary sets *}
101.49
101.50 +lemma card_of_set_type[simp]: "|UNIV::'a set| <o |UNIV::'a set set|"
101.51 +using card_of_Pow[of "UNIV::'a set"] by simp
101.52 +
101.53 +lemma card_of_Un1[simp]:
101.54 +shows "|A| \<le>o |A \<union> B| "
101.55 +using inj_on_id[of A] card_of_ordLeq[of A _] by fastforce
101.56 +
101.57 +lemma card_of_diff[simp]:
101.58 +shows "|A - B| \<le>o |A|"
101.59 +using inj_on_id[of "A - B"] card_of_ordLeq[of "A - B" _] by fastforce
101.60 +
101.61 lemma subset_ordLeq_strict:
101.62 assumes "A \<le> B" and "|A| <o |B|"
101.63 shows "A < B"
101.64 @@ -304,8 +308,17 @@
101.65
101.66 corollary Card_order_Times3:
101.67 "Card_order r \<Longrightarrow> |Field r| \<le>o |(Field r) \<times> (Field r)|"
101.68 -using card_of_Times3 card_of_Field_ordIso
101.69 - ordIso_ordLeq_trans ordIso_symmetric by blast
101.70 + by (rule card_of_Times3)
101.71 +
101.72 +lemma card_of_Times_cong1[simp]:
101.73 +assumes "|A| =o |B|"
101.74 +shows "|A \<times> C| =o |B \<times> C|"
101.75 +using assms by (simp add: ordIso_iff_ordLeq)
101.76 +
101.77 +lemma card_of_Times_cong2[simp]:
101.78 +assumes "|A| =o |B|"
101.79 +shows "|C \<times> A| =o |C \<times> B|"
101.80 +using assms by (simp add: ordIso_iff_ordLeq)
101.81
101.82 lemma card_of_Times_mono[simp]:
101.83 assumes "|A| \<le>o |B|" and "|C| \<le>o |D|"
101.84 @@ -323,6 +336,11 @@
101.85 shows "|(Field r) \<times> C| =o |(Field r') \<times> C|"
101.86 using assms card_of_cong card_of_Times_cong1 by blast
101.87
101.88 +corollary ordIso_Times_cong2:
101.89 +assumes "r =o r'"
101.90 +shows "|A \<times> (Field r)| =o |A \<times> (Field r')|"
101.91 +using assms card_of_cong card_of_Times_cong2 by blast
101.92 +
101.93 lemma card_of_Times_cong[simp]:
101.94 assumes "|A| =o |B|" and "|C| =o |D|"
101.95 shows "|A \<times> C| =o |B \<times> D|"
101.96 @@ -454,18 +472,18 @@
101.97 by auto
101.98
101.99 corollary Times_same_infinite_bij_betw:
101.100 -assumes "infinite A"
101.101 +assumes "\<not>finite A"
101.102 shows "\<exists>f. bij_betw f (A \<times> A) A"
101.103 using assms by (auto simp add: card_of_ordIso)
101.104
101.105 corollary Times_same_infinite_bij_betw_types:
101.106 -assumes INF: "infinite(UNIV::'a set)"
101.107 +assumes INF: "\<not>finite(UNIV::'a set)"
101.108 shows "\<exists>(f::('a * 'a) => 'a). bij f"
101.109 using assms Times_same_infinite_bij_betw[of "UNIV::'a set"]
101.110 by auto
101.111
101.112 corollary Times_infinite_bij_betw:
101.113 -assumes INF: "infinite A" and NE: "B \<noteq> {}" and INJ: "inj_on g B \<and> g ` B \<le> A"
101.114 +assumes INF: "\<not>finite A" and NE: "B \<noteq> {}" and INJ: "inj_on g B \<and> g ` B \<le> A"
101.115 shows "(\<exists>f. bij_betw f (A \<times> B) A) \<and> (\<exists>h. bij_betw h (B \<times> A) A)"
101.116 proof-
101.117 have "|B| \<le>o |A|" using INJ card_of_ordLeq by blast
101.118 @@ -474,19 +492,19 @@
101.119 qed
101.120
101.121 corollary Times_infinite_bij_betw_types:
101.122 -assumes INF: "infinite(UNIV::'a set)" and
101.123 +assumes INF: "\<not>finite(UNIV::'a set)" and
101.124 BIJ: "inj(g::'b \<Rightarrow> 'a)"
101.125 shows "(\<exists>(f::('b * 'a) => 'a). bij f) \<and> (\<exists>(h::('a * 'b) => 'a). bij h)"
101.126 using assms Times_infinite_bij_betw[of "UNIV::'a set" "UNIV::'b set" g]
101.127 by auto
101.128
101.129 lemma card_of_Times_ordLeq_infinite:
101.130 -"\<lbrakk>infinite C; |A| \<le>o |C|; |B| \<le>o |C|\<rbrakk>
101.131 +"\<lbrakk>\<not>finite C; |A| \<le>o |C|; |B| \<le>o |C|\<rbrakk>
101.132 \<Longrightarrow> |A <*> B| \<le>o |C|"
101.133 by(simp add: card_of_Sigma_ordLeq_infinite)
101.134
101.135 corollary Plus_infinite_bij_betw:
101.136 -assumes INF: "infinite A" and INJ: "inj_on g B \<and> g ` B \<le> A"
101.137 +assumes INF: "\<not>finite A" and INJ: "inj_on g B \<and> g ` B \<le> A"
101.138 shows "(\<exists>f. bij_betw f (A <+> B) A) \<and> (\<exists>h. bij_betw h (B <+> A) A)"
101.139 proof-
101.140 have "|B| \<le>o |A|" using INJ card_of_ordLeq by blast
101.141 @@ -495,19 +513,63 @@
101.142 qed
101.143
101.144 corollary Plus_infinite_bij_betw_types:
101.145 -assumes INF: "infinite(UNIV::'a set)" and
101.146 +assumes INF: "\<not>finite(UNIV::'a set)" and
101.147 BIJ: "inj(g::'b \<Rightarrow> 'a)"
101.148 shows "(\<exists>(f::('b + 'a) => 'a). bij f) \<and> (\<exists>(h::('a + 'b) => 'a). bij h)"
101.149 using assms Plus_infinite_bij_betw[of "UNIV::'a set" g "UNIV::'b set"]
101.150 by auto
101.151
101.152 +lemma card_of_Un_infinite:
101.153 +assumes INF: "\<not>finite A" and LEQ: "|B| \<le>o |A|"
101.154 +shows "|A \<union> B| =o |A| \<and> |B \<union> A| =o |A|"
101.155 +proof-
101.156 + have "|A \<union> B| \<le>o |A <+> B|" by (rule card_of_Un_Plus_ordLeq)
101.157 + moreover have "|A <+> B| =o |A|"
101.158 + using assms by (metis card_of_Plus_infinite)
101.159 + ultimately have "|A \<union> B| \<le>o |A|" using ordLeq_ordIso_trans by blast
101.160 + hence "|A \<union> B| =o |A|" using card_of_Un1 ordIso_iff_ordLeq by blast
101.161 + thus ?thesis using Un_commute[of B A] by auto
101.162 +qed
101.163 +
101.164 lemma card_of_Un_infinite_simps[simp]:
101.165 -"\<lbrakk>infinite A; |B| \<le>o |A| \<rbrakk> \<Longrightarrow> |A \<union> B| =o |A|"
101.166 -"\<lbrakk>infinite A; |B| \<le>o |A| \<rbrakk> \<Longrightarrow> |B \<union> A| =o |A|"
101.167 +"\<lbrakk>\<not>finite A; |B| \<le>o |A| \<rbrakk> \<Longrightarrow> |A \<union> B| =o |A|"
101.168 +"\<lbrakk>\<not>finite A; |B| \<le>o |A| \<rbrakk> \<Longrightarrow> |B \<union> A| =o |A|"
101.169 using card_of_Un_infinite by auto
101.170
101.171 +lemma card_of_Un_diff_infinite:
101.172 +assumes INF: "\<not>finite A" and LESS: "|B| <o |A|"
101.173 +shows "|A - B| =o |A|"
101.174 +proof-
101.175 + obtain C where C_def: "C = A - B" by blast
101.176 + have "|A \<union> B| =o |A|"
101.177 + using assms ordLeq_iff_ordLess_or_ordIso card_of_Un_infinite by blast
101.178 + moreover have "C \<union> B = A \<union> B" unfolding C_def by auto
101.179 + ultimately have 1: "|C \<union> B| =o |A|" by auto
101.180 + (* *)
101.181 + {assume *: "|C| \<le>o |B|"
101.182 + moreover
101.183 + {assume **: "finite B"
101.184 + hence "finite C"
101.185 + using card_of_ordLeq_finite * by blast
101.186 + hence False using ** INF card_of_ordIso_finite 1 by blast
101.187 + }
101.188 + hence "\<not>finite B" by auto
101.189 + ultimately have False
101.190 + using card_of_Un_infinite 1 ordIso_equivalence(1,3) LESS not_ordLess_ordIso by metis
101.191 + }
101.192 + hence 2: "|B| \<le>o |C|" using card_of_Well_order ordLeq_total by blast
101.193 + {assume *: "finite C"
101.194 + hence "finite B" using card_of_ordLeq_finite 2 by blast
101.195 + hence False using * INF card_of_ordIso_finite 1 by blast
101.196 + }
101.197 + hence "\<not>finite C" by auto
101.198 + hence "|C| =o |A|"
101.199 + using card_of_Un_infinite 1 2 ordIso_equivalence(1,3) by metis
101.200 + thus ?thesis unfolding C_def .
101.201 +qed
101.202 +
101.203 corollary Card_order_Un_infinite:
101.204 -assumes INF: "infinite(Field r)" and CARD: "Card_order r" and
101.205 +assumes INF: "\<not>finite(Field r)" and CARD: "Card_order r" and
101.206 LEQ: "p \<le>o r"
101.207 shows "| (Field r) \<union> (Field p) | =o r \<and> | (Field p) \<union> (Field r) | =o r"
101.208 proof-
101.209 @@ -521,12 +583,12 @@
101.210 qed
101.211
101.212 corollary subset_ordLeq_diff_infinite:
101.213 -assumes INF: "infinite B" and SUB: "A \<le> B" and LESS: "|A| <o |B|"
101.214 -shows "infinite (B - A)"
101.215 +assumes INF: "\<not>finite B" and SUB: "A \<le> B" and LESS: "|A| <o |B|"
101.216 +shows "\<not>finite (B - A)"
101.217 using assms card_of_Un_diff_infinite card_of_ordIso_finite by blast
101.218
101.219 lemma card_of_Times_ordLess_infinite[simp]:
101.220 -assumes INF: "infinite C" and
101.221 +assumes INF: "\<not>finite C" and
101.222 LESS1: "|A| <o |C|" and LESS2: "|B| <o |C|"
101.223 shows "|A \<times> B| <o |C|"
101.224 proof(cases "A = {} \<or> B = {}")
101.225 @@ -538,17 +600,17 @@
101.226 next
101.227 assume Case2: "\<not>(A = {} \<or> B = {})"
101.228 {assume *: "|C| \<le>o |A \<times> B|"
101.229 - hence "infinite (A \<times> B)" using INF card_of_ordLeq_finite by blast
101.230 - hence 1: "infinite A \<or> infinite B" using finite_cartesian_product by blast
101.231 + hence "\<not>finite (A \<times> B)" using INF card_of_ordLeq_finite by blast
101.232 + hence 1: "\<not>finite A \<or> \<not>finite B" using finite_cartesian_product by blast
101.233 {assume Case21: "|A| \<le>o |B|"
101.234 - hence "infinite B" using 1 card_of_ordLeq_finite by blast
101.235 + hence "\<not>finite B" using 1 card_of_ordLeq_finite by blast
101.236 hence "|A \<times> B| =o |B|" using Case2 Case21
101.237 by (auto simp add: card_of_Times_infinite)
101.238 hence False using LESS2 not_ordLess_ordLeq * ordLeq_ordIso_trans by blast
101.239 }
101.240 moreover
101.241 {assume Case22: "|B| \<le>o |A|"
101.242 - hence "infinite A" using 1 card_of_ordLeq_finite by blast
101.243 + hence "\<not>finite A" using 1 card_of_ordLeq_finite by blast
101.244 hence "|A \<times> B| =o |A|" using Case2 Case22
101.245 by (auto simp add: card_of_Times_infinite)
101.246 hence False using LESS1 not_ordLess_ordLeq * ordLeq_ordIso_trans by blast
101.247 @@ -561,7 +623,7 @@
101.248 qed
101.249
101.250 lemma card_of_Times_ordLess_infinite_Field[simp]:
101.251 -assumes INF: "infinite (Field r)" and r: "Card_order r" and
101.252 +assumes INF: "\<not>finite (Field r)" and r: "Card_order r" and
101.253 LESS1: "|A| <o r" and LESS2: "|B| <o r"
101.254 shows "|A \<times> B| <o r"
101.255 proof-
101.256 @@ -576,14 +638,14 @@
101.257 qed
101.258
101.259 lemma card_of_Un_ordLess_infinite[simp]:
101.260 -assumes INF: "infinite C" and
101.261 +assumes INF: "\<not>finite C" and
101.262 LESS1: "|A| <o |C|" and LESS2: "|B| <o |C|"
101.263 shows "|A \<union> B| <o |C|"
101.264 using assms card_of_Plus_ordLess_infinite card_of_Un_Plus_ordLeq
101.265 ordLeq_ordLess_trans by blast
101.266
101.267 lemma card_of_Un_ordLess_infinite_Field[simp]:
101.268 -assumes INF: "infinite (Field r)" and r: "Card_order r" and
101.269 +assumes INF: "\<not>finite (Field r)" and r: "Card_order r" and
101.270 LESS1: "|A| <o r" and LESS2: "|B| <o r"
101.271 shows "|A Un B| <o r"
101.272 proof-
101.273 @@ -597,8 +659,35 @@
101.274 thus ?thesis using 1 ordLess_ordIso_trans by blast
101.275 qed
101.276
101.277 +
101.278 +subsection {* Cardinals versus set operations involving infinite sets *}
101.279 +
101.280 +lemma finite_iff_cardOf_nat:
101.281 +"finite A = ( |A| <o |UNIV :: nat set| )"
101.282 +using infinite_iff_card_of_nat[of A]
101.283 +not_ordLeq_iff_ordLess[of "|A|" "|UNIV :: nat set|"]
101.284 +by fastforce
101.285 +
101.286 +lemma finite_ordLess_infinite2[simp]:
101.287 +assumes "finite A" and "\<not>finite B"
101.288 +shows "|A| <o |B|"
101.289 +using assms
101.290 +finite_ordLess_infinite[of "|A|" "|B|"]
101.291 +card_of_Well_order[of A] card_of_Well_order[of B]
101.292 +Field_card_of[of A] Field_card_of[of B] by auto
101.293 +
101.294 +lemma infinite_card_of_insert:
101.295 +assumes "\<not>finite A"
101.296 +shows "|insert a A| =o |A|"
101.297 +proof-
101.298 + have iA: "insert a A = A \<union> {a}" by simp
101.299 + show ?thesis
101.300 + using infinite_imp_bij_betw2[OF assms] unfolding iA
101.301 + by (metis bij_betw_inv card_of_ordIso)
101.302 +qed
101.303 +
101.304 lemma card_of_Un_singl_ordLess_infinite1:
101.305 -assumes "infinite B" and "|A| <o |B|"
101.306 +assumes "\<not>finite B" and "|A| <o |B|"
101.307 shows "|{a} Un A| <o |B|"
101.308 proof-
101.309 have "|{a}| <o |B|" using assms by auto
101.310 @@ -606,7 +695,7 @@
101.311 qed
101.312
101.313 lemma card_of_Un_singl_ordLess_infinite:
101.314 -assumes "infinite B"
101.315 +assumes "\<not>finite B"
101.316 shows "( |A| <o |B| ) = ( |{a} Un A| <o |B| )"
101.317 using assms card_of_Un_singl_ordLess_infinite1[of B A]
101.318 proof(auto)
101.319 @@ -616,7 +705,83 @@
101.320 qed
101.321
101.322
101.323 -subsection {* Cardinals versus lists *}
101.324 +subsection {* Cardinals versus lists *}
101.325 +
101.326 +text{* The next is an auxiliary operator, which shall be used for inductive
101.327 +proofs of facts concerning the cardinality of @{text "List"} : *}
101.328 +
101.329 +definition nlists :: "'a set \<Rightarrow> nat \<Rightarrow> 'a list set"
101.330 +where "nlists A n \<equiv> {l. set l \<le> A \<and> length l = n}"
101.331 +
101.332 +lemma lists_def2: "lists A = {l. set l \<le> A}"
101.333 +using in_listsI by blast
101.334 +
101.335 +lemma lists_UNION_nlists: "lists A = (\<Union> n. nlists A n)"
101.336 +unfolding lists_def2 nlists_def by blast
101.337 +
101.338 +lemma card_of_lists: "|A| \<le>o |lists A|"
101.339 +proof-
101.340 + let ?h = "\<lambda> a. [a]"
101.341 + have "inj_on ?h A \<and> ?h ` A \<le> lists A"
101.342 + unfolding inj_on_def lists_def2 by auto
101.343 + thus ?thesis by (metis card_of_ordLeq)
101.344 +qed
101.345 +
101.346 +lemma nlists_0: "nlists A 0 = {[]}"
101.347 +unfolding nlists_def by auto
101.348 +
101.349 +lemma nlists_not_empty:
101.350 +assumes "A \<noteq> {}"
101.351 +shows "nlists A n \<noteq> {}"
101.352 +proof(induct n, simp add: nlists_0)
101.353 + fix n assume "nlists A n \<noteq> {}"
101.354 + then obtain a and l where "a \<in> A \<and> l \<in> nlists A n" using assms by auto
101.355 + hence "a # l \<in> nlists A (Suc n)" unfolding nlists_def by auto
101.356 + thus "nlists A (Suc n) \<noteq> {}" by auto
101.357 +qed
101.358 +
101.359 +lemma Nil_in_lists: "[] \<in> lists A"
101.360 +unfolding lists_def2 by auto
101.361 +
101.362 +lemma lists_not_empty: "lists A \<noteq> {}"
101.363 +using Nil_in_lists by blast
101.364 +
101.365 +lemma card_of_nlists_Succ: "|nlists A (Suc n)| =o |A \<times> (nlists A n)|"
101.366 +proof-
101.367 + let ?B = "A \<times> (nlists A n)" let ?h = "\<lambda>(a,l). a # l"
101.368 + have "inj_on ?h ?B \<and> ?h ` ?B \<le> nlists A (Suc n)"
101.369 + unfolding inj_on_def nlists_def by auto
101.370 + moreover have "nlists A (Suc n) \<le> ?h ` ?B"
101.371 + proof(auto)
101.372 + fix l assume "l \<in> nlists A (Suc n)"
101.373 + hence 1: "length l = Suc n \<and> set l \<le> A" unfolding nlists_def by auto
101.374 + then obtain a and l' where 2: "l = a # l'" by (auto simp: length_Suc_conv)
101.375 + hence "a \<in> A \<and> set l' \<le> A \<and> length l' = n" using 1 by auto
101.376 + thus "l \<in> ?h ` ?B" using 2 unfolding nlists_def by auto
101.377 + qed
101.378 + ultimately have "bij_betw ?h ?B (nlists A (Suc n))"
101.379 + unfolding bij_betw_def by auto
101.380 + thus ?thesis using card_of_ordIso ordIso_symmetric by blast
101.381 +qed
101.382 +
101.383 +lemma card_of_nlists_infinite:
101.384 +assumes "\<not>finite A"
101.385 +shows "|nlists A n| \<le>o |A|"
101.386 +proof(induct n)
101.387 + have "A \<noteq> {}" using assms by auto
101.388 + thus "|nlists A 0| \<le>o |A|" by (simp add: nlists_0)
101.389 +next
101.390 + fix n assume IH: "|nlists A n| \<le>o |A|"
101.391 + have "|nlists A (Suc n)| =o |A \<times> (nlists A n)|"
101.392 + using card_of_nlists_Succ by blast
101.393 + moreover
101.394 + {have "nlists A n \<noteq> {}" using assms nlists_not_empty[of A] by blast
101.395 + hence "|A \<times> (nlists A n)| =o |A|"
101.396 + using assms IH by (auto simp add: card_of_Times_infinite)
101.397 + }
101.398 + ultimately show "|nlists A (Suc n)| \<le>o |A|"
101.399 + using ordIso_transitive ordIso_iff_ordLeq by blast
101.400 +qed
101.401
101.402 lemma Card_order_lists: "Card_order r \<Longrightarrow> r \<le>o |lists(Field r) |"
101.403 using card_of_lists card_of_Field_ordIso ordIso_ordLeq_trans ordIso_symmetric by blast
101.404 @@ -690,18 +855,33 @@
101.405 thus ?thesis using card_of_ordIso[of "lists A"] by auto
101.406 qed
101.407
101.408 +lemma card_of_lists_infinite[simp]:
101.409 +assumes "\<not>finite A"
101.410 +shows "|lists A| =o |A|"
101.411 +proof-
101.412 + have "|lists A| \<le>o |A|" unfolding lists_UNION_nlists
101.413 + by (rule card_of_UNION_ordLeq_infinite[OF assms _ ballI[OF card_of_nlists_infinite[OF assms]]])
101.414 + (metis infinite_iff_card_of_nat assms)
101.415 + thus ?thesis using card_of_lists ordIso_iff_ordLeq by blast
101.416 +qed
101.417 +
101.418 +lemma Card_order_lists_infinite:
101.419 +assumes "Card_order r" and "\<not>finite(Field r)"
101.420 +shows "|lists(Field r)| =o r"
101.421 +using assms card_of_lists_infinite card_of_Field_ordIso ordIso_transitive by blast
101.422 +
101.423 lemma ordIso_lists_cong:
101.424 assumes "r =o r'"
101.425 shows "|lists(Field r)| =o |lists(Field r')|"
101.426 using assms card_of_cong card_of_lists_cong by blast
101.427
101.428 corollary lists_infinite_bij_betw:
101.429 -assumes "infinite A"
101.430 +assumes "\<not>finite A"
101.431 shows "\<exists>f. bij_betw f (lists A) A"
101.432 using assms card_of_lists_infinite card_of_ordIso by blast
101.433
101.434 corollary lists_infinite_bij_betw_types:
101.435 -assumes "infinite(UNIV :: 'a set)"
101.436 +assumes "\<not>finite(UNIV :: 'a set)"
101.437 shows "\<exists>(f::'a list \<Rightarrow> 'a). bij f"
101.438 using assms assms lists_infinite_bij_betw[of "UNIV::'a set"]
101.439 using lists_UNIV by auto
101.440 @@ -809,13 +989,13 @@
101.441 qed
101.442
101.443 lemma card_of_Fpow_infinite[simp]:
101.444 -assumes "infinite A"
101.445 +assumes "\<not>finite A"
101.446 shows "|Fpow A| =o |A|"
101.447 using assms card_of_Fpow_lists card_of_lists_infinite card_of_Fpow
101.448 ordLeq_ordIso_trans ordIso_iff_ordLeq by blast
101.449
101.450 corollary Fpow_infinite_bij_betw:
101.451 -assumes "infinite A"
101.452 +assumes "\<not>finite A"
101.453 shows "\<exists>f. bij_betw f (Fpow A) A"
101.454 using assms card_of_Fpow_infinite card_of_ordIso by blast
101.455
101.456 @@ -827,13 +1007,43 @@
101.457 lemma Field_natLess: "Field natLess = (UNIV::nat set)"
101.458 by(unfold Field_def, auto)
101.459
101.460 +lemma natLeq_well_order_on: "well_order_on UNIV natLeq"
101.461 +using natLeq_Well_order Field_natLeq by auto
101.462 +
101.463 +lemma natLeq_wo_rel: "wo_rel natLeq"
101.464 +unfolding wo_rel_def using natLeq_Well_order .
101.465 +
101.466 lemma natLeq_ofilter_less: "ofilter natLeq {0 ..< n}"
101.467 by(auto simp add: natLeq_wo_rel wo_rel.ofilter_def,
101.468 - simp add: Field_natLeq, unfold rel.under_def, auto)
101.469 + simp add: Field_natLeq, unfold rel.under_def, auto)
101.470
101.471 lemma natLeq_ofilter_leq: "ofilter natLeq {0 .. n}"
101.472 by(auto simp add: natLeq_wo_rel wo_rel.ofilter_def,
101.473 - simp add: Field_natLeq, unfold rel.under_def, auto)
101.474 + simp add: Field_natLeq, unfold rel.under_def, auto)
101.475 +
101.476 +lemma natLeq_UNIV_ofilter: "wo_rel.ofilter natLeq UNIV"
101.477 +using natLeq_wo_rel Field_natLeq wo_rel.Field_ofilter[of natLeq] by auto
101.478 +
101.479 +lemma closed_nat_set_iff:
101.480 +assumes "\<forall>(m::nat) n. n \<in> A \<and> m \<le> n \<longrightarrow> m \<in> A"
101.481 +shows "A = UNIV \<or> (\<exists>n. A = {0 ..< n})"
101.482 +proof-
101.483 + {assume "A \<noteq> UNIV" hence "\<exists>n. n \<notin> A" by blast
101.484 + moreover obtain n where n_def: "n = (LEAST n. n \<notin> A)" by blast
101.485 + ultimately have 1: "n \<notin> A \<and> (\<forall>m. m < n \<longrightarrow> m \<in> A)"
101.486 + using LeastI_ex[of "\<lambda> n. n \<notin> A"] n_def Least_le[of "\<lambda> n. n \<notin> A"] by fastforce
101.487 + have "A = {0 ..< n}"
101.488 + proof(auto simp add: 1)
101.489 + fix m assume *: "m \<in> A"
101.490 + {assume "n \<le> m" with assms * have "n \<in> A" by blast
101.491 + hence False using 1 by auto
101.492 + }
101.493 + thus "m < n" by fastforce
101.494 + qed
101.495 + hence "\<exists>n. A = {0 ..< n}" by blast
101.496 + }
101.497 + thus ?thesis by blast
101.498 +qed
101.499
101.500 lemma natLeq_ofilter_iff:
101.501 "ofilter natLeq A = (A = UNIV \<or> (\<exists>n. A = {0 ..< n}))"
101.502 @@ -851,6 +1061,27 @@
101.503 lemma natLeq_under_leq: "under natLeq n = {0 .. n}"
101.504 unfolding rel.under_def by auto
101.505
101.506 +lemma natLeq_on_ofilter_less_eq:
101.507 +"n \<le> m \<Longrightarrow> wo_rel.ofilter (natLeq_on m) {0 ..< n}"
101.508 +apply (auto simp add: natLeq_on_wo_rel wo_rel.ofilter_def)
101.509 +apply (simp add: Field_natLeq_on)
101.510 +by (auto simp add: rel.under_def)
101.511 +
101.512 +lemma natLeq_on_ofilter_iff:
101.513 +"wo_rel.ofilter (natLeq_on m) A = (\<exists>n \<le> m. A = {0 ..< n})"
101.514 +proof(rule iffI)
101.515 + assume *: "wo_rel.ofilter (natLeq_on m) A"
101.516 + hence 1: "A \<le> {0..<m}"
101.517 + by (auto simp add: natLeq_on_wo_rel wo_rel.ofilter_def rel.under_def Field_natLeq_on)
101.518 + hence "\<forall>n1 n2. n2 \<in> A \<and> n1 \<le> n2 \<longrightarrow> n1 \<in> A"
101.519 + using * by(fastforce simp add: natLeq_on_wo_rel wo_rel.ofilter_def rel.under_def)
101.520 + hence "A = UNIV \<or> (\<exists>n. A = {0 ..< n})" using closed_nat_set_iff by blast
101.521 + thus "\<exists>n \<le> m. A = {0 ..< n}" using 1 atLeastLessThan_less_eq by blast
101.522 +next
101.523 + assume "(\<exists>n\<le>m. A = {0 ..< n})"
101.524 + thus "wo_rel.ofilter (natLeq_on m) A" by (auto simp add: natLeq_on_ofilter_less_eq)
101.525 +qed
101.526 +
101.527 corollary natLeq_on_ofilter:
101.528 "ofilter(natLeq_on n) {0 ..< n}"
101.529 by (auto simp add: natLeq_on_ofilter_less_eq)
101.530 @@ -861,35 +1092,91 @@
101.531 simp add: Field_natLeq_on, unfold rel.under_def, auto)
101.532
101.533 lemma natLeq_on_ordLess_natLeq: "natLeq_on n <o natLeq"
101.534 -using Field_natLeq Field_natLeq_on[of n] nat_infinite
101.535 +using Field_natLeq Field_natLeq_on[of n]
101.536 finite_ordLess_infinite[of "natLeq_on n" natLeq]
101.537 natLeq_Well_order natLeq_on_Well_order[of n] by auto
101.538
101.539 lemma natLeq_on_injective:
101.540 "natLeq_on m = natLeq_on n \<Longrightarrow> m = n"
101.541 using Field_natLeq_on[of m] Field_natLeq_on[of n]
101.542 - atLeastLessThan_injective[of m n] by auto
101.543 + atLeastLessThan_injective[of m n, unfolded atLeastLessThan_def] by blast
101.544
101.545 lemma natLeq_on_injective_ordIso:
101.546 "(natLeq_on m =o natLeq_on n) = (m = n)"
101.547 proof(auto simp add: natLeq_on_Well_order ordIso_reflexive)
101.548 assume "natLeq_on m =o natLeq_on n"
101.549 - then obtain f where "bij_betw f {0..<m} {0..<n}"
101.550 + then obtain f where "bij_betw f {x. x<m} {x. x<n}"
101.551 using Field_natLeq_on assms unfolding ordIso_def iso_def[abs_def] by auto
101.552 - thus "m = n" using atLeastLessThan_injective2 by blast
101.553 + thus "m = n" using atLeastLessThan_injective2[of f m n]
101.554 + unfolding atLeast_0 atLeastLessThan_def lessThan_def Int_UNIV_left by blast
101.555 qed
101.556
101.557
101.558 subsubsection {* Then as cardinals *}
101.559
101.560 lemma ordIso_natLeq_infinite1:
101.561 -"|A| =o natLeq \<Longrightarrow> infinite A"
101.562 +"|A| =o natLeq \<Longrightarrow> \<not>finite A"
101.563 using ordIso_symmetric ordIso_imp_ordLeq infinite_iff_natLeq_ordLeq by blast
101.564
101.565 lemma ordIso_natLeq_infinite2:
101.566 -"natLeq =o |A| \<Longrightarrow> infinite A"
101.567 +"natLeq =o |A| \<Longrightarrow> \<not>finite A"
101.568 using ordIso_imp_ordLeq infinite_iff_natLeq_ordLeq by blast
101.569
101.570 +
101.571 +lemma ordIso_natLeq_on_imp_finite:
101.572 +"|A| =o natLeq_on n \<Longrightarrow> finite A"
101.573 +unfolding ordIso_def iso_def[abs_def]
101.574 +by (auto simp: Field_natLeq_on bij_betw_finite)
101.575 +
101.576 +
101.577 +lemma natLeq_on_Card_order: "Card_order (natLeq_on n)"
101.578 +proof(unfold card_order_on_def,
101.579 + auto simp add: natLeq_on_Well_order, simp add: Field_natLeq_on)
101.580 + fix r assume "well_order_on {x. x < n} r"
101.581 + thus "natLeq_on n \<le>o r"
101.582 + using finite_atLeastLessThan natLeq_on_well_order_on
101.583 + finite_well_order_on_ordIso ordIso_iff_ordLeq by blast
101.584 +qed
101.585 +
101.586 +
101.587 +corollary card_of_Field_natLeq_on:
101.588 +"|Field (natLeq_on n)| =o natLeq_on n"
101.589 +using Field_natLeq_on natLeq_on_Card_order
101.590 + Card_order_iff_ordIso_card_of[of "natLeq_on n"]
101.591 + ordIso_symmetric[of "natLeq_on n"] by blast
101.592 +
101.593 +
101.594 +corollary card_of_less:
101.595 +"|{0 ..< n}| =o natLeq_on n"
101.596 +using Field_natLeq_on card_of_Field_natLeq_on
101.597 +unfolding atLeast_0 atLeastLessThan_def lessThan_def Int_UNIV_left by auto
101.598 +
101.599 +
101.600 +lemma natLeq_on_ordLeq_less_eq:
101.601 +"((natLeq_on m) \<le>o (natLeq_on n)) = (m \<le> n)"
101.602 +proof
101.603 + assume "natLeq_on m \<le>o natLeq_on n"
101.604 + then obtain f where "inj_on f {x. x < m} \<and> f ` {x. x < m} \<le> {x. x < n}"
101.605 + unfolding ordLeq_def using
101.606 + embed_inj_on[OF natLeq_on_Well_order[of m], of "natLeq_on n", unfolded Field_natLeq_on]
101.607 + embed_Field[OF natLeq_on_Well_order[of m], of "natLeq_on n", unfolded Field_natLeq_on] by blast
101.608 + thus "m \<le> n" using atLeastLessThan_less_eq2
101.609 + unfolding atLeast_0 atLeastLessThan_def lessThan_def Int_UNIV_left by blast
101.610 +next
101.611 + assume "m \<le> n"
101.612 + hence "inj_on id {0..<m} \<and> id ` {0..<m} \<le> {0..<n}" unfolding inj_on_def by auto
101.613 + hence "|{0..<m}| \<le>o |{0..<n}|" using card_of_ordLeq by blast
101.614 + thus "natLeq_on m \<le>o natLeq_on n"
101.615 + using card_of_less ordIso_ordLeq_trans ordLeq_ordIso_trans ordIso_symmetric by blast
101.616 +qed
101.617 +
101.618 +
101.619 +lemma natLeq_on_ordLeq_less:
101.620 +"((natLeq_on m) <o (natLeq_on n)) = (m < n)"
101.621 +using not_ordLeq_iff_ordLess[of "natLeq_on m" "natLeq_on n"]
101.622 + natLeq_on_Well_order natLeq_on_ordLeq_less_eq
101.623 +by fastforce
101.624 +
101.625 lemma ordLeq_natLeq_on_imp_finite:
101.626 assumes "|A| \<le>o natLeq_on n"
101.627 shows "finite A"
101.628 @@ -900,7 +1187,27 @@
101.629 qed
101.630
101.631
101.632 -subsubsection {* "Backwards compatibility" with the numeric cardinal operator for finite sets *}
101.633 +subsubsection {* "Backward compatibility" with the numeric cardinal operator for finite sets *}
101.634 +
101.635 +lemma finite_card_of_iff_card2:
101.636 +assumes FIN: "finite A" and FIN': "finite B"
101.637 +shows "( |A| \<le>o |B| ) = (card A \<le> card B)"
101.638 +using assms card_of_ordLeq[of A B] inj_on_iff_card_le[of A B] by blast
101.639 +
101.640 +lemma finite_imp_card_of_natLeq_on:
101.641 +assumes "finite A"
101.642 +shows "|A| =o natLeq_on (card A)"
101.643 +proof-
101.644 + obtain h where "bij_betw h A {0 ..< card A}"
101.645 + using assms ex_bij_betw_finite_nat by blast
101.646 + thus ?thesis using card_of_ordIso card_of_less ordIso_equivalence by blast
101.647 +qed
101.648 +
101.649 +lemma finite_iff_card_of_natLeq_on:
101.650 +"finite A = (\<exists>n. |A| =o natLeq_on n)"
101.651 +using finite_imp_card_of_natLeq_on[of A]
101.652 +by(auto simp add: ordIso_natLeq_on_imp_finite)
101.653 +
101.654
101.655 lemma finite_card_of_iff_card:
101.656 assumes FIN: "finite A" and FIN': "finite B"
101.657 @@ -956,12 +1263,60 @@
101.658 using cardSuc_mono_ordLeq[of r' r] assms by blast
101.659 qed
101.660
101.661 +lemma cardSuc_natLeq_on_Suc:
101.662 +"cardSuc(natLeq_on n) =o natLeq_on(Suc n)"
101.663 +proof-
101.664 + obtain r r' p where r_def: "r = natLeq_on n" and
101.665 + r'_def: "r' = cardSuc(natLeq_on n)" and
101.666 + p_def: "p = natLeq_on(Suc n)" by blast
101.667 + (* Preliminary facts: *)
101.668 + have CARD: "Card_order r \<and> Card_order r' \<and> Card_order p" unfolding r_def r'_def p_def
101.669 + using cardSuc_ordLess_ordLeq natLeq_on_Card_order cardSuc_Card_order by blast
101.670 + hence WELL: "Well_order r \<and> Well_order r' \<and> Well_order p"
101.671 + unfolding card_order_on_def by force
101.672 + have FIELD: "Field r = {0..<n} \<and> Field p = {0..<(Suc n)}"
101.673 + unfolding r_def p_def Field_natLeq_on atLeast_0 atLeastLessThan_def lessThan_def by simp
101.674 + hence FIN: "finite (Field r)" by force
101.675 + have "r <o r'" using CARD unfolding r_def r'_def using cardSuc_greater by blast
101.676 + hence "|Field r| <o r'" using CARD card_of_Field_ordIso ordIso_ordLess_trans by blast
101.677 + hence LESS: "|Field r| <o |Field r'|"
101.678 + using CARD card_of_Field_ordIso ordLess_ordIso_trans ordIso_symmetric by blast
101.679 + (* Main proof: *)
101.680 + have "r' \<le>o p" using CARD unfolding r_def r'_def p_def
101.681 + using natLeq_on_ordLeq_less cardSuc_ordLess_ordLeq by blast
101.682 + moreover have "p \<le>o r'"
101.683 + proof-
101.684 + {assume "r' <o p"
101.685 + then obtain f where 0: "embedS r' p f" unfolding ordLess_def by force
101.686 + let ?q = "Restr p (f ` Field r')"
101.687 + have 1: "embed r' p f" using 0 unfolding embedS_def by force
101.688 + hence 2: "f ` Field r' < {0..<(Suc n)}"
101.689 + using WELL FIELD 0 by (auto simp add: embedS_iff)
101.690 + have "wo_rel.ofilter p (f ` Field r')" using embed_Field_ofilter 1 WELL by blast
101.691 + then obtain m where "m \<le> Suc n" and 3: "f ` (Field r') = {0..<m}"
101.692 + unfolding p_def by (auto simp add: natLeq_on_ofilter_iff)
101.693 + hence 4: "m \<le> n" using 2 by force
101.694 + (* *)
101.695 + have "bij_betw f (Field r') (f ` (Field r'))"
101.696 + using 1 WELL embed_inj_on unfolding bij_betw_def by force
101.697 + moreover have "finite(f ` (Field r'))" using 3 finite_atLeastLessThan[of 0 m] by force
101.698 + ultimately have 5: "finite (Field r') \<and> card(Field r') = card (f ` (Field r'))"
101.699 + using bij_betw_same_card bij_betw_finite by metis
101.700 + hence "card(Field r') \<le> card(Field r)" using 3 4 FIELD by force
101.701 + hence "|Field r'| \<le>o |Field r|" using FIN 5 finite_card_of_iff_card2 by blast
101.702 + hence False using LESS not_ordLess_ordLeq by auto
101.703 + }
101.704 + thus ?thesis using WELL CARD by fastforce
101.705 + qed
101.706 + ultimately show ?thesis using ordIso_iff_ordLeq unfolding r'_def p_def by blast
101.707 +qed
101.708 +
101.709 lemma card_of_Plus_ordLeq_infinite[simp]:
101.710 -assumes C: "infinite C" and A: "|A| \<le>o |C|" and B: "|B| \<le>o |C|"
101.711 +assumes C: "\<not>finite C" and A: "|A| \<le>o |C|" and B: "|B| \<le>o |C|"
101.712 shows "|A <+> B| \<le>o |C|"
101.713 proof-
101.714 let ?r = "cardSuc |C|"
101.715 - have "Card_order ?r \<and> infinite (Field ?r)" using assms by simp
101.716 + have "Card_order ?r \<and> \<not>finite (Field ?r)" using assms by simp
101.717 moreover have "|A| <o ?r" and "|B| <o ?r" using A B by auto
101.718 ultimately have "|A <+> B| <o ?r"
101.719 using card_of_Plus_ordLess_infinite_Field by blast
101.720 @@ -969,7 +1324,7 @@
101.721 qed
101.722
101.723 lemma card_of_Un_ordLeq_infinite[simp]:
101.724 -assumes C: "infinite C" and A: "|A| \<le>o |C|" and B: "|B| \<le>o |C|"
101.725 +assumes C: "\<not>finite C" and A: "|A| \<le>o |C|" and B: "|B| \<le>o |C|"
101.726 shows "|A Un B| \<le>o |C|"
101.727 using assms card_of_Plus_ordLeq_infinite card_of_Un_Plus_ordLeq
101.728 ordLeq_transitive by metis
101.729 @@ -993,8 +1348,13 @@
101.730 shows "relChain r (\<lambda> i. under r i)"
101.731 using assms unfolding relChain_def by auto
101.732
101.733 +lemma card_of_infinite_diff_finite:
101.734 +assumes "\<not>finite A" and "finite B"
101.735 +shows "|A - B| =o |A|"
101.736 +by (metis assms card_of_Un_diff_infinite finite_ordLess_infinite2)
101.737 +
101.738 lemma infinite_card_of_diff_singl:
101.739 -assumes "infinite A"
101.740 +assumes "\<not>finite A"
101.741 shows "|A - {a}| =o |A|"
101.742 by (metis assms card_of_infinite_diff_finite finite.emptyI finite_insert)
101.743
101.744 @@ -1039,8 +1399,8 @@
101.745
101.746 lemma infinite_Bpow:
101.747 assumes rc: "Card_order r" and r: "Field r \<noteq> {}"
101.748 -and A: "infinite A"
101.749 -shows "infinite (Bpow r A)"
101.750 +and A: "\<not>finite A"
101.751 +shows "\<not>finite (Bpow r A)"
101.752 using ordLeq_card_Bpow[OF rc r]
101.753 by (metis A card_of_ordLeq_infinite)
101.754
101.755 @@ -1110,6 +1470,30 @@
101.756 thus "f \<in> Pfunc A B" unfolding Func_option_def Pfunc_def by auto
101.757 qed
101.758
101.759 +lemma card_of_Func_mono:
101.760 +fixes A1 A2 :: "'a set" and B :: "'b set"
101.761 +assumes A12: "A1 \<subseteq> A2" and B: "B \<noteq> {}"
101.762 +shows "|Func A1 B| \<le>o |Func A2 B|"
101.763 +proof-
101.764 + obtain bb where bb: "bb \<in> B" using B by auto
101.765 + def F \<equiv> "\<lambda> (f1::'a \<Rightarrow> 'b) a. if a \<in> A2 then (if a \<in> A1 then f1 a else bb)
101.766 + else undefined"
101.767 + show ?thesis unfolding card_of_ordLeq[symmetric] proof(intro exI[of _ F] conjI)
101.768 + show "inj_on F (Func A1 B)" unfolding inj_on_def proof safe
101.769 + fix f g assume f: "f \<in> Func A1 B" and g: "g \<in> Func A1 B" and eq: "F f = F g"
101.770 + show "f = g"
101.771 + proof(rule ext)
101.772 + fix a show "f a = g a"
101.773 + proof(cases "a \<in> A1")
101.774 + case True
101.775 + thus ?thesis using eq A12 unfolding F_def fun_eq_iff
101.776 + by (elim allE[of _ a]) auto
101.777 + qed(insert f g, unfold Func_def, fastforce)
101.778 + qed
101.779 + qed
101.780 + qed(insert bb, unfold Func_def F_def, force)
101.781 +qed
101.782 +
101.783 lemma card_of_Func_option_mono:
101.784 fixes A1 A2 :: "'a set" and B :: "'b set"
101.785 assumes A12: "A1 \<subseteq> A2" and B: "B \<noteq> {}"
101.786 @@ -1130,7 +1514,7 @@
101.787 qed
101.788
101.789 lemma Bpow_ordLeq_Func_Field:
101.790 -assumes rc: "Card_order r" and r: "Field r \<noteq> {}" and A: "infinite A"
101.791 +assumes rc: "Card_order r" and r: "Field r \<noteq> {}" and A: "\<not>finite A"
101.792 shows "|Bpow r A| \<le>o |Func (Field r) A|"
101.793 proof-
101.794 let ?F = "\<lambda> f. {x | x a. f a = x \<and> a \<in> Field r}"
101.795 @@ -1148,10 +1532,9 @@
101.796 hence "|Bpow r A - {{}}| \<le>o |Func (Field r) A|"
101.797 by (rule surj_imp_ordLeq)
101.798 moreover
101.799 - {have 2: "infinite (Bpow r A)" using infinite_Bpow[OF rc r A] .
101.800 + {have 2: "\<not>finite (Bpow r A)" using infinite_Bpow[OF rc r A] .
101.801 have "|Bpow r A| =o |Bpow r A - {{}}|"
101.802 - using card_of_infinite_diff_finite
101.803 - by (metis Pow_empty 2 finite_Pow_iff infinite_imp_nonempty ordIso_symmetric)
101.804 + by (metis 2 infinite_card_of_diff_singl ordIso_symmetric)
101.805 }
101.806 ultimately show ?thesis by (metis ordIso_ordLeq_trans)
101.807 qed
101.808 @@ -1178,4 +1561,18 @@
101.809 "|Func (UNIV::'a set) (UNIV::'b set)| =o |UNIV::('a \<Rightarrow> 'b) set|"
101.810 using card_of_Func_UNIV[of "UNIV::'b set"] by auto
101.811
101.812 +lemma ordLeq_Func:
101.813 +assumes "{b1,b2} \<subseteq> B" "b1 \<noteq> b2"
101.814 +shows "|A| \<le>o |Func A B|"
101.815 +unfolding card_of_ordLeq[symmetric] proof(intro exI conjI)
101.816 + let ?F = "\<lambda> aa a. if a \<in> A then (if a = aa then b1 else b2) else undefined"
101.817 + show "inj_on ?F A" using assms unfolding inj_on_def fun_eq_iff by auto
101.818 + show "?F ` A \<subseteq> Func A B" using assms unfolding Func_def by auto
101.819 +qed
101.820 +
101.821 +lemma infinite_Func:
101.822 +assumes A: "\<not>finite A" and B: "{b1,b2} \<subseteq> B" "b1 \<noteq> b2"
101.823 +shows "\<not>finite (Func A B)"
101.824 +using ordLeq_Func[OF B] by (metis A card_of_ordLeq_finite)
101.825 +
101.826 end
102.1 --- a/src/HOL/Cardinals/Cardinal_Order_Relation_Base.thy Thu Dec 05 17:52:12 2013 +0100
102.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
102.3 @@ -1,2438 +0,0 @@
102.4 -(* Title: HOL/Cardinals/Cardinal_Order_Relation_Base.thy
102.5 - Author: Andrei Popescu, TU Muenchen
102.6 - Copyright 2012
102.7 -
102.8 -Cardinal-order relations (base).
102.9 -*)
102.10 -
102.11 -header {* Cardinal-Order Relations (Base) *}
102.12 -
102.13 -theory Cardinal_Order_Relation_Base
102.14 -imports Constructions_on_Wellorders_Base
102.15 -begin
102.16 -
102.17 -
102.18 -text{* In this section, we define cardinal-order relations to be minim well-orders
102.19 -on their field. Then we define the cardinal of a set to be {\em some} cardinal-order
102.20 -relation on that set, which will be unique up to order isomorphism. Then we study
102.21 -the connection between cardinals and:
102.22 -\begin{itemize}
102.23 -\item standard set-theoretic constructions: products,
102.24 -sums, unions, lists, powersets, set-of finite sets operator;
102.25 -\item finiteness and infiniteness (in particular, with the numeric cardinal operator
102.26 -for finite sets, @{text "card"}, from the theory @{text "Finite_Sets.thy"}).
102.27 -\end{itemize}
102.28 -%
102.29 -On the way, we define the canonical $\omega$ cardinal and finite cardinals. We also
102.30 -define (again, up to order isomorphism) the successor of a cardinal, and show that
102.31 -any cardinal admits a successor.
102.32 -
102.33 -Main results of this section are the existence of cardinal relations and the
102.34 -facts that, in the presence of infiniteness,
102.35 -most of the standard set-theoretic constructions (except for the powerset)
102.36 -{\em do not increase cardinality}. In particular, e.g., the set of words/lists over
102.37 -any infinite set has the same cardinality (hence, is in bijection) with that set.
102.38 -*}
102.39 -
102.40 -
102.41 -subsection {* Cardinal orders *}
102.42 -
102.43 -
102.44 -text{* A cardinal order in our setting shall be a well-order {\em minim} w.r.t. the
102.45 -order-embedding relation, @{text "\<le>o"} (which is the same as being {\em minimal} w.r.t. the
102.46 -strict order-embedding relation, @{text "<o"}), among all the well-orders on its field. *}
102.47 -
102.48 -definition card_order_on :: "'a set \<Rightarrow> 'a rel \<Rightarrow> bool"
102.49 -where
102.50 -"card_order_on A r \<equiv> well_order_on A r \<and> (\<forall>r'. well_order_on A r' \<longrightarrow> r \<le>o r')"
102.51 -
102.52 -
102.53 -abbreviation "Card_order r \<equiv> card_order_on (Field r) r"
102.54 -abbreviation "card_order r \<equiv> card_order_on UNIV r"
102.55 -
102.56 -
102.57 -lemma card_order_on_well_order_on:
102.58 -assumes "card_order_on A r"
102.59 -shows "well_order_on A r"
102.60 -using assms unfolding card_order_on_def by simp
102.61 -
102.62 -
102.63 -lemma card_order_on_Card_order:
102.64 -"card_order_on A r \<Longrightarrow> A = Field r \<and> Card_order r"
102.65 -unfolding card_order_on_def using rel.well_order_on_Field by blast
102.66 -
102.67 -
102.68 -text{* The existence of a cardinal relation on any given set (which will mean
102.69 -that any set has a cardinal) follows from two facts:
102.70 -\begin{itemize}
102.71 -\item Zermelo's theorem (proved in @{text "Zorn.thy"} as theorem @{text "well_order_on"}),
102.72 -which states that on any given set there exists a well-order;
102.73 -\item The well-founded-ness of @{text "<o"}, ensuring that then there exists a minimal
102.74 -such well-order, i.e., a cardinal order.
102.75 -\end{itemize}
102.76 -*}
102.77 -
102.78 -
102.79 -theorem card_order_on: "\<exists>r. card_order_on A r"
102.80 -proof-
102.81 - obtain R where R_def: "R = {r. well_order_on A r}" by blast
102.82 - have 1: "R \<noteq> {} \<and> (\<forall>r \<in> R. Well_order r)"
102.83 - using well_order_on[of A] R_def rel.well_order_on_Well_order by blast
102.84 - hence "\<exists>r \<in> R. \<forall>r' \<in> R. r \<le>o r'"
102.85 - using exists_minim_Well_order[of R] by auto
102.86 - thus ?thesis using R_def unfolding card_order_on_def by auto
102.87 -qed
102.88 -
102.89 -
102.90 -lemma card_order_on_ordIso:
102.91 -assumes CO: "card_order_on A r" and CO': "card_order_on A r'"
102.92 -shows "r =o r'"
102.93 -using assms unfolding card_order_on_def
102.94 -using ordIso_iff_ordLeq by blast
102.95 -
102.96 -
102.97 -lemma Card_order_ordIso:
102.98 -assumes CO: "Card_order r" and ISO: "r' =o r"
102.99 -shows "Card_order r'"
102.100 -using ISO unfolding ordIso_def
102.101 -proof(unfold card_order_on_def, auto)
102.102 - fix p' assume "well_order_on (Field r') p'"
102.103 - hence 0: "Well_order p' \<and> Field p' = Field r'"
102.104 - using rel.well_order_on_Well_order by blast
102.105 - obtain f where 1: "iso r' r f" and 2: "Well_order r \<and> Well_order r'"
102.106 - using ISO unfolding ordIso_def by auto
102.107 - hence 3: "inj_on f (Field r') \<and> f ` (Field r') = Field r"
102.108 - by (auto simp add: iso_iff embed_inj_on)
102.109 - let ?p = "dir_image p' f"
102.110 - have 4: "p' =o ?p \<and> Well_order ?p"
102.111 - using 0 2 3 by (auto simp add: dir_image_ordIso Well_order_dir_image)
102.112 - moreover have "Field ?p = Field r"
102.113 - using 0 3 by (auto simp add: dir_image_Field2 order_on_defs)
102.114 - ultimately have "well_order_on (Field r) ?p" by auto
102.115 - hence "r \<le>o ?p" using CO unfolding card_order_on_def by auto
102.116 - thus "r' \<le>o p'"
102.117 - using ISO 4 ordLeq_ordIso_trans ordIso_ordLeq_trans ordIso_symmetric by blast
102.118 -qed
102.119 -
102.120 -
102.121 -lemma Card_order_ordIso2:
102.122 -assumes CO: "Card_order r" and ISO: "r =o r'"
102.123 -shows "Card_order r'"
102.124 -using assms Card_order_ordIso ordIso_symmetric by blast
102.125 -
102.126 -
102.127 -subsection {* Cardinal of a set *}
102.128 -
102.129 -
102.130 -text{* We define the cardinal of set to be {\em some} cardinal order on that set.
102.131 -We shall prove that this notion is unique up to order isomorphism, meaning
102.132 -that order isomorphism shall be the true identity of cardinals. *}
102.133 -
102.134 -
102.135 -definition card_of :: "'a set \<Rightarrow> 'a rel" ("|_|" )
102.136 -where "card_of A = (SOME r. card_order_on A r)"
102.137 -
102.138 -
102.139 -lemma card_of_card_order_on: "card_order_on A |A|"
102.140 -unfolding card_of_def by (auto simp add: card_order_on someI_ex)
102.141 -
102.142 -
102.143 -lemma card_of_well_order_on: "well_order_on A |A|"
102.144 -using card_of_card_order_on card_order_on_def by blast
102.145 -
102.146 -
102.147 -lemma Field_card_of: "Field |A| = A"
102.148 -using card_of_card_order_on[of A] unfolding card_order_on_def
102.149 -using rel.well_order_on_Field by blast
102.150 -
102.151 -
102.152 -lemma card_of_Card_order: "Card_order |A|"
102.153 -by (simp only: card_of_card_order_on Field_card_of)
102.154 -
102.155 -
102.156 -corollary ordIso_card_of_imp_Card_order:
102.157 -"r =o |A| \<Longrightarrow> Card_order r"
102.158 -using card_of_Card_order Card_order_ordIso by blast
102.159 -
102.160 -
102.161 -lemma card_of_Well_order: "Well_order |A|"
102.162 -using card_of_Card_order unfolding card_order_on_def by auto
102.163 -
102.164 -
102.165 -lemma card_of_refl: "|A| =o |A|"
102.166 -using card_of_Well_order ordIso_reflexive by blast
102.167 -
102.168 -
102.169 -lemma card_of_least: "well_order_on A r \<Longrightarrow> |A| \<le>o r"
102.170 -using card_of_card_order_on unfolding card_order_on_def by blast
102.171 -
102.172 -
102.173 -lemma card_of_ordIso:
102.174 -"(\<exists>f. bij_betw f A B) = ( |A| =o |B| )"
102.175 -proof(auto)
102.176 - fix f assume *: "bij_betw f A B"
102.177 - then obtain r where "well_order_on B r \<and> |A| =o r"
102.178 - using Well_order_iso_copy card_of_well_order_on by blast
102.179 - hence "|B| \<le>o |A|" using card_of_least
102.180 - ordLeq_ordIso_trans ordIso_symmetric by blast
102.181 - moreover
102.182 - {let ?g = "inv_into A f"
102.183 - have "bij_betw ?g B A" using * bij_betw_inv_into by blast
102.184 - then obtain r where "well_order_on A r \<and> |B| =o r"
102.185 - using Well_order_iso_copy card_of_well_order_on by blast
102.186 - hence "|A| \<le>o |B|" using card_of_least
102.187 - ordLeq_ordIso_trans ordIso_symmetric by blast
102.188 - }
102.189 - ultimately show "|A| =o |B|" using ordIso_iff_ordLeq by blast
102.190 -next
102.191 - assume "|A| =o |B|"
102.192 - then obtain f where "iso ( |A| ) ( |B| ) f"
102.193 - unfolding ordIso_def by auto
102.194 - hence "bij_betw f A B" unfolding iso_def Field_card_of by simp
102.195 - thus "\<exists>f. bij_betw f A B" by auto
102.196 -qed
102.197 -
102.198 -
102.199 -lemma card_of_ordLeq:
102.200 -"(\<exists>f. inj_on f A \<and> f ` A \<le> B) = ( |A| \<le>o |B| )"
102.201 -proof(auto)
102.202 - fix f assume *: "inj_on f A" and **: "f ` A \<le> B"
102.203 - {assume "|B| <o |A|"
102.204 - hence "|B| \<le>o |A|" using ordLeq_iff_ordLess_or_ordIso by blast
102.205 - then obtain g where "embed ( |B| ) ( |A| ) g"
102.206 - unfolding ordLeq_def by auto
102.207 - hence 1: "inj_on g B \<and> g ` B \<le> A" using embed_inj_on[of "|B|" "|A|" "g"]
102.208 - card_of_Well_order[of "B"] Field_card_of[of "B"] Field_card_of[of "A"]
102.209 - embed_Field[of "|B|" "|A|" g] by auto
102.210 - obtain h where "bij_betw h A B"
102.211 - using * ** 1 Cantor_Bernstein[of f] by fastforce
102.212 - hence "|A| =o |B|" using card_of_ordIso by blast
102.213 - hence "|A| \<le>o |B|" using ordIso_iff_ordLeq by auto
102.214 - }
102.215 - thus "|A| \<le>o |B|" using ordLess_or_ordLeq[of "|B|" "|A|"]
102.216 - by (auto simp: card_of_Well_order)
102.217 -next
102.218 - assume *: "|A| \<le>o |B|"
102.219 - obtain f where "embed ( |A| ) ( |B| ) f"
102.220 - using * unfolding ordLeq_def by auto
102.221 - hence "inj_on f A \<and> f ` A \<le> B" using embed_inj_on[of "|A|" "|B|" f]
102.222 - card_of_Well_order[of "A"] Field_card_of[of "A"] Field_card_of[of "B"]
102.223 - embed_Field[of "|A|" "|B|" f] by auto
102.224 - thus "\<exists>f. inj_on f A \<and> f ` A \<le> B" by auto
102.225 -qed
102.226 -
102.227 -
102.228 -lemma card_of_ordLeq2:
102.229 -"A \<noteq> {} \<Longrightarrow> (\<exists>g. g ` B = A) = ( |A| \<le>o |B| )"
102.230 -using card_of_ordLeq[of A B] inj_on_iff_surj[of A B] by auto
102.231 -
102.232 -
102.233 -lemma card_of_ordLess:
102.234 -"(\<not>(\<exists>f. inj_on f A \<and> f ` A \<le> B)) = ( |B| <o |A| )"
102.235 -proof-
102.236 - have "(\<not>(\<exists>f. inj_on f A \<and> f ` A \<le> B)) = (\<not> |A| \<le>o |B| )"
102.237 - using card_of_ordLeq by blast
102.238 - also have "\<dots> = ( |B| <o |A| )"
102.239 - using card_of_Well_order[of A] card_of_Well_order[of B]
102.240 - not_ordLeq_iff_ordLess by blast
102.241 - finally show ?thesis .
102.242 -qed
102.243 -
102.244 -
102.245 -lemma card_of_ordLess2:
102.246 -"B \<noteq> {} \<Longrightarrow> (\<not>(\<exists>f. f ` A = B)) = ( |A| <o |B| )"
102.247 -using card_of_ordLess[of B A] inj_on_iff_surj[of B A] by auto
102.248 -
102.249 -
102.250 -lemma card_of_ordIsoI:
102.251 -assumes "bij_betw f A B"
102.252 -shows "|A| =o |B|"
102.253 -using assms unfolding card_of_ordIso[symmetric] by auto
102.254 -
102.255 -
102.256 -lemma card_of_ordLeqI:
102.257 -assumes "inj_on f A" and "\<And> a. a \<in> A \<Longrightarrow> f a \<in> B"
102.258 -shows "|A| \<le>o |B|"
102.259 -using assms unfolding card_of_ordLeq[symmetric] by auto
102.260 -
102.261 -
102.262 -lemma card_of_unique:
102.263 -"card_order_on A r \<Longrightarrow> r =o |A|"
102.264 -by (simp only: card_order_on_ordIso card_of_card_order_on)
102.265 -
102.266 -
102.267 -lemma card_of_mono1:
102.268 -"A \<le> B \<Longrightarrow> |A| \<le>o |B|"
102.269 -using inj_on_id[of A] card_of_ordLeq[of A B] by fastforce
102.270 -
102.271 -
102.272 -lemma card_of_mono2:
102.273 -assumes "r \<le>o r'"
102.274 -shows "|Field r| \<le>o |Field r'|"
102.275 -proof-
102.276 - obtain f where
102.277 - 1: "well_order_on (Field r) r \<and> well_order_on (Field r) r \<and> embed r r' f"
102.278 - using assms unfolding ordLeq_def
102.279 - by (auto simp add: rel.well_order_on_Well_order)
102.280 - hence "inj_on f (Field r) \<and> f ` (Field r) \<le> Field r'"
102.281 - by (auto simp add: embed_inj_on embed_Field)
102.282 - thus "|Field r| \<le>o |Field r'|" using card_of_ordLeq by blast
102.283 -qed
102.284 -
102.285 -
102.286 -lemma card_of_cong: "r =o r' \<Longrightarrow> |Field r| =o |Field r'|"
102.287 -by (simp add: ordIso_iff_ordLeq card_of_mono2)
102.288 -
102.289 -
102.290 -lemma card_of_Field_ordLess: "Well_order r \<Longrightarrow> |Field r| \<le>o r"
102.291 -using card_of_least card_of_well_order_on rel.well_order_on_Well_order by blast
102.292 -
102.293 -
102.294 -lemma card_of_Field_ordIso:
102.295 -assumes "Card_order r"
102.296 -shows "|Field r| =o r"
102.297 -proof-
102.298 - have "card_order_on (Field r) r"
102.299 - using assms card_order_on_Card_order by blast
102.300 - moreover have "card_order_on (Field r) |Field r|"
102.301 - using card_of_card_order_on by blast
102.302 - ultimately show ?thesis using card_order_on_ordIso by blast
102.303 -qed
102.304 -
102.305 -
102.306 -lemma Card_order_iff_ordIso_card_of:
102.307 -"Card_order r = (r =o |Field r| )"
102.308 -using ordIso_card_of_imp_Card_order card_of_Field_ordIso ordIso_symmetric by blast
102.309 -
102.310 -
102.311 -lemma Card_order_iff_ordLeq_card_of:
102.312 -"Card_order r = (r \<le>o |Field r| )"
102.313 -proof-
102.314 - have "Card_order r = (r =o |Field r| )"
102.315 - unfolding Card_order_iff_ordIso_card_of by simp
102.316 - also have "... = (r \<le>o |Field r| \<and> |Field r| \<le>o r)"
102.317 - unfolding ordIso_iff_ordLeq by simp
102.318 - also have "... = (r \<le>o |Field r| )"
102.319 - using card_of_Field_ordLess
102.320 - by (auto simp: card_of_Field_ordLess ordLeq_Well_order_simp)
102.321 - finally show ?thesis .
102.322 -qed
102.323 -
102.324 -
102.325 -lemma Card_order_iff_Restr_underS:
102.326 -assumes "Well_order r"
102.327 -shows "Card_order r = (\<forall>a \<in> Field r. Restr r (rel.underS r a) <o |Field r| )"
102.328 -using assms unfolding Card_order_iff_ordLeq_card_of
102.329 -using ordLeq_iff_ordLess_Restr card_of_Well_order by blast
102.330 -
102.331 -
102.332 -lemma card_of_underS:
102.333 -assumes r: "Card_order r" and a: "a : Field r"
102.334 -shows "|rel.underS r a| <o r"
102.335 -proof-
102.336 - let ?A = "rel.underS r a" let ?r' = "Restr r ?A"
102.337 - have 1: "Well_order r"
102.338 - using r unfolding card_order_on_def by simp
102.339 - have "Well_order ?r'" using 1 Well_order_Restr by auto
102.340 - moreover have "card_order_on (Field ?r') |Field ?r'|"
102.341 - using card_of_card_order_on .
102.342 - ultimately have "|Field ?r'| \<le>o ?r'"
102.343 - unfolding card_order_on_def by simp
102.344 - moreover have "Field ?r' = ?A"
102.345 - using 1 wo_rel.underS_ofilter Field_Restr_ofilter
102.346 - unfolding wo_rel_def by fastforce
102.347 - ultimately have "|?A| \<le>o ?r'" by simp
102.348 - also have "?r' <o |Field r|"
102.349 - using 1 a r Card_order_iff_Restr_underS by blast
102.350 - also have "|Field r| =o r"
102.351 - using r ordIso_symmetric unfolding Card_order_iff_ordIso_card_of by auto
102.352 - finally show ?thesis .
102.353 -qed
102.354 -
102.355 -
102.356 -lemma ordLess_Field:
102.357 -assumes "r <o r'"
102.358 -shows "|Field r| <o r'"
102.359 -proof-
102.360 - have "well_order_on (Field r) r" using assms unfolding ordLess_def
102.361 - by (auto simp add: rel.well_order_on_Well_order)
102.362 - hence "|Field r| \<le>o r" using card_of_least by blast
102.363 - thus ?thesis using assms ordLeq_ordLess_trans by blast
102.364 -qed
102.365 -
102.366 -
102.367 -lemma internalize_card_of_ordLeq:
102.368 -"( |A| \<le>o r) = (\<exists>B \<le> Field r. |A| =o |B| \<and> |B| \<le>o r)"
102.369 -proof
102.370 - assume "|A| \<le>o r"
102.371 - then obtain p where 1: "Field p \<le> Field r \<and> |A| =o p \<and> p \<le>o r"
102.372 - using internalize_ordLeq[of "|A|" r] by blast
102.373 - hence "Card_order p" using card_of_Card_order Card_order_ordIso2 by blast
102.374 - hence "|Field p| =o p" using card_of_Field_ordIso by blast
102.375 - hence "|A| =o |Field p| \<and> |Field p| \<le>o r"
102.376 - using 1 ordIso_equivalence ordIso_ordLeq_trans by blast
102.377 - thus "\<exists>B \<le> Field r. |A| =o |B| \<and> |B| \<le>o r" using 1 by blast
102.378 -next
102.379 - assume "\<exists>B \<le> Field r. |A| =o |B| \<and> |B| \<le>o r"
102.380 - thus "|A| \<le>o r" using ordIso_ordLeq_trans by blast
102.381 -qed
102.382 -
102.383 -
102.384 -lemma internalize_card_of_ordLeq2:
102.385 -"( |A| \<le>o |C| ) = (\<exists>B \<le> C. |A| =o |B| \<and> |B| \<le>o |C| )"
102.386 -using internalize_card_of_ordLeq[of "A" "|C|"] Field_card_of[of C] by auto
102.387 -
102.388 -
102.389 -
102.390 -subsection {* Cardinals versus set operations on arbitrary sets *}
102.391 -
102.392 -
102.393 -text{* Here we embark in a long journey of simple results showing
102.394 -that the standard set-theoretic operations are well-behaved w.r.t. the notion of
102.395 -cardinal -- essentially, this means that they preserve the ``cardinal identity"
102.396 -@{text "=o"} and are monotonic w.r.t. @{text "\<le>o"}.
102.397 -*}
102.398 -
102.399 -
102.400 -lemma card_of_empty: "|{}| \<le>o |A|"
102.401 -using card_of_ordLeq inj_on_id by blast
102.402 -
102.403 -
102.404 -lemma card_of_empty1:
102.405 -assumes "Well_order r \<or> Card_order r"
102.406 -shows "|{}| \<le>o r"
102.407 -proof-
102.408 - have "Well_order r" using assms unfolding card_order_on_def by auto
102.409 - hence "|Field r| <=o r"
102.410 - using assms card_of_Field_ordLess by blast
102.411 - moreover have "|{}| \<le>o |Field r|" by (simp add: card_of_empty)
102.412 - ultimately show ?thesis using ordLeq_transitive by blast
102.413 -qed
102.414 -
102.415 -
102.416 -corollary Card_order_empty:
102.417 -"Card_order r \<Longrightarrow> |{}| \<le>o r" by (simp add: card_of_empty1)
102.418 -
102.419 -
102.420 -lemma card_of_empty2:
102.421 -assumes LEQ: "|A| =o |{}|"
102.422 -shows "A = {}"
102.423 -using assms card_of_ordIso[of A] bij_betw_empty2 by blast
102.424 -
102.425 -
102.426 -lemma card_of_empty3:
102.427 -assumes LEQ: "|A| \<le>o |{}|"
102.428 -shows "A = {}"
102.429 -using assms
102.430 -by (simp add: ordIso_iff_ordLeq card_of_empty1 card_of_empty2
102.431 - ordLeq_Well_order_simp)
102.432 -
102.433 -
102.434 -lemma card_of_empty_ordIso:
102.435 -"|{}::'a set| =o |{}::'b set|"
102.436 -using card_of_ordIso unfolding bij_betw_def inj_on_def by blast
102.437 -
102.438 -
102.439 -lemma card_of_image:
102.440 -"|f ` A| <=o |A|"
102.441 -proof(cases "A = {}", simp add: card_of_empty)
102.442 - assume "A ~= {}"
102.443 - hence "f ` A ~= {}" by auto
102.444 - thus "|f ` A| \<le>o |A|"
102.445 - using card_of_ordLeq2[of "f ` A" A] by auto
102.446 -qed
102.447 -
102.448 -
102.449 -lemma surj_imp_ordLeq:
102.450 -assumes "B <= f ` A"
102.451 -shows "|B| <=o |A|"
102.452 -proof-
102.453 - have "|B| <=o |f ` A|" using assms card_of_mono1 by auto
102.454 - thus ?thesis using card_of_image ordLeq_transitive by blast
102.455 -qed
102.456 -
102.457 -
102.458 -lemma card_of_ordLeqI2:
102.459 -assumes "B \<subseteq> f ` A"
102.460 -shows "|B| \<le>o |A|"
102.461 -using assms by (metis surj_imp_ordLeq)
102.462 -
102.463 -
102.464 -lemma card_of_singl_ordLeq:
102.465 -assumes "A \<noteq> {}"
102.466 -shows "|{b}| \<le>o |A|"
102.467 -proof-
102.468 - obtain a where *: "a \<in> A" using assms by auto
102.469 - let ?h = "\<lambda> b'::'b. if b' = b then a else undefined"
102.470 - have "inj_on ?h {b} \<and> ?h ` {b} \<le> A"
102.471 - using * unfolding inj_on_def by auto
102.472 - thus ?thesis using card_of_ordLeq by blast
102.473 -qed
102.474 -
102.475 -
102.476 -corollary Card_order_singl_ordLeq:
102.477 -"\<lbrakk>Card_order r; Field r \<noteq> {}\<rbrakk> \<Longrightarrow> |{b}| \<le>o r"
102.478 -using card_of_singl_ordLeq[of "Field r" b]
102.479 - card_of_Field_ordIso[of r] ordLeq_ordIso_trans by blast
102.480 -
102.481 -
102.482 -lemma card_of_Pow: "|A| <o |Pow A|"
102.483 -using card_of_ordLess2[of "Pow A" A] Cantors_paradox[of A]
102.484 - Pow_not_empty[of A] by auto
102.485 -
102.486 -
102.487 -lemma infinite_Pow:
102.488 -assumes "infinite A"
102.489 -shows "infinite (Pow A)"
102.490 -proof-
102.491 - have "|A| \<le>o |Pow A|" by (metis card_of_Pow ordLess_imp_ordLeq)
102.492 - thus ?thesis by (metis assms finite_Pow_iff)
102.493 -qed
102.494 -
102.495 -
102.496 -corollary Card_order_Pow:
102.497 -"Card_order r \<Longrightarrow> r <o |Pow(Field r)|"
102.498 -using card_of_Pow card_of_Field_ordIso ordIso_ordLess_trans ordIso_symmetric by blast
102.499 -
102.500 -
102.501 -corollary card_of_set_type: "|UNIV::'a set| <o |UNIV::'a set set|"
102.502 -using card_of_Pow[of "UNIV::'a set"] by simp
102.503 -
102.504 -
102.505 -lemma card_of_Plus1: "|A| \<le>o |A <+> B|"
102.506 -proof-
102.507 - have "Inl ` A \<le> A <+> B" by auto
102.508 - thus ?thesis using inj_Inl[of A] card_of_ordLeq by blast
102.509 -qed
102.510 -
102.511 -
102.512 -corollary Card_order_Plus1:
102.513 -"Card_order r \<Longrightarrow> r \<le>o |(Field r) <+> B|"
102.514 -using card_of_Plus1 card_of_Field_ordIso ordIso_ordLeq_trans ordIso_symmetric by blast
102.515 -
102.516 -
102.517 -lemma card_of_Plus2: "|B| \<le>o |A <+> B|"
102.518 -proof-
102.519 - have "Inr ` B \<le> A <+> B" by auto
102.520 - thus ?thesis using inj_Inr[of B] card_of_ordLeq by blast
102.521 -qed
102.522 -
102.523 -
102.524 -corollary Card_order_Plus2:
102.525 -"Card_order r \<Longrightarrow> r \<le>o |A <+> (Field r)|"
102.526 -using card_of_Plus2 card_of_Field_ordIso ordIso_ordLeq_trans ordIso_symmetric by blast
102.527 -
102.528 -
102.529 -lemma card_of_Plus_empty1: "|A| =o |A <+> {}|"
102.530 -proof-
102.531 - have "bij_betw Inl A (A <+> {})" unfolding bij_betw_def inj_on_def by auto
102.532 - thus ?thesis using card_of_ordIso by auto
102.533 -qed
102.534 -
102.535 -
102.536 -lemma card_of_Plus_empty2: "|A| =o |{} <+> A|"
102.537 -proof-
102.538 - have "bij_betw Inr A ({} <+> A)" unfolding bij_betw_def inj_on_def by auto
102.539 - thus ?thesis using card_of_ordIso by auto
102.540 -qed
102.541 -
102.542 -
102.543 -lemma card_of_Plus_commute: "|A <+> B| =o |B <+> A|"
102.544 -proof-
102.545 - let ?f = "\<lambda>(c::'a + 'b). case c of Inl a \<Rightarrow> Inr a
102.546 - | Inr b \<Rightarrow> Inl b"
102.547 - have "bij_betw ?f (A <+> B) (B <+> A)"
102.548 - unfolding bij_betw_def inj_on_def by force
102.549 - thus ?thesis using card_of_ordIso by blast
102.550 -qed
102.551 -
102.552 -
102.553 -lemma card_of_Plus_assoc:
102.554 -fixes A :: "'a set" and B :: "'b set" and C :: "'c set"
102.555 -shows "|(A <+> B) <+> C| =o |A <+> B <+> C|"
102.556 -proof -
102.557 - def f \<equiv> "\<lambda>(k::('a + 'b) + 'c).
102.558 - case k of Inl ab \<Rightarrow> (case ab of Inl a \<Rightarrow> Inl a
102.559 - |Inr b \<Rightarrow> Inr (Inl b))
102.560 - |Inr c \<Rightarrow> Inr (Inr c)"
102.561 - have "A <+> B <+> C \<subseteq> f ` ((A <+> B) <+> C)"
102.562 - proof
102.563 - fix x assume x: "x \<in> A <+> B <+> C"
102.564 - show "x \<in> f ` ((A <+> B) <+> C)"
102.565 - proof(cases x)
102.566 - case (Inl a)
102.567 - hence "a \<in> A" "x = f (Inl (Inl a))"
102.568 - using x unfolding f_def by auto
102.569 - thus ?thesis by auto
102.570 - next
102.571 - case (Inr bc) note 1 = Inr show ?thesis
102.572 - proof(cases bc)
102.573 - case (Inl b)
102.574 - hence "b \<in> B" "x = f (Inl (Inr b))"
102.575 - using x 1 unfolding f_def by auto
102.576 - thus ?thesis by auto
102.577 - next
102.578 - case (Inr c)
102.579 - hence "c \<in> C" "x = f (Inr c)"
102.580 - using x 1 unfolding f_def by auto
102.581 - thus ?thesis by auto
102.582 - qed
102.583 - qed
102.584 - qed
102.585 - hence "bij_betw f ((A <+> B) <+> C) (A <+> B <+> C)"
102.586 - unfolding bij_betw_def inj_on_def f_def by force
102.587 - thus ?thesis using card_of_ordIso by blast
102.588 -qed
102.589 -
102.590 -
102.591 -lemma card_of_Plus_mono1:
102.592 -assumes "|A| \<le>o |B|"
102.593 -shows "|A <+> C| \<le>o |B <+> C|"
102.594 -proof-
102.595 - obtain f where 1: "inj_on f A \<and> f ` A \<le> B"
102.596 - using assms card_of_ordLeq[of A] by fastforce
102.597 - obtain g where g_def:
102.598 - "g = (\<lambda>d. case d of Inl a \<Rightarrow> Inl(f a) | Inr (c::'c) \<Rightarrow> Inr c)" by blast
102.599 - have "inj_on g (A <+> C) \<and> g ` (A <+> C) \<le> (B <+> C)"
102.600 - proof-
102.601 - {fix d1 and d2 assume "d1 \<in> A <+> C \<and> d2 \<in> A <+> C" and
102.602 - "g d1 = g d2"
102.603 - hence "d1 = d2" using 1 unfolding inj_on_def
102.604 - by(case_tac d1, case_tac d2, auto simp add: g_def)
102.605 - }
102.606 - moreover
102.607 - {fix d assume "d \<in> A <+> C"
102.608 - hence "g d \<in> B <+> C" using 1
102.609 - by(case_tac d, auto simp add: g_def)
102.610 - }
102.611 - ultimately show ?thesis unfolding inj_on_def by auto
102.612 - qed
102.613 - thus ?thesis using card_of_ordLeq by metis
102.614 -qed
102.615 -
102.616 -
102.617 -corollary ordLeq_Plus_mono1:
102.618 -assumes "r \<le>o r'"
102.619 -shows "|(Field r) <+> C| \<le>o |(Field r') <+> C|"
102.620 -using assms card_of_mono2 card_of_Plus_mono1 by blast
102.621 -
102.622 -
102.623 -lemma card_of_Plus_mono2:
102.624 -assumes "|A| \<le>o |B|"
102.625 -shows "|C <+> A| \<le>o |C <+> B|"
102.626 -using assms card_of_Plus_mono1[of A B C]
102.627 - card_of_Plus_commute[of C A] card_of_Plus_commute[of B C]
102.628 - ordIso_ordLeq_trans[of "|C <+> A|"] ordLeq_ordIso_trans[of "|C <+> A|"]
102.629 -by blast
102.630 -
102.631 -
102.632 -corollary ordLeq_Plus_mono2:
102.633 -assumes "r \<le>o r'"
102.634 -shows "|A <+> (Field r)| \<le>o |A <+> (Field r')|"
102.635 -using assms card_of_mono2 card_of_Plus_mono2 by blast
102.636 -
102.637 -
102.638 -lemma card_of_Plus_mono:
102.639 -assumes "|A| \<le>o |B|" and "|C| \<le>o |D|"
102.640 -shows "|A <+> C| \<le>o |B <+> D|"
102.641 -using assms card_of_Plus_mono1[of A B C] card_of_Plus_mono2[of C D B]
102.642 - ordLeq_transitive[of "|A <+> C|"] by blast
102.643 -
102.644 -
102.645 -corollary ordLeq_Plus_mono:
102.646 -assumes "r \<le>o r'" and "p \<le>o p'"
102.647 -shows "|(Field r) <+> (Field p)| \<le>o |(Field r') <+> (Field p')|"
102.648 -using assms card_of_mono2[of r r'] card_of_mono2[of p p'] card_of_Plus_mono by blast
102.649 -
102.650 -
102.651 -lemma card_of_Plus_cong1:
102.652 -assumes "|A| =o |B|"
102.653 -shows "|A <+> C| =o |B <+> C|"
102.654 -using assms by (simp add: ordIso_iff_ordLeq card_of_Plus_mono1)
102.655 -
102.656 -
102.657 -corollary ordIso_Plus_cong1:
102.658 -assumes "r =o r'"
102.659 -shows "|(Field r) <+> C| =o |(Field r') <+> C|"
102.660 -using assms card_of_cong card_of_Plus_cong1 by blast
102.661 -
102.662 -
102.663 -lemma card_of_Plus_cong2:
102.664 -assumes "|A| =o |B|"
102.665 -shows "|C <+> A| =o |C <+> B|"
102.666 -using assms by (simp add: ordIso_iff_ordLeq card_of_Plus_mono2)
102.667 -
102.668 -
102.669 -corollary ordIso_Plus_cong2:
102.670 -assumes "r =o r'"
102.671 -shows "|A <+> (Field r)| =o |A <+> (Field r')|"
102.672 -using assms card_of_cong card_of_Plus_cong2 by blast
102.673 -
102.674 -
102.675 -lemma card_of_Plus_cong:
102.676 -assumes "|A| =o |B|" and "|C| =o |D|"
102.677 -shows "|A <+> C| =o |B <+> D|"
102.678 -using assms by (simp add: ordIso_iff_ordLeq card_of_Plus_mono)
102.679 -
102.680 -
102.681 -corollary ordIso_Plus_cong:
102.682 -assumes "r =o r'" and "p =o p'"
102.683 -shows "|(Field r) <+> (Field p)| =o |(Field r') <+> (Field p')|"
102.684 -using assms card_of_cong[of r r'] card_of_cong[of p p'] card_of_Plus_cong by blast
102.685 -
102.686 -
102.687 -lemma card_of_Un1:
102.688 -shows "|A| \<le>o |A \<union> B| "
102.689 -using inj_on_id[of A] card_of_ordLeq[of A _] by fastforce
102.690 -
102.691 -
102.692 -lemma card_of_diff:
102.693 -shows "|A - B| \<le>o |A|"
102.694 -using inj_on_id[of "A - B"] card_of_ordLeq[of "A - B" _] by fastforce
102.695 -
102.696 -
102.697 -lemma card_of_Un_Plus_ordLeq:
102.698 -"|A \<union> B| \<le>o |A <+> B|"
102.699 -proof-
102.700 - let ?f = "\<lambda> c. if c \<in> A then Inl c else Inr c"
102.701 - have "inj_on ?f (A \<union> B) \<and> ?f ` (A \<union> B) \<le> A <+> B"
102.702 - unfolding inj_on_def by auto
102.703 - thus ?thesis using card_of_ordLeq by blast
102.704 -qed
102.705 -
102.706 -
102.707 -lemma card_of_Times1:
102.708 -assumes "A \<noteq> {}"
102.709 -shows "|B| \<le>o |B \<times> A|"
102.710 -proof(cases "B = {}", simp add: card_of_empty)
102.711 - assume *: "B \<noteq> {}"
102.712 - have "fst `(B \<times> A) = B" unfolding image_def using assms by auto
102.713 - thus ?thesis using inj_on_iff_surj[of B "B \<times> A"]
102.714 - card_of_ordLeq[of B "B \<times> A"] * by blast
102.715 -qed
102.716 -
102.717 -
102.718 -corollary Card_order_Times1:
102.719 -"\<lbrakk>Card_order r; B \<noteq> {}\<rbrakk> \<Longrightarrow> r \<le>o |(Field r) \<times> B|"
102.720 -using card_of_Times1[of B] card_of_Field_ordIso
102.721 - ordIso_ordLeq_trans ordIso_symmetric by blast
102.722 -
102.723 -
102.724 -lemma card_of_Times_commute: "|A \<times> B| =o |B \<times> A|"
102.725 -proof-
102.726 - let ?f = "\<lambda>(a::'a,b::'b). (b,a)"
102.727 - have "bij_betw ?f (A \<times> B) (B \<times> A)"
102.728 - unfolding bij_betw_def inj_on_def by auto
102.729 - thus ?thesis using card_of_ordIso by blast
102.730 -qed
102.731 -
102.732 -
102.733 -lemma card_of_Times2:
102.734 -assumes "A \<noteq> {}" shows "|B| \<le>o |A \<times> B|"
102.735 -using assms card_of_Times1[of A B] card_of_Times_commute[of B A]
102.736 - ordLeq_ordIso_trans by blast
102.737 -
102.738 -
102.739 -corollary Card_order_Times2:
102.740 -"\<lbrakk>Card_order r; A \<noteq> {}\<rbrakk> \<Longrightarrow> r \<le>o |A \<times> (Field r)|"
102.741 -using card_of_Times2[of A] card_of_Field_ordIso
102.742 - ordIso_ordLeq_trans ordIso_symmetric by blast
102.743 -
102.744 -
102.745 -lemma card_of_Times3: "|A| \<le>o |A \<times> A|"
102.746 -using card_of_Times1[of A]
102.747 -by(cases "A = {}", simp add: card_of_empty, blast)
102.748 -
102.749 -
102.750 -lemma card_of_Plus_Times_bool: "|A <+> A| =o |A \<times> (UNIV::bool set)|"
102.751 -proof-
102.752 - let ?f = "\<lambda>c::'a + 'a. case c of Inl a \<Rightarrow> (a,True)
102.753 - |Inr a \<Rightarrow> (a,False)"
102.754 - have "bij_betw ?f (A <+> A) (A \<times> (UNIV::bool set))"
102.755 - proof-
102.756 - {fix c1 and c2 assume "?f c1 = ?f c2"
102.757 - hence "c1 = c2"
102.758 - by(case_tac "c1", case_tac "c2", auto, case_tac "c2", auto)
102.759 - }
102.760 - moreover
102.761 - {fix c assume "c \<in> A <+> A"
102.762 - hence "?f c \<in> A \<times> (UNIV::bool set)"
102.763 - by(case_tac c, auto)
102.764 - }
102.765 - moreover
102.766 - {fix a bl assume *: "(a,bl) \<in> A \<times> (UNIV::bool set)"
102.767 - have "(a,bl) \<in> ?f ` ( A <+> A)"
102.768 - proof(cases bl)
102.769 - assume bl hence "?f(Inl a) = (a,bl)" by auto
102.770 - thus ?thesis using * by force
102.771 - next
102.772 - assume "\<not> bl" hence "?f(Inr a) = (a,bl)" by auto
102.773 - thus ?thesis using * by force
102.774 - qed
102.775 - }
102.776 - ultimately show ?thesis unfolding bij_betw_def inj_on_def by auto
102.777 - qed
102.778 - thus ?thesis using card_of_ordIso by blast
102.779 -qed
102.780 -
102.781 -
102.782 -lemma card_of_Times_mono1:
102.783 -assumes "|A| \<le>o |B|"
102.784 -shows "|A \<times> C| \<le>o |B \<times> C|"
102.785 -proof-
102.786 - obtain f where 1: "inj_on f A \<and> f ` A \<le> B"
102.787 - using assms card_of_ordLeq[of A] by fastforce
102.788 - obtain g where g_def:
102.789 - "g = (\<lambda>(a,c::'c). (f a,c))" by blast
102.790 - have "inj_on g (A \<times> C) \<and> g ` (A \<times> C) \<le> (B \<times> C)"
102.791 - using 1 unfolding inj_on_def using g_def by auto
102.792 - thus ?thesis using card_of_ordLeq by metis
102.793 -qed
102.794 -
102.795 -
102.796 -corollary ordLeq_Times_mono1:
102.797 -assumes "r \<le>o r'"
102.798 -shows "|(Field r) \<times> C| \<le>o |(Field r') \<times> C|"
102.799 -using assms card_of_mono2 card_of_Times_mono1 by blast
102.800 -
102.801 -
102.802 -lemma card_of_Times_mono2:
102.803 -assumes "|A| \<le>o |B|"
102.804 -shows "|C \<times> A| \<le>o |C \<times> B|"
102.805 -using assms card_of_Times_mono1[of A B C]
102.806 - card_of_Times_commute[of C A] card_of_Times_commute[of B C]
102.807 - ordIso_ordLeq_trans[of "|C \<times> A|"] ordLeq_ordIso_trans[of "|C \<times> A|"]
102.808 -by blast
102.809 -
102.810 -
102.811 -corollary ordLeq_Times_mono2:
102.812 -assumes "r \<le>o r'"
102.813 -shows "|A \<times> (Field r)| \<le>o |A \<times> (Field r')|"
102.814 -using assms card_of_mono2 card_of_Times_mono2 by blast
102.815 -
102.816 -
102.817 -lemma card_of_Times_cong1:
102.818 -assumes "|A| =o |B|"
102.819 -shows "|A \<times> C| =o |B \<times> C|"
102.820 -using assms by (simp add: ordIso_iff_ordLeq card_of_Times_mono1)
102.821 -
102.822 -
102.823 -lemma card_of_Times_cong2:
102.824 -assumes "|A| =o |B|"
102.825 -shows "|C \<times> A| =o |C \<times> B|"
102.826 -using assms by (simp add: ordIso_iff_ordLeq card_of_Times_mono2)
102.827 -
102.828 -
102.829 -corollary ordIso_Times_cong2:
102.830 -assumes "r =o r'"
102.831 -shows "|A \<times> (Field r)| =o |A \<times> (Field r')|"
102.832 -using assms card_of_cong card_of_Times_cong2 by blast
102.833 -
102.834 -
102.835 -lemma card_of_Sigma_mono1:
102.836 -assumes "\<forall>i \<in> I. |A i| \<le>o |B i|"
102.837 -shows "|SIGMA i : I. A i| \<le>o |SIGMA i : I. B i|"
102.838 -proof-
102.839 - have "\<forall>i. i \<in> I \<longrightarrow> (\<exists>f. inj_on f (A i) \<and> f ` (A i) \<le> B i)"
102.840 - using assms by (auto simp add: card_of_ordLeq)
102.841 - with choice[of "\<lambda> i f. i \<in> I \<longrightarrow> inj_on f (A i) \<and> f ` (A i) \<le> B i"]
102.842 - obtain F where 1: "\<forall>i \<in> I. inj_on (F i) (A i) \<and> (F i) ` (A i) \<le> B i" by metis
102.843 - obtain g where g_def: "g = (\<lambda>(i,a::'b). (i,F i a))" by blast
102.844 - have "inj_on g (Sigma I A) \<and> g ` (Sigma I A) \<le> (Sigma I B)"
102.845 - using 1 unfolding inj_on_def using g_def by force
102.846 - thus ?thesis using card_of_ordLeq by metis
102.847 -qed
102.848 -
102.849 -
102.850 -corollary card_of_Sigma_Times:
102.851 -"\<forall>i \<in> I. |A i| \<le>o |B| \<Longrightarrow> |SIGMA i : I. A i| \<le>o |I \<times> B|"
102.852 -using card_of_Sigma_mono1[of I A "\<lambda>i. B"] .
102.853 -
102.854 -
102.855 -lemma card_of_UNION_Sigma:
102.856 -"|\<Union>i \<in> I. A i| \<le>o |SIGMA i : I. A i|"
102.857 -using Ex_inj_on_UNION_Sigma[of I A] card_of_ordLeq by metis
102.858 -
102.859 -
102.860 -lemma card_of_bool:
102.861 -assumes "a1 \<noteq> a2"
102.862 -shows "|UNIV::bool set| =o |{a1,a2}|"
102.863 -proof-
102.864 - let ?f = "\<lambda> bl. case bl of True \<Rightarrow> a1 | False \<Rightarrow> a2"
102.865 - have "bij_betw ?f UNIV {a1,a2}"
102.866 - proof-
102.867 - {fix bl1 and bl2 assume "?f bl1 = ?f bl2"
102.868 - hence "bl1 = bl2" using assms by (case_tac bl1, case_tac bl2, auto)
102.869 - }
102.870 - moreover
102.871 - {fix bl have "?f bl \<in> {a1,a2}" by (case_tac bl, auto)
102.872 - }
102.873 - moreover
102.874 - {fix a assume *: "a \<in> {a1,a2}"
102.875 - have "a \<in> ?f ` UNIV"
102.876 - proof(cases "a = a1")
102.877 - assume "a = a1"
102.878 - hence "?f True = a" by auto thus ?thesis by blast
102.879 - next
102.880 - assume "a \<noteq> a1" hence "a = a2" using * by auto
102.881 - hence "?f False = a" by auto thus ?thesis by blast
102.882 - qed
102.883 - }
102.884 - ultimately show ?thesis unfolding bij_betw_def inj_on_def
102.885 - by (metis image_subsetI order_eq_iff subsetI)
102.886 - qed
102.887 - thus ?thesis using card_of_ordIso by blast
102.888 -qed
102.889 -
102.890 -
102.891 -lemma card_of_Plus_Times_aux:
102.892 -assumes A2: "a1 \<noteq> a2 \<and> {a1,a2} \<le> A" and
102.893 - LEQ: "|A| \<le>o |B|"
102.894 -shows "|A <+> B| \<le>o |A \<times> B|"
102.895 -proof-
102.896 - have 1: "|UNIV::bool set| \<le>o |A|"
102.897 - using A2 card_of_mono1[of "{a1,a2}"] card_of_bool[of a1 a2]
102.898 - ordIso_ordLeq_trans[of "|UNIV::bool set|"] by metis
102.899 - (* *)
102.900 - have "|A <+> B| \<le>o |B <+> B|"
102.901 - using LEQ card_of_Plus_mono1 by blast
102.902 - moreover have "|B <+> B| =o |B \<times> (UNIV::bool set)|"
102.903 - using card_of_Plus_Times_bool by blast
102.904 - moreover have "|B \<times> (UNIV::bool set)| \<le>o |B \<times> A|"
102.905 - using 1 by (simp add: card_of_Times_mono2)
102.906 - moreover have " |B \<times> A| =o |A \<times> B|"
102.907 - using card_of_Times_commute by blast
102.908 - ultimately show "|A <+> B| \<le>o |A \<times> B|"
102.909 - using ordLeq_ordIso_trans[of "|A <+> B|" "|B <+> B|" "|B \<times> (UNIV::bool set)|"]
102.910 - ordLeq_transitive[of "|A <+> B|" "|B \<times> (UNIV::bool set)|" "|B \<times> A|"]
102.911 - ordLeq_ordIso_trans[of "|A <+> B|" "|B \<times> A|" "|A \<times> B|"]
102.912 - by blast
102.913 -qed
102.914 -
102.915 -
102.916 -lemma card_of_Plus_Times:
102.917 -assumes A2: "a1 \<noteq> a2 \<and> {a1,a2} \<le> A" and
102.918 - B2: "b1 \<noteq> b2 \<and> {b1,b2} \<le> B"
102.919 -shows "|A <+> B| \<le>o |A \<times> B|"
102.920 -proof-
102.921 - {assume "|A| \<le>o |B|"
102.922 - hence ?thesis using assms by (auto simp add: card_of_Plus_Times_aux)
102.923 - }
102.924 - moreover
102.925 - {assume "|B| \<le>o |A|"
102.926 - hence "|B <+> A| \<le>o |B \<times> A|"
102.927 - using assms by (auto simp add: card_of_Plus_Times_aux)
102.928 - hence ?thesis
102.929 - using card_of_Plus_commute card_of_Times_commute
102.930 - ordIso_ordLeq_trans ordLeq_ordIso_trans by metis
102.931 - }
102.932 - ultimately show ?thesis
102.933 - using card_of_Well_order[of A] card_of_Well_order[of B]
102.934 - ordLeq_total[of "|A|"] by metis
102.935 -qed
102.936 -
102.937 -
102.938 -lemma card_of_ordLeq_finite:
102.939 -assumes "|A| \<le>o |B|" and "finite B"
102.940 -shows "finite A"
102.941 -using assms unfolding ordLeq_def
102.942 -using embed_inj_on[of "|A|" "|B|"] embed_Field[of "|A|" "|B|"]
102.943 - Field_card_of[of "A"] Field_card_of[of "B"] inj_on_finite[of _ "A" "B"] by fastforce
102.944 -
102.945 -
102.946 -lemma card_of_ordLeq_infinite:
102.947 -assumes "|A| \<le>o |B|" and "infinite A"
102.948 -shows "infinite B"
102.949 -using assms card_of_ordLeq_finite by auto
102.950 -
102.951 -
102.952 -lemma card_of_ordIso_finite:
102.953 -assumes "|A| =o |B|"
102.954 -shows "finite A = finite B"
102.955 -using assms unfolding ordIso_def iso_def[abs_def]
102.956 -by (auto simp: bij_betw_finite Field_card_of)
102.957 -
102.958 -
102.959 -lemma card_of_ordIso_finite_Field:
102.960 -assumes "Card_order r" and "r =o |A|"
102.961 -shows "finite(Field r) = finite A"
102.962 -using assms card_of_Field_ordIso card_of_ordIso_finite ordIso_equivalence by blast
102.963 -
102.964 -
102.965 -subsection {* Cardinals versus set operations involving infinite sets *}
102.966 -
102.967 -
102.968 -text{* Here we show that, for infinite sets, most set-theoretic constructions
102.969 -do not increase the cardinality. The cornerstone for this is
102.970 -theorem @{text "Card_order_Times_same_infinite"}, which states that self-product
102.971 -does not increase cardinality -- the proof of this fact adapts a standard
102.972 -set-theoretic argument, as presented, e.g., in the proof of theorem 1.5.11
102.973 -at page 47 in \cite{card-book}. Then everything else follows fairly easily. *}
102.974 -
102.975 -
102.976 -lemma infinite_iff_card_of_nat:
102.977 -"infinite A = ( |UNIV::nat set| \<le>o |A| )"
102.978 -by (auto simp add: infinite_iff_countable_subset card_of_ordLeq)
102.979 -
102.980 -
102.981 -lemma finite_iff_cardOf_nat:
102.982 -"finite A = ( |A| <o |UNIV :: nat set| )"
102.983 -using infinite_iff_card_of_nat[of A]
102.984 -not_ordLeq_iff_ordLess[of "|A|" "|UNIV :: nat set|"]
102.985 -by (fastforce simp: card_of_Well_order)
102.986 -
102.987 -lemma finite_ordLess_infinite2:
102.988 -assumes "finite A" and "infinite B"
102.989 -shows "|A| <o |B|"
102.990 -using assms
102.991 -finite_ordLess_infinite[of "|A|" "|B|"]
102.992 -card_of_Well_order[of A] card_of_Well_order[of B]
102.993 -Field_card_of[of A] Field_card_of[of B] by auto
102.994 -
102.995 -
102.996 -text{* The next two results correspond to the ZF fact that all infinite cardinals are
102.997 -limit ordinals: *}
102.998 -
102.999 -lemma Card_order_infinite_not_under:
102.1000 -assumes CARD: "Card_order r" and INF: "infinite (Field r)"
102.1001 -shows "\<not> (\<exists>a. Field r = rel.under r a)"
102.1002 -proof(auto)
102.1003 - have 0: "Well_order r \<and> wo_rel r \<and> Refl r"
102.1004 - using CARD unfolding wo_rel_def card_order_on_def order_on_defs by auto
102.1005 - fix a assume *: "Field r = rel.under r a"
102.1006 - show False
102.1007 - proof(cases "a \<in> Field r")
102.1008 - assume Case1: "a \<notin> Field r"
102.1009 - hence "rel.under r a = {}" unfolding Field_def rel.under_def by auto
102.1010 - thus False using INF * by auto
102.1011 - next
102.1012 - let ?r' = "Restr r (rel.underS r a)"
102.1013 - assume Case2: "a \<in> Field r"
102.1014 - hence 1: "rel.under r a = rel.underS r a \<union> {a} \<and> a \<notin> rel.underS r a"
102.1015 - using 0 rel.Refl_under_underS rel.underS_notIn by fastforce
102.1016 - have 2: "wo_rel.ofilter r (rel.underS r a) \<and> rel.underS r a < Field r"
102.1017 - using 0 wo_rel.underS_ofilter * 1 Case2 by auto
102.1018 - hence "?r' <o r" using 0 using ofilter_ordLess by blast
102.1019 - moreover
102.1020 - have "Field ?r' = rel.underS r a \<and> Well_order ?r'"
102.1021 - using 2 0 Field_Restr_ofilter[of r] Well_order_Restr[of r] by blast
102.1022 - ultimately have "|rel.underS r a| <o r" using ordLess_Field[of ?r'] by auto
102.1023 - moreover have "|rel.under r a| =o r" using * CARD card_of_Field_ordIso[of r] by auto
102.1024 - ultimately have "|rel.underS r a| <o |rel.under r a|"
102.1025 - using ordIso_symmetric ordLess_ordIso_trans by blast
102.1026 - moreover
102.1027 - {have "\<exists>f. bij_betw f (rel.under r a) (rel.underS r a)"
102.1028 - using infinite_imp_bij_betw[of "Field r" a] INF * 1 by auto
102.1029 - hence "|rel.under r a| =o |rel.underS r a|" using card_of_ordIso by blast
102.1030 - }
102.1031 - ultimately show False using not_ordLess_ordIso ordIso_symmetric by blast
102.1032 - qed
102.1033 -qed
102.1034 -
102.1035 -
102.1036 -lemma infinite_Card_order_limit:
102.1037 -assumes r: "Card_order r" and "infinite (Field r)"
102.1038 -and a: "a : Field r"
102.1039 -shows "EX b : Field r. a \<noteq> b \<and> (a,b) : r"
102.1040 -proof-
102.1041 - have "Field r \<noteq> rel.under r a"
102.1042 - using assms Card_order_infinite_not_under by blast
102.1043 - moreover have "rel.under r a \<le> Field r"
102.1044 - using rel.under_Field .
102.1045 - ultimately have "rel.under r a < Field r" by blast
102.1046 - then obtain b where 1: "b : Field r \<and> ~ (b,a) : r"
102.1047 - unfolding rel.under_def by blast
102.1048 - moreover have ba: "b \<noteq> a"
102.1049 - using 1 r unfolding card_order_on_def well_order_on_def
102.1050 - linear_order_on_def partial_order_on_def preorder_on_def refl_on_def by auto
102.1051 - ultimately have "(a,b) : r"
102.1052 - using a r unfolding card_order_on_def well_order_on_def linear_order_on_def
102.1053 - total_on_def by blast
102.1054 - thus ?thesis using 1 ba by auto
102.1055 -qed
102.1056 -
102.1057 -
102.1058 -theorem Card_order_Times_same_infinite:
102.1059 -assumes CO: "Card_order r" and INF: "infinite(Field r)"
102.1060 -shows "|Field r \<times> Field r| \<le>o r"
102.1061 -proof-
102.1062 - obtain phi where phi_def:
102.1063 - "phi = (\<lambda>r::'a rel. Card_order r \<and> infinite(Field r) \<and>
102.1064 - \<not> |Field r \<times> Field r| \<le>o r )" by blast
102.1065 - have temp1: "\<forall>r. phi r \<longrightarrow> Well_order r"
102.1066 - unfolding phi_def card_order_on_def by auto
102.1067 - have Ft: "\<not>(\<exists>r. phi r)"
102.1068 - proof
102.1069 - assume "\<exists>r. phi r"
102.1070 - hence "{r. phi r} \<noteq> {} \<and> {r. phi r} \<le> {r. Well_order r}"
102.1071 - using temp1 by auto
102.1072 - then obtain r where 1: "phi r" and 2: "\<forall>r'. phi r' \<longrightarrow> r \<le>o r'" and
102.1073 - 3: "Card_order r \<and> Well_order r"
102.1074 - using exists_minim_Well_order[of "{r. phi r}"] temp1 phi_def by blast
102.1075 - let ?A = "Field r" let ?r' = "bsqr r"
102.1076 - have 4: "Well_order ?r' \<and> Field ?r' = ?A \<times> ?A \<and> |?A| =o r"
102.1077 - using 3 bsqr_Well_order Field_bsqr card_of_Field_ordIso by blast
102.1078 - have 5: "Card_order |?A \<times> ?A| \<and> Well_order |?A \<times> ?A|"
102.1079 - using card_of_Card_order card_of_Well_order by blast
102.1080 - (* *)
102.1081 - have "r <o |?A \<times> ?A|"
102.1082 - using 1 3 5 ordLess_or_ordLeq unfolding phi_def by blast
102.1083 - moreover have "|?A \<times> ?A| \<le>o ?r'"
102.1084 - using card_of_least[of "?A \<times> ?A"] 4 by auto
102.1085 - ultimately have "r <o ?r'" using ordLess_ordLeq_trans by auto
102.1086 - then obtain f where 6: "embed r ?r' f" and 7: "\<not> bij_betw f ?A (?A \<times> ?A)"
102.1087 - unfolding ordLess_def embedS_def[abs_def]
102.1088 - by (auto simp add: Field_bsqr)
102.1089 - let ?B = "f ` ?A"
102.1090 - have "|?A| =o |?B|"
102.1091 - using 3 6 embed_inj_on inj_on_imp_bij_betw card_of_ordIso by blast
102.1092 - hence 8: "r =o |?B|" using 4 ordIso_transitive ordIso_symmetric by blast
102.1093 - (* *)
102.1094 - have "wo_rel.ofilter ?r' ?B"
102.1095 - using 6 embed_Field_ofilter 3 4 by blast
102.1096 - hence "wo_rel.ofilter ?r' ?B \<and> ?B \<noteq> ?A \<times> ?A \<and> ?B \<noteq> Field ?r'"
102.1097 - using 7 unfolding bij_betw_def using 6 3 embed_inj_on 4 by auto
102.1098 - hence temp2: "wo_rel.ofilter ?r' ?B \<and> ?B < ?A \<times> ?A"
102.1099 - using 4 wo_rel_def[of ?r'] wo_rel.ofilter_def[of ?r' ?B] by blast
102.1100 - have "\<not> (\<exists>a. Field r = rel.under r a)"
102.1101 - using 1 unfolding phi_def using Card_order_infinite_not_under[of r] by auto
102.1102 - then obtain A1 where temp3: "wo_rel.ofilter r A1 \<and> A1 < ?A" and 9: "?B \<le> A1 \<times> A1"
102.1103 - using temp2 3 bsqr_ofilter[of r ?B] by blast
102.1104 - hence "|?B| \<le>o |A1 \<times> A1|" using card_of_mono1 by blast
102.1105 - hence 10: "r \<le>o |A1 \<times> A1|" using 8 ordIso_ordLeq_trans by blast
102.1106 - let ?r1 = "Restr r A1"
102.1107 - have "?r1 <o r" using temp3 ofilter_ordLess 3 by blast
102.1108 - moreover
102.1109 - {have "well_order_on A1 ?r1" using 3 temp3 well_order_on_Restr by blast
102.1110 - hence "|A1| \<le>o ?r1" using 3 Well_order_Restr card_of_least by blast
102.1111 - }
102.1112 - ultimately have 11: "|A1| <o r" using ordLeq_ordLess_trans by blast
102.1113 - (* *)
102.1114 - have "infinite (Field r)" using 1 unfolding phi_def by simp
102.1115 - hence "infinite ?B" using 8 3 card_of_ordIso_finite_Field[of r ?B] by blast
102.1116 - hence "infinite A1" using 9 infinite_super finite_cartesian_product by blast
102.1117 - moreover have temp4: "Field |A1| = A1 \<and> Well_order |A1| \<and> Card_order |A1|"
102.1118 - using card_of_Card_order[of A1] card_of_Well_order[of A1]
102.1119 - by (simp add: Field_card_of)
102.1120 - moreover have "\<not> r \<le>o | A1 |"
102.1121 - using temp4 11 3 using not_ordLeq_iff_ordLess by blast
102.1122 - ultimately have "infinite(Field |A1| ) \<and> Card_order |A1| \<and> \<not> r \<le>o | A1 |"
102.1123 - by (simp add: card_of_card_order_on)
102.1124 - hence "|Field |A1| \<times> Field |A1| | \<le>o |A1|"
102.1125 - using 2 unfolding phi_def by blast
102.1126 - hence "|A1 \<times> A1 | \<le>o |A1|" using temp4 by auto
102.1127 - hence "r \<le>o |A1|" using 10 ordLeq_transitive by blast
102.1128 - thus False using 11 not_ordLess_ordLeq by auto
102.1129 - qed
102.1130 - thus ?thesis using assms unfolding phi_def by blast
102.1131 -qed
102.1132 -
102.1133 -
102.1134 -corollary card_of_Times_same_infinite:
102.1135 -assumes "infinite A"
102.1136 -shows "|A \<times> A| =o |A|"
102.1137 -proof-
102.1138 - let ?r = "|A|"
102.1139 - have "Field ?r = A \<and> Card_order ?r"
102.1140 - using Field_card_of card_of_Card_order[of A] by fastforce
102.1141 - hence "|A \<times> A| \<le>o |A|"
102.1142 - using Card_order_Times_same_infinite[of ?r] assms by auto
102.1143 - thus ?thesis using card_of_Times3 ordIso_iff_ordLeq by blast
102.1144 -qed
102.1145 -
102.1146 -
102.1147 -lemma card_of_Times_infinite:
102.1148 -assumes INF: "infinite A" and NE: "B \<noteq> {}" and LEQ: "|B| \<le>o |A|"
102.1149 -shows "|A \<times> B| =o |A| \<and> |B \<times> A| =o |A|"
102.1150 -proof-
102.1151 - have "|A| \<le>o |A \<times> B| \<and> |A| \<le>o |B \<times> A|"
102.1152 - using assms by (simp add: card_of_Times1 card_of_Times2)
102.1153 - moreover
102.1154 - {have "|A \<times> B| \<le>o |A \<times> A| \<and> |B \<times> A| \<le>o |A \<times> A|"
102.1155 - using LEQ card_of_Times_mono1 card_of_Times_mono2 by blast
102.1156 - moreover have "|A \<times> A| =o |A|" using INF card_of_Times_same_infinite by blast
102.1157 - ultimately have "|A \<times> B| \<le>o |A| \<and> |B \<times> A| \<le>o |A|"
102.1158 - using ordLeq_ordIso_trans[of "|A \<times> B|"] ordLeq_ordIso_trans[of "|B \<times> A|"] by auto
102.1159 - }
102.1160 - ultimately show ?thesis by (simp add: ordIso_iff_ordLeq)
102.1161 -qed
102.1162 -
102.1163 -
102.1164 -corollary card_of_Times_infinite_simps:
102.1165 -"\<lbrakk>infinite A; B \<noteq> {}; |B| \<le>o |A|\<rbrakk> \<Longrightarrow> |A \<times> B| =o |A|"
102.1166 -"\<lbrakk>infinite A; B \<noteq> {}; |B| \<le>o |A|\<rbrakk> \<Longrightarrow> |A| =o |A \<times> B|"
102.1167 -"\<lbrakk>infinite A; B \<noteq> {}; |B| \<le>o |A|\<rbrakk> \<Longrightarrow> |B \<times> A| =o |A|"
102.1168 -"\<lbrakk>infinite A; B \<noteq> {}; |B| \<le>o |A|\<rbrakk> \<Longrightarrow> |A| =o |B \<times> A|"
102.1169 -by (auto simp add: card_of_Times_infinite ordIso_symmetric)
102.1170 -
102.1171 -
102.1172 -corollary Card_order_Times_infinite:
102.1173 -assumes INF: "infinite(Field r)" and CARD: "Card_order r" and
102.1174 - NE: "Field p \<noteq> {}" and LEQ: "p \<le>o r"
102.1175 -shows "| (Field r) \<times> (Field p) | =o r \<and> | (Field p) \<times> (Field r) | =o r"
102.1176 -proof-
102.1177 - have "|Field r \<times> Field p| =o |Field r| \<and> |Field p \<times> Field r| =o |Field r|"
102.1178 - using assms by (simp add: card_of_Times_infinite card_of_mono2)
102.1179 - thus ?thesis
102.1180 - using assms card_of_Field_ordIso[of r]
102.1181 - ordIso_transitive[of "|Field r \<times> Field p|"]
102.1182 - ordIso_transitive[of _ "|Field r|"] by blast
102.1183 -qed
102.1184 -
102.1185 -
102.1186 -lemma card_of_Sigma_ordLeq_infinite:
102.1187 -assumes INF: "infinite B" and
102.1188 - LEQ_I: "|I| \<le>o |B|" and LEQ: "\<forall>i \<in> I. |A i| \<le>o |B|"
102.1189 -shows "|SIGMA i : I. A i| \<le>o |B|"
102.1190 -proof(cases "I = {}", simp add: card_of_empty)
102.1191 - assume *: "I \<noteq> {}"
102.1192 - have "|SIGMA i : I. A i| \<le>o |I \<times> B|"
102.1193 - using LEQ card_of_Sigma_Times by blast
102.1194 - moreover have "|I \<times> B| =o |B|"
102.1195 - using INF * LEQ_I by (auto simp add: card_of_Times_infinite)
102.1196 - ultimately show ?thesis using ordLeq_ordIso_trans by blast
102.1197 -qed
102.1198 -
102.1199 -
102.1200 -lemma card_of_Sigma_ordLeq_infinite_Field:
102.1201 -assumes INF: "infinite (Field r)" and r: "Card_order r" and
102.1202 - LEQ_I: "|I| \<le>o r" and LEQ: "\<forall>i \<in> I. |A i| \<le>o r"
102.1203 -shows "|SIGMA i : I. A i| \<le>o r"
102.1204 -proof-
102.1205 - let ?B = "Field r"
102.1206 - have 1: "r =o |?B| \<and> |?B| =o r" using r card_of_Field_ordIso
102.1207 - ordIso_symmetric by blast
102.1208 - hence "|I| \<le>o |?B|" "\<forall>i \<in> I. |A i| \<le>o |?B|"
102.1209 - using LEQ_I LEQ ordLeq_ordIso_trans by blast+
102.1210 - hence "|SIGMA i : I. A i| \<le>o |?B|" using INF LEQ
102.1211 - card_of_Sigma_ordLeq_infinite by blast
102.1212 - thus ?thesis using 1 ordLeq_ordIso_trans by blast
102.1213 -qed
102.1214 -
102.1215 -
102.1216 -lemma card_of_Times_ordLeq_infinite_Field:
102.1217 -"\<lbrakk>infinite (Field r); |A| \<le>o r; |B| \<le>o r; Card_order r\<rbrakk>
102.1218 - \<Longrightarrow> |A <*> B| \<le>o r"
102.1219 -by(simp add: card_of_Sigma_ordLeq_infinite_Field)
102.1220 -
102.1221 -
102.1222 -lemma card_of_UNION_ordLeq_infinite:
102.1223 -assumes INF: "infinite B" and
102.1224 - LEQ_I: "|I| \<le>o |B|" and LEQ: "\<forall>i \<in> I. |A i| \<le>o |B|"
102.1225 -shows "|\<Union> i \<in> I. A i| \<le>o |B|"
102.1226 -proof(cases "I = {}", simp add: card_of_empty)
102.1227 - assume *: "I \<noteq> {}"
102.1228 - have "|\<Union> i \<in> I. A i| \<le>o |SIGMA i : I. A i|"
102.1229 - using card_of_UNION_Sigma by blast
102.1230 - moreover have "|SIGMA i : I. A i| \<le>o |B|"
102.1231 - using assms card_of_Sigma_ordLeq_infinite by blast
102.1232 - ultimately show ?thesis using ordLeq_transitive by blast
102.1233 -qed
102.1234 -
102.1235 -
102.1236 -corollary card_of_UNION_ordLeq_infinite_Field:
102.1237 -assumes INF: "infinite (Field r)" and r: "Card_order r" and
102.1238 - LEQ_I: "|I| \<le>o r" and LEQ: "\<forall>i \<in> I. |A i| \<le>o r"
102.1239 -shows "|\<Union> i \<in> I. A i| \<le>o r"
102.1240 -proof-
102.1241 - let ?B = "Field r"
102.1242 - have 1: "r =o |?B| \<and> |?B| =o r" using r card_of_Field_ordIso
102.1243 - ordIso_symmetric by blast
102.1244 - hence "|I| \<le>o |?B|" "\<forall>i \<in> I. |A i| \<le>o |?B|"
102.1245 - using LEQ_I LEQ ordLeq_ordIso_trans by blast+
102.1246 - hence "|\<Union> i \<in> I. A i| \<le>o |?B|" using INF LEQ
102.1247 - card_of_UNION_ordLeq_infinite by blast
102.1248 - thus ?thesis using 1 ordLeq_ordIso_trans by blast
102.1249 -qed
102.1250 -
102.1251 -
102.1252 -lemma card_of_Plus_infinite1:
102.1253 -assumes INF: "infinite A" and LEQ: "|B| \<le>o |A|"
102.1254 -shows "|A <+> B| =o |A|"
102.1255 -proof(cases "B = {}", simp add: card_of_Plus_empty1 card_of_Plus_empty2 ordIso_symmetric)
102.1256 - let ?Inl = "Inl::'a \<Rightarrow> 'a + 'b" let ?Inr = "Inr::'b \<Rightarrow> 'a + 'b"
102.1257 - assume *: "B \<noteq> {}"
102.1258 - then obtain b1 where 1: "b1 \<in> B" by blast
102.1259 - show ?thesis
102.1260 - proof(cases "B = {b1}")
102.1261 - assume Case1: "B = {b1}"
102.1262 - have 2: "bij_betw ?Inl A ((?Inl ` A))"
102.1263 - unfolding bij_betw_def inj_on_def by auto
102.1264 - hence 3: "infinite (?Inl ` A)"
102.1265 - using INF bij_betw_finite[of ?Inl A] by blast
102.1266 - let ?A' = "?Inl ` A \<union> {?Inr b1}"
102.1267 - obtain g where "bij_betw g (?Inl ` A) ?A'"
102.1268 - using 3 infinite_imp_bij_betw2[of "?Inl ` A"] by auto
102.1269 - moreover have "?A' = A <+> B" using Case1 by blast
102.1270 - ultimately have "bij_betw g (?Inl ` A) (A <+> B)" by simp
102.1271 - hence "bij_betw (g o ?Inl) A (A <+> B)"
102.1272 - using 2 by (auto simp add: bij_betw_trans)
102.1273 - thus ?thesis using card_of_ordIso ordIso_symmetric by blast
102.1274 - next
102.1275 - assume Case2: "B \<noteq> {b1}"
102.1276 - with * 1 obtain b2 where 3: "b1 \<noteq> b2 \<and> {b1,b2} \<le> B" by fastforce
102.1277 - obtain f where "inj_on f B \<and> f ` B \<le> A"
102.1278 - using LEQ card_of_ordLeq[of B] by fastforce
102.1279 - with 3 have "f b1 \<noteq> f b2 \<and> {f b1, f b2} \<le> A"
102.1280 - unfolding inj_on_def by auto
102.1281 - with 3 have "|A <+> B| \<le>o |A \<times> B|"
102.1282 - by (auto simp add: card_of_Plus_Times)
102.1283 - moreover have "|A \<times> B| =o |A|"
102.1284 - using assms * by (simp add: card_of_Times_infinite_simps)
102.1285 - ultimately have "|A <+> B| \<le>o |A|" using ordLeq_ordIso_trans by metis
102.1286 - thus ?thesis using card_of_Plus1 ordIso_iff_ordLeq by blast
102.1287 - qed
102.1288 -qed
102.1289 -
102.1290 -
102.1291 -lemma card_of_Plus_infinite2:
102.1292 -assumes INF: "infinite A" and LEQ: "|B| \<le>o |A|"
102.1293 -shows "|B <+> A| =o |A|"
102.1294 -using assms card_of_Plus_commute card_of_Plus_infinite1
102.1295 -ordIso_equivalence by blast
102.1296 -
102.1297 -
102.1298 -lemma card_of_Plus_infinite:
102.1299 -assumes INF: "infinite A" and LEQ: "|B| \<le>o |A|"
102.1300 -shows "|A <+> B| =o |A| \<and> |B <+> A| =o |A|"
102.1301 -using assms by (auto simp: card_of_Plus_infinite1 card_of_Plus_infinite2)
102.1302 -
102.1303 -
102.1304 -corollary Card_order_Plus_infinite:
102.1305 -assumes INF: "infinite(Field r)" and CARD: "Card_order r" and
102.1306 - LEQ: "p \<le>o r"
102.1307 -shows "| (Field r) <+> (Field p) | =o r \<and> | (Field p) <+> (Field r) | =o r"
102.1308 -proof-
102.1309 - have "| Field r <+> Field p | =o | Field r | \<and>
102.1310 - | Field p <+> Field r | =o | Field r |"
102.1311 - using assms by (simp add: card_of_Plus_infinite card_of_mono2)
102.1312 - thus ?thesis
102.1313 - using assms card_of_Field_ordIso[of r]
102.1314 - ordIso_transitive[of "|Field r <+> Field p|"]
102.1315 - ordIso_transitive[of _ "|Field r|"] by blast
102.1316 -qed
102.1317 -
102.1318 -
102.1319 -lemma card_of_Un_infinite:
102.1320 -assumes INF: "infinite A" and LEQ: "|B| \<le>o |A|"
102.1321 -shows "|A \<union> B| =o |A| \<and> |B \<union> A| =o |A|"
102.1322 -proof-
102.1323 - have "|A \<union> B| \<le>o |A <+> B|" by (rule card_of_Un_Plus_ordLeq)
102.1324 - moreover have "|A <+> B| =o |A|"
102.1325 - using assms by (metis card_of_Plus_infinite)
102.1326 - ultimately have "|A \<union> B| \<le>o |A|" using ordLeq_ordIso_trans by blast
102.1327 - hence "|A \<union> B| =o |A|" using card_of_Un1 ordIso_iff_ordLeq by blast
102.1328 - thus ?thesis using Un_commute[of B A] by auto
102.1329 -qed
102.1330 -
102.1331 -
102.1332 -lemma card_of_Un_diff_infinite:
102.1333 -assumes INF: "infinite A" and LESS: "|B| <o |A|"
102.1334 -shows "|A - B| =o |A|"
102.1335 -proof-
102.1336 - obtain C where C_def: "C = A - B" by blast
102.1337 - have "|A \<union> B| =o |A|"
102.1338 - using assms ordLeq_iff_ordLess_or_ordIso card_of_Un_infinite by blast
102.1339 - moreover have "C \<union> B = A \<union> B" unfolding C_def by auto
102.1340 - ultimately have 1: "|C \<union> B| =o |A|" by auto
102.1341 - (* *)
102.1342 - {assume *: "|C| \<le>o |B|"
102.1343 - moreover
102.1344 - {assume **: "finite B"
102.1345 - hence "finite C"
102.1346 - using card_of_ordLeq_finite * by blast
102.1347 - hence False using ** INF card_of_ordIso_finite 1 by blast
102.1348 - }
102.1349 - hence "infinite B" by auto
102.1350 - ultimately have False
102.1351 - using card_of_Un_infinite 1 ordIso_equivalence(1,3) LESS not_ordLess_ordIso by metis
102.1352 - }
102.1353 - hence 2: "|B| \<le>o |C|" using card_of_Well_order ordLeq_total by blast
102.1354 - {assume *: "finite C"
102.1355 - hence "finite B" using card_of_ordLeq_finite 2 by blast
102.1356 - hence False using * INF card_of_ordIso_finite 1 by blast
102.1357 - }
102.1358 - hence "infinite C" by auto
102.1359 - hence "|C| =o |A|"
102.1360 - using card_of_Un_infinite 1 2 ordIso_equivalence(1,3) by metis
102.1361 - thus ?thesis unfolding C_def .
102.1362 -qed
102.1363 -
102.1364 -
102.1365 -lemma card_of_Plus_ordLess_infinite:
102.1366 -assumes INF: "infinite C" and
102.1367 - LESS1: "|A| <o |C|" and LESS2: "|B| <o |C|"
102.1368 -shows "|A <+> B| <o |C|"
102.1369 -proof(cases "A = {} \<or> B = {}")
102.1370 - assume Case1: "A = {} \<or> B = {}"
102.1371 - hence "|A| =o |A <+> B| \<or> |B| =o |A <+> B|"
102.1372 - using card_of_Plus_empty1 card_of_Plus_empty2 by blast
102.1373 - hence "|A <+> B| =o |A| \<or> |A <+> B| =o |B|"
102.1374 - using ordIso_symmetric[of "|A|"] ordIso_symmetric[of "|B|"] by blast
102.1375 - thus ?thesis using LESS1 LESS2
102.1376 - ordIso_ordLess_trans[of "|A <+> B|" "|A|"]
102.1377 - ordIso_ordLess_trans[of "|A <+> B|" "|B|"] by blast
102.1378 -next
102.1379 - assume Case2: "\<not>(A = {} \<or> B = {})"
102.1380 - {assume *: "|C| \<le>o |A <+> B|"
102.1381 - hence "infinite (A <+> B)" using INF card_of_ordLeq_finite by blast
102.1382 - hence 1: "infinite A \<or> infinite B" using finite_Plus by blast
102.1383 - {assume Case21: "|A| \<le>o |B|"
102.1384 - hence "infinite B" using 1 card_of_ordLeq_finite by blast
102.1385 - hence "|A <+> B| =o |B|" using Case2 Case21
102.1386 - by (auto simp add: card_of_Plus_infinite)
102.1387 - hence False using LESS2 not_ordLess_ordLeq * ordLeq_ordIso_trans by blast
102.1388 - }
102.1389 - moreover
102.1390 - {assume Case22: "|B| \<le>o |A|"
102.1391 - hence "infinite A" using 1 card_of_ordLeq_finite by blast
102.1392 - hence "|A <+> B| =o |A|" using Case2 Case22
102.1393 - by (auto simp add: card_of_Plus_infinite)
102.1394 - hence False using LESS1 not_ordLess_ordLeq * ordLeq_ordIso_trans by blast
102.1395 - }
102.1396 - ultimately have False using ordLeq_total card_of_Well_order[of A]
102.1397 - card_of_Well_order[of B] by blast
102.1398 - }
102.1399 - thus ?thesis using ordLess_or_ordLeq[of "|A <+> B|" "|C|"]
102.1400 - card_of_Well_order[of "A <+> B"] card_of_Well_order[of "C"] by auto
102.1401 -qed
102.1402 -
102.1403 -
102.1404 -lemma card_of_Plus_ordLess_infinite_Field:
102.1405 -assumes INF: "infinite (Field r)" and r: "Card_order r" and
102.1406 - LESS1: "|A| <o r" and LESS2: "|B| <o r"
102.1407 -shows "|A <+> B| <o r"
102.1408 -proof-
102.1409 - let ?C = "Field r"
102.1410 - have 1: "r =o |?C| \<and> |?C| =o r" using r card_of_Field_ordIso
102.1411 - ordIso_symmetric by blast
102.1412 - hence "|A| <o |?C|" "|B| <o |?C|"
102.1413 - using LESS1 LESS2 ordLess_ordIso_trans by blast+
102.1414 - hence "|A <+> B| <o |?C|" using INF
102.1415 - card_of_Plus_ordLess_infinite by blast
102.1416 - thus ?thesis using 1 ordLess_ordIso_trans by blast
102.1417 -qed
102.1418 -
102.1419 -
102.1420 -lemma infinite_card_of_insert:
102.1421 -assumes "infinite A"
102.1422 -shows "|insert a A| =o |A|"
102.1423 -proof-
102.1424 - have iA: "insert a A = A \<union> {a}" by simp
102.1425 - show ?thesis
102.1426 - using infinite_imp_bij_betw2[OF assms] unfolding iA
102.1427 - by (metis bij_betw_inv card_of_ordIso)
102.1428 -qed
102.1429 -
102.1430 -
102.1431 -subsection {* Cardinals versus lists *}
102.1432 -
102.1433 -
102.1434 -text{* The next is an auxiliary operator, which shall be used for inductive
102.1435 -proofs of facts concerning the cardinality of @{text "List"} : *}
102.1436 -
102.1437 -definition nlists :: "'a set \<Rightarrow> nat \<Rightarrow> 'a list set"
102.1438 -where "nlists A n \<equiv> {l. set l \<le> A \<and> length l = n}"
102.1439 -
102.1440 -
102.1441 -lemma lists_def2: "lists A = {l. set l \<le> A}"
102.1442 -using in_listsI by blast
102.1443 -
102.1444 -
102.1445 -lemma lists_UNION_nlists: "lists A = (\<Union> n. nlists A n)"
102.1446 -unfolding lists_def2 nlists_def by blast
102.1447 -
102.1448 -
102.1449 -lemma card_of_lists: "|A| \<le>o |lists A|"
102.1450 -proof-
102.1451 - let ?h = "\<lambda> a. [a]"
102.1452 - have "inj_on ?h A \<and> ?h ` A \<le> lists A"
102.1453 - unfolding inj_on_def lists_def2 by auto
102.1454 - thus ?thesis by (metis card_of_ordLeq)
102.1455 -qed
102.1456 -
102.1457 -
102.1458 -lemma nlists_0: "nlists A 0 = {[]}"
102.1459 -unfolding nlists_def by auto
102.1460 -
102.1461 -
102.1462 -lemma nlists_not_empty:
102.1463 -assumes "A \<noteq> {}"
102.1464 -shows "nlists A n \<noteq> {}"
102.1465 -proof(induct n, simp add: nlists_0)
102.1466 - fix n assume "nlists A n \<noteq> {}"
102.1467 - then obtain a and l where "a \<in> A \<and> l \<in> nlists A n" using assms by auto
102.1468 - hence "a # l \<in> nlists A (Suc n)" unfolding nlists_def by auto
102.1469 - thus "nlists A (Suc n) \<noteq> {}" by auto
102.1470 -qed
102.1471 -
102.1472 -
102.1473 -lemma Nil_in_lists: "[] \<in> lists A"
102.1474 -unfolding lists_def2 by auto
102.1475 -
102.1476 -
102.1477 -lemma lists_not_empty: "lists A \<noteq> {}"
102.1478 -using Nil_in_lists by blast
102.1479 -
102.1480 -
102.1481 -lemma card_of_nlists_Succ: "|nlists A (Suc n)| =o |A \<times> (nlists A n)|"
102.1482 -proof-
102.1483 - let ?B = "A \<times> (nlists A n)" let ?h = "\<lambda>(a,l). a # l"
102.1484 - have "inj_on ?h ?B \<and> ?h ` ?B \<le> nlists A (Suc n)"
102.1485 - unfolding inj_on_def nlists_def by auto
102.1486 - moreover have "nlists A (Suc n) \<le> ?h ` ?B"
102.1487 - proof(auto)
102.1488 - fix l assume "l \<in> nlists A (Suc n)"
102.1489 - hence 1: "length l = Suc n \<and> set l \<le> A" unfolding nlists_def by auto
102.1490 - then obtain a and l' where 2: "l = a # l'" by (auto simp: length_Suc_conv)
102.1491 - hence "a \<in> A \<and> set l' \<le> A \<and> length l' = n" using 1 by auto
102.1492 - thus "l \<in> ?h ` ?B" using 2 unfolding nlists_def by auto
102.1493 - qed
102.1494 - ultimately have "bij_betw ?h ?B (nlists A (Suc n))"
102.1495 - unfolding bij_betw_def by auto
102.1496 - thus ?thesis using card_of_ordIso ordIso_symmetric by blast
102.1497 -qed
102.1498 -
102.1499 -
102.1500 -lemma card_of_nlists_infinite:
102.1501 -assumes "infinite A"
102.1502 -shows "|nlists A n| \<le>o |A|"
102.1503 -proof(induct n)
102.1504 - have "A \<noteq> {}" using assms by auto
102.1505 - thus "|nlists A 0| \<le>o |A|" by (simp add: nlists_0 card_of_singl_ordLeq)
102.1506 -next
102.1507 - fix n assume IH: "|nlists A n| \<le>o |A|"
102.1508 - have "|nlists A (Suc n)| =o |A \<times> (nlists A n)|"
102.1509 - using card_of_nlists_Succ by blast
102.1510 - moreover
102.1511 - {have "nlists A n \<noteq> {}" using assms nlists_not_empty[of A] by blast
102.1512 - hence "|A \<times> (nlists A n)| =o |A|"
102.1513 - using assms IH by (auto simp add: card_of_Times_infinite)
102.1514 - }
102.1515 - ultimately show "|nlists A (Suc n)| \<le>o |A|"
102.1516 - using ordIso_transitive ordIso_iff_ordLeq by blast
102.1517 -qed
102.1518 -
102.1519 -
102.1520 -lemma card_of_lists_infinite:
102.1521 -assumes "infinite A"
102.1522 -shows "|lists A| =o |A|"
102.1523 -proof-
102.1524 - have "|lists A| \<le>o |A|"
102.1525 - using assms
102.1526 - by (auto simp add: lists_UNION_nlists card_of_UNION_ordLeq_infinite
102.1527 - infinite_iff_card_of_nat card_of_nlists_infinite)
102.1528 - thus ?thesis using card_of_lists ordIso_iff_ordLeq by blast
102.1529 -qed
102.1530 -
102.1531 -
102.1532 -lemma Card_order_lists_infinite:
102.1533 -assumes "Card_order r" and "infinite(Field r)"
102.1534 -shows "|lists(Field r)| =o r"
102.1535 -using assms card_of_lists_infinite card_of_Field_ordIso ordIso_transitive by blast
102.1536 -
102.1537 -
102.1538 -
102.1539 -subsection {* The cardinal $\omega$ and the finite cardinals *}
102.1540 -
102.1541 -
102.1542 -text{* The cardinal $\omega$, of natural numbers, shall be the standard non-strict
102.1543 -order relation on
102.1544 -@{text "nat"}, that we abbreviate by @{text "natLeq"}. The finite cardinals
102.1545 -shall be the restrictions of these relations to the numbers smaller than
102.1546 -fixed numbers @{text "n"}, that we abbreviate by @{text "natLeq_on n"}. *}
102.1547 -
102.1548 -abbreviation "(natLeq::(nat * nat) set) \<equiv> {(x,y). x \<le> y}"
102.1549 -abbreviation "(natLess::(nat * nat) set) \<equiv> {(x,y). x < y}"
102.1550 -
102.1551 -abbreviation natLeq_on :: "nat \<Rightarrow> (nat * nat) set"
102.1552 -where "natLeq_on n \<equiv> {(x,y). x < n \<and> y < n \<and> x \<le> y}"
102.1553 -
102.1554 -lemma infinite_cartesian_product:
102.1555 -assumes "infinite A" "infinite B"
102.1556 -shows "infinite (A \<times> B)"
102.1557 -proof
102.1558 - assume "finite (A \<times> B)"
102.1559 - from assms(1) have "A \<noteq> {}" by auto
102.1560 - with `finite (A \<times> B)` have "finite B" using finite_cartesian_productD2 by auto
102.1561 - with assms(2) show False by simp
102.1562 -qed
102.1563 -
102.1564 -
102.1565 -
102.1566 -subsubsection {* First as well-orders *}
102.1567 -
102.1568 -
102.1569 -lemma Field_natLeq: "Field natLeq = (UNIV::nat set)"
102.1570 -by(unfold Field_def, auto)
102.1571 -
102.1572 -
102.1573 -lemma natLeq_Refl: "Refl natLeq"
102.1574 -unfolding refl_on_def Field_def by auto
102.1575 -
102.1576 -
102.1577 -lemma natLeq_trans: "trans natLeq"
102.1578 -unfolding trans_def by auto
102.1579 -
102.1580 -
102.1581 -lemma natLeq_Preorder: "Preorder natLeq"
102.1582 -unfolding preorder_on_def
102.1583 -by (auto simp add: natLeq_Refl natLeq_trans)
102.1584 -
102.1585 -
102.1586 -lemma natLeq_antisym: "antisym natLeq"
102.1587 -unfolding antisym_def by auto
102.1588 -
102.1589 -
102.1590 -lemma natLeq_Partial_order: "Partial_order natLeq"
102.1591 -unfolding partial_order_on_def
102.1592 -by (auto simp add: natLeq_Preorder natLeq_antisym)
102.1593 -
102.1594 -
102.1595 -lemma natLeq_Total: "Total natLeq"
102.1596 -unfolding total_on_def by auto
102.1597 -
102.1598 -
102.1599 -lemma natLeq_Linear_order: "Linear_order natLeq"
102.1600 -unfolding linear_order_on_def
102.1601 -by (auto simp add: natLeq_Partial_order natLeq_Total)
102.1602 -
102.1603 -
102.1604 -lemma natLeq_natLess_Id: "natLess = natLeq - Id"
102.1605 -by auto
102.1606 -
102.1607 -
102.1608 -lemma natLeq_Well_order: "Well_order natLeq"
102.1609 -unfolding well_order_on_def
102.1610 -using natLeq_Linear_order wf_less natLeq_natLess_Id by auto
102.1611 -
102.1612 -
102.1613 -corollary natLeq_well_order_on: "well_order_on UNIV natLeq"
102.1614 -using natLeq_Well_order Field_natLeq by auto
102.1615 -
102.1616 -
102.1617 -lemma natLeq_wo_rel: "wo_rel natLeq"
102.1618 -unfolding wo_rel_def using natLeq_Well_order .
102.1619 -
102.1620 -
102.1621 -lemma natLeq_UNIV_ofilter: "wo_rel.ofilter natLeq UNIV"
102.1622 -using natLeq_wo_rel Field_natLeq wo_rel.Field_ofilter[of natLeq] by auto
102.1623 -
102.1624 -
102.1625 -lemma closed_nat_set_iff:
102.1626 -assumes "\<forall>(m::nat) n. n \<in> A \<and> m \<le> n \<longrightarrow> m \<in> A"
102.1627 -shows "A = UNIV \<or> (\<exists>n. A = {0 ..< n})"
102.1628 -proof-
102.1629 - {assume "A \<noteq> UNIV" hence "\<exists>n. n \<notin> A" by blast
102.1630 - moreover obtain n where n_def: "n = (LEAST n. n \<notin> A)" by blast
102.1631 - ultimately have 1: "n \<notin> A \<and> (\<forall>m. m < n \<longrightarrow> m \<in> A)"
102.1632 - using LeastI_ex[of "\<lambda> n. n \<notin> A"] n_def Least_le[of "\<lambda> n. n \<notin> A"] by fastforce
102.1633 - have "A = {0 ..< n}"
102.1634 - proof(auto simp add: 1)
102.1635 - fix m assume *: "m \<in> A"
102.1636 - {assume "n \<le> m" with assms * have "n \<in> A" by blast
102.1637 - hence False using 1 by auto
102.1638 - }
102.1639 - thus "m < n" by fastforce
102.1640 - qed
102.1641 - hence "\<exists>n. A = {0 ..< n}" by blast
102.1642 - }
102.1643 - thus ?thesis by blast
102.1644 -qed
102.1645 -
102.1646 -
102.1647 -lemma Field_natLeq_on: "Field (natLeq_on n) = {0 ..< n}"
102.1648 -unfolding Field_def by auto
102.1649 -
102.1650 -
102.1651 -lemma natLeq_underS_less: "rel.underS natLeq n = {0 ..< n}"
102.1652 -unfolding rel.underS_def by auto
102.1653 -
102.1654 -
102.1655 -lemma Restr_natLeq: "Restr natLeq {0 ..< n} = natLeq_on n"
102.1656 -by auto
102.1657 -
102.1658 -
102.1659 -lemma Restr_natLeq2:
102.1660 -"Restr natLeq (rel.underS natLeq n) = natLeq_on n"
102.1661 -by (auto simp add: Restr_natLeq natLeq_underS_less)
102.1662 -
102.1663 -
102.1664 -lemma natLeq_on_Well_order: "Well_order(natLeq_on n)"
102.1665 -using Restr_natLeq[of n] natLeq_Well_order
102.1666 - Well_order_Restr[of natLeq "{0..<n}"] by auto
102.1667 -
102.1668 -
102.1669 -corollary natLeq_on_well_order_on: "well_order_on {0 ..< n} (natLeq_on n)"
102.1670 -using natLeq_on_Well_order Field_natLeq_on by auto
102.1671 -
102.1672 -
102.1673 -lemma natLeq_on_wo_rel: "wo_rel(natLeq_on n)"
102.1674 -unfolding wo_rel_def using natLeq_on_Well_order .
102.1675 -
102.1676 -
102.1677 -lemma natLeq_on_ofilter_less_eq:
102.1678 -"n \<le> m \<Longrightarrow> wo_rel.ofilter (natLeq_on m) {0 ..< n}"
102.1679 -by (auto simp add: natLeq_on_wo_rel wo_rel.ofilter_def,
102.1680 - simp add: Field_natLeq_on, unfold rel.under_def, auto)
102.1681 -
102.1682 -
102.1683 -lemma natLeq_on_ofilter_iff:
102.1684 -"wo_rel.ofilter (natLeq_on m) A = (\<exists>n \<le> m. A = {0 ..< n})"
102.1685 -proof(rule iffI)
102.1686 - assume *: "wo_rel.ofilter (natLeq_on m) A"
102.1687 - hence 1: "A \<le> {0..<m}"
102.1688 - by (auto simp add: natLeq_on_wo_rel wo_rel.ofilter_def rel.under_def Field_natLeq_on)
102.1689 - hence "\<forall>n1 n2. n2 \<in> A \<and> n1 \<le> n2 \<longrightarrow> n1 \<in> A"
102.1690 - using * by(fastforce simp add: natLeq_on_wo_rel wo_rel.ofilter_def rel.under_def)
102.1691 - hence "A = UNIV \<or> (\<exists>n. A = {0 ..< n})" using closed_nat_set_iff by blast
102.1692 - thus "\<exists>n \<le> m. A = {0 ..< n}" using 1 atLeastLessThan_less_eq by blast
102.1693 -next
102.1694 - assume "(\<exists>n\<le>m. A = {0 ..< n})"
102.1695 - thus "wo_rel.ofilter (natLeq_on m) A" by (auto simp add: natLeq_on_ofilter_less_eq)
102.1696 -qed
102.1697 -
102.1698 -
102.1699 -
102.1700 -subsubsection {* Then as cardinals *}
102.1701 -
102.1702 -
102.1703 -lemma natLeq_Card_order: "Card_order natLeq"
102.1704 -proof(auto simp add: natLeq_Well_order
102.1705 - Card_order_iff_Restr_underS Restr_natLeq2, simp add: Field_natLeq)
102.1706 - fix n have "finite(Field (natLeq_on n))"
102.1707 - unfolding Field_natLeq_on by auto
102.1708 - moreover have "infinite(UNIV::nat set)" by auto
102.1709 - ultimately show "natLeq_on n <o |UNIV::nat set|"
102.1710 - using finite_ordLess_infinite[of "natLeq_on n" "|UNIV::nat set|"]
102.1711 - Field_card_of[of "UNIV::nat set"]
102.1712 - card_of_Well_order[of "UNIV::nat set"] natLeq_on_Well_order[of n] by auto
102.1713 -qed
102.1714 -
102.1715 -
102.1716 -corollary card_of_Field_natLeq:
102.1717 -"|Field natLeq| =o natLeq"
102.1718 -using Field_natLeq natLeq_Card_order Card_order_iff_ordIso_card_of[of natLeq]
102.1719 - ordIso_symmetric[of natLeq] by blast
102.1720 -
102.1721 -
102.1722 -corollary card_of_nat:
102.1723 -"|UNIV::nat set| =o natLeq"
102.1724 -using Field_natLeq card_of_Field_natLeq by auto
102.1725 -
102.1726 -
102.1727 -corollary infinite_iff_natLeq_ordLeq:
102.1728 -"infinite A = ( natLeq \<le>o |A| )"
102.1729 -using infinite_iff_card_of_nat[of A] card_of_nat
102.1730 - ordIso_ordLeq_trans ordLeq_ordIso_trans ordIso_symmetric by blast
102.1731 -
102.1732 -
102.1733 -corollary finite_iff_ordLess_natLeq:
102.1734 -"finite A = ( |A| <o natLeq)"
102.1735 -using infinite_iff_natLeq_ordLeq not_ordLeq_iff_ordLess
102.1736 - card_of_Well_order natLeq_Well_order by blast
102.1737 -
102.1738 -
102.1739 -lemma ordIso_natLeq_on_imp_finite:
102.1740 -"|A| =o natLeq_on n \<Longrightarrow> finite A"
102.1741 -unfolding ordIso_def iso_def[abs_def]
102.1742 -by (auto simp: Field_natLeq_on bij_betw_finite Field_card_of)
102.1743 -
102.1744 -
102.1745 -lemma natLeq_on_Card_order: "Card_order (natLeq_on n)"
102.1746 -proof(unfold card_order_on_def,
102.1747 - auto simp add: natLeq_on_Well_order, simp add: Field_natLeq_on)
102.1748 - fix r assume "well_order_on {0..<n} r"
102.1749 - thus "natLeq_on n \<le>o r"
102.1750 - using finite_atLeastLessThan natLeq_on_well_order_on
102.1751 - finite_well_order_on_ordIso ordIso_iff_ordLeq by blast
102.1752 -qed
102.1753 -
102.1754 -
102.1755 -corollary card_of_Field_natLeq_on:
102.1756 -"|Field (natLeq_on n)| =o natLeq_on n"
102.1757 -using Field_natLeq_on natLeq_on_Card_order
102.1758 - Card_order_iff_ordIso_card_of[of "natLeq_on n"]
102.1759 - ordIso_symmetric[of "natLeq_on n"] by blast
102.1760 -
102.1761 -
102.1762 -corollary card_of_less:
102.1763 -"|{0 ..< n}| =o natLeq_on n"
102.1764 -using Field_natLeq_on card_of_Field_natLeq_on by auto
102.1765 -
102.1766 -
102.1767 -lemma natLeq_on_ordLeq_less_eq:
102.1768 -"((natLeq_on m) \<le>o (natLeq_on n)) = (m \<le> n)"
102.1769 -proof
102.1770 - assume "natLeq_on m \<le>o natLeq_on n"
102.1771 - then obtain f where "inj_on f {0..<m} \<and> f ` {0..<m} \<le> {0..<n}"
102.1772 - unfolding ordLeq_def using
102.1773 - embed_inj_on[OF natLeq_on_Well_order[of m], of "natLeq_on n", unfolded Field_natLeq_on]
102.1774 - embed_Field[OF natLeq_on_Well_order[of m], of "natLeq_on n", unfolded Field_natLeq_on] by blast
102.1775 - thus "m \<le> n" using atLeastLessThan_less_eq2 by blast
102.1776 -next
102.1777 - assume "m \<le> n"
102.1778 - hence "inj_on id {0..<m} \<and> id ` {0..<m} \<le> {0..<n}" unfolding inj_on_def by auto
102.1779 - hence "|{0..<m}| \<le>o |{0..<n}|" using card_of_ordLeq by blast
102.1780 - thus "natLeq_on m \<le>o natLeq_on n"
102.1781 - using card_of_less ordIso_ordLeq_trans ordLeq_ordIso_trans ordIso_symmetric by blast
102.1782 -qed
102.1783 -
102.1784 -
102.1785 -lemma natLeq_on_ordLeq_less:
102.1786 -"((natLeq_on m) <o (natLeq_on n)) = (m < n)"
102.1787 -using not_ordLeq_iff_ordLess[of "natLeq_on m" "natLeq_on n"]
102.1788 -natLeq_on_Well_order natLeq_on_ordLeq_less_eq by auto
102.1789 -
102.1790 -
102.1791 -
102.1792 -subsubsection {* "Backwards compatibility" with the numeric cardinal operator for finite sets *}
102.1793 -
102.1794 -
102.1795 -lemma finite_card_of_iff_card2:
102.1796 -assumes FIN: "finite A" and FIN': "finite B"
102.1797 -shows "( |A| \<le>o |B| ) = (card A \<le> card B)"
102.1798 -using assms card_of_ordLeq[of A B] inj_on_iff_card_le[of A B] by blast
102.1799 -
102.1800 -
102.1801 -lemma finite_imp_card_of_natLeq_on:
102.1802 -assumes "finite A"
102.1803 -shows "|A| =o natLeq_on (card A)"
102.1804 -proof-
102.1805 - obtain h where "bij_betw h A {0 ..< card A}"
102.1806 - using assms ex_bij_betw_finite_nat by blast
102.1807 - thus ?thesis using card_of_ordIso card_of_less ordIso_equivalence by blast
102.1808 -qed
102.1809 -
102.1810 -
102.1811 -lemma finite_iff_card_of_natLeq_on:
102.1812 -"finite A = (\<exists>n. |A| =o natLeq_on n)"
102.1813 -using finite_imp_card_of_natLeq_on[of A]
102.1814 -by(auto simp add: ordIso_natLeq_on_imp_finite)
102.1815 -
102.1816 -
102.1817 -
102.1818 -subsection {* The successor of a cardinal *}
102.1819 -
102.1820 -
102.1821 -text{* First we define @{text "isCardSuc r r'"}, the notion of @{text "r'"}
102.1822 -being a successor cardinal of @{text "r"}. Although the definition does
102.1823 -not require @{text "r"} to be a cardinal, only this case will be meaningful. *}
102.1824 -
102.1825 -
102.1826 -definition isCardSuc :: "'a rel \<Rightarrow> 'a set rel \<Rightarrow> bool"
102.1827 -where
102.1828 -"isCardSuc r r' \<equiv>
102.1829 - Card_order r' \<and> r <o r' \<and>
102.1830 - (\<forall>(r''::'a set rel). Card_order r'' \<and> r <o r'' \<longrightarrow> r' \<le>o r'')"
102.1831 -
102.1832 -
102.1833 -text{* Now we introduce the cardinal-successor operator @{text "cardSuc"},
102.1834 -by picking {\em some} cardinal-order relation fulfilling @{text "isCardSuc"}.
102.1835 -Again, the picked item shall be proved unique up to order-isomorphism. *}
102.1836 -
102.1837 -
102.1838 -definition cardSuc :: "'a rel \<Rightarrow> 'a set rel"
102.1839 -where
102.1840 -"cardSuc r \<equiv> SOME r'. isCardSuc r r'"
102.1841 -
102.1842 -
102.1843 -lemma exists_minim_Card_order:
102.1844 -"\<lbrakk>R \<noteq> {}; \<forall>r \<in> R. Card_order r\<rbrakk> \<Longrightarrow> \<exists>r \<in> R. \<forall>r' \<in> R. r \<le>o r'"
102.1845 -unfolding card_order_on_def using exists_minim_Well_order by blast
102.1846 -
102.1847 -
102.1848 -lemma exists_isCardSuc:
102.1849 -assumes "Card_order r"
102.1850 -shows "\<exists>r'. isCardSuc r r'"
102.1851 -proof-
102.1852 - let ?R = "{(r'::'a set rel). Card_order r' \<and> r <o r'}"
102.1853 - have "|Pow(Field r)| \<in> ?R \<and> (\<forall>r \<in> ?R. Card_order r)" using assms
102.1854 - by (simp add: card_of_Card_order Card_order_Pow)
102.1855 - then obtain r where "r \<in> ?R \<and> (\<forall>r' \<in> ?R. r \<le>o r')"
102.1856 - using exists_minim_Card_order[of ?R] by blast
102.1857 - thus ?thesis unfolding isCardSuc_def by auto
102.1858 -qed
102.1859 -
102.1860 -
102.1861 -lemma cardSuc_isCardSuc:
102.1862 -assumes "Card_order r"
102.1863 -shows "isCardSuc r (cardSuc r)"
102.1864 -unfolding cardSuc_def using assms
102.1865 -by (simp add: exists_isCardSuc someI_ex)
102.1866 -
102.1867 -
102.1868 -lemma cardSuc_Card_order:
102.1869 -"Card_order r \<Longrightarrow> Card_order(cardSuc r)"
102.1870 -using cardSuc_isCardSuc unfolding isCardSuc_def by blast
102.1871 -
102.1872 -
102.1873 -lemma cardSuc_greater:
102.1874 -"Card_order r \<Longrightarrow> r <o cardSuc r"
102.1875 -using cardSuc_isCardSuc unfolding isCardSuc_def by blast
102.1876 -
102.1877 -
102.1878 -lemma cardSuc_ordLeq:
102.1879 -"Card_order r \<Longrightarrow> r \<le>o cardSuc r"
102.1880 -using cardSuc_greater ordLeq_iff_ordLess_or_ordIso by blast
102.1881 -
102.1882 -
102.1883 -text{* The minimality property of @{text "cardSuc"} originally present in its definition
102.1884 -is local to the type @{text "'a set rel"}, i.e., that of @{text "cardSuc r"}: *}
102.1885 -
102.1886 -lemma cardSuc_least_aux:
102.1887 -"\<lbrakk>Card_order (r::'a rel); Card_order (r'::'a set rel); r <o r'\<rbrakk> \<Longrightarrow> cardSuc r \<le>o r'"
102.1888 -using cardSuc_isCardSuc unfolding isCardSuc_def by blast
102.1889 -
102.1890 -
102.1891 -text{* But from this we can infer general minimality: *}
102.1892 -
102.1893 -lemma cardSuc_least:
102.1894 -assumes CARD: "Card_order r" and CARD': "Card_order r'" and LESS: "r <o r'"
102.1895 -shows "cardSuc r \<le>o r'"
102.1896 -proof-
102.1897 - let ?p = "cardSuc r"
102.1898 - have 0: "Well_order ?p \<and> Well_order r'"
102.1899 - using assms cardSuc_Card_order unfolding card_order_on_def by blast
102.1900 - {assume "r' <o ?p"
102.1901 - then obtain r'' where 1: "Field r'' < Field ?p" and 2: "r' =o r'' \<and> r'' <o ?p"
102.1902 - using internalize_ordLess[of r' ?p] by blast
102.1903 - (* *)
102.1904 - have "Card_order r''" using CARD' Card_order_ordIso2 2 by blast
102.1905 - moreover have "r <o r''" using LESS 2 ordLess_ordIso_trans by blast
102.1906 - ultimately have "?p \<le>o r''" using cardSuc_least_aux CARD by blast
102.1907 - hence False using 2 not_ordLess_ordLeq by blast
102.1908 - }
102.1909 - thus ?thesis using 0 ordLess_or_ordLeq by blast
102.1910 -qed
102.1911 -
102.1912 -
102.1913 -lemma cardSuc_ordLess_ordLeq:
102.1914 -assumes CARD: "Card_order r" and CARD': "Card_order r'"
102.1915 -shows "(r <o r') = (cardSuc r \<le>o r')"
102.1916 -proof(auto simp add: assms cardSuc_least)
102.1917 - assume "cardSuc r \<le>o r'"
102.1918 - thus "r <o r'" using assms cardSuc_greater ordLess_ordLeq_trans by blast
102.1919 -qed
102.1920 -
102.1921 -
102.1922 -lemma cardSuc_ordLeq_ordLess:
102.1923 -assumes CARD: "Card_order r" and CARD': "Card_order r'"
102.1924 -shows "(r' <o cardSuc r) = (r' \<le>o r)"
102.1925 -proof-
102.1926 - have "Well_order r \<and> Well_order r'"
102.1927 - using assms unfolding card_order_on_def by auto
102.1928 - moreover have "Well_order(cardSuc r)"
102.1929 - using assms cardSuc_Card_order card_order_on_def by blast
102.1930 - ultimately show ?thesis
102.1931 - using assms cardSuc_ordLess_ordLeq[of r r']
102.1932 - not_ordLeq_iff_ordLess[of r r'] not_ordLeq_iff_ordLess[of r' "cardSuc r"] by blast
102.1933 -qed
102.1934 -
102.1935 -
102.1936 -lemma cardSuc_mono_ordLeq:
102.1937 -assumes CARD: "Card_order r" and CARD': "Card_order r'"
102.1938 -shows "(cardSuc r \<le>o cardSuc r') = (r \<le>o r')"
102.1939 -using assms cardSuc_ordLeq_ordLess cardSuc_ordLess_ordLeq cardSuc_Card_order by blast
102.1940 -
102.1941 -
102.1942 -lemma cardSuc_invar_ordIso:
102.1943 -assumes CARD: "Card_order r" and CARD': "Card_order r'"
102.1944 -shows "(cardSuc r =o cardSuc r') = (r =o r')"
102.1945 -proof-
102.1946 - have 0: "Well_order r \<and> Well_order r' \<and> Well_order(cardSuc r) \<and> Well_order(cardSuc r')"
102.1947 - using assms by (simp add: card_order_on_well_order_on cardSuc_Card_order)
102.1948 - thus ?thesis
102.1949 - using ordIso_iff_ordLeq[of r r'] ordIso_iff_ordLeq
102.1950 - using cardSuc_mono_ordLeq[of r r'] cardSuc_mono_ordLeq[of r' r] assms by blast
102.1951 -qed
102.1952 -
102.1953 -
102.1954 -lemma cardSuc_natLeq_on_Suc:
102.1955 -"cardSuc(natLeq_on n) =o natLeq_on(Suc n)"
102.1956 -proof-
102.1957 - obtain r r' p where r_def: "r = natLeq_on n" and
102.1958 - r'_def: "r' = cardSuc(natLeq_on n)" and
102.1959 - p_def: "p = natLeq_on(Suc n)" by blast
102.1960 - (* Preliminary facts: *)
102.1961 - have CARD: "Card_order r \<and> Card_order r' \<and> Card_order p" unfolding r_def r'_def p_def
102.1962 - using cardSuc_ordLess_ordLeq natLeq_on_Card_order cardSuc_Card_order by blast
102.1963 - hence WELL: "Well_order r \<and> Well_order r' \<and> Well_order p"
102.1964 - unfolding card_order_on_def by force
102.1965 - have FIELD: "Field r = {0..<n} \<and> Field p = {0..<(Suc n)}"
102.1966 - unfolding r_def p_def Field_natLeq_on by simp
102.1967 - hence FIN: "finite (Field r)" by force
102.1968 - have "r <o r'" using CARD unfolding r_def r'_def using cardSuc_greater by blast
102.1969 - hence "|Field r| <o r'" using CARD card_of_Field_ordIso ordIso_ordLess_trans by blast
102.1970 - hence LESS: "|Field r| <o |Field r'|"
102.1971 - using CARD card_of_Field_ordIso ordLess_ordIso_trans ordIso_symmetric by blast
102.1972 - (* Main proof: *)
102.1973 - have "r' \<le>o p" using CARD unfolding r_def r'_def p_def
102.1974 - using natLeq_on_ordLeq_less cardSuc_ordLess_ordLeq by blast
102.1975 - moreover have "p \<le>o r'"
102.1976 - proof-
102.1977 - {assume "r' <o p"
102.1978 - then obtain f where 0: "embedS r' p f" unfolding ordLess_def by force
102.1979 - let ?q = "Restr p (f ` Field r')"
102.1980 - have 1: "embed r' p f" using 0 unfolding embedS_def by force
102.1981 - hence 2: "f ` Field r' < {0..<(Suc n)}"
102.1982 - using WELL FIELD 0 by (auto simp add: embedS_iff)
102.1983 - have "wo_rel.ofilter p (f ` Field r')" using embed_Field_ofilter 1 WELL by blast
102.1984 - then obtain m where "m \<le> Suc n" and 3: "f ` (Field r') = {0..<m}"
102.1985 - unfolding p_def by (auto simp add: natLeq_on_ofilter_iff)
102.1986 - hence 4: "m \<le> n" using 2 by force
102.1987 - (* *)
102.1988 - have "bij_betw f (Field r') (f ` (Field r'))"
102.1989 - using 1 WELL embed_inj_on unfolding bij_betw_def by force
102.1990 - moreover have "finite(f ` (Field r'))" using 3 finite_atLeastLessThan[of 0 m] by force
102.1991 - ultimately have 5: "finite (Field r') \<and> card(Field r') = card (f ` (Field r'))"
102.1992 - using bij_betw_same_card bij_betw_finite by metis
102.1993 - hence "card(Field r') \<le> card(Field r)" using 3 4 FIELD by force
102.1994 - hence "|Field r'| \<le>o |Field r|" using FIN 5 finite_card_of_iff_card2 by blast
102.1995 - hence False using LESS not_ordLess_ordLeq by auto
102.1996 - }
102.1997 - thus ?thesis using WELL CARD by (fastforce simp: not_ordLess_iff_ordLeq)
102.1998 - qed
102.1999 - ultimately show ?thesis using ordIso_iff_ordLeq unfolding r'_def p_def by blast
102.2000 -qed
102.2001 -
102.2002 -
102.2003 -lemma card_of_cardSuc_finite:
102.2004 -"finite(Field(cardSuc |A| )) = finite A"
102.2005 -proof
102.2006 - assume *: "finite (Field (cardSuc |A| ))"
102.2007 - have 0: "|Field(cardSuc |A| )| =o cardSuc |A|"
102.2008 - using card_of_Card_order cardSuc_Card_order card_of_Field_ordIso by blast
102.2009 - hence "|A| \<le>o |Field(cardSuc |A| )|"
102.2010 - using card_of_Card_order[of A] cardSuc_ordLeq[of "|A|"] ordIso_symmetric
102.2011 - ordLeq_ordIso_trans by blast
102.2012 - thus "finite A" using * card_of_ordLeq_finite by blast
102.2013 -next
102.2014 - assume "finite A"
102.2015 - then obtain n where "|A| =o natLeq_on n" using finite_iff_card_of_natLeq_on by blast
102.2016 - hence "cardSuc |A| =o cardSuc(natLeq_on n)"
102.2017 - using card_of_Card_order cardSuc_invar_ordIso natLeq_on_Card_order by blast
102.2018 - hence "cardSuc |A| =o natLeq_on(Suc n)"
102.2019 - using cardSuc_natLeq_on_Suc ordIso_transitive by blast
102.2020 - hence "cardSuc |A| =o |{0..<(Suc n)}|" using card_of_less ordIso_equivalence by blast
102.2021 - moreover have "|Field (cardSuc |A| ) | =o cardSuc |A|"
102.2022 - using card_of_Field_ordIso cardSuc_Card_order card_of_Card_order by blast
102.2023 - ultimately have "|Field (cardSuc |A| ) | =o |{0..<(Suc n)}|"
102.2024 - using ordIso_equivalence by blast
102.2025 - thus "finite (Field (cardSuc |A| ))"
102.2026 - using card_of_ordIso_finite finite_atLeastLessThan by blast
102.2027 -qed
102.2028 -
102.2029 -
102.2030 -lemma cardSuc_finite:
102.2031 -assumes "Card_order r"
102.2032 -shows "finite (Field (cardSuc r)) = finite (Field r)"
102.2033 -proof-
102.2034 - let ?A = "Field r"
102.2035 - have "|?A| =o r" using assms by (simp add: card_of_Field_ordIso)
102.2036 - hence "cardSuc |?A| =o cardSuc r" using assms
102.2037 - by (simp add: card_of_Card_order cardSuc_invar_ordIso)
102.2038 - moreover have "|Field (cardSuc |?A| ) | =o cardSuc |?A|"
102.2039 - by (simp add: card_of_card_order_on Field_card_of card_of_Field_ordIso cardSuc_Card_order)
102.2040 - moreover
102.2041 - {have "|Field (cardSuc r) | =o cardSuc r"
102.2042 - using assms by (simp add: card_of_Field_ordIso cardSuc_Card_order)
102.2043 - hence "cardSuc r =o |Field (cardSuc r) |"
102.2044 - using ordIso_symmetric by blast
102.2045 - }
102.2046 - ultimately have "|Field (cardSuc |?A| ) | =o |Field (cardSuc r) |"
102.2047 - using ordIso_transitive by blast
102.2048 - hence "finite (Field (cardSuc |?A| )) = finite (Field (cardSuc r))"
102.2049 - using card_of_ordIso_finite by blast
102.2050 - thus ?thesis by (simp only: card_of_cardSuc_finite)
102.2051 -qed
102.2052 -
102.2053 -
102.2054 -lemma card_of_Plus_ordLeq_infinite_Field:
102.2055 -assumes r: "infinite (Field r)" and A: "|A| \<le>o r" and B: "|B| \<le>o r"
102.2056 -and c: "Card_order r"
102.2057 -shows "|A <+> B| \<le>o r"
102.2058 -proof-
102.2059 - let ?r' = "cardSuc r"
102.2060 - have "Card_order ?r' \<and> infinite (Field ?r')" using assms
102.2061 - by (simp add: cardSuc_Card_order cardSuc_finite)
102.2062 - moreover have "|A| <o ?r'" and "|B| <o ?r'" using A B c
102.2063 - by (auto simp: card_of_card_order_on Field_card_of cardSuc_ordLeq_ordLess)
102.2064 - ultimately have "|A <+> B| <o ?r'"
102.2065 - using card_of_Plus_ordLess_infinite_Field by blast
102.2066 - thus ?thesis using c r
102.2067 - by (simp add: card_of_card_order_on Field_card_of cardSuc_ordLeq_ordLess)
102.2068 -qed
102.2069 -
102.2070 -
102.2071 -lemma card_of_Un_ordLeq_infinite_Field:
102.2072 -assumes C: "infinite (Field r)" and A: "|A| \<le>o r" and B: "|B| \<le>o r"
102.2073 -and "Card_order r"
102.2074 -shows "|A Un B| \<le>o r"
102.2075 -using assms card_of_Plus_ordLeq_infinite_Field card_of_Un_Plus_ordLeq
102.2076 -ordLeq_transitive by blast
102.2077 -
102.2078 -
102.2079 -
102.2080 -subsection {* Regular cardinals *}
102.2081 -
102.2082 -
102.2083 -definition cofinal where
102.2084 -"cofinal A r \<equiv>
102.2085 - ALL a : Field r. EX b : A. a \<noteq> b \<and> (a,b) : r"
102.2086 -
102.2087 -
102.2088 -definition regular where
102.2089 -"regular r \<equiv>
102.2090 - ALL K. K \<le> Field r \<and> cofinal K r \<longrightarrow> |K| =o r"
102.2091 -
102.2092 -
102.2093 -definition relChain where
102.2094 -"relChain r As \<equiv>
102.2095 - ALL i j. (i,j) \<in> r \<longrightarrow> As i \<le> As j"
102.2096 -
102.2097 -lemma regular_UNION:
102.2098 -assumes r: "Card_order r" "regular r"
102.2099 -and As: "relChain r As"
102.2100 -and Bsub: "B \<le> (UN i : Field r. As i)"
102.2101 -and cardB: "|B| <o r"
102.2102 -shows "EX i : Field r. B \<le> As i"
102.2103 -proof-
102.2104 - let ?phi = "%b j. j : Field r \<and> b : As j"
102.2105 - have "ALL b : B. EX j. ?phi b j" using Bsub by blast
102.2106 - then obtain f where f: "!! b. b : B \<Longrightarrow> ?phi b (f b)"
102.2107 - using bchoice[of B ?phi] by blast
102.2108 - let ?K = "f ` B"
102.2109 - {assume 1: "!! i. i : Field r \<Longrightarrow> ~ B \<le> As i"
102.2110 - have 2: "cofinal ?K r"
102.2111 - unfolding cofinal_def proof auto
102.2112 - fix i assume i: "i : Field r"
102.2113 - with 1 obtain b where b: "b : B \<and> b \<notin> As i" by blast
102.2114 - hence "i \<noteq> f b \<and> ~ (f b,i) : r"
102.2115 - using As f unfolding relChain_def by auto
102.2116 - hence "i \<noteq> f b \<and> (i, f b) : r" using r
102.2117 - unfolding card_order_on_def well_order_on_def linear_order_on_def
102.2118 - total_on_def using i f b by auto
102.2119 - with b show "\<exists>b\<in>B. i \<noteq> f b \<and> (i, f b) \<in> r" by blast
102.2120 - qed
102.2121 - moreover have "?K \<le> Field r" using f by blast
102.2122 - ultimately have "|?K| =o r" using 2 r unfolding regular_def by blast
102.2123 - moreover
102.2124 - {
102.2125 - have "|?K| <=o |B|" using card_of_image .
102.2126 - hence "|?K| <o r" using cardB ordLeq_ordLess_trans by blast
102.2127 - }
102.2128 - ultimately have False using not_ordLess_ordIso by blast
102.2129 - }
102.2130 - thus ?thesis by blast
102.2131 -qed
102.2132 -
102.2133 -
102.2134 -lemma infinite_cardSuc_regular:
102.2135 -assumes r_inf: "infinite (Field r)" and r_card: "Card_order r"
102.2136 -shows "regular (cardSuc r)"
102.2137 -proof-
102.2138 - let ?r' = "cardSuc r"
102.2139 - have r': "Card_order ?r'"
102.2140 - "!! p. Card_order p \<longrightarrow> (p \<le>o r) = (p <o ?r')"
102.2141 - using r_card by (auto simp: cardSuc_Card_order cardSuc_ordLeq_ordLess)
102.2142 - show ?thesis
102.2143 - unfolding regular_def proof auto
102.2144 - fix K assume 1: "K \<le> Field ?r'" and 2: "cofinal K ?r'"
102.2145 - hence "|K| \<le>o |Field ?r'|" by (simp only: card_of_mono1)
102.2146 - also have 22: "|Field ?r'| =o ?r'"
102.2147 - using r' by (simp add: card_of_Field_ordIso[of ?r'])
102.2148 - finally have "|K| \<le>o ?r'" .
102.2149 - moreover
102.2150 - {let ?L = "UN j : K. rel.underS ?r' j"
102.2151 - let ?J = "Field r"
102.2152 - have rJ: "r =o |?J|"
102.2153 - using r_card card_of_Field_ordIso ordIso_symmetric by blast
102.2154 - assume "|K| <o ?r'"
102.2155 - hence "|K| <=o r" using r' card_of_Card_order[of K] by blast
102.2156 - hence "|K| \<le>o |?J|" using rJ ordLeq_ordIso_trans by blast
102.2157 - moreover
102.2158 - {have "ALL j : K. |rel.underS ?r' j| <o ?r'"
102.2159 - using r' 1 by (auto simp: card_of_underS)
102.2160 - hence "ALL j : K. |rel.underS ?r' j| \<le>o r"
102.2161 - using r' card_of_Card_order by blast
102.2162 - hence "ALL j : K. |rel.underS ?r' j| \<le>o |?J|"
102.2163 - using rJ ordLeq_ordIso_trans by blast
102.2164 - }
102.2165 - ultimately have "|?L| \<le>o |?J|"
102.2166 - using r_inf card_of_UNION_ordLeq_infinite by blast
102.2167 - hence "|?L| \<le>o r" using rJ ordIso_symmetric ordLeq_ordIso_trans by blast
102.2168 - hence "|?L| <o ?r'" using r' card_of_Card_order by blast
102.2169 - moreover
102.2170 - {
102.2171 - have "Field ?r' \<le> ?L"
102.2172 - using 2 unfolding rel.underS_def cofinal_def by auto
102.2173 - hence "|Field ?r'| \<le>o |?L|" by (simp add: card_of_mono1)
102.2174 - hence "?r' \<le>o |?L|"
102.2175 - using 22 ordIso_ordLeq_trans ordIso_symmetric by blast
102.2176 - }
102.2177 - ultimately have "|?L| <o |?L|" using ordLess_ordLeq_trans by blast
102.2178 - hence False using ordLess_irreflexive by blast
102.2179 - }
102.2180 - ultimately show "|K| =o ?r'"
102.2181 - unfolding ordLeq_iff_ordLess_or_ordIso by blast
102.2182 - qed
102.2183 -qed
102.2184 -
102.2185 -lemma cardSuc_UNION:
102.2186 -assumes r: "Card_order r" and "infinite (Field r)"
102.2187 -and As: "relChain (cardSuc r) As"
102.2188 -and Bsub: "B \<le> (UN i : Field (cardSuc r). As i)"
102.2189 -and cardB: "|B| <=o r"
102.2190 -shows "EX i : Field (cardSuc r). B \<le> As i"
102.2191 -proof-
102.2192 - let ?r' = "cardSuc r"
102.2193 - have "Card_order ?r' \<and> |B| <o ?r'"
102.2194 - using r cardB cardSuc_ordLeq_ordLess cardSuc_Card_order
102.2195 - card_of_Card_order by blast
102.2196 - moreover have "regular ?r'"
102.2197 - using assms by(simp add: infinite_cardSuc_regular)
102.2198 - ultimately show ?thesis
102.2199 - using As Bsub cardB regular_UNION by blast
102.2200 -qed
102.2201 -
102.2202 -
102.2203 -subsection {* Others *}
102.2204 -
102.2205 -lemma card_of_infinite_diff_finite:
102.2206 -assumes "infinite A" and "finite B"
102.2207 -shows "|A - B| =o |A|"
102.2208 -by (metis assms card_of_Un_diff_infinite finite_ordLess_infinite2)
102.2209 -
102.2210 -(* function space *)
102.2211 -definition Func where
102.2212 -"Func A B = {f . (\<forall> a \<in> A. f a \<in> B) \<and> (\<forall> a. a \<notin> A \<longrightarrow> f a = undefined)}"
102.2213 -
102.2214 -lemma Func_empty:
102.2215 -"Func {} B = {\<lambda>x. undefined}"
102.2216 -unfolding Func_def by auto
102.2217 -
102.2218 -lemma Func_elim:
102.2219 -assumes "g \<in> Func A B" and "a \<in> A"
102.2220 -shows "\<exists> b. b \<in> B \<and> g a = b"
102.2221 -using assms unfolding Func_def by (cases "g a = undefined") auto
102.2222 -
102.2223 -definition curr where
102.2224 -"curr A f \<equiv> \<lambda> a. if a \<in> A then \<lambda>b. f (a,b) else undefined"
102.2225 -
102.2226 -lemma curr_in:
102.2227 -assumes f: "f \<in> Func (A <*> B) C"
102.2228 -shows "curr A f \<in> Func A (Func B C)"
102.2229 -using assms unfolding curr_def Func_def by auto
102.2230 -
102.2231 -lemma curr_inj:
102.2232 -assumes "f1 \<in> Func (A <*> B) C" and "f2 \<in> Func (A <*> B) C"
102.2233 -shows "curr A f1 = curr A f2 \<longleftrightarrow> f1 = f2"
102.2234 -proof safe
102.2235 - assume c: "curr A f1 = curr A f2"
102.2236 - show "f1 = f2"
102.2237 - proof (rule ext, clarify)
102.2238 - fix a b show "f1 (a, b) = f2 (a, b)"
102.2239 - proof (cases "(a,b) \<in> A <*> B")
102.2240 - case False
102.2241 - thus ?thesis using assms unfolding Func_def by auto
102.2242 - next
102.2243 - case True hence a: "a \<in> A" and b: "b \<in> B" by auto
102.2244 - thus ?thesis
102.2245 - using c unfolding curr_def fun_eq_iff by(elim allE[of _ a]) simp
102.2246 - qed
102.2247 - qed
102.2248 -qed
102.2249 -
102.2250 -lemma curr_surj:
102.2251 -assumes "g \<in> Func A (Func B C)"
102.2252 -shows "\<exists> f \<in> Func (A <*> B) C. curr A f = g"
102.2253 -proof
102.2254 - let ?f = "\<lambda> ab. if fst ab \<in> A \<and> snd ab \<in> B then g (fst ab) (snd ab) else undefined"
102.2255 - show "curr A ?f = g"
102.2256 - proof (rule ext)
102.2257 - fix a show "curr A ?f a = g a"
102.2258 - proof (cases "a \<in> A")
102.2259 - case False
102.2260 - hence "g a = undefined" using assms unfolding Func_def by auto
102.2261 - thus ?thesis unfolding curr_def using False by simp
102.2262 - next
102.2263 - case True
102.2264 - obtain g1 where "g1 \<in> Func B C" and "g a = g1"
102.2265 - using assms using Func_elim[OF assms True] by blast
102.2266 - thus ?thesis using True unfolding Func_def curr_def by auto
102.2267 - qed
102.2268 - qed
102.2269 - show "?f \<in> Func (A <*> B) C" using assms unfolding Func_def mem_Collect_eq by auto
102.2270 -qed
102.2271 -
102.2272 -lemma bij_betw_curr:
102.2273 -"bij_betw (curr A) (Func (A <*> B) C) (Func A (Func B C))"
102.2274 -unfolding bij_betw_def inj_on_def image_def
102.2275 -using curr_in curr_inj curr_surj by blast
102.2276 -
102.2277 -lemma card_of_Func_Times:
102.2278 -"|Func (A <*> B) C| =o |Func A (Func B C)|"
102.2279 -unfolding card_of_ordIso[symmetric]
102.2280 -using bij_betw_curr by blast
102.2281 -
102.2282 -definition Func_map where
102.2283 -"Func_map B2 f1 f2 g b2 \<equiv> if b2 \<in> B2 then f1 (g (f2 b2)) else undefined"
102.2284 -
102.2285 -lemma Func_map:
102.2286 -assumes g: "g \<in> Func A2 A1" and f1: "f1 ` A1 \<subseteq> B1" and f2: "f2 ` B2 \<subseteq> A2"
102.2287 -shows "Func_map B2 f1 f2 g \<in> Func B2 B1"
102.2288 -using assms unfolding Func_def Func_map_def mem_Collect_eq by auto
102.2289 -
102.2290 -lemma Func_non_emp:
102.2291 -assumes "B \<noteq> {}"
102.2292 -shows "Func A B \<noteq> {}"
102.2293 -proof-
102.2294 - obtain b where b: "b \<in> B" using assms by auto
102.2295 - hence "(\<lambda> a. if a \<in> A then b else undefined) \<in> Func A B" unfolding Func_def by auto
102.2296 - thus ?thesis by blast
102.2297 -qed
102.2298 -
102.2299 -lemma Func_is_emp:
102.2300 -"Func A B = {} \<longleftrightarrow> A \<noteq> {} \<and> B = {}" (is "?L \<longleftrightarrow> ?R")
102.2301 -proof
102.2302 - assume L: ?L
102.2303 - moreover {assume "A = {}" hence False using L Func_empty by auto}
102.2304 - moreover {assume "B \<noteq> {}" hence False using L Func_non_emp by metis}
102.2305 - ultimately show ?R by blast
102.2306 -next
102.2307 - assume R: ?R
102.2308 - moreover
102.2309 - {fix f assume "f \<in> Func A B"
102.2310 - moreover obtain a where "a \<in> A" using R by blast
102.2311 - ultimately obtain b where "b \<in> B" unfolding Func_def by(cases "f a = undefined", force+)
102.2312 - with R have False by auto
102.2313 - }
102.2314 - thus ?L by blast
102.2315 -qed
102.2316 -
102.2317 -lemma Func_map_surj:
102.2318 -assumes B1: "f1 ` A1 = B1" and A2: "inj_on f2 B2" "f2 ` B2 \<subseteq> A2"
102.2319 -and B2A2: "B2 = {} \<Longrightarrow> A2 = {}"
102.2320 -shows "Func B2 B1 = Func_map B2 f1 f2 ` Func A2 A1"
102.2321 -proof(cases "B2 = {}")
102.2322 - case True
102.2323 - thus ?thesis using B2A2 by (auto simp: Func_empty Func_map_def)
102.2324 -next
102.2325 - case False note B2 = False
102.2326 - show ?thesis
102.2327 - proof safe
102.2328 - fix h assume h: "h \<in> Func B2 B1"
102.2329 - def j1 \<equiv> "inv_into A1 f1"
102.2330 - have "\<forall> a2 \<in> f2 ` B2. \<exists> b2. b2 \<in> B2 \<and> f2 b2 = a2" by blast
102.2331 - then obtain k where k: "\<forall> a2 \<in> f2 ` B2. k a2 \<in> B2 \<and> f2 (k a2) = a2" by metis
102.2332 - {fix b2 assume b2: "b2 \<in> B2"
102.2333 - hence "f2 (k (f2 b2)) = f2 b2" using k A2(2) by auto
102.2334 - moreover have "k (f2 b2) \<in> B2" using b2 A2(2) k by auto
102.2335 - ultimately have "k (f2 b2) = b2" using b2 A2(1) unfolding inj_on_def by blast
102.2336 - } note kk = this
102.2337 - obtain b22 where b22: "b22 \<in> B2" using B2 by auto
102.2338 - def j2 \<equiv> "\<lambda> a2. if a2 \<in> f2 ` B2 then k a2 else b22"
102.2339 - have j2A2: "j2 ` A2 \<subseteq> B2" unfolding j2_def using k b22 by auto
102.2340 - have j2: "\<And> b2. b2 \<in> B2 \<Longrightarrow> j2 (f2 b2) = b2"
102.2341 - using kk unfolding j2_def by auto
102.2342 - def g \<equiv> "Func_map A2 j1 j2 h"
102.2343 - have "Func_map B2 f1 f2 g = h"
102.2344 - proof (rule ext)
102.2345 - fix b2 show "Func_map B2 f1 f2 g b2 = h b2"
102.2346 - proof(cases "b2 \<in> B2")
102.2347 - case True
102.2348 - show ?thesis
102.2349 - proof (cases "h b2 = undefined")
102.2350 - case True
102.2351 - hence b1: "h b2 \<in> f1 ` A1" using h `b2 \<in> B2` unfolding B1 Func_def by auto
102.2352 - show ?thesis using A2 f_inv_into_f[OF b1]
102.2353 - unfolding True g_def Func_map_def j1_def j2[OF `b2 \<in> B2`] by auto
102.2354 - qed(insert A2 True j2[OF True] h B1, unfold j1_def g_def Func_def Func_map_def,
102.2355 - auto intro: f_inv_into_f)
102.2356 - qed(insert h, unfold Func_def Func_map_def, auto)
102.2357 - qed
102.2358 - moreover have "g \<in> Func A2 A1" unfolding g_def apply(rule Func_map[OF h])
102.2359 - using inv_into_into j2A2 B1 A2 inv_into_into
102.2360 - unfolding j1_def image_def by fast+
102.2361 - ultimately show "h \<in> Func_map B2 f1 f2 ` Func A2 A1"
102.2362 - unfolding Func_map_def[abs_def] unfolding image_def by auto
102.2363 - qed(insert B1 Func_map[OF _ _ A2(2)], auto)
102.2364 -qed
102.2365 -
102.2366 -lemma card_of_Pow_Func:
102.2367 -"|Pow A| =o |Func A (UNIV::bool set)|"
102.2368 -proof-
102.2369 - def F \<equiv> "\<lambda> A' a. if a \<in> A then (if a \<in> A' then True else False)
102.2370 - else undefined"
102.2371 - have "bij_betw F (Pow A) (Func A (UNIV::bool set))"
102.2372 - unfolding bij_betw_def inj_on_def proof (intro ballI impI conjI)
102.2373 - fix A1 A2 assume "A1 \<in> Pow A" "A2 \<in> Pow A" "F A1 = F A2"
102.2374 - thus "A1 = A2" unfolding F_def Pow_def fun_eq_iff by (auto split: split_if_asm)
102.2375 - next
102.2376 - show "F ` Pow A = Func A UNIV"
102.2377 - proof safe
102.2378 - fix f assume f: "f \<in> Func A (UNIV::bool set)"
102.2379 - show "f \<in> F ` Pow A" unfolding image_def mem_Collect_eq proof(intro bexI)
102.2380 - let ?A1 = "{a \<in> A. f a = True}"
102.2381 - show "f = F ?A1" unfolding F_def apply(rule ext)
102.2382 - using f unfolding Func_def mem_Collect_eq by auto
102.2383 - qed auto
102.2384 - qed(unfold Func_def mem_Collect_eq F_def, auto)
102.2385 - qed
102.2386 - thus ?thesis unfolding card_of_ordIso[symmetric] by blast
102.2387 -qed
102.2388 -
102.2389 -lemma card_of_Func_mono:
102.2390 -fixes A1 A2 :: "'a set" and B :: "'b set"
102.2391 -assumes A12: "A1 \<subseteq> A2" and B: "B \<noteq> {}"
102.2392 -shows "|Func A1 B| \<le>o |Func A2 B|"
102.2393 -proof-
102.2394 - obtain bb where bb: "bb \<in> B" using B by auto
102.2395 - def F \<equiv> "\<lambda> (f1::'a \<Rightarrow> 'b) a. if a \<in> A2 then (if a \<in> A1 then f1 a else bb)
102.2396 - else undefined"
102.2397 - show ?thesis unfolding card_of_ordLeq[symmetric] proof(intro exI[of _ F] conjI)
102.2398 - show "inj_on F (Func A1 B)" unfolding inj_on_def proof safe
102.2399 - fix f g assume f: "f \<in> Func A1 B" and g: "g \<in> Func A1 B" and eq: "F f = F g"
102.2400 - show "f = g"
102.2401 - proof(rule ext)
102.2402 - fix a show "f a = g a"
102.2403 - proof(cases "a \<in> A1")
102.2404 - case True
102.2405 - thus ?thesis using eq A12 unfolding F_def fun_eq_iff
102.2406 - by (elim allE[of _ a]) auto
102.2407 - qed(insert f g, unfold Func_def, fastforce)
102.2408 - qed
102.2409 - qed
102.2410 - qed(insert bb, unfold Func_def F_def, force)
102.2411 -qed
102.2412 -
102.2413 -lemma ordLeq_Func:
102.2414 -assumes "{b1,b2} \<subseteq> B" "b1 \<noteq> b2"
102.2415 -shows "|A| \<le>o |Func A B|"
102.2416 -unfolding card_of_ordLeq[symmetric] proof(intro exI conjI)
102.2417 - let ?F = "\<lambda> aa a. if a \<in> A then (if a = aa then b1 else b2) else undefined"
102.2418 - show "inj_on ?F A" using assms unfolding inj_on_def fun_eq_iff by auto
102.2419 - show "?F ` A \<subseteq> Func A B" using assms unfolding Func_def by auto
102.2420 -qed
102.2421 -
102.2422 -lemma infinite_Func:
102.2423 -assumes A: "infinite A" and B: "{b1,b2} \<subseteq> B" "b1 \<noteq> b2"
102.2424 -shows "infinite (Func A B)"
102.2425 -using ordLeq_Func[OF B] by (metis A card_of_ordLeq_finite)
102.2426 -
102.2427 -lemma card_of_Func_UNIV:
102.2428 -"|Func (UNIV::'a set) (B::'b set)| =o |{f::'a \<Rightarrow> 'b. range f \<subseteq> B}|"
102.2429 -apply(rule ordIso_symmetric) proof(intro card_of_ordIsoI)
102.2430 - let ?F = "\<lambda> f (a::'a). ((f a)::'b)"
102.2431 - show "bij_betw ?F {f. range f \<subseteq> B} (Func UNIV B)"
102.2432 - unfolding bij_betw_def inj_on_def proof safe
102.2433 - fix h :: "'a \<Rightarrow> 'b" assume h: "h \<in> Func UNIV B"
102.2434 - hence "\<forall> a. \<exists> b. h a = b" unfolding Func_def by auto
102.2435 - then obtain f where f: "\<forall> a. h a = f a" by metis
102.2436 - hence "range f \<subseteq> B" using h unfolding Func_def by auto
102.2437 - thus "h \<in> (\<lambda>f a. f a) ` {f. range f \<subseteq> B}" using f unfolding image_def by auto
102.2438 - qed(unfold Func_def fun_eq_iff, auto)
102.2439 -qed
102.2440 -
102.2441 -end
103.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
103.2 +++ b/src/HOL/Cardinals/Cardinal_Order_Relation_FP.thy Thu Dec 05 17:58:03 2013 +0100
103.3 @@ -0,0 +1,1992 @@
103.4 +(* Title: HOL/Cardinals/Cardinal_Order_Relation_FP.thy
103.5 + Author: Andrei Popescu, TU Muenchen
103.6 + Copyright 2012
103.7 +
103.8 +Cardinal-order relations (FP).
103.9 +*)
103.10 +
103.11 +header {* Cardinal-Order Relations (FP) *}
103.12 +
103.13 +theory Cardinal_Order_Relation_FP
103.14 +imports Constructions_on_Wellorders_FP
103.15 +begin
103.16 +
103.17 +
103.18 +text{* In this section, we define cardinal-order relations to be minim well-orders
103.19 +on their field. Then we define the cardinal of a set to be {\em some} cardinal-order
103.20 +relation on that set, which will be unique up to order isomorphism. Then we study
103.21 +the connection between cardinals and:
103.22 +\begin{itemize}
103.23 +\item standard set-theoretic constructions: products,
103.24 +sums, unions, lists, powersets, set-of finite sets operator;
103.25 +\item finiteness and infiniteness (in particular, with the numeric cardinal operator
103.26 +for finite sets, @{text "card"}, from the theory @{text "Finite_Sets.thy"}).
103.27 +\end{itemize}
103.28 +%
103.29 +On the way, we define the canonical $\omega$ cardinal and finite cardinals. We also
103.30 +define (again, up to order isomorphism) the successor of a cardinal, and show that
103.31 +any cardinal admits a successor.
103.32 +
103.33 +Main results of this section are the existence of cardinal relations and the
103.34 +facts that, in the presence of infiniteness,
103.35 +most of the standard set-theoretic constructions (except for the powerset)
103.36 +{\em do not increase cardinality}. In particular, e.g., the set of words/lists over
103.37 +any infinite set has the same cardinality (hence, is in bijection) with that set.
103.38 +*}
103.39 +
103.40 +
103.41 +subsection {* Cardinal orders *}
103.42 +
103.43 +
103.44 +text{* A cardinal order in our setting shall be a well-order {\em minim} w.r.t. the
103.45 +order-embedding relation, @{text "\<le>o"} (which is the same as being {\em minimal} w.r.t. the
103.46 +strict order-embedding relation, @{text "<o"}), among all the well-orders on its field. *}
103.47 +
103.48 +definition card_order_on :: "'a set \<Rightarrow> 'a rel \<Rightarrow> bool"
103.49 +where
103.50 +"card_order_on A r \<equiv> well_order_on A r \<and> (\<forall>r'. well_order_on A r' \<longrightarrow> r \<le>o r')"
103.51 +
103.52 +
103.53 +abbreviation "Card_order r \<equiv> card_order_on (Field r) r"
103.54 +abbreviation "card_order r \<equiv> card_order_on UNIV r"
103.55 +
103.56 +
103.57 +lemma card_order_on_well_order_on:
103.58 +assumes "card_order_on A r"
103.59 +shows "well_order_on A r"
103.60 +using assms unfolding card_order_on_def by simp
103.61 +
103.62 +
103.63 +lemma card_order_on_Card_order:
103.64 +"card_order_on A r \<Longrightarrow> A = Field r \<and> Card_order r"
103.65 +unfolding card_order_on_def using rel.well_order_on_Field by blast
103.66 +
103.67 +
103.68 +text{* The existence of a cardinal relation on any given set (which will mean
103.69 +that any set has a cardinal) follows from two facts:
103.70 +\begin{itemize}
103.71 +\item Zermelo's theorem (proved in @{text "Zorn.thy"} as theorem @{text "well_order_on"}),
103.72 +which states that on any given set there exists a well-order;
103.73 +\item The well-founded-ness of @{text "<o"}, ensuring that then there exists a minimal
103.74 +such well-order, i.e., a cardinal order.
103.75 +\end{itemize}
103.76 +*}
103.77 +
103.78 +
103.79 +theorem card_order_on: "\<exists>r. card_order_on A r"
103.80 +proof-
103.81 + obtain R where R_def: "R = {r. well_order_on A r}" by blast
103.82 + have 1: "R \<noteq> {} \<and> (\<forall>r \<in> R. Well_order r)"
103.83 + using well_order_on[of A] R_def rel.well_order_on_Well_order by blast
103.84 + hence "\<exists>r \<in> R. \<forall>r' \<in> R. r \<le>o r'"
103.85 + using exists_minim_Well_order[of R] by auto
103.86 + thus ?thesis using R_def unfolding card_order_on_def by auto
103.87 +qed
103.88 +
103.89 +
103.90 +lemma card_order_on_ordIso:
103.91 +assumes CO: "card_order_on A r" and CO': "card_order_on A r'"
103.92 +shows "r =o r'"
103.93 +using assms unfolding card_order_on_def
103.94 +using ordIso_iff_ordLeq by blast
103.95 +
103.96 +
103.97 +lemma Card_order_ordIso:
103.98 +assumes CO: "Card_order r" and ISO: "r' =o r"
103.99 +shows "Card_order r'"
103.100 +using ISO unfolding ordIso_def
103.101 +proof(unfold card_order_on_def, auto)
103.102 + fix p' assume "well_order_on (Field r') p'"
103.103 + hence 0: "Well_order p' \<and> Field p' = Field r'"
103.104 + using rel.well_order_on_Well_order by blast
103.105 + obtain f where 1: "iso r' r f" and 2: "Well_order r \<and> Well_order r'"
103.106 + using ISO unfolding ordIso_def by auto
103.107 + hence 3: "inj_on f (Field r') \<and> f ` (Field r') = Field r"
103.108 + by (auto simp add: iso_iff embed_inj_on)
103.109 + let ?p = "dir_image p' f"
103.110 + have 4: "p' =o ?p \<and> Well_order ?p"
103.111 + using 0 2 3 by (auto simp add: dir_image_ordIso Well_order_dir_image)
103.112 + moreover have "Field ?p = Field r"
103.113 + using 0 3 by (auto simp add: dir_image_Field2 order_on_defs)
103.114 + ultimately have "well_order_on (Field r) ?p" by auto
103.115 + hence "r \<le>o ?p" using CO unfolding card_order_on_def by auto
103.116 + thus "r' \<le>o p'"
103.117 + using ISO 4 ordLeq_ordIso_trans ordIso_ordLeq_trans ordIso_symmetric by blast
103.118 +qed
103.119 +
103.120 +
103.121 +lemma Card_order_ordIso2:
103.122 +assumes CO: "Card_order r" and ISO: "r =o r'"
103.123 +shows "Card_order r'"
103.124 +using assms Card_order_ordIso ordIso_symmetric by blast
103.125 +
103.126 +
103.127 +subsection {* Cardinal of a set *}
103.128 +
103.129 +
103.130 +text{* We define the cardinal of set to be {\em some} cardinal order on that set.
103.131 +We shall prove that this notion is unique up to order isomorphism, meaning
103.132 +that order isomorphism shall be the true identity of cardinals. *}
103.133 +
103.134 +
103.135 +definition card_of :: "'a set \<Rightarrow> 'a rel" ("|_|" )
103.136 +where "card_of A = (SOME r. card_order_on A r)"
103.137 +
103.138 +
103.139 +lemma card_of_card_order_on: "card_order_on A |A|"
103.140 +unfolding card_of_def by (auto simp add: card_order_on someI_ex)
103.141 +
103.142 +
103.143 +lemma card_of_well_order_on: "well_order_on A |A|"
103.144 +using card_of_card_order_on card_order_on_def by blast
103.145 +
103.146 +
103.147 +lemma Field_card_of: "Field |A| = A"
103.148 +using card_of_card_order_on[of A] unfolding card_order_on_def
103.149 +using rel.well_order_on_Field by blast
103.150 +
103.151 +
103.152 +lemma card_of_Card_order: "Card_order |A|"
103.153 +by (simp only: card_of_card_order_on Field_card_of)
103.154 +
103.155 +
103.156 +corollary ordIso_card_of_imp_Card_order:
103.157 +"r =o |A| \<Longrightarrow> Card_order r"
103.158 +using card_of_Card_order Card_order_ordIso by blast
103.159 +
103.160 +
103.161 +lemma card_of_Well_order: "Well_order |A|"
103.162 +using card_of_Card_order unfolding card_order_on_def by auto
103.163 +
103.164 +
103.165 +lemma card_of_refl: "|A| =o |A|"
103.166 +using card_of_Well_order ordIso_reflexive by blast
103.167 +
103.168 +
103.169 +lemma card_of_least: "well_order_on A r \<Longrightarrow> |A| \<le>o r"
103.170 +using card_of_card_order_on unfolding card_order_on_def by blast
103.171 +
103.172 +
103.173 +lemma card_of_ordIso:
103.174 +"(\<exists>f. bij_betw f A B) = ( |A| =o |B| )"
103.175 +proof(auto)
103.176 + fix f assume *: "bij_betw f A B"
103.177 + then obtain r where "well_order_on B r \<and> |A| =o r"
103.178 + using Well_order_iso_copy card_of_well_order_on by blast
103.179 + hence "|B| \<le>o |A|" using card_of_least
103.180 + ordLeq_ordIso_trans ordIso_symmetric by blast
103.181 + moreover
103.182 + {let ?g = "inv_into A f"
103.183 + have "bij_betw ?g B A" using * bij_betw_inv_into by blast
103.184 + then obtain r where "well_order_on A r \<and> |B| =o r"
103.185 + using Well_order_iso_copy card_of_well_order_on by blast
103.186 + hence "|A| \<le>o |B|" using card_of_least
103.187 + ordLeq_ordIso_trans ordIso_symmetric by blast
103.188 + }
103.189 + ultimately show "|A| =o |B|" using ordIso_iff_ordLeq by blast
103.190 +next
103.191 + assume "|A| =o |B|"
103.192 + then obtain f where "iso ( |A| ) ( |B| ) f"
103.193 + unfolding ordIso_def by auto
103.194 + hence "bij_betw f A B" unfolding iso_def Field_card_of by simp
103.195 + thus "\<exists>f. bij_betw f A B" by auto
103.196 +qed
103.197 +
103.198 +
103.199 +lemma card_of_ordLeq:
103.200 +"(\<exists>f. inj_on f A \<and> f ` A \<le> B) = ( |A| \<le>o |B| )"
103.201 +proof(auto)
103.202 + fix f assume *: "inj_on f A" and **: "f ` A \<le> B"
103.203 + {assume "|B| <o |A|"
103.204 + hence "|B| \<le>o |A|" using ordLeq_iff_ordLess_or_ordIso by blast
103.205 + then obtain g where "embed ( |B| ) ( |A| ) g"
103.206 + unfolding ordLeq_def by auto
103.207 + hence 1: "inj_on g B \<and> g ` B \<le> A" using embed_inj_on[of "|B|" "|A|" "g"]
103.208 + card_of_Well_order[of "B"] Field_card_of[of "B"] Field_card_of[of "A"]
103.209 + embed_Field[of "|B|" "|A|" g] by auto
103.210 + obtain h where "bij_betw h A B"
103.211 + using * ** 1 Cantor_Bernstein[of f] by fastforce
103.212 + hence "|A| =o |B|" using card_of_ordIso by blast
103.213 + hence "|A| \<le>o |B|" using ordIso_iff_ordLeq by auto
103.214 + }
103.215 + thus "|A| \<le>o |B|" using ordLess_or_ordLeq[of "|B|" "|A|"]
103.216 + by (auto simp: card_of_Well_order)
103.217 +next
103.218 + assume *: "|A| \<le>o |B|"
103.219 + obtain f where "embed ( |A| ) ( |B| ) f"
103.220 + using * unfolding ordLeq_def by auto
103.221 + hence "inj_on f A \<and> f ` A \<le> B" using embed_inj_on[of "|A|" "|B|" f]
103.222 + card_of_Well_order[of "A"] Field_card_of[of "A"] Field_card_of[of "B"]
103.223 + embed_Field[of "|A|" "|B|" f] by auto
103.224 + thus "\<exists>f. inj_on f A \<and> f ` A \<le> B" by auto
103.225 +qed
103.226 +
103.227 +
103.228 +lemma card_of_ordLeq2:
103.229 +"A \<noteq> {} \<Longrightarrow> (\<exists>g. g ` B = A) = ( |A| \<le>o |B| )"
103.230 +using card_of_ordLeq[of A B] inj_on_iff_surj[of A B] by auto
103.231 +
103.232 +
103.233 +lemma card_of_ordLess:
103.234 +"(\<not>(\<exists>f. inj_on f A \<and> f ` A \<le> B)) = ( |B| <o |A| )"
103.235 +proof-
103.236 + have "(\<not>(\<exists>f. inj_on f A \<and> f ` A \<le> B)) = (\<not> |A| \<le>o |B| )"
103.237 + using card_of_ordLeq by blast
103.238 + also have "\<dots> = ( |B| <o |A| )"
103.239 + using card_of_Well_order[of A] card_of_Well_order[of B]
103.240 + not_ordLeq_iff_ordLess by blast
103.241 + finally show ?thesis .
103.242 +qed
103.243 +
103.244 +
103.245 +lemma card_of_ordLess2:
103.246 +"B \<noteq> {} \<Longrightarrow> (\<not>(\<exists>f. f ` A = B)) = ( |A| <o |B| )"
103.247 +using card_of_ordLess[of B A] inj_on_iff_surj[of B A] by auto
103.248 +
103.249 +
103.250 +lemma card_of_ordIsoI:
103.251 +assumes "bij_betw f A B"
103.252 +shows "|A| =o |B|"
103.253 +using assms unfolding card_of_ordIso[symmetric] by auto
103.254 +
103.255 +
103.256 +lemma card_of_ordLeqI:
103.257 +assumes "inj_on f A" and "\<And> a. a \<in> A \<Longrightarrow> f a \<in> B"
103.258 +shows "|A| \<le>o |B|"
103.259 +using assms unfolding card_of_ordLeq[symmetric] by auto
103.260 +
103.261 +
103.262 +lemma card_of_unique:
103.263 +"card_order_on A r \<Longrightarrow> r =o |A|"
103.264 +by (simp only: card_order_on_ordIso card_of_card_order_on)
103.265 +
103.266 +
103.267 +lemma card_of_mono1:
103.268 +"A \<le> B \<Longrightarrow> |A| \<le>o |B|"
103.269 +using inj_on_id[of A] card_of_ordLeq[of A B] by fastforce
103.270 +
103.271 +
103.272 +lemma card_of_mono2:
103.273 +assumes "r \<le>o r'"
103.274 +shows "|Field r| \<le>o |Field r'|"
103.275 +proof-
103.276 + obtain f where
103.277 + 1: "well_order_on (Field r) r \<and> well_order_on (Field r) r \<and> embed r r' f"
103.278 + using assms unfolding ordLeq_def
103.279 + by (auto simp add: rel.well_order_on_Well_order)
103.280 + hence "inj_on f (Field r) \<and> f ` (Field r) \<le> Field r'"
103.281 + by (auto simp add: embed_inj_on embed_Field)
103.282 + thus "|Field r| \<le>o |Field r'|" using card_of_ordLeq by blast
103.283 +qed
103.284 +
103.285 +
103.286 +lemma card_of_cong: "r =o r' \<Longrightarrow> |Field r| =o |Field r'|"
103.287 +by (simp add: ordIso_iff_ordLeq card_of_mono2)
103.288 +
103.289 +
103.290 +lemma card_of_Field_ordLess: "Well_order r \<Longrightarrow> |Field r| \<le>o r"
103.291 +using card_of_least card_of_well_order_on rel.well_order_on_Well_order by blast
103.292 +
103.293 +
103.294 +lemma card_of_Field_ordIso:
103.295 +assumes "Card_order r"
103.296 +shows "|Field r| =o r"
103.297 +proof-
103.298 + have "card_order_on (Field r) r"
103.299 + using assms card_order_on_Card_order by blast
103.300 + moreover have "card_order_on (Field r) |Field r|"
103.301 + using card_of_card_order_on by blast
103.302 + ultimately show ?thesis using card_order_on_ordIso by blast
103.303 +qed
103.304 +
103.305 +
103.306 +lemma Card_order_iff_ordIso_card_of:
103.307 +"Card_order r = (r =o |Field r| )"
103.308 +using ordIso_card_of_imp_Card_order card_of_Field_ordIso ordIso_symmetric by blast
103.309 +
103.310 +
103.311 +lemma Card_order_iff_ordLeq_card_of:
103.312 +"Card_order r = (r \<le>o |Field r| )"
103.313 +proof-
103.314 + have "Card_order r = (r =o |Field r| )"
103.315 + unfolding Card_order_iff_ordIso_card_of by simp
103.316 + also have "... = (r \<le>o |Field r| \<and> |Field r| \<le>o r)"
103.317 + unfolding ordIso_iff_ordLeq by simp
103.318 + also have "... = (r \<le>o |Field r| )"
103.319 + using card_of_Field_ordLess
103.320 + by (auto simp: card_of_Field_ordLess ordLeq_Well_order_simp)
103.321 + finally show ?thesis .
103.322 +qed
103.323 +
103.324 +
103.325 +lemma Card_order_iff_Restr_underS:
103.326 +assumes "Well_order r"
103.327 +shows "Card_order r = (\<forall>a \<in> Field r. Restr r (rel.underS r a) <o |Field r| )"
103.328 +using assms unfolding Card_order_iff_ordLeq_card_of
103.329 +using ordLeq_iff_ordLess_Restr card_of_Well_order by blast
103.330 +
103.331 +
103.332 +lemma card_of_underS:
103.333 +assumes r: "Card_order r" and a: "a : Field r"
103.334 +shows "|rel.underS r a| <o r"
103.335 +proof-
103.336 + let ?A = "rel.underS r a" let ?r' = "Restr r ?A"
103.337 + have 1: "Well_order r"
103.338 + using r unfolding card_order_on_def by simp
103.339 + have "Well_order ?r'" using 1 Well_order_Restr by auto
103.340 + moreover have "card_order_on (Field ?r') |Field ?r'|"
103.341 + using card_of_card_order_on .
103.342 + ultimately have "|Field ?r'| \<le>o ?r'"
103.343 + unfolding card_order_on_def by simp
103.344 + moreover have "Field ?r' = ?A"
103.345 + using 1 wo_rel.underS_ofilter Field_Restr_ofilter
103.346 + unfolding wo_rel_def by fastforce
103.347 + ultimately have "|?A| \<le>o ?r'" by simp
103.348 + also have "?r' <o |Field r|"
103.349 + using 1 a r Card_order_iff_Restr_underS by blast
103.350 + also have "|Field r| =o r"
103.351 + using r ordIso_symmetric unfolding Card_order_iff_ordIso_card_of by auto
103.352 + finally show ?thesis .
103.353 +qed
103.354 +
103.355 +
103.356 +lemma ordLess_Field:
103.357 +assumes "r <o r'"
103.358 +shows "|Field r| <o r'"
103.359 +proof-
103.360 + have "well_order_on (Field r) r" using assms unfolding ordLess_def
103.361 + by (auto simp add: rel.well_order_on_Well_order)
103.362 + hence "|Field r| \<le>o r" using card_of_least by blast
103.363 + thus ?thesis using assms ordLeq_ordLess_trans by blast
103.364 +qed
103.365 +
103.366 +
103.367 +lemma internalize_card_of_ordLeq:
103.368 +"( |A| \<le>o r) = (\<exists>B \<le> Field r. |A| =o |B| \<and> |B| \<le>o r)"
103.369 +proof
103.370 + assume "|A| \<le>o r"
103.371 + then obtain p where 1: "Field p \<le> Field r \<and> |A| =o p \<and> p \<le>o r"
103.372 + using internalize_ordLeq[of "|A|" r] by blast
103.373 + hence "Card_order p" using card_of_Card_order Card_order_ordIso2 by blast
103.374 + hence "|Field p| =o p" using card_of_Field_ordIso by blast
103.375 + hence "|A| =o |Field p| \<and> |Field p| \<le>o r"
103.376 + using 1 ordIso_equivalence ordIso_ordLeq_trans by blast
103.377 + thus "\<exists>B \<le> Field r. |A| =o |B| \<and> |B| \<le>o r" using 1 by blast
103.378 +next
103.379 + assume "\<exists>B \<le> Field r. |A| =o |B| \<and> |B| \<le>o r"
103.380 + thus "|A| \<le>o r" using ordIso_ordLeq_trans by blast
103.381 +qed
103.382 +
103.383 +
103.384 +lemma internalize_card_of_ordLeq2:
103.385 +"( |A| \<le>o |C| ) = (\<exists>B \<le> C. |A| =o |B| \<and> |B| \<le>o |C| )"
103.386 +using internalize_card_of_ordLeq[of "A" "|C|"] Field_card_of[of C] by auto
103.387 +
103.388 +
103.389 +
103.390 +subsection {* Cardinals versus set operations on arbitrary sets *}
103.391 +
103.392 +
103.393 +text{* Here we embark in a long journey of simple results showing
103.394 +that the standard set-theoretic operations are well-behaved w.r.t. the notion of
103.395 +cardinal -- essentially, this means that they preserve the ``cardinal identity"
103.396 +@{text "=o"} and are monotonic w.r.t. @{text "\<le>o"}.
103.397 +*}
103.398 +
103.399 +
103.400 +lemma card_of_empty: "|{}| \<le>o |A|"
103.401 +using card_of_ordLeq inj_on_id by blast
103.402 +
103.403 +
103.404 +lemma card_of_empty1:
103.405 +assumes "Well_order r \<or> Card_order r"
103.406 +shows "|{}| \<le>o r"
103.407 +proof-
103.408 + have "Well_order r" using assms unfolding card_order_on_def by auto
103.409 + hence "|Field r| <=o r"
103.410 + using assms card_of_Field_ordLess by blast
103.411 + moreover have "|{}| \<le>o |Field r|" by (simp add: card_of_empty)
103.412 + ultimately show ?thesis using ordLeq_transitive by blast
103.413 +qed
103.414 +
103.415 +
103.416 +corollary Card_order_empty:
103.417 +"Card_order r \<Longrightarrow> |{}| \<le>o r" by (simp add: card_of_empty1)
103.418 +
103.419 +
103.420 +lemma card_of_empty2:
103.421 +assumes LEQ: "|A| =o |{}|"
103.422 +shows "A = {}"
103.423 +using assms card_of_ordIso[of A] bij_betw_empty2 by blast
103.424 +
103.425 +
103.426 +lemma card_of_empty3:
103.427 +assumes LEQ: "|A| \<le>o |{}|"
103.428 +shows "A = {}"
103.429 +using assms
103.430 +by (simp add: ordIso_iff_ordLeq card_of_empty1 card_of_empty2
103.431 + ordLeq_Well_order_simp)
103.432 +
103.433 +
103.434 +lemma card_of_empty_ordIso:
103.435 +"|{}::'a set| =o |{}::'b set|"
103.436 +using card_of_ordIso unfolding bij_betw_def inj_on_def by blast
103.437 +
103.438 +
103.439 +lemma card_of_image:
103.440 +"|f ` A| <=o |A|"
103.441 +proof(cases "A = {}", simp add: card_of_empty)
103.442 + assume "A ~= {}"
103.443 + hence "f ` A ~= {}" by auto
103.444 + thus "|f ` A| \<le>o |A|"
103.445 + using card_of_ordLeq2[of "f ` A" A] by auto
103.446 +qed
103.447 +
103.448 +
103.449 +lemma surj_imp_ordLeq:
103.450 +assumes "B <= f ` A"
103.451 +shows "|B| <=o |A|"
103.452 +proof-
103.453 + have "|B| <=o |f ` A|" using assms card_of_mono1 by auto
103.454 + thus ?thesis using card_of_image ordLeq_transitive by blast
103.455 +qed
103.456 +
103.457 +
103.458 +lemma card_of_ordLeqI2:
103.459 +assumes "B \<subseteq> f ` A"
103.460 +shows "|B| \<le>o |A|"
103.461 +using assms by (metis surj_imp_ordLeq)
103.462 +
103.463 +
103.464 +lemma card_of_singl_ordLeq:
103.465 +assumes "A \<noteq> {}"
103.466 +shows "|{b}| \<le>o |A|"
103.467 +proof-
103.468 + obtain a where *: "a \<in> A" using assms by auto
103.469 + let ?h = "\<lambda> b'::'b. if b' = b then a else undefined"
103.470 + have "inj_on ?h {b} \<and> ?h ` {b} \<le> A"
103.471 + using * unfolding inj_on_def by auto
103.472 + thus ?thesis using card_of_ordLeq by fast
103.473 +qed
103.474 +
103.475 +
103.476 +corollary Card_order_singl_ordLeq:
103.477 +"\<lbrakk>Card_order r; Field r \<noteq> {}\<rbrakk> \<Longrightarrow> |{b}| \<le>o r"
103.478 +using card_of_singl_ordLeq[of "Field r" b]
103.479 + card_of_Field_ordIso[of r] ordLeq_ordIso_trans by blast
103.480 +
103.481 +
103.482 +lemma card_of_Pow: "|A| <o |Pow A|"
103.483 +using card_of_ordLess2[of "Pow A" A] Cantors_paradox[of A]
103.484 + Pow_not_empty[of A] by auto
103.485 +
103.486 +
103.487 +corollary Card_order_Pow:
103.488 +"Card_order r \<Longrightarrow> r <o |Pow(Field r)|"
103.489 +using card_of_Pow card_of_Field_ordIso ordIso_ordLess_trans ordIso_symmetric by blast
103.490 +
103.491 +
103.492 +lemma infinite_Pow:
103.493 +assumes "\<not> finite A"
103.494 +shows "\<not> finite (Pow A)"
103.495 +proof-
103.496 + have "|A| \<le>o |Pow A|" by (metis card_of_Pow ordLess_imp_ordLeq)
103.497 + thus ?thesis by (metis assms finite_Pow_iff)
103.498 +qed
103.499 +
103.500 +
103.501 +lemma card_of_Plus1: "|A| \<le>o |A <+> B|"
103.502 +proof-
103.503 + have "Inl ` A \<le> A <+> B" by auto
103.504 + thus ?thesis using inj_Inl[of A] card_of_ordLeq by blast
103.505 +qed
103.506 +
103.507 +
103.508 +corollary Card_order_Plus1:
103.509 +"Card_order r \<Longrightarrow> r \<le>o |(Field r) <+> B|"
103.510 +using card_of_Plus1 card_of_Field_ordIso ordIso_ordLeq_trans ordIso_symmetric by blast
103.511 +
103.512 +
103.513 +lemma card_of_Plus2: "|B| \<le>o |A <+> B|"
103.514 +proof-
103.515 + have "Inr ` B \<le> A <+> B" by auto
103.516 + thus ?thesis using inj_Inr[of B] card_of_ordLeq by blast
103.517 +qed
103.518 +
103.519 +
103.520 +corollary Card_order_Plus2:
103.521 +"Card_order r \<Longrightarrow> r \<le>o |A <+> (Field r)|"
103.522 +using card_of_Plus2 card_of_Field_ordIso ordIso_ordLeq_trans ordIso_symmetric by blast
103.523 +
103.524 +
103.525 +lemma card_of_Plus_empty1: "|A| =o |A <+> {}|"
103.526 +proof-
103.527 + have "bij_betw Inl A (A <+> {})" unfolding bij_betw_def inj_on_def by auto
103.528 + thus ?thesis using card_of_ordIso by auto
103.529 +qed
103.530 +
103.531 +
103.532 +lemma card_of_Plus_empty2: "|A| =o |{} <+> A|"
103.533 +proof-
103.534 + have "bij_betw Inr A ({} <+> A)" unfolding bij_betw_def inj_on_def by auto
103.535 + thus ?thesis using card_of_ordIso by auto
103.536 +qed
103.537 +
103.538 +
103.539 +lemma card_of_Plus_commute: "|A <+> B| =o |B <+> A|"
103.540 +proof-
103.541 + let ?f = "\<lambda>(c::'a + 'b). case c of Inl a \<Rightarrow> Inr a
103.542 + | Inr b \<Rightarrow> Inl b"
103.543 + have "bij_betw ?f (A <+> B) (B <+> A)"
103.544 + unfolding bij_betw_def inj_on_def by force
103.545 + thus ?thesis using card_of_ordIso by blast
103.546 +qed
103.547 +
103.548 +
103.549 +lemma card_of_Plus_assoc:
103.550 +fixes A :: "'a set" and B :: "'b set" and C :: "'c set"
103.551 +shows "|(A <+> B) <+> C| =o |A <+> B <+> C|"
103.552 +proof -
103.553 + def f \<equiv> "\<lambda>(k::('a + 'b) + 'c).
103.554 + case k of Inl ab \<Rightarrow> (case ab of Inl a \<Rightarrow> Inl a
103.555 + |Inr b \<Rightarrow> Inr (Inl b))
103.556 + |Inr c \<Rightarrow> Inr (Inr c)"
103.557 + have "A <+> B <+> C \<subseteq> f ` ((A <+> B) <+> C)"
103.558 + proof
103.559 + fix x assume x: "x \<in> A <+> B <+> C"
103.560 + show "x \<in> f ` ((A <+> B) <+> C)"
103.561 + proof(cases x)
103.562 + case (Inl a)
103.563 + hence "a \<in> A" "x = f (Inl (Inl a))"
103.564 + using x unfolding f_def by auto
103.565 + thus ?thesis by auto
103.566 + next
103.567 + case (Inr bc) note 1 = Inr show ?thesis
103.568 + proof(cases bc)
103.569 + case (Inl b)
103.570 + hence "b \<in> B" "x = f (Inl (Inr b))"
103.571 + using x 1 unfolding f_def by auto
103.572 + thus ?thesis by auto
103.573 + next
103.574 + case (Inr c)
103.575 + hence "c \<in> C" "x = f (Inr c)"
103.576 + using x 1 unfolding f_def by auto
103.577 + thus ?thesis by auto
103.578 + qed
103.579 + qed
103.580 + qed
103.581 + hence "bij_betw f ((A <+> B) <+> C) (A <+> B <+> C)"
103.582 + unfolding bij_betw_def inj_on_def f_def by fastforce
103.583 + thus ?thesis using card_of_ordIso by blast
103.584 +qed
103.585 +
103.586 +
103.587 +lemma card_of_Plus_mono1:
103.588 +assumes "|A| \<le>o |B|"
103.589 +shows "|A <+> C| \<le>o |B <+> C|"
103.590 +proof-
103.591 + obtain f where 1: "inj_on f A \<and> f ` A \<le> B"
103.592 + using assms card_of_ordLeq[of A] by fastforce
103.593 + obtain g where g_def:
103.594 + "g = (\<lambda>d. case d of Inl a \<Rightarrow> Inl(f a) | Inr (c::'c) \<Rightarrow> Inr c)" by blast
103.595 + have "inj_on g (A <+> C) \<and> g ` (A <+> C) \<le> (B <+> C)"
103.596 + proof-
103.597 + {fix d1 and d2 assume "d1 \<in> A <+> C \<and> d2 \<in> A <+> C" and
103.598 + "g d1 = g d2"
103.599 + hence "d1 = d2" using 1 unfolding inj_on_def g_def by force
103.600 + }
103.601 + moreover
103.602 + {fix d assume "d \<in> A <+> C"
103.603 + hence "g d \<in> B <+> C" using 1
103.604 + by(case_tac d, auto simp add: g_def)
103.605 + }
103.606 + ultimately show ?thesis unfolding inj_on_def by auto
103.607 + qed
103.608 + thus ?thesis using card_of_ordLeq by metis
103.609 +qed
103.610 +
103.611 +
103.612 +corollary ordLeq_Plus_mono1:
103.613 +assumes "r \<le>o r'"
103.614 +shows "|(Field r) <+> C| \<le>o |(Field r') <+> C|"
103.615 +using assms card_of_mono2 card_of_Plus_mono1 by blast
103.616 +
103.617 +
103.618 +lemma card_of_Plus_mono2:
103.619 +assumes "|A| \<le>o |B|"
103.620 +shows "|C <+> A| \<le>o |C <+> B|"
103.621 +using assms card_of_Plus_mono1[of A B C]
103.622 + card_of_Plus_commute[of C A] card_of_Plus_commute[of B C]
103.623 + ordIso_ordLeq_trans[of "|C <+> A|"] ordLeq_ordIso_trans[of "|C <+> A|"]
103.624 +by blast
103.625 +
103.626 +
103.627 +corollary ordLeq_Plus_mono2:
103.628 +assumes "r \<le>o r'"
103.629 +shows "|A <+> (Field r)| \<le>o |A <+> (Field r')|"
103.630 +using assms card_of_mono2 card_of_Plus_mono2 by blast
103.631 +
103.632 +
103.633 +lemma card_of_Plus_mono:
103.634 +assumes "|A| \<le>o |B|" and "|C| \<le>o |D|"
103.635 +shows "|A <+> C| \<le>o |B <+> D|"
103.636 +using assms card_of_Plus_mono1[of A B C] card_of_Plus_mono2[of C D B]
103.637 + ordLeq_transitive[of "|A <+> C|"] by blast
103.638 +
103.639 +
103.640 +corollary ordLeq_Plus_mono:
103.641 +assumes "r \<le>o r'" and "p \<le>o p'"
103.642 +shows "|(Field r) <+> (Field p)| \<le>o |(Field r') <+> (Field p')|"
103.643 +using assms card_of_mono2[of r r'] card_of_mono2[of p p'] card_of_Plus_mono by blast
103.644 +
103.645 +
103.646 +lemma card_of_Plus_cong1:
103.647 +assumes "|A| =o |B|"
103.648 +shows "|A <+> C| =o |B <+> C|"
103.649 +using assms by (simp add: ordIso_iff_ordLeq card_of_Plus_mono1)
103.650 +
103.651 +
103.652 +corollary ordIso_Plus_cong1:
103.653 +assumes "r =o r'"
103.654 +shows "|(Field r) <+> C| =o |(Field r') <+> C|"
103.655 +using assms card_of_cong card_of_Plus_cong1 by blast
103.656 +
103.657 +
103.658 +lemma card_of_Plus_cong2:
103.659 +assumes "|A| =o |B|"
103.660 +shows "|C <+> A| =o |C <+> B|"
103.661 +using assms by (simp add: ordIso_iff_ordLeq card_of_Plus_mono2)
103.662 +
103.663 +
103.664 +corollary ordIso_Plus_cong2:
103.665 +assumes "r =o r'"
103.666 +shows "|A <+> (Field r)| =o |A <+> (Field r')|"
103.667 +using assms card_of_cong card_of_Plus_cong2 by blast
103.668 +
103.669 +
103.670 +lemma card_of_Plus_cong:
103.671 +assumes "|A| =o |B|" and "|C| =o |D|"
103.672 +shows "|A <+> C| =o |B <+> D|"
103.673 +using assms by (simp add: ordIso_iff_ordLeq card_of_Plus_mono)
103.674 +
103.675 +
103.676 +corollary ordIso_Plus_cong:
103.677 +assumes "r =o r'" and "p =o p'"
103.678 +shows "|(Field r) <+> (Field p)| =o |(Field r') <+> (Field p')|"
103.679 +using assms card_of_cong[of r r'] card_of_cong[of p p'] card_of_Plus_cong by blast
103.680 +
103.681 +
103.682 +lemma card_of_Un_Plus_ordLeq:
103.683 +"|A \<union> B| \<le>o |A <+> B|"
103.684 +proof-
103.685 + let ?f = "\<lambda> c. if c \<in> A then Inl c else Inr c"
103.686 + have "inj_on ?f (A \<union> B) \<and> ?f ` (A \<union> B) \<le> A <+> B"
103.687 + unfolding inj_on_def by auto
103.688 + thus ?thesis using card_of_ordLeq by blast
103.689 +qed
103.690 +
103.691 +
103.692 +lemma card_of_Times1:
103.693 +assumes "A \<noteq> {}"
103.694 +shows "|B| \<le>o |B \<times> A|"
103.695 +proof(cases "B = {}", simp add: card_of_empty)
103.696 + assume *: "B \<noteq> {}"
103.697 + have "fst `(B \<times> A) = B" unfolding image_def using assms by auto
103.698 + thus ?thesis using inj_on_iff_surj[of B "B \<times> A"]
103.699 + card_of_ordLeq[of B "B \<times> A"] * by blast
103.700 +qed
103.701 +
103.702 +
103.703 +lemma card_of_Times_commute: "|A \<times> B| =o |B \<times> A|"
103.704 +proof-
103.705 + let ?f = "\<lambda>(a::'a,b::'b). (b,a)"
103.706 + have "bij_betw ?f (A \<times> B) (B \<times> A)"
103.707 + unfolding bij_betw_def inj_on_def by auto
103.708 + thus ?thesis using card_of_ordIso by blast
103.709 +qed
103.710 +
103.711 +
103.712 +lemma card_of_Times2:
103.713 +assumes "A \<noteq> {}" shows "|B| \<le>o |A \<times> B|"
103.714 +using assms card_of_Times1[of A B] card_of_Times_commute[of B A]
103.715 + ordLeq_ordIso_trans by blast
103.716 +
103.717 +
103.718 +corollary Card_order_Times1:
103.719 +"\<lbrakk>Card_order r; B \<noteq> {}\<rbrakk> \<Longrightarrow> r \<le>o |(Field r) \<times> B|"
103.720 +using card_of_Times1[of B] card_of_Field_ordIso
103.721 + ordIso_ordLeq_trans ordIso_symmetric by blast
103.722 +
103.723 +
103.724 +corollary Card_order_Times2:
103.725 +"\<lbrakk>Card_order r; A \<noteq> {}\<rbrakk> \<Longrightarrow> r \<le>o |A \<times> (Field r)|"
103.726 +using card_of_Times2[of A] card_of_Field_ordIso
103.727 + ordIso_ordLeq_trans ordIso_symmetric by blast
103.728 +
103.729 +
103.730 +lemma card_of_Times3: "|A| \<le>o |A \<times> A|"
103.731 +using card_of_Times1[of A]
103.732 +by(cases "A = {}", simp add: card_of_empty, blast)
103.733 +
103.734 +
103.735 +lemma card_of_Plus_Times_bool: "|A <+> A| =o |A \<times> (UNIV::bool set)|"
103.736 +proof-
103.737 + let ?f = "\<lambda>c::'a + 'a. case c of Inl a \<Rightarrow> (a,True)
103.738 + |Inr a \<Rightarrow> (a,False)"
103.739 + have "bij_betw ?f (A <+> A) (A \<times> (UNIV::bool set))"
103.740 + proof-
103.741 + {fix c1 and c2 assume "?f c1 = ?f c2"
103.742 + hence "c1 = c2"
103.743 + by(case_tac "c1", case_tac "c2", auto, case_tac "c2", auto)
103.744 + }
103.745 + moreover
103.746 + {fix c assume "c \<in> A <+> A"
103.747 + hence "?f c \<in> A \<times> (UNIV::bool set)"
103.748 + by(case_tac c, auto)
103.749 + }
103.750 + moreover
103.751 + {fix a bl assume *: "(a,bl) \<in> A \<times> (UNIV::bool set)"
103.752 + have "(a,bl) \<in> ?f ` ( A <+> A)"
103.753 + proof(cases bl)
103.754 + assume bl hence "?f(Inl a) = (a,bl)" by auto
103.755 + thus ?thesis using * by force
103.756 + next
103.757 + assume "\<not> bl" hence "?f(Inr a) = (a,bl)" by auto
103.758 + thus ?thesis using * by force
103.759 + qed
103.760 + }
103.761 + ultimately show ?thesis unfolding bij_betw_def inj_on_def by auto
103.762 + qed
103.763 + thus ?thesis using card_of_ordIso by blast
103.764 +qed
103.765 +
103.766 +
103.767 +lemma card_of_Times_mono1:
103.768 +assumes "|A| \<le>o |B|"
103.769 +shows "|A \<times> C| \<le>o |B \<times> C|"
103.770 +proof-
103.771 + obtain f where 1: "inj_on f A \<and> f ` A \<le> B"
103.772 + using assms card_of_ordLeq[of A] by fastforce
103.773 + obtain g where g_def:
103.774 + "g = (\<lambda>(a,c::'c). (f a,c))" by blast
103.775 + have "inj_on g (A \<times> C) \<and> g ` (A \<times> C) \<le> (B \<times> C)"
103.776 + using 1 unfolding inj_on_def using g_def by auto
103.777 + thus ?thesis using card_of_ordLeq by metis
103.778 +qed
103.779 +
103.780 +
103.781 +corollary ordLeq_Times_mono1:
103.782 +assumes "r \<le>o r'"
103.783 +shows "|(Field r) \<times> C| \<le>o |(Field r') \<times> C|"
103.784 +using assms card_of_mono2 card_of_Times_mono1 by blast
103.785 +
103.786 +
103.787 +lemma card_of_Times_mono2:
103.788 +assumes "|A| \<le>o |B|"
103.789 +shows "|C \<times> A| \<le>o |C \<times> B|"
103.790 +using assms card_of_Times_mono1[of A B C]
103.791 + card_of_Times_commute[of C A] card_of_Times_commute[of B C]
103.792 + ordIso_ordLeq_trans[of "|C \<times> A|"] ordLeq_ordIso_trans[of "|C \<times> A|"]
103.793 +by blast
103.794 +
103.795 +
103.796 +corollary ordLeq_Times_mono2:
103.797 +assumes "r \<le>o r'"
103.798 +shows "|A \<times> (Field r)| \<le>o |A \<times> (Field r')|"
103.799 +using assms card_of_mono2 card_of_Times_mono2 by blast
103.800 +
103.801 +
103.802 +lemma card_of_Sigma_mono1:
103.803 +assumes "\<forall>i \<in> I. |A i| \<le>o |B i|"
103.804 +shows "|SIGMA i : I. A i| \<le>o |SIGMA i : I. B i|"
103.805 +proof-
103.806 + have "\<forall>i. i \<in> I \<longrightarrow> (\<exists>f. inj_on f (A i) \<and> f ` (A i) \<le> B i)"
103.807 + using assms by (auto simp add: card_of_ordLeq)
103.808 + with choice[of "\<lambda> i f. i \<in> I \<longrightarrow> inj_on f (A i) \<and> f ` (A i) \<le> B i"]
103.809 + obtain F where 1: "\<forall>i \<in> I. inj_on (F i) (A i) \<and> (F i) ` (A i) \<le> B i" by metis
103.810 + obtain g where g_def: "g = (\<lambda>(i,a::'b). (i,F i a))" by blast
103.811 + have "inj_on g (Sigma I A) \<and> g ` (Sigma I A) \<le> (Sigma I B)"
103.812 + using 1 unfolding inj_on_def using g_def by force
103.813 + thus ?thesis using card_of_ordLeq by metis
103.814 +qed
103.815 +
103.816 +
103.817 +corollary card_of_Sigma_Times:
103.818 +"\<forall>i \<in> I. |A i| \<le>o |B| \<Longrightarrow> |SIGMA i : I. A i| \<le>o |I \<times> B|"
103.819 +using card_of_Sigma_mono1[of I A "\<lambda>i. B"] .
103.820 +
103.821 +
103.822 +lemma card_of_UNION_Sigma:
103.823 +"|\<Union>i \<in> I. A i| \<le>o |SIGMA i : I. A i|"
103.824 +using Ex_inj_on_UNION_Sigma[of I A] card_of_ordLeq by metis
103.825 +
103.826 +
103.827 +lemma card_of_bool:
103.828 +assumes "a1 \<noteq> a2"
103.829 +shows "|UNIV::bool set| =o |{a1,a2}|"
103.830 +proof-
103.831 + let ?f = "\<lambda> bl. case bl of True \<Rightarrow> a1 | False \<Rightarrow> a2"
103.832 + have "bij_betw ?f UNIV {a1,a2}"
103.833 + proof-
103.834 + {fix bl1 and bl2 assume "?f bl1 = ?f bl2"
103.835 + hence "bl1 = bl2" using assms by (case_tac bl1, case_tac bl2, auto)
103.836 + }
103.837 + moreover
103.838 + {fix bl have "?f bl \<in> {a1,a2}" by (case_tac bl, auto)
103.839 + }
103.840 + moreover
103.841 + {fix a assume *: "a \<in> {a1,a2}"
103.842 + have "a \<in> ?f ` UNIV"
103.843 + proof(cases "a = a1")
103.844 + assume "a = a1"
103.845 + hence "?f True = a" by auto thus ?thesis by blast
103.846 + next
103.847 + assume "a \<noteq> a1" hence "a = a2" using * by auto
103.848 + hence "?f False = a" by auto thus ?thesis by blast
103.849 + qed
103.850 + }
103.851 + ultimately show ?thesis unfolding bij_betw_def inj_on_def
103.852 + by (metis image_subsetI order_eq_iff subsetI)
103.853 + qed
103.854 + thus ?thesis using card_of_ordIso by blast
103.855 +qed
103.856 +
103.857 +
103.858 +lemma card_of_Plus_Times_aux:
103.859 +assumes A2: "a1 \<noteq> a2 \<and> {a1,a2} \<le> A" and
103.860 + LEQ: "|A| \<le>o |B|"
103.861 +shows "|A <+> B| \<le>o |A \<times> B|"
103.862 +proof-
103.863 + have 1: "|UNIV::bool set| \<le>o |A|"
103.864 + using A2 card_of_mono1[of "{a1,a2}"] card_of_bool[of a1 a2]
103.865 + ordIso_ordLeq_trans[of "|UNIV::bool set|"] by metis
103.866 + (* *)
103.867 + have "|A <+> B| \<le>o |B <+> B|"
103.868 + using LEQ card_of_Plus_mono1 by blast
103.869 + moreover have "|B <+> B| =o |B \<times> (UNIV::bool set)|"
103.870 + using card_of_Plus_Times_bool by blast
103.871 + moreover have "|B \<times> (UNIV::bool set)| \<le>o |B \<times> A|"
103.872 + using 1 by (simp add: card_of_Times_mono2)
103.873 + moreover have " |B \<times> A| =o |A \<times> B|"
103.874 + using card_of_Times_commute by blast
103.875 + ultimately show "|A <+> B| \<le>o |A \<times> B|"
103.876 + using ordLeq_ordIso_trans[of "|A <+> B|" "|B <+> B|" "|B \<times> (UNIV::bool set)|"]
103.877 + ordLeq_transitive[of "|A <+> B|" "|B \<times> (UNIV::bool set)|" "|B \<times> A|"]
103.878 + ordLeq_ordIso_trans[of "|A <+> B|" "|B \<times> A|" "|A \<times> B|"]
103.879 + by blast
103.880 +qed
103.881 +
103.882 +
103.883 +lemma card_of_Plus_Times:
103.884 +assumes A2: "a1 \<noteq> a2 \<and> {a1,a2} \<le> A" and
103.885 + B2: "b1 \<noteq> b2 \<and> {b1,b2} \<le> B"
103.886 +shows "|A <+> B| \<le>o |A \<times> B|"
103.887 +proof-
103.888 + {assume "|A| \<le>o |B|"
103.889 + hence ?thesis using assms by (auto simp add: card_of_Plus_Times_aux)
103.890 + }
103.891 + moreover
103.892 + {assume "|B| \<le>o |A|"
103.893 + hence "|B <+> A| \<le>o |B \<times> A|"
103.894 + using assms by (auto simp add: card_of_Plus_Times_aux)
103.895 + hence ?thesis
103.896 + using card_of_Plus_commute card_of_Times_commute
103.897 + ordIso_ordLeq_trans ordLeq_ordIso_trans by metis
103.898 + }
103.899 + ultimately show ?thesis
103.900 + using card_of_Well_order[of A] card_of_Well_order[of B]
103.901 + ordLeq_total[of "|A|"] by metis
103.902 +qed
103.903 +
103.904 +
103.905 +lemma card_of_ordLeq_finite:
103.906 +assumes "|A| \<le>o |B|" and "finite B"
103.907 +shows "finite A"
103.908 +using assms unfolding ordLeq_def
103.909 +using embed_inj_on[of "|A|" "|B|"] embed_Field[of "|A|" "|B|"]
103.910 + Field_card_of[of "A"] Field_card_of[of "B"] inj_on_finite[of _ "A" "B"] by fastforce
103.911 +
103.912 +
103.913 +lemma card_of_ordLeq_infinite:
103.914 +assumes "|A| \<le>o |B|" and "\<not> finite A"
103.915 +shows "\<not> finite B"
103.916 +using assms card_of_ordLeq_finite by auto
103.917 +
103.918 +
103.919 +lemma card_of_ordIso_finite:
103.920 +assumes "|A| =o |B|"
103.921 +shows "finite A = finite B"
103.922 +using assms unfolding ordIso_def iso_def[abs_def]
103.923 +by (auto simp: bij_betw_finite Field_card_of)
103.924 +
103.925 +
103.926 +lemma card_of_ordIso_finite_Field:
103.927 +assumes "Card_order r" and "r =o |A|"
103.928 +shows "finite(Field r) = finite A"
103.929 +using assms card_of_Field_ordIso card_of_ordIso_finite ordIso_equivalence by blast
103.930 +
103.931 +
103.932 +subsection {* Cardinals versus set operations involving infinite sets *}
103.933 +
103.934 +
103.935 +text{* Here we show that, for infinite sets, most set-theoretic constructions
103.936 +do not increase the cardinality. The cornerstone for this is
103.937 +theorem @{text "Card_order_Times_same_infinite"}, which states that self-product
103.938 +does not increase cardinality -- the proof of this fact adapts a standard
103.939 +set-theoretic argument, as presented, e.g., in the proof of theorem 1.5.11
103.940 +at page 47 in \cite{card-book}. Then everything else follows fairly easily. *}
103.941 +
103.942 +
103.943 +lemma infinite_iff_card_of_nat:
103.944 +"\<not> finite A \<longleftrightarrow> ( |UNIV::nat set| \<le>o |A| )"
103.945 +unfolding infinite_iff_countable_subset card_of_ordLeq ..
103.946 +
103.947 +text{* The next two results correspond to the ZF fact that all infinite cardinals are
103.948 +limit ordinals: *}
103.949 +
103.950 +lemma Card_order_infinite_not_under:
103.951 +assumes CARD: "Card_order r" and INF: "\<not>finite (Field r)"
103.952 +shows "\<not> (\<exists>a. Field r = rel.under r a)"
103.953 +proof(auto)
103.954 + have 0: "Well_order r \<and> wo_rel r \<and> Refl r"
103.955 + using CARD unfolding wo_rel_def card_order_on_def order_on_defs by auto
103.956 + fix a assume *: "Field r = rel.under r a"
103.957 + show False
103.958 + proof(cases "a \<in> Field r")
103.959 + assume Case1: "a \<notin> Field r"
103.960 + hence "rel.under r a = {}" unfolding Field_def rel.under_def by auto
103.961 + thus False using INF * by auto
103.962 + next
103.963 + let ?r' = "Restr r (rel.underS r a)"
103.964 + assume Case2: "a \<in> Field r"
103.965 + hence 1: "rel.under r a = rel.underS r a \<union> {a} \<and> a \<notin> rel.underS r a"
103.966 + using 0 rel.Refl_under_underS rel.underS_notIn by metis
103.967 + have 2: "wo_rel.ofilter r (rel.underS r a) \<and> rel.underS r a < Field r"
103.968 + using 0 wo_rel.underS_ofilter * 1 Case2 by fast
103.969 + hence "?r' <o r" using 0 using ofilter_ordLess by blast
103.970 + moreover
103.971 + have "Field ?r' = rel.underS r a \<and> Well_order ?r'"
103.972 + using 2 0 Field_Restr_ofilter[of r] Well_order_Restr[of r] by blast
103.973 + ultimately have "|rel.underS r a| <o r" using ordLess_Field[of ?r'] by auto
103.974 + moreover have "|rel.under r a| =o r" using * CARD card_of_Field_ordIso[of r] by auto
103.975 + ultimately have "|rel.underS r a| <o |rel.under r a|"
103.976 + using ordIso_symmetric ordLess_ordIso_trans by blast
103.977 + moreover
103.978 + {have "\<exists>f. bij_betw f (rel.under r a) (rel.underS r a)"
103.979 + using infinite_imp_bij_betw[of "Field r" a] INF * 1 by auto
103.980 + hence "|rel.under r a| =o |rel.underS r a|" using card_of_ordIso by blast
103.981 + }
103.982 + ultimately show False using not_ordLess_ordIso ordIso_symmetric by blast
103.983 + qed
103.984 +qed
103.985 +
103.986 +
103.987 +lemma infinite_Card_order_limit:
103.988 +assumes r: "Card_order r" and "\<not>finite (Field r)"
103.989 +and a: "a : Field r"
103.990 +shows "EX b : Field r. a \<noteq> b \<and> (a,b) : r"
103.991 +proof-
103.992 + have "Field r \<noteq> rel.under r a"
103.993 + using assms Card_order_infinite_not_under by blast
103.994 + moreover have "rel.under r a \<le> Field r"
103.995 + using rel.under_Field .
103.996 + ultimately have "rel.under r a < Field r" by blast
103.997 + then obtain b where 1: "b : Field r \<and> ~ (b,a) : r"
103.998 + unfolding rel.under_def by blast
103.999 + moreover have ba: "b \<noteq> a"
103.1000 + using 1 r unfolding card_order_on_def well_order_on_def
103.1001 + linear_order_on_def partial_order_on_def preorder_on_def refl_on_def by auto
103.1002 + ultimately have "(a,b) : r"
103.1003 + using a r unfolding card_order_on_def well_order_on_def linear_order_on_def
103.1004 + total_on_def by blast
103.1005 + thus ?thesis using 1 ba by auto
103.1006 +qed
103.1007 +
103.1008 +
103.1009 +theorem Card_order_Times_same_infinite:
103.1010 +assumes CO: "Card_order r" and INF: "\<not>finite(Field r)"
103.1011 +shows "|Field r \<times> Field r| \<le>o r"
103.1012 +proof-
103.1013 + obtain phi where phi_def:
103.1014 + "phi = (\<lambda>r::'a rel. Card_order r \<and> \<not>finite(Field r) \<and>
103.1015 + \<not> |Field r \<times> Field r| \<le>o r )" by blast
103.1016 + have temp1: "\<forall>r. phi r \<longrightarrow> Well_order r"
103.1017 + unfolding phi_def card_order_on_def by auto
103.1018 + have Ft: "\<not>(\<exists>r. phi r)"
103.1019 + proof
103.1020 + assume "\<exists>r. phi r"
103.1021 + hence "{r. phi r} \<noteq> {} \<and> {r. phi r} \<le> {r. Well_order r}"
103.1022 + using temp1 by auto
103.1023 + then obtain r where 1: "phi r" and 2: "\<forall>r'. phi r' \<longrightarrow> r \<le>o r'" and
103.1024 + 3: "Card_order r \<and> Well_order r"
103.1025 + using exists_minim_Well_order[of "{r. phi r}"] temp1 phi_def by blast
103.1026 + let ?A = "Field r" let ?r' = "bsqr r"
103.1027 + have 4: "Well_order ?r' \<and> Field ?r' = ?A \<times> ?A \<and> |?A| =o r"
103.1028 + using 3 bsqr_Well_order Field_bsqr card_of_Field_ordIso by blast
103.1029 + have 5: "Card_order |?A \<times> ?A| \<and> Well_order |?A \<times> ?A|"
103.1030 + using card_of_Card_order card_of_Well_order by blast
103.1031 + (* *)
103.1032 + have "r <o |?A \<times> ?A|"
103.1033 + using 1 3 5 ordLess_or_ordLeq unfolding phi_def by blast
103.1034 + moreover have "|?A \<times> ?A| \<le>o ?r'"
103.1035 + using card_of_least[of "?A \<times> ?A"] 4 by auto
103.1036 + ultimately have "r <o ?r'" using ordLess_ordLeq_trans by auto
103.1037 + then obtain f where 6: "embed r ?r' f" and 7: "\<not> bij_betw f ?A (?A \<times> ?A)"
103.1038 + unfolding ordLess_def embedS_def[abs_def]
103.1039 + by (auto simp add: Field_bsqr)
103.1040 + let ?B = "f ` ?A"
103.1041 + have "|?A| =o |?B|"
103.1042 + using 3 6 embed_inj_on inj_on_imp_bij_betw card_of_ordIso by blast
103.1043 + hence 8: "r =o |?B|" using 4 ordIso_transitive ordIso_symmetric by blast
103.1044 + (* *)
103.1045 + have "wo_rel.ofilter ?r' ?B"
103.1046 + using 6 embed_Field_ofilter 3 4 by blast
103.1047 + hence "wo_rel.ofilter ?r' ?B \<and> ?B \<noteq> ?A \<times> ?A \<and> ?B \<noteq> Field ?r'"
103.1048 + using 7 unfolding bij_betw_def using 6 3 embed_inj_on 4 by auto
103.1049 + hence temp2: "wo_rel.ofilter ?r' ?B \<and> ?B < ?A \<times> ?A"
103.1050 + using 4 wo_rel_def[of ?r'] wo_rel.ofilter_def[of ?r' ?B] by blast
103.1051 + have "\<not> (\<exists>a. Field r = rel.under r a)"
103.1052 + using 1 unfolding phi_def using Card_order_infinite_not_under[of r] by auto
103.1053 + then obtain A1 where temp3: "wo_rel.ofilter r A1 \<and> A1 < ?A" and 9: "?B \<le> A1 \<times> A1"
103.1054 + using temp2 3 bsqr_ofilter[of r ?B] by blast
103.1055 + hence "|?B| \<le>o |A1 \<times> A1|" using card_of_mono1 by blast
103.1056 + hence 10: "r \<le>o |A1 \<times> A1|" using 8 ordIso_ordLeq_trans by blast
103.1057 + let ?r1 = "Restr r A1"
103.1058 + have "?r1 <o r" using temp3 ofilter_ordLess 3 by blast
103.1059 + moreover
103.1060 + {have "well_order_on A1 ?r1" using 3 temp3 well_order_on_Restr by blast
103.1061 + hence "|A1| \<le>o ?r1" using 3 Well_order_Restr card_of_least by blast
103.1062 + }
103.1063 + ultimately have 11: "|A1| <o r" using ordLeq_ordLess_trans by blast
103.1064 + (* *)
103.1065 + have "\<not> finite (Field r)" using 1 unfolding phi_def by simp
103.1066 + hence "\<not> finite ?B" using 8 3 card_of_ordIso_finite_Field[of r ?B] by blast
103.1067 + hence "\<not> finite A1" using 9 finite_cartesian_product finite_subset by metis
103.1068 + moreover have temp4: "Field |A1| = A1 \<and> Well_order |A1| \<and> Card_order |A1|"
103.1069 + using card_of_Card_order[of A1] card_of_Well_order[of A1]
103.1070 + by (simp add: Field_card_of)
103.1071 + moreover have "\<not> r \<le>o | A1 |"
103.1072 + using temp4 11 3 using not_ordLeq_iff_ordLess by blast
103.1073 + ultimately have "\<not> finite(Field |A1| ) \<and> Card_order |A1| \<and> \<not> r \<le>o | A1 |"
103.1074 + by (simp add: card_of_card_order_on)
103.1075 + hence "|Field |A1| \<times> Field |A1| | \<le>o |A1|"
103.1076 + using 2 unfolding phi_def by blast
103.1077 + hence "|A1 \<times> A1 | \<le>o |A1|" using temp4 by auto
103.1078 + hence "r \<le>o |A1|" using 10 ordLeq_transitive by blast
103.1079 + thus False using 11 not_ordLess_ordLeq by auto
103.1080 + qed
103.1081 + thus ?thesis using assms unfolding phi_def by blast
103.1082 +qed
103.1083 +
103.1084 +
103.1085 +corollary card_of_Times_same_infinite:
103.1086 +assumes "\<not>finite A"
103.1087 +shows "|A \<times> A| =o |A|"
103.1088 +proof-
103.1089 + let ?r = "|A|"
103.1090 + have "Field ?r = A \<and> Card_order ?r"
103.1091 + using Field_card_of card_of_Card_order[of A] by fastforce
103.1092 + hence "|A \<times> A| \<le>o |A|"
103.1093 + using Card_order_Times_same_infinite[of ?r] assms by auto
103.1094 + thus ?thesis using card_of_Times3 ordIso_iff_ordLeq by blast
103.1095 +qed
103.1096 +
103.1097 +
103.1098 +lemma card_of_Times_infinite:
103.1099 +assumes INF: "\<not>finite A" and NE: "B \<noteq> {}" and LEQ: "|B| \<le>o |A|"
103.1100 +shows "|A \<times> B| =o |A| \<and> |B \<times> A| =o |A|"
103.1101 +proof-
103.1102 + have "|A| \<le>o |A \<times> B| \<and> |A| \<le>o |B \<times> A|"
103.1103 + using assms by (simp add: card_of_Times1 card_of_Times2)
103.1104 + moreover
103.1105 + {have "|A \<times> B| \<le>o |A \<times> A| \<and> |B \<times> A| \<le>o |A \<times> A|"
103.1106 + using LEQ card_of_Times_mono1 card_of_Times_mono2 by blast
103.1107 + moreover have "|A \<times> A| =o |A|" using INF card_of_Times_same_infinite by blast
103.1108 + ultimately have "|A \<times> B| \<le>o |A| \<and> |B \<times> A| \<le>o |A|"
103.1109 + using ordLeq_ordIso_trans[of "|A \<times> B|"] ordLeq_ordIso_trans[of "|B \<times> A|"] by auto
103.1110 + }
103.1111 + ultimately show ?thesis by (simp add: ordIso_iff_ordLeq)
103.1112 +qed
103.1113 +
103.1114 +
103.1115 +corollary Card_order_Times_infinite:
103.1116 +assumes INF: "\<not>finite(Field r)" and CARD: "Card_order r" and
103.1117 + NE: "Field p \<noteq> {}" and LEQ: "p \<le>o r"
103.1118 +shows "| (Field r) \<times> (Field p) | =o r \<and> | (Field p) \<times> (Field r) | =o r"
103.1119 +proof-
103.1120 + have "|Field r \<times> Field p| =o |Field r| \<and> |Field p \<times> Field r| =o |Field r|"
103.1121 + using assms by (simp add: card_of_Times_infinite card_of_mono2)
103.1122 + thus ?thesis
103.1123 + using assms card_of_Field_ordIso[of r]
103.1124 + ordIso_transitive[of "|Field r \<times> Field p|"]
103.1125 + ordIso_transitive[of _ "|Field r|"] by blast
103.1126 +qed
103.1127 +
103.1128 +
103.1129 +lemma card_of_Sigma_ordLeq_infinite:
103.1130 +assumes INF: "\<not>finite B" and
103.1131 + LEQ_I: "|I| \<le>o |B|" and LEQ: "\<forall>i \<in> I. |A i| \<le>o |B|"
103.1132 +shows "|SIGMA i : I. A i| \<le>o |B|"
103.1133 +proof(cases "I = {}", simp add: card_of_empty)
103.1134 + assume *: "I \<noteq> {}"
103.1135 + have "|SIGMA i : I. A i| \<le>o |I \<times> B|"
103.1136 + using LEQ card_of_Sigma_Times by blast
103.1137 + moreover have "|I \<times> B| =o |B|"
103.1138 + using INF * LEQ_I by (auto simp add: card_of_Times_infinite)
103.1139 + ultimately show ?thesis using ordLeq_ordIso_trans by blast
103.1140 +qed
103.1141 +
103.1142 +
103.1143 +lemma card_of_Sigma_ordLeq_infinite_Field:
103.1144 +assumes INF: "\<not>finite (Field r)" and r: "Card_order r" and
103.1145 + LEQ_I: "|I| \<le>o r" and LEQ: "\<forall>i \<in> I. |A i| \<le>o r"
103.1146 +shows "|SIGMA i : I. A i| \<le>o r"
103.1147 +proof-
103.1148 + let ?B = "Field r"
103.1149 + have 1: "r =o |?B| \<and> |?B| =o r" using r card_of_Field_ordIso
103.1150 + ordIso_symmetric by blast
103.1151 + hence "|I| \<le>o |?B|" "\<forall>i \<in> I. |A i| \<le>o |?B|"
103.1152 + using LEQ_I LEQ ordLeq_ordIso_trans by blast+
103.1153 + hence "|SIGMA i : I. A i| \<le>o |?B|" using INF LEQ
103.1154 + card_of_Sigma_ordLeq_infinite by blast
103.1155 + thus ?thesis using 1 ordLeq_ordIso_trans by blast
103.1156 +qed
103.1157 +
103.1158 +
103.1159 +lemma card_of_Times_ordLeq_infinite_Field:
103.1160 +"\<lbrakk>\<not>finite (Field r); |A| \<le>o r; |B| \<le>o r; Card_order r\<rbrakk>
103.1161 + \<Longrightarrow> |A <*> B| \<le>o r"
103.1162 +by(simp add: card_of_Sigma_ordLeq_infinite_Field)
103.1163 +
103.1164 +
103.1165 +lemma card_of_Times_infinite_simps:
103.1166 +"\<lbrakk>\<not>finite A; B \<noteq> {}; |B| \<le>o |A|\<rbrakk> \<Longrightarrow> |A \<times> B| =o |A|"
103.1167 +"\<lbrakk>\<not>finite A; B \<noteq> {}; |B| \<le>o |A|\<rbrakk> \<Longrightarrow> |A| =o |A \<times> B|"
103.1168 +"\<lbrakk>\<not>finite A; B \<noteq> {}; |B| \<le>o |A|\<rbrakk> \<Longrightarrow> |B \<times> A| =o |A|"
103.1169 +"\<lbrakk>\<not>finite A; B \<noteq> {}; |B| \<le>o |A|\<rbrakk> \<Longrightarrow> |A| =o |B \<times> A|"
103.1170 +by (auto simp add: card_of_Times_infinite ordIso_symmetric)
103.1171 +
103.1172 +
103.1173 +lemma card_of_UNION_ordLeq_infinite:
103.1174 +assumes INF: "\<not>finite B" and
103.1175 + LEQ_I: "|I| \<le>o |B|" and LEQ: "\<forall>i \<in> I. |A i| \<le>o |B|"
103.1176 +shows "|\<Union> i \<in> I. A i| \<le>o |B|"
103.1177 +proof(cases "I = {}", simp add: card_of_empty)
103.1178 + assume *: "I \<noteq> {}"
103.1179 + have "|\<Union> i \<in> I. A i| \<le>o |SIGMA i : I. A i|"
103.1180 + using card_of_UNION_Sigma by blast
103.1181 + moreover have "|SIGMA i : I. A i| \<le>o |B|"
103.1182 + using assms card_of_Sigma_ordLeq_infinite by blast
103.1183 + ultimately show ?thesis using ordLeq_transitive by blast
103.1184 +qed
103.1185 +
103.1186 +
103.1187 +corollary card_of_UNION_ordLeq_infinite_Field:
103.1188 +assumes INF: "\<not>finite (Field r)" and r: "Card_order r" and
103.1189 + LEQ_I: "|I| \<le>o r" and LEQ: "\<forall>i \<in> I. |A i| \<le>o r"
103.1190 +shows "|\<Union> i \<in> I. A i| \<le>o r"
103.1191 +proof-
103.1192 + let ?B = "Field r"
103.1193 + have 1: "r =o |?B| \<and> |?B| =o r" using r card_of_Field_ordIso
103.1194 + ordIso_symmetric by blast
103.1195 + hence "|I| \<le>o |?B|" "\<forall>i \<in> I. |A i| \<le>o |?B|"
103.1196 + using LEQ_I LEQ ordLeq_ordIso_trans by blast+
103.1197 + hence "|\<Union> i \<in> I. A i| \<le>o |?B|" using INF LEQ
103.1198 + card_of_UNION_ordLeq_infinite by blast
103.1199 + thus ?thesis using 1 ordLeq_ordIso_trans by blast
103.1200 +qed
103.1201 +
103.1202 +
103.1203 +lemma card_of_Plus_infinite1:
103.1204 +assumes INF: "\<not>finite A" and LEQ: "|B| \<le>o |A|"
103.1205 +shows "|A <+> B| =o |A|"
103.1206 +proof(cases "B = {}", simp add: card_of_Plus_empty1 card_of_Plus_empty2 ordIso_symmetric)
103.1207 + let ?Inl = "Inl::'a \<Rightarrow> 'a + 'b" let ?Inr = "Inr::'b \<Rightarrow> 'a + 'b"
103.1208 + assume *: "B \<noteq> {}"
103.1209 + then obtain b1 where 1: "b1 \<in> B" by blast
103.1210 + show ?thesis
103.1211 + proof(cases "B = {b1}")
103.1212 + assume Case1: "B = {b1}"
103.1213 + have 2: "bij_betw ?Inl A ((?Inl ` A))"
103.1214 + unfolding bij_betw_def inj_on_def by auto
103.1215 + hence 3: "\<not>finite (?Inl ` A)"
103.1216 + using INF bij_betw_finite[of ?Inl A] by blast
103.1217 + let ?A' = "?Inl ` A \<union> {?Inr b1}"
103.1218 + obtain g where "bij_betw g (?Inl ` A) ?A'"
103.1219 + using 3 infinite_imp_bij_betw2[of "?Inl ` A"] by auto
103.1220 + moreover have "?A' = A <+> B" using Case1 by blast
103.1221 + ultimately have "bij_betw g (?Inl ` A) (A <+> B)" by simp
103.1222 + hence "bij_betw (g o ?Inl) A (A <+> B)"
103.1223 + using 2 by (auto simp add: bij_betw_trans)
103.1224 + thus ?thesis using card_of_ordIso ordIso_symmetric by blast
103.1225 + next
103.1226 + assume Case2: "B \<noteq> {b1}"
103.1227 + with * 1 obtain b2 where 3: "b1 \<noteq> b2 \<and> {b1,b2} \<le> B" by fastforce
103.1228 + obtain f where "inj_on f B \<and> f ` B \<le> A"
103.1229 + using LEQ card_of_ordLeq[of B] by fastforce
103.1230 + with 3 have "f b1 \<noteq> f b2 \<and> {f b1, f b2} \<le> A"
103.1231 + unfolding inj_on_def by auto
103.1232 + with 3 have "|A <+> B| \<le>o |A \<times> B|"
103.1233 + by (auto simp add: card_of_Plus_Times)
103.1234 + moreover have "|A \<times> B| =o |A|"
103.1235 + using assms * by (simp add: card_of_Times_infinite_simps)
103.1236 + ultimately have "|A <+> B| \<le>o |A|" using ordLeq_ordIso_trans by metis
103.1237 + thus ?thesis using card_of_Plus1 ordIso_iff_ordLeq by blast
103.1238 + qed
103.1239 +qed
103.1240 +
103.1241 +
103.1242 +lemma card_of_Plus_infinite2:
103.1243 +assumes INF: "\<not>finite A" and LEQ: "|B| \<le>o |A|"
103.1244 +shows "|B <+> A| =o |A|"
103.1245 +using assms card_of_Plus_commute card_of_Plus_infinite1
103.1246 +ordIso_equivalence by blast
103.1247 +
103.1248 +
103.1249 +lemma card_of_Plus_infinite:
103.1250 +assumes INF: "\<not>finite A" and LEQ: "|B| \<le>o |A|"
103.1251 +shows "|A <+> B| =o |A| \<and> |B <+> A| =o |A|"
103.1252 +using assms by (auto simp: card_of_Plus_infinite1 card_of_Plus_infinite2)
103.1253 +
103.1254 +
103.1255 +corollary Card_order_Plus_infinite:
103.1256 +assumes INF: "\<not>finite(Field r)" and CARD: "Card_order r" and
103.1257 + LEQ: "p \<le>o r"
103.1258 +shows "| (Field r) <+> (Field p) | =o r \<and> | (Field p) <+> (Field r) | =o r"
103.1259 +proof-
103.1260 + have "| Field r <+> Field p | =o | Field r | \<and>
103.1261 + | Field p <+> Field r | =o | Field r |"
103.1262 + using assms by (simp add: card_of_Plus_infinite card_of_mono2)
103.1263 + thus ?thesis
103.1264 + using assms card_of_Field_ordIso[of r]
103.1265 + ordIso_transitive[of "|Field r <+> Field p|"]
103.1266 + ordIso_transitive[of _ "|Field r|"] by blast
103.1267 +qed
103.1268 +
103.1269 +
103.1270 +subsection {* The cardinal $\omega$ and the finite cardinals *}
103.1271 +
103.1272 +
103.1273 +text{* The cardinal $\omega$, of natural numbers, shall be the standard non-strict
103.1274 +order relation on
103.1275 +@{text "nat"}, that we abbreviate by @{text "natLeq"}. The finite cardinals
103.1276 +shall be the restrictions of these relations to the numbers smaller than
103.1277 +fixed numbers @{text "n"}, that we abbreviate by @{text "natLeq_on n"}. *}
103.1278 +
103.1279 +abbreviation "(natLeq::(nat * nat) set) \<equiv> {(x,y). x \<le> y}"
103.1280 +abbreviation "(natLess::(nat * nat) set) \<equiv> {(x,y). x < y}"
103.1281 +
103.1282 +abbreviation natLeq_on :: "nat \<Rightarrow> (nat * nat) set"
103.1283 +where "natLeq_on n \<equiv> {(x,y). x < n \<and> y < n \<and> x \<le> y}"
103.1284 +
103.1285 +lemma infinite_cartesian_product:
103.1286 +assumes "\<not>finite A" "\<not>finite B"
103.1287 +shows "\<not>finite (A \<times> B)"
103.1288 +proof
103.1289 + assume "finite (A \<times> B)"
103.1290 + from assms(1) have "A \<noteq> {}" by auto
103.1291 + with `finite (A \<times> B)` have "finite B" using finite_cartesian_productD2 by auto
103.1292 + with assms(2) show False by simp
103.1293 +qed
103.1294 +
103.1295 +
103.1296 +subsubsection {* First as well-orders *}
103.1297 +
103.1298 +
103.1299 +lemma Field_natLeq: "Field natLeq = (UNIV::nat set)"
103.1300 +by(unfold Field_def, auto)
103.1301 +
103.1302 +
103.1303 +lemma natLeq_Refl: "Refl natLeq"
103.1304 +unfolding refl_on_def Field_def by auto
103.1305 +
103.1306 +
103.1307 +lemma natLeq_trans: "trans natLeq"
103.1308 +unfolding trans_def by auto
103.1309 +
103.1310 +
103.1311 +lemma natLeq_Preorder: "Preorder natLeq"
103.1312 +unfolding preorder_on_def
103.1313 +by (auto simp add: natLeq_Refl natLeq_trans)
103.1314 +
103.1315 +
103.1316 +lemma natLeq_antisym: "antisym natLeq"
103.1317 +unfolding antisym_def by auto
103.1318 +
103.1319 +
103.1320 +lemma natLeq_Partial_order: "Partial_order natLeq"
103.1321 +unfolding partial_order_on_def
103.1322 +by (auto simp add: natLeq_Preorder natLeq_antisym)
103.1323 +
103.1324 +
103.1325 +lemma natLeq_Total: "Total natLeq"
103.1326 +unfolding total_on_def by auto
103.1327 +
103.1328 +
103.1329 +lemma natLeq_Linear_order: "Linear_order natLeq"
103.1330 +unfolding linear_order_on_def
103.1331 +by (auto simp add: natLeq_Partial_order natLeq_Total)
103.1332 +
103.1333 +
103.1334 +lemma natLeq_natLess_Id: "natLess = natLeq - Id"
103.1335 +by auto
103.1336 +
103.1337 +
103.1338 +lemma natLeq_Well_order: "Well_order natLeq"
103.1339 +unfolding well_order_on_def
103.1340 +using natLeq_Linear_order wf_less natLeq_natLess_Id by auto
103.1341 +
103.1342 +
103.1343 +lemma Field_natLeq_on: "Field (natLeq_on n) = {x. x < n}"
103.1344 +unfolding Field_def by auto
103.1345 +
103.1346 +
103.1347 +lemma natLeq_underS_less: "rel.underS natLeq n = {x. x < n}"
103.1348 +unfolding rel.underS_def by auto
103.1349 +
103.1350 +
103.1351 +lemma Restr_natLeq: "Restr natLeq {x. x < n} = natLeq_on n"
103.1352 +by force
103.1353 +
103.1354 +
103.1355 +lemma Restr_natLeq2:
103.1356 +"Restr natLeq (rel.underS natLeq n) = natLeq_on n"
103.1357 +by (auto simp add: Restr_natLeq natLeq_underS_less)
103.1358 +
103.1359 +
103.1360 +lemma natLeq_on_Well_order: "Well_order(natLeq_on n)"
103.1361 +using Restr_natLeq[of n] natLeq_Well_order
103.1362 + Well_order_Restr[of natLeq "{x. x < n}"] by auto
103.1363 +
103.1364 +
103.1365 +corollary natLeq_on_well_order_on: "well_order_on {x. x < n} (natLeq_on n)"
103.1366 +using natLeq_on_Well_order Field_natLeq_on by auto
103.1367 +
103.1368 +
103.1369 +lemma natLeq_on_wo_rel: "wo_rel(natLeq_on n)"
103.1370 +unfolding wo_rel_def using natLeq_on_Well_order .
103.1371 +
103.1372 +
103.1373 +
103.1374 +subsubsection {* Then as cardinals *}
103.1375 +
103.1376 +
103.1377 +lemma natLeq_Card_order: "Card_order natLeq"
103.1378 +proof(auto simp add: natLeq_Well_order
103.1379 + Card_order_iff_Restr_underS Restr_natLeq2, simp add: Field_natLeq)
103.1380 + fix n have "finite(Field (natLeq_on n))" by (auto simp: Field_def)
103.1381 + moreover have "\<not>finite(UNIV::nat set)" by auto
103.1382 + ultimately show "natLeq_on n <o |UNIV::nat set|"
103.1383 + using finite_ordLess_infinite[of "natLeq_on n" "|UNIV::nat set|"]
103.1384 + Field_card_of[of "UNIV::nat set"]
103.1385 + card_of_Well_order[of "UNIV::nat set"] natLeq_on_Well_order[of n] by auto
103.1386 +qed
103.1387 +
103.1388 +
103.1389 +corollary card_of_Field_natLeq:
103.1390 +"|Field natLeq| =o natLeq"
103.1391 +using Field_natLeq natLeq_Card_order Card_order_iff_ordIso_card_of[of natLeq]
103.1392 + ordIso_symmetric[of natLeq] by blast
103.1393 +
103.1394 +
103.1395 +corollary card_of_nat:
103.1396 +"|UNIV::nat set| =o natLeq"
103.1397 +using Field_natLeq card_of_Field_natLeq by auto
103.1398 +
103.1399 +
103.1400 +corollary infinite_iff_natLeq_ordLeq:
103.1401 +"\<not>finite A = ( natLeq \<le>o |A| )"
103.1402 +using infinite_iff_card_of_nat[of A] card_of_nat
103.1403 + ordIso_ordLeq_trans ordLeq_ordIso_trans ordIso_symmetric by blast
103.1404 +
103.1405 +corollary finite_iff_ordLess_natLeq:
103.1406 +"finite A = ( |A| <o natLeq)"
103.1407 +using infinite_iff_natLeq_ordLeq not_ordLeq_iff_ordLess
103.1408 + card_of_Well_order natLeq_Well_order by metis
103.1409 +
103.1410 +
103.1411 +subsection {* The successor of a cardinal *}
103.1412 +
103.1413 +
103.1414 +text{* First we define @{text "isCardSuc r r'"}, the notion of @{text "r'"}
103.1415 +being a successor cardinal of @{text "r"}. Although the definition does
103.1416 +not require @{text "r"} to be a cardinal, only this case will be meaningful. *}
103.1417 +
103.1418 +
103.1419 +definition isCardSuc :: "'a rel \<Rightarrow> 'a set rel \<Rightarrow> bool"
103.1420 +where
103.1421 +"isCardSuc r r' \<equiv>
103.1422 + Card_order r' \<and> r <o r' \<and>
103.1423 + (\<forall>(r''::'a set rel). Card_order r'' \<and> r <o r'' \<longrightarrow> r' \<le>o r'')"
103.1424 +
103.1425 +
103.1426 +text{* Now we introduce the cardinal-successor operator @{text "cardSuc"},
103.1427 +by picking {\em some} cardinal-order relation fulfilling @{text "isCardSuc"}.
103.1428 +Again, the picked item shall be proved unique up to order-isomorphism. *}
103.1429 +
103.1430 +
103.1431 +definition cardSuc :: "'a rel \<Rightarrow> 'a set rel"
103.1432 +where
103.1433 +"cardSuc r \<equiv> SOME r'. isCardSuc r r'"
103.1434 +
103.1435 +
103.1436 +lemma exists_minim_Card_order:
103.1437 +"\<lbrakk>R \<noteq> {}; \<forall>r \<in> R. Card_order r\<rbrakk> \<Longrightarrow> \<exists>r \<in> R. \<forall>r' \<in> R. r \<le>o r'"
103.1438 +unfolding card_order_on_def using exists_minim_Well_order by blast
103.1439 +
103.1440 +
103.1441 +lemma exists_isCardSuc:
103.1442 +assumes "Card_order r"
103.1443 +shows "\<exists>r'. isCardSuc r r'"
103.1444 +proof-
103.1445 + let ?R = "{(r'::'a set rel). Card_order r' \<and> r <o r'}"
103.1446 + have "|Pow(Field r)| \<in> ?R \<and> (\<forall>r \<in> ?R. Card_order r)" using assms
103.1447 + by (simp add: card_of_Card_order Card_order_Pow)
103.1448 + then obtain r where "r \<in> ?R \<and> (\<forall>r' \<in> ?R. r \<le>o r')"
103.1449 + using exists_minim_Card_order[of ?R] by blast
103.1450 + thus ?thesis unfolding isCardSuc_def by auto
103.1451 +qed
103.1452 +
103.1453 +
103.1454 +lemma cardSuc_isCardSuc:
103.1455 +assumes "Card_order r"
103.1456 +shows "isCardSuc r (cardSuc r)"
103.1457 +unfolding cardSuc_def using assms
103.1458 +by (simp add: exists_isCardSuc someI_ex)
103.1459 +
103.1460 +
103.1461 +lemma cardSuc_Card_order:
103.1462 +"Card_order r \<Longrightarrow> Card_order(cardSuc r)"
103.1463 +using cardSuc_isCardSuc unfolding isCardSuc_def by blast
103.1464 +
103.1465 +
103.1466 +lemma cardSuc_greater:
103.1467 +"Card_order r \<Longrightarrow> r <o cardSuc r"
103.1468 +using cardSuc_isCardSuc unfolding isCardSuc_def by blast
103.1469 +
103.1470 +
103.1471 +lemma cardSuc_ordLeq:
103.1472 +"Card_order r \<Longrightarrow> r \<le>o cardSuc r"
103.1473 +using cardSuc_greater ordLeq_iff_ordLess_or_ordIso by blast
103.1474 +
103.1475 +
103.1476 +text{* The minimality property of @{text "cardSuc"} originally present in its definition
103.1477 +is local to the type @{text "'a set rel"}, i.e., that of @{text "cardSuc r"}: *}
103.1478 +
103.1479 +lemma cardSuc_least_aux:
103.1480 +"\<lbrakk>Card_order (r::'a rel); Card_order (r'::'a set rel); r <o r'\<rbrakk> \<Longrightarrow> cardSuc r \<le>o r'"
103.1481 +using cardSuc_isCardSuc unfolding isCardSuc_def by blast
103.1482 +
103.1483 +
103.1484 +text{* But from this we can infer general minimality: *}
103.1485 +
103.1486 +lemma cardSuc_least:
103.1487 +assumes CARD: "Card_order r" and CARD': "Card_order r'" and LESS: "r <o r'"
103.1488 +shows "cardSuc r \<le>o r'"
103.1489 +proof-
103.1490 + let ?p = "cardSuc r"
103.1491 + have 0: "Well_order ?p \<and> Well_order r'"
103.1492 + using assms cardSuc_Card_order unfolding card_order_on_def by blast
103.1493 + {assume "r' <o ?p"
103.1494 + then obtain r'' where 1: "Field r'' < Field ?p" and 2: "r' =o r'' \<and> r'' <o ?p"
103.1495 + using internalize_ordLess[of r' ?p] by blast
103.1496 + (* *)
103.1497 + have "Card_order r''" using CARD' Card_order_ordIso2 2 by blast
103.1498 + moreover have "r <o r''" using LESS 2 ordLess_ordIso_trans by blast
103.1499 + ultimately have "?p \<le>o r''" using cardSuc_least_aux CARD by blast
103.1500 + hence False using 2 not_ordLess_ordLeq by blast
103.1501 + }
103.1502 + thus ?thesis using 0 ordLess_or_ordLeq by blast
103.1503 +qed
103.1504 +
103.1505 +
103.1506 +lemma cardSuc_ordLess_ordLeq:
103.1507 +assumes CARD: "Card_order r" and CARD': "Card_order r'"
103.1508 +shows "(r <o r') = (cardSuc r \<le>o r')"
103.1509 +proof(auto simp add: assms cardSuc_least)
103.1510 + assume "cardSuc r \<le>o r'"
103.1511 + thus "r <o r'" using assms cardSuc_greater ordLess_ordLeq_trans by blast
103.1512 +qed
103.1513 +
103.1514 +
103.1515 +lemma cardSuc_ordLeq_ordLess:
103.1516 +assumes CARD: "Card_order r" and CARD': "Card_order r'"
103.1517 +shows "(r' <o cardSuc r) = (r' \<le>o r)"
103.1518 +proof-
103.1519 + have "Well_order r \<and> Well_order r'"
103.1520 + using assms unfolding card_order_on_def by auto
103.1521 + moreover have "Well_order(cardSuc r)"
103.1522 + using assms cardSuc_Card_order card_order_on_def by blast
103.1523 + ultimately show ?thesis
103.1524 + using assms cardSuc_ordLess_ordLeq[of r r']
103.1525 + not_ordLeq_iff_ordLess[of r r'] not_ordLeq_iff_ordLess[of r' "cardSuc r"] by blast
103.1526 +qed
103.1527 +
103.1528 +
103.1529 +lemma cardSuc_mono_ordLeq:
103.1530 +assumes CARD: "Card_order r" and CARD': "Card_order r'"
103.1531 +shows "(cardSuc r \<le>o cardSuc r') = (r \<le>o r')"
103.1532 +using assms cardSuc_ordLeq_ordLess cardSuc_ordLess_ordLeq cardSuc_Card_order by blast
103.1533 +
103.1534 +
103.1535 +lemma cardSuc_invar_ordIso:
103.1536 +assumes CARD: "Card_order r" and CARD': "Card_order r'"
103.1537 +shows "(cardSuc r =o cardSuc r') = (r =o r')"
103.1538 +proof-
103.1539 + have 0: "Well_order r \<and> Well_order r' \<and> Well_order(cardSuc r) \<and> Well_order(cardSuc r')"
103.1540 + using assms by (simp add: card_order_on_well_order_on cardSuc_Card_order)
103.1541 + thus ?thesis
103.1542 + using ordIso_iff_ordLeq[of r r'] ordIso_iff_ordLeq
103.1543 + using cardSuc_mono_ordLeq[of r r'] cardSuc_mono_ordLeq[of r' r] assms by blast
103.1544 +qed
103.1545 +
103.1546 +
103.1547 +lemma card_of_cardSuc_finite:
103.1548 +"finite(Field(cardSuc |A| )) = finite A"
103.1549 +proof
103.1550 + assume *: "finite (Field (cardSuc |A| ))"
103.1551 + have 0: "|Field(cardSuc |A| )| =o cardSuc |A|"
103.1552 + using card_of_Card_order cardSuc_Card_order card_of_Field_ordIso by blast
103.1553 + hence "|A| \<le>o |Field(cardSuc |A| )|"
103.1554 + using card_of_Card_order[of A] cardSuc_ordLeq[of "|A|"] ordIso_symmetric
103.1555 + ordLeq_ordIso_trans by blast
103.1556 + thus "finite A" using * card_of_ordLeq_finite by blast
103.1557 +next
103.1558 + assume "finite A"
103.1559 + then have "finite ( Field |Pow A| )" unfolding Field_card_of by simp
103.1560 + then show "finite (Field (cardSuc |A| ))"
103.1561 + proof (rule card_of_ordLeq_finite[OF card_of_mono2, rotated])
103.1562 + show "cardSuc |A| \<le>o |Pow A|"
103.1563 + by (metis cardSuc_ordLess_ordLeq card_of_Card_order card_of_Pow)
103.1564 + qed
103.1565 +qed
103.1566 +
103.1567 +
103.1568 +lemma cardSuc_finite:
103.1569 +assumes "Card_order r"
103.1570 +shows "finite (Field (cardSuc r)) = finite (Field r)"
103.1571 +proof-
103.1572 + let ?A = "Field r"
103.1573 + have "|?A| =o r" using assms by (simp add: card_of_Field_ordIso)
103.1574 + hence "cardSuc |?A| =o cardSuc r" using assms
103.1575 + by (simp add: card_of_Card_order cardSuc_invar_ordIso)
103.1576 + moreover have "|Field (cardSuc |?A| ) | =o cardSuc |?A|"
103.1577 + by (simp add: card_of_card_order_on Field_card_of card_of_Field_ordIso cardSuc_Card_order)
103.1578 + moreover
103.1579 + {have "|Field (cardSuc r) | =o cardSuc r"
103.1580 + using assms by (simp add: card_of_Field_ordIso cardSuc_Card_order)
103.1581 + hence "cardSuc r =o |Field (cardSuc r) |"
103.1582 + using ordIso_symmetric by blast
103.1583 + }
103.1584 + ultimately have "|Field (cardSuc |?A| ) | =o |Field (cardSuc r) |"
103.1585 + using ordIso_transitive by blast
103.1586 + hence "finite (Field (cardSuc |?A| )) = finite (Field (cardSuc r))"
103.1587 + using card_of_ordIso_finite by blast
103.1588 + thus ?thesis by (simp only: card_of_cardSuc_finite)
103.1589 +qed
103.1590 +
103.1591 +
103.1592 +lemma card_of_Plus_ordLess_infinite:
103.1593 +assumes INF: "\<not>finite C" and
103.1594 + LESS1: "|A| <o |C|" and LESS2: "|B| <o |C|"
103.1595 +shows "|A <+> B| <o |C|"
103.1596 +proof(cases "A = {} \<or> B = {}")
103.1597 + assume Case1: "A = {} \<or> B = {}"
103.1598 + hence "|A| =o |A <+> B| \<or> |B| =o |A <+> B|"
103.1599 + using card_of_Plus_empty1 card_of_Plus_empty2 by blast
103.1600 + hence "|A <+> B| =o |A| \<or> |A <+> B| =o |B|"
103.1601 + using ordIso_symmetric[of "|A|"] ordIso_symmetric[of "|B|"] by blast
103.1602 + thus ?thesis using LESS1 LESS2
103.1603 + ordIso_ordLess_trans[of "|A <+> B|" "|A|"]
103.1604 + ordIso_ordLess_trans[of "|A <+> B|" "|B|"] by blast
103.1605 +next
103.1606 + assume Case2: "\<not>(A = {} \<or> B = {})"
103.1607 + {assume *: "|C| \<le>o |A <+> B|"
103.1608 + hence "\<not>finite (A <+> B)" using INF card_of_ordLeq_finite by blast
103.1609 + hence 1: "\<not>finite A \<or> \<not>finite B" using finite_Plus by blast
103.1610 + {assume Case21: "|A| \<le>o |B|"
103.1611 + hence "\<not>finite B" using 1 card_of_ordLeq_finite by blast
103.1612 + hence "|A <+> B| =o |B|" using Case2 Case21
103.1613 + by (auto simp add: card_of_Plus_infinite)
103.1614 + hence False using LESS2 not_ordLess_ordLeq * ordLeq_ordIso_trans by blast
103.1615 + }
103.1616 + moreover
103.1617 + {assume Case22: "|B| \<le>o |A|"
103.1618 + hence "\<not>finite A" using 1 card_of_ordLeq_finite by blast
103.1619 + hence "|A <+> B| =o |A|" using Case2 Case22
103.1620 + by (auto simp add: card_of_Plus_infinite)
103.1621 + hence False using LESS1 not_ordLess_ordLeq * ordLeq_ordIso_trans by blast
103.1622 + }
103.1623 + ultimately have False using ordLeq_total card_of_Well_order[of A]
103.1624 + card_of_Well_order[of B] by blast
103.1625 + }
103.1626 + thus ?thesis using ordLess_or_ordLeq[of "|A <+> B|" "|C|"]
103.1627 + card_of_Well_order[of "A <+> B"] card_of_Well_order[of "C"] by auto
103.1628 +qed
103.1629 +
103.1630 +
103.1631 +lemma card_of_Plus_ordLess_infinite_Field:
103.1632 +assumes INF: "\<not>finite (Field r)" and r: "Card_order r" and
103.1633 + LESS1: "|A| <o r" and LESS2: "|B| <o r"
103.1634 +shows "|A <+> B| <o r"
103.1635 +proof-
103.1636 + let ?C = "Field r"
103.1637 + have 1: "r =o |?C| \<and> |?C| =o r" using r card_of_Field_ordIso
103.1638 + ordIso_symmetric by blast
103.1639 + hence "|A| <o |?C|" "|B| <o |?C|"
103.1640 + using LESS1 LESS2 ordLess_ordIso_trans by blast+
103.1641 + hence "|A <+> B| <o |?C|" using INF
103.1642 + card_of_Plus_ordLess_infinite by blast
103.1643 + thus ?thesis using 1 ordLess_ordIso_trans by blast
103.1644 +qed
103.1645 +
103.1646 +
103.1647 +lemma card_of_Plus_ordLeq_infinite_Field:
103.1648 +assumes r: "\<not>finite (Field r)" and A: "|A| \<le>o r" and B: "|B| \<le>o r"
103.1649 +and c: "Card_order r"
103.1650 +shows "|A <+> B| \<le>o r"
103.1651 +proof-
103.1652 + let ?r' = "cardSuc r"
103.1653 + have "Card_order ?r' \<and> \<not>finite (Field ?r')" using assms
103.1654 + by (simp add: cardSuc_Card_order cardSuc_finite)
103.1655 + moreover have "|A| <o ?r'" and "|B| <o ?r'" using A B c
103.1656 + by (auto simp: card_of_card_order_on Field_card_of cardSuc_ordLeq_ordLess)
103.1657 + ultimately have "|A <+> B| <o ?r'"
103.1658 + using card_of_Plus_ordLess_infinite_Field by blast
103.1659 + thus ?thesis using c r
103.1660 + by (simp add: card_of_card_order_on Field_card_of cardSuc_ordLeq_ordLess)
103.1661 +qed
103.1662 +
103.1663 +
103.1664 +lemma card_of_Un_ordLeq_infinite_Field:
103.1665 +assumes C: "\<not>finite (Field r)" and A: "|A| \<le>o r" and B: "|B| \<le>o r"
103.1666 +and "Card_order r"
103.1667 +shows "|A Un B| \<le>o r"
103.1668 +using assms card_of_Plus_ordLeq_infinite_Field card_of_Un_Plus_ordLeq
103.1669 +ordLeq_transitive by fast
103.1670 +
103.1671 +
103.1672 +
103.1673 +subsection {* Regular cardinals *}
103.1674 +
103.1675 +
103.1676 +definition cofinal where
103.1677 +"cofinal A r \<equiv>
103.1678 + ALL a : Field r. EX b : A. a \<noteq> b \<and> (a,b) : r"
103.1679 +
103.1680 +
103.1681 +definition regular where
103.1682 +"regular r \<equiv>
103.1683 + ALL K. K \<le> Field r \<and> cofinal K r \<longrightarrow> |K| =o r"
103.1684 +
103.1685 +
103.1686 +definition relChain where
103.1687 +"relChain r As \<equiv>
103.1688 + ALL i j. (i,j) \<in> r \<longrightarrow> As i \<le> As j"
103.1689 +
103.1690 +lemma regular_UNION:
103.1691 +assumes r: "Card_order r" "regular r"
103.1692 +and As: "relChain r As"
103.1693 +and Bsub: "B \<le> (UN i : Field r. As i)"
103.1694 +and cardB: "|B| <o r"
103.1695 +shows "EX i : Field r. B \<le> As i"
103.1696 +proof-
103.1697 + let ?phi = "%b j. j : Field r \<and> b : As j"
103.1698 + have "ALL b : B. EX j. ?phi b j" using Bsub by blast
103.1699 + then obtain f where f: "!! b. b : B \<Longrightarrow> ?phi b (f b)"
103.1700 + using bchoice[of B ?phi] by blast
103.1701 + let ?K = "f ` B"
103.1702 + {assume 1: "!! i. i : Field r \<Longrightarrow> ~ B \<le> As i"
103.1703 + have 2: "cofinal ?K r"
103.1704 + unfolding cofinal_def proof auto
103.1705 + fix i assume i: "i : Field r"
103.1706 + with 1 obtain b where b: "b : B \<and> b \<notin> As i" by blast
103.1707 + hence "i \<noteq> f b \<and> ~ (f b,i) : r"
103.1708 + using As f unfolding relChain_def by auto
103.1709 + hence "i \<noteq> f b \<and> (i, f b) : r" using r
103.1710 + unfolding card_order_on_def well_order_on_def linear_order_on_def
103.1711 + total_on_def using i f b by auto
103.1712 + with b show "\<exists>b\<in>B. i \<noteq> f b \<and> (i, f b) \<in> r" by blast
103.1713 + qed
103.1714 + moreover have "?K \<le> Field r" using f by blast
103.1715 + ultimately have "|?K| =o r" using 2 r unfolding regular_def by blast
103.1716 + moreover
103.1717 + {
103.1718 + have "|?K| <=o |B|" using card_of_image .
103.1719 + hence "|?K| <o r" using cardB ordLeq_ordLess_trans by blast
103.1720 + }
103.1721 + ultimately have False using not_ordLess_ordIso by blast
103.1722 + }
103.1723 + thus ?thesis by blast
103.1724 +qed
103.1725 +
103.1726 +
103.1727 +lemma infinite_cardSuc_regular:
103.1728 +assumes r_inf: "\<not>finite (Field r)" and r_card: "Card_order r"
103.1729 +shows "regular (cardSuc r)"
103.1730 +proof-
103.1731 + let ?r' = "cardSuc r"
103.1732 + have r': "Card_order ?r'"
103.1733 + "!! p. Card_order p \<longrightarrow> (p \<le>o r) = (p <o ?r')"
103.1734 + using r_card by (auto simp: cardSuc_Card_order cardSuc_ordLeq_ordLess)
103.1735 + show ?thesis
103.1736 + unfolding regular_def proof auto
103.1737 + fix K assume 1: "K \<le> Field ?r'" and 2: "cofinal K ?r'"
103.1738 + hence "|K| \<le>o |Field ?r'|" by (simp only: card_of_mono1)
103.1739 + also have 22: "|Field ?r'| =o ?r'"
103.1740 + using r' by (simp add: card_of_Field_ordIso[of ?r'])
103.1741 + finally have "|K| \<le>o ?r'" .
103.1742 + moreover
103.1743 + {let ?L = "UN j : K. rel.underS ?r' j"
103.1744 + let ?J = "Field r"
103.1745 + have rJ: "r =o |?J|"
103.1746 + using r_card card_of_Field_ordIso ordIso_symmetric by blast
103.1747 + assume "|K| <o ?r'"
103.1748 + hence "|K| <=o r" using r' card_of_Card_order[of K] by blast
103.1749 + hence "|K| \<le>o |?J|" using rJ ordLeq_ordIso_trans by blast
103.1750 + moreover
103.1751 + {have "ALL j : K. |rel.underS ?r' j| <o ?r'"
103.1752 + using r' 1 by (auto simp: card_of_underS)
103.1753 + hence "ALL j : K. |rel.underS ?r' j| \<le>o r"
103.1754 + using r' card_of_Card_order by blast
103.1755 + hence "ALL j : K. |rel.underS ?r' j| \<le>o |?J|"
103.1756 + using rJ ordLeq_ordIso_trans by blast
103.1757 + }
103.1758 + ultimately have "|?L| \<le>o |?J|"
103.1759 + using r_inf card_of_UNION_ordLeq_infinite by blast
103.1760 + hence "|?L| \<le>o r" using rJ ordIso_symmetric ordLeq_ordIso_trans by blast
103.1761 + hence "|?L| <o ?r'" using r' card_of_Card_order by blast
103.1762 + moreover
103.1763 + {
103.1764 + have "Field ?r' \<le> ?L"
103.1765 + using 2 unfolding rel.underS_def cofinal_def by auto
103.1766 + hence "|Field ?r'| \<le>o |?L|" by (simp add: card_of_mono1)
103.1767 + hence "?r' \<le>o |?L|"
103.1768 + using 22 ordIso_ordLeq_trans ordIso_symmetric by blast
103.1769 + }
103.1770 + ultimately have "|?L| <o |?L|" using ordLess_ordLeq_trans by blast
103.1771 + hence False using ordLess_irreflexive by blast
103.1772 + }
103.1773 + ultimately show "|K| =o ?r'"
103.1774 + unfolding ordLeq_iff_ordLess_or_ordIso by blast
103.1775 + qed
103.1776 +qed
103.1777 +
103.1778 +lemma cardSuc_UNION:
103.1779 +assumes r: "Card_order r" and "\<not>finite (Field r)"
103.1780 +and As: "relChain (cardSuc r) As"
103.1781 +and Bsub: "B \<le> (UN i : Field (cardSuc r). As i)"
103.1782 +and cardB: "|B| <=o r"
103.1783 +shows "EX i : Field (cardSuc r). B \<le> As i"
103.1784 +proof-
103.1785 + let ?r' = "cardSuc r"
103.1786 + have "Card_order ?r' \<and> |B| <o ?r'"
103.1787 + using r cardB cardSuc_ordLeq_ordLess cardSuc_Card_order
103.1788 + card_of_Card_order by blast
103.1789 + moreover have "regular ?r'"
103.1790 + using assms by(simp add: infinite_cardSuc_regular)
103.1791 + ultimately show ?thesis
103.1792 + using As Bsub cardB regular_UNION by blast
103.1793 +qed
103.1794 +
103.1795 +
103.1796 +subsection {* Others *}
103.1797 +
103.1798 +(* function space *)
103.1799 +definition Func where
103.1800 +"Func A B = {f . (\<forall> a \<in> A. f a \<in> B) \<and> (\<forall> a. a \<notin> A \<longrightarrow> f a = undefined)}"
103.1801 +
103.1802 +lemma Func_empty:
103.1803 +"Func {} B = {\<lambda>x. undefined}"
103.1804 +unfolding Func_def by auto
103.1805 +
103.1806 +lemma Func_elim:
103.1807 +assumes "g \<in> Func A B" and "a \<in> A"
103.1808 +shows "\<exists> b. b \<in> B \<and> g a = b"
103.1809 +using assms unfolding Func_def by (cases "g a = undefined") auto
103.1810 +
103.1811 +definition curr where
103.1812 +"curr A f \<equiv> \<lambda> a. if a \<in> A then \<lambda>b. f (a,b) else undefined"
103.1813 +
103.1814 +lemma curr_in:
103.1815 +assumes f: "f \<in> Func (A <*> B) C"
103.1816 +shows "curr A f \<in> Func A (Func B C)"
103.1817 +using assms unfolding curr_def Func_def by auto
103.1818 +
103.1819 +lemma curr_inj:
103.1820 +assumes "f1 \<in> Func (A <*> B) C" and "f2 \<in> Func (A <*> B) C"
103.1821 +shows "curr A f1 = curr A f2 \<longleftrightarrow> f1 = f2"
103.1822 +proof safe
103.1823 + assume c: "curr A f1 = curr A f2"
103.1824 + show "f1 = f2"
103.1825 + proof (rule ext, clarify)
103.1826 + fix a b show "f1 (a, b) = f2 (a, b)"
103.1827 + proof (cases "(a,b) \<in> A <*> B")
103.1828 + case False
103.1829 + thus ?thesis using assms unfolding Func_def by auto
103.1830 + next
103.1831 + case True hence a: "a \<in> A" and b: "b \<in> B" by auto
103.1832 + thus ?thesis
103.1833 + using c unfolding curr_def fun_eq_iff by(elim allE[of _ a]) simp
103.1834 + qed
103.1835 + qed
103.1836 +qed
103.1837 +
103.1838 +lemma curr_surj:
103.1839 +assumes "g \<in> Func A (Func B C)"
103.1840 +shows "\<exists> f \<in> Func (A <*> B) C. curr A f = g"
103.1841 +proof
103.1842 + let ?f = "\<lambda> ab. if fst ab \<in> A \<and> snd ab \<in> B then g (fst ab) (snd ab) else undefined"
103.1843 + show "curr A ?f = g"
103.1844 + proof (rule ext)
103.1845 + fix a show "curr A ?f a = g a"
103.1846 + proof (cases "a \<in> A")
103.1847 + case False
103.1848 + hence "g a = undefined" using assms unfolding Func_def by auto
103.1849 + thus ?thesis unfolding curr_def using False by simp
103.1850 + next
103.1851 + case True
103.1852 + obtain g1 where "g1 \<in> Func B C" and "g a = g1"
103.1853 + using assms using Func_elim[OF assms True] by blast
103.1854 + thus ?thesis using True unfolding Func_def curr_def by auto
103.1855 + qed
103.1856 + qed
103.1857 + show "?f \<in> Func (A <*> B) C" using assms unfolding Func_def mem_Collect_eq by auto
103.1858 +qed
103.1859 +
103.1860 +lemma bij_betw_curr:
103.1861 +"bij_betw (curr A) (Func (A <*> B) C) (Func A (Func B C))"
103.1862 +unfolding bij_betw_def inj_on_def image_def
103.1863 +apply (intro impI conjI ballI)
103.1864 +apply (erule curr_inj[THEN iffD1], assumption+)
103.1865 +apply auto
103.1866 +apply (erule curr_in)
103.1867 +using curr_surj by blast
103.1868 +
103.1869 +lemma card_of_Func_Times:
103.1870 +"|Func (A <*> B) C| =o |Func A (Func B C)|"
103.1871 +unfolding card_of_ordIso[symmetric]
103.1872 +using bij_betw_curr by blast
103.1873 +
103.1874 +definition Func_map where
103.1875 +"Func_map B2 f1 f2 g b2 \<equiv> if b2 \<in> B2 then f1 (g (f2 b2)) else undefined"
103.1876 +
103.1877 +lemma Func_map:
103.1878 +assumes g: "g \<in> Func A2 A1" and f1: "f1 ` A1 \<subseteq> B1" and f2: "f2 ` B2 \<subseteq> A2"
103.1879 +shows "Func_map B2 f1 f2 g \<in> Func B2 B1"
103.1880 +using assms unfolding Func_def Func_map_def mem_Collect_eq by auto
103.1881 +
103.1882 +lemma Func_non_emp:
103.1883 +assumes "B \<noteq> {}"
103.1884 +shows "Func A B \<noteq> {}"
103.1885 +proof-
103.1886 + obtain b where b: "b \<in> B" using assms by auto
103.1887 + hence "(\<lambda> a. if a \<in> A then b else undefined) \<in> Func A B" unfolding Func_def by auto
103.1888 + thus ?thesis by blast
103.1889 +qed
103.1890 +
103.1891 +lemma Func_is_emp:
103.1892 +"Func A B = {} \<longleftrightarrow> A \<noteq> {} \<and> B = {}" (is "?L \<longleftrightarrow> ?R")
103.1893 +proof
103.1894 + assume L: ?L
103.1895 + moreover {assume "A = {}" hence False using L Func_empty by auto}
103.1896 + moreover {assume "B \<noteq> {}" hence False using L Func_non_emp by metis}
103.1897 + ultimately show ?R by blast
103.1898 +next
103.1899 + assume R: ?R
103.1900 + moreover
103.1901 + {fix f assume "f \<in> Func A B"
103.1902 + moreover obtain a where "a \<in> A" using R by blast
103.1903 + ultimately obtain b where "b \<in> B" unfolding Func_def by blast
103.1904 + with R have False by blast
103.1905 + }
103.1906 + thus ?L by blast
103.1907 +qed
103.1908 +
103.1909 +lemma Func_map_surj:
103.1910 +assumes B1: "f1 ` A1 = B1" and A2: "inj_on f2 B2" "f2 ` B2 \<subseteq> A2"
103.1911 +and B2A2: "B2 = {} \<Longrightarrow> A2 = {}"
103.1912 +shows "Func B2 B1 = Func_map B2 f1 f2 ` Func A2 A1"
103.1913 +proof(cases "B2 = {}")
103.1914 + case True
103.1915 + thus ?thesis using B2A2 by (auto simp: Func_empty Func_map_def)
103.1916 +next
103.1917 + case False note B2 = False
103.1918 + show ?thesis
103.1919 + proof safe
103.1920 + fix h assume h: "h \<in> Func B2 B1"
103.1921 + def j1 \<equiv> "inv_into A1 f1"
103.1922 + have "\<forall> a2 \<in> f2 ` B2. \<exists> b2. b2 \<in> B2 \<and> f2 b2 = a2" by blast
103.1923 + then obtain k where k: "\<forall> a2 \<in> f2 ` B2. k a2 \<in> B2 \<and> f2 (k a2) = a2" by metis
103.1924 + {fix b2 assume b2: "b2 \<in> B2"
103.1925 + hence "f2 (k (f2 b2)) = f2 b2" using k A2(2) by auto
103.1926 + moreover have "k (f2 b2) \<in> B2" using b2 A2(2) k by auto
103.1927 + ultimately have "k (f2 b2) = b2" using b2 A2(1) unfolding inj_on_def by blast
103.1928 + } note kk = this
103.1929 + obtain b22 where b22: "b22 \<in> B2" using B2 by auto
103.1930 + def j2 \<equiv> "\<lambda> a2. if a2 \<in> f2 ` B2 then k a2 else b22"
103.1931 + have j2A2: "j2 ` A2 \<subseteq> B2" unfolding j2_def using k b22 by auto
103.1932 + have j2: "\<And> b2. b2 \<in> B2 \<Longrightarrow> j2 (f2 b2) = b2"
103.1933 + using kk unfolding j2_def by auto
103.1934 + def g \<equiv> "Func_map A2 j1 j2 h"
103.1935 + have "Func_map B2 f1 f2 g = h"
103.1936 + proof (rule ext)
103.1937 + fix b2 show "Func_map B2 f1 f2 g b2 = h b2"
103.1938 + proof(cases "b2 \<in> B2")
103.1939 + case True
103.1940 + show ?thesis
103.1941 + proof (cases "h b2 = undefined")
103.1942 + case True
103.1943 + hence b1: "h b2 \<in> f1 ` A1" using h `b2 \<in> B2` unfolding B1 Func_def by auto
103.1944 + show ?thesis using A2 f_inv_into_f[OF b1]
103.1945 + unfolding True g_def Func_map_def j1_def j2[OF `b2 \<in> B2`] by auto
103.1946 + qed(insert A2 True j2[OF True] h B1, unfold j1_def g_def Func_def Func_map_def,
103.1947 + auto intro: f_inv_into_f)
103.1948 + qed(insert h, unfold Func_def Func_map_def, auto)
103.1949 + qed
103.1950 + moreover have "g \<in> Func A2 A1" unfolding g_def apply(rule Func_map[OF h])
103.1951 + using inv_into_into j2A2 B1 A2 inv_into_into
103.1952 + unfolding j1_def image_def by fast+
103.1953 + ultimately show "h \<in> Func_map B2 f1 f2 ` Func A2 A1"
103.1954 + unfolding Func_map_def[abs_def] unfolding image_def by auto
103.1955 + qed(insert B1 Func_map[OF _ _ A2(2)], auto)
103.1956 +qed
103.1957 +
103.1958 +lemma card_of_Pow_Func:
103.1959 +"|Pow A| =o |Func A (UNIV::bool set)|"
103.1960 +proof-
103.1961 + def F \<equiv> "\<lambda> A' a. if a \<in> A then (if a \<in> A' then True else False)
103.1962 + else undefined"
103.1963 + have "bij_betw F (Pow A) (Func A (UNIV::bool set))"
103.1964 + unfolding bij_betw_def inj_on_def proof (intro ballI impI conjI)
103.1965 + fix A1 A2 assume "A1 \<in> Pow A" "A2 \<in> Pow A" "F A1 = F A2"
103.1966 + thus "A1 = A2" unfolding F_def Pow_def fun_eq_iff by (auto split: split_if_asm)
103.1967 + next
103.1968 + show "F ` Pow A = Func A UNIV"
103.1969 + proof safe
103.1970 + fix f assume f: "f \<in> Func A (UNIV::bool set)"
103.1971 + show "f \<in> F ` Pow A" unfolding image_def mem_Collect_eq proof(intro bexI)
103.1972 + let ?A1 = "{a \<in> A. f a = True}"
103.1973 + show "f = F ?A1" unfolding F_def apply(rule ext)
103.1974 + using f unfolding Func_def mem_Collect_eq by auto
103.1975 + qed auto
103.1976 + qed(unfold Func_def mem_Collect_eq F_def, auto)
103.1977 + qed
103.1978 + thus ?thesis unfolding card_of_ordIso[symmetric] by blast
103.1979 +qed
103.1980 +
103.1981 +lemma card_of_Func_UNIV:
103.1982 +"|Func (UNIV::'a set) (B::'b set)| =o |{f::'a \<Rightarrow> 'b. range f \<subseteq> B}|"
103.1983 +apply(rule ordIso_symmetric) proof(intro card_of_ordIsoI)
103.1984 + let ?F = "\<lambda> f (a::'a). ((f a)::'b)"
103.1985 + show "bij_betw ?F {f. range f \<subseteq> B} (Func UNIV B)"
103.1986 + unfolding bij_betw_def inj_on_def proof safe
103.1987 + fix h :: "'a \<Rightarrow> 'b" assume h: "h \<in> Func UNIV B"
103.1988 + hence "\<forall> a. \<exists> b. h a = b" unfolding Func_def by auto
103.1989 + then obtain f where f: "\<forall> a. h a = f a" by metis
103.1990 + hence "range f \<subseteq> B" using h unfolding Func_def by auto
103.1991 + thus "h \<in> (\<lambda>f a. f a) ` {f. range f \<subseteq> B}" using f unfolding image_def by auto
103.1992 + qed(unfold Func_def fun_eq_iff, auto)
103.1993 +qed
103.1994 +
103.1995 +end
104.1 --- a/src/HOL/Cardinals/Cardinals.thy Thu Dec 05 17:52:12 2013 +0100
104.2 +++ b/src/HOL/Cardinals/Cardinals.thy Thu Dec 05 17:58:03 2013 +0100
104.3 @@ -9,7 +9,7 @@
104.4 header {* Theory of Ordinals and Cardinals *}
104.5
104.6 theory Cardinals
104.7 -imports Cardinal_Order_Relation Cardinal_Arithmetic
104.8 +imports Cardinal_Order_Relation Cardinal_Arithmetic Wellorder_Extension
104.9 begin
104.10
104.11 end
105.1 --- a/src/HOL/Cardinals/Constructions_on_Wellorders.thy Thu Dec 05 17:52:12 2013 +0100
105.2 +++ b/src/HOL/Cardinals/Constructions_on_Wellorders.thy Thu Dec 05 17:58:03 2013 +0100
105.3 @@ -8,13 +8,11 @@
105.4 header {* Constructions on Wellorders *}
105.5
105.6 theory Constructions_on_Wellorders
105.7 -imports Constructions_on_Wellorders_Base Wellorder_Embedding
105.8 +imports Constructions_on_Wellorders_FP Wellorder_Embedding Order_Union
105.9 begin
105.10
105.11 declare
105.12 ordLeq_Well_order_simp[simp]
105.13 - ordLess_Well_order_simp[simp]
105.14 - ordIso_Well_order_simp[simp]
105.15 not_ordLeq_iff_ordLess[simp]
105.16 not_ordLess_iff_ordLeq[simp]
105.17
105.18 @@ -88,7 +86,7 @@
105.19 by (auto simp add: ofilter_subset_embedS_iso)
105.20
105.21
105.22 -subsection {* Ordering the well-orders by existence of embeddings *}
105.23 +subsection {* Ordering the well-orders by existence of embeddings *}
105.24
105.25 corollary ordLeq_refl_on: "refl_on {r. Well_order r} ordLeq"
105.26 using ordLeq_reflexive unfolding ordLeq_def refl_on_def
105.27 @@ -113,6 +111,16 @@
105.28 corollary ordIso_equiv: "equiv {r. Well_order r} ordIso"
105.29 by (auto simp add: equiv_def ordIso_sym ordIso_refl_on ordIso_trans)
105.30
105.31 +lemma ordLess_Well_order_simp[simp]:
105.32 +assumes "r <o r'"
105.33 +shows "Well_order r \<and> Well_order r'"
105.34 +using assms unfolding ordLess_def by simp
105.35 +
105.36 +lemma ordIso_Well_order_simp[simp]:
105.37 +assumes "r =o r'"
105.38 +shows "Well_order r \<and> Well_order r'"
105.39 +using assms unfolding ordIso_def by simp
105.40 +
105.41 lemma ordLess_irrefl: "irrefl ordLess"
105.42 by(unfold irrefl_def, auto simp add: ordLess_irreflexive)
105.43
106.1 --- a/src/HOL/Cardinals/Constructions_on_Wellorders_Base.thy Thu Dec 05 17:52:12 2013 +0100
106.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
106.3 @@ -1,1633 +0,0 @@
106.4 -(* Title: HOL/Cardinals/Constructions_on_Wellorders_Base.thy
106.5 - Author: Andrei Popescu, TU Muenchen
106.6 - Copyright 2012
106.7 -
106.8 -Constructions on wellorders (base).
106.9 -*)
106.10 -
106.11 -header {* Constructions on Wellorders (Base) *}
106.12 -
106.13 -theory Constructions_on_Wellorders_Base
106.14 -imports Wellorder_Embedding_Base
106.15 -begin
106.16 -
106.17 -
106.18 -text {* In this section, we study basic constructions on well-orders, such as restriction to
106.19 -a set/order filter, copy via direct images, ordinal-like sum of disjoint well-orders,
106.20 -and bounded square. We also define between well-orders
106.21 -the relations @{text "ordLeq"}, of being embedded (abbreviated @{text "\<le>o"}),
106.22 -@{text "ordLess"}, of being strictly embedded (abbreviated @{text "<o"}), and
106.23 -@{text "ordIso"}, of being isomorphic (abbreviated @{text "=o"}). We study the
106.24 -connections between these relations, order filters, and the aforementioned constructions.
106.25 -A main result of this section is that @{text "<o"} is well-founded. *}
106.26 -
106.27 -
106.28 -subsection {* Restriction to a set *}
106.29 -
106.30 -
106.31 -abbreviation Restr :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a rel"
106.32 -where "Restr r A \<equiv> r Int (A \<times> A)"
106.33 -
106.34 -
106.35 -lemma Restr_subset:
106.36 -"A \<le> B \<Longrightarrow> Restr (Restr r B) A = Restr r A"
106.37 -by blast
106.38 -
106.39 -
106.40 -lemma Restr_Field: "Restr r (Field r) = r"
106.41 -unfolding Field_def by auto
106.42 -
106.43 -
106.44 -lemma Refl_Restr: "Refl r \<Longrightarrow> Refl(Restr r A)"
106.45 -unfolding refl_on_def Field_def by auto
106.46 -
106.47 -
106.48 -lemma antisym_Restr:
106.49 -"antisym r \<Longrightarrow> antisym(Restr r A)"
106.50 -unfolding antisym_def Field_def by auto
106.51 -
106.52 -
106.53 -lemma Total_Restr:
106.54 -"Total r \<Longrightarrow> Total(Restr r A)"
106.55 -unfolding total_on_def Field_def by auto
106.56 -
106.57 -
106.58 -lemma trans_Restr:
106.59 -"trans r \<Longrightarrow> trans(Restr r A)"
106.60 -unfolding trans_def Field_def by blast
106.61 -
106.62 -
106.63 -lemma Preorder_Restr:
106.64 -"Preorder r \<Longrightarrow> Preorder(Restr r A)"
106.65 -unfolding preorder_on_def by (simp add: Refl_Restr trans_Restr)
106.66 -
106.67 -
106.68 -lemma Partial_order_Restr:
106.69 -"Partial_order r \<Longrightarrow> Partial_order(Restr r A)"
106.70 -unfolding partial_order_on_def by (simp add: Preorder_Restr antisym_Restr)
106.71 -
106.72 -
106.73 -lemma Linear_order_Restr:
106.74 -"Linear_order r \<Longrightarrow> Linear_order(Restr r A)"
106.75 -unfolding linear_order_on_def by (simp add: Partial_order_Restr Total_Restr)
106.76 -
106.77 -
106.78 -lemma Well_order_Restr:
106.79 -assumes "Well_order r"
106.80 -shows "Well_order(Restr r A)"
106.81 -proof-
106.82 - have "Restr r A - Id \<le> r - Id" using Restr_subset by blast
106.83 - hence "wf(Restr r A - Id)" using assms
106.84 - using well_order_on_def wf_subset by blast
106.85 - thus ?thesis using assms unfolding well_order_on_def
106.86 - by (simp add: Linear_order_Restr)
106.87 -qed
106.88 -
106.89 -
106.90 -lemma Field_Restr_subset: "Field(Restr r A) \<le> A"
106.91 -by (auto simp add: Field_def)
106.92 -
106.93 -
106.94 -lemma Refl_Field_Restr:
106.95 -"Refl r \<Longrightarrow> Field(Restr r A) = (Field r) Int A"
106.96 -by (auto simp add: refl_on_def Field_def)
106.97 -
106.98 -
106.99 -lemma Refl_Field_Restr2:
106.100 -"\<lbrakk>Refl r; A \<le> Field r\<rbrakk> \<Longrightarrow> Field(Restr r A) = A"
106.101 -by (auto simp add: Refl_Field_Restr)
106.102 -
106.103 -
106.104 -lemma well_order_on_Restr:
106.105 -assumes WELL: "Well_order r" and SUB: "A \<le> Field r"
106.106 -shows "well_order_on A (Restr r A)"
106.107 -using assms
106.108 -using Well_order_Restr[of r A] Refl_Field_Restr2[of r A]
106.109 - order_on_defs[of "Field r" r] by auto
106.110 -
106.111 -
106.112 -subsection {* Order filters versus restrictions and embeddings *}
106.113 -
106.114 -
106.115 -lemma Field_Restr_ofilter:
106.116 -"\<lbrakk>Well_order r; wo_rel.ofilter r A\<rbrakk> \<Longrightarrow> Field(Restr r A) = A"
106.117 -by (auto simp add: wo_rel_def wo_rel.ofilter_def wo_rel.REFL Refl_Field_Restr2)
106.118 -
106.119 -
106.120 -lemma ofilter_Restr_under:
106.121 -assumes WELL: "Well_order r" and OF: "wo_rel.ofilter r A" and IN: "a \<in> A"
106.122 -shows "rel.under (Restr r A) a = rel.under r a"
106.123 -using assms wo_rel_def
106.124 -proof(auto simp add: wo_rel.ofilter_def rel.under_def)
106.125 - fix b assume *: "a \<in> A" and "(b,a) \<in> r"
106.126 - hence "b \<in> rel.under r a \<and> a \<in> Field r"
106.127 - unfolding rel.under_def using Field_def by fastforce
106.128 - thus "b \<in> A" using * assms by (auto simp add: wo_rel_def wo_rel.ofilter_def)
106.129 -qed
106.130 -
106.131 -
106.132 -lemma ofilter_embed:
106.133 -assumes "Well_order r"
106.134 -shows "wo_rel.ofilter r A = (A \<le> Field r \<and> embed (Restr r A) r id)"
106.135 -proof
106.136 - assume *: "wo_rel.ofilter r A"
106.137 - show "A \<le> Field r \<and> embed (Restr r A) r id"
106.138 - proof(unfold embed_def, auto)
106.139 - fix a assume "a \<in> A" thus "a \<in> Field r" using assms *
106.140 - by (auto simp add: wo_rel_def wo_rel.ofilter_def)
106.141 - next
106.142 - fix a assume "a \<in> Field (Restr r A)"
106.143 - thus "bij_betw id (rel.under (Restr r A) a) (rel.under r a)" using assms *
106.144 - by (simp add: ofilter_Restr_under Field_Restr_ofilter)
106.145 - qed
106.146 -next
106.147 - assume *: "A \<le> Field r \<and> embed (Restr r A) r id"
106.148 - hence "Field(Restr r A) \<le> Field r"
106.149 - using assms embed_Field[of "Restr r A" r id] id_def
106.150 - Well_order_Restr[of r] by auto
106.151 - {fix a assume "a \<in> A"
106.152 - hence "a \<in> Field(Restr r A)" using * assms
106.153 - by (simp add: order_on_defs Refl_Field_Restr2)
106.154 - hence "bij_betw id (rel.under (Restr r A) a) (rel.under r a)"
106.155 - using * unfolding embed_def by auto
106.156 - hence "rel.under r a \<le> rel.under (Restr r A) a"
106.157 - unfolding bij_betw_def by auto
106.158 - also have "\<dots> \<le> Field(Restr r A)" by (simp add: rel.under_Field)
106.159 - also have "\<dots> \<le> A" by (simp add: Field_Restr_subset)
106.160 - finally have "rel.under r a \<le> A" .
106.161 - }
106.162 - thus "wo_rel.ofilter r A" using assms * by (simp add: wo_rel_def wo_rel.ofilter_def)
106.163 -qed
106.164 -
106.165 -
106.166 -lemma ofilter_Restr_Int:
106.167 -assumes WELL: "Well_order r" and OFA: "wo_rel.ofilter r A"
106.168 -shows "wo_rel.ofilter (Restr r B) (A Int B)"
106.169 -proof-
106.170 - let ?rB = "Restr r B"
106.171 - have Well: "wo_rel r" unfolding wo_rel_def using WELL .
106.172 - hence Refl: "Refl r" by (simp add: wo_rel.REFL)
106.173 - hence Field: "Field ?rB = Field r Int B"
106.174 - using Refl_Field_Restr by blast
106.175 - have WellB: "wo_rel ?rB \<and> Well_order ?rB" using WELL
106.176 - by (simp add: Well_order_Restr wo_rel_def)
106.177 - (* Main proof *)
106.178 - show ?thesis using WellB assms
106.179 - proof(auto simp add: wo_rel.ofilter_def rel.under_def)
106.180 - fix a assume "a \<in> A" and *: "a \<in> B"
106.181 - hence "a \<in> Field r" using OFA Well by (auto simp add: wo_rel.ofilter_def)
106.182 - with * show "a \<in> Field ?rB" using Field by auto
106.183 - next
106.184 - fix a b assume "a \<in> A" and "(b,a) \<in> r"
106.185 - thus "b \<in> A" using Well OFA by (auto simp add: wo_rel.ofilter_def rel.under_def)
106.186 - qed
106.187 -qed
106.188 -
106.189 -
106.190 -lemma ofilter_Restr_subset:
106.191 -assumes WELL: "Well_order r" and OFA: "wo_rel.ofilter r A" and SUB: "A \<le> B"
106.192 -shows "wo_rel.ofilter (Restr r B) A"
106.193 -proof-
106.194 - have "A Int B = A" using SUB by blast
106.195 - thus ?thesis using assms ofilter_Restr_Int[of r A B] by auto
106.196 -qed
106.197 -
106.198 -
106.199 -lemma ofilter_subset_embed:
106.200 -assumes WELL: "Well_order r" and
106.201 - OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
106.202 -shows "(A \<le> B) = (embed (Restr r A) (Restr r B) id)"
106.203 -proof-
106.204 - let ?rA = "Restr r A" let ?rB = "Restr r B"
106.205 - have Well: "wo_rel r" unfolding wo_rel_def using WELL .
106.206 - hence Refl: "Refl r" by (simp add: wo_rel.REFL)
106.207 - hence FieldA: "Field ?rA = Field r Int A"
106.208 - using Refl_Field_Restr by blast
106.209 - have FieldB: "Field ?rB = Field r Int B"
106.210 - using Refl Refl_Field_Restr by blast
106.211 - have WellA: "wo_rel ?rA \<and> Well_order ?rA" using WELL
106.212 - by (simp add: Well_order_Restr wo_rel_def)
106.213 - have WellB: "wo_rel ?rB \<and> Well_order ?rB" using WELL
106.214 - by (simp add: Well_order_Restr wo_rel_def)
106.215 - (* Main proof *)
106.216 - show ?thesis
106.217 - proof
106.218 - assume *: "A \<le> B"
106.219 - hence "wo_rel.ofilter (Restr r B) A" using assms
106.220 - by (simp add: ofilter_Restr_subset)
106.221 - hence "embed (Restr ?rB A) (Restr r B) id"
106.222 - using WellB ofilter_embed[of "?rB" A] by auto
106.223 - thus "embed (Restr r A) (Restr r B) id"
106.224 - using * by (simp add: Restr_subset)
106.225 - next
106.226 - assume *: "embed (Restr r A) (Restr r B) id"
106.227 - {fix a assume **: "a \<in> A"
106.228 - hence "a \<in> Field r" using Well OFA by (auto simp add: wo_rel.ofilter_def)
106.229 - with ** FieldA have "a \<in> Field ?rA" by auto
106.230 - hence "a \<in> Field ?rB" using * WellA embed_Field[of ?rA ?rB id] by auto
106.231 - hence "a \<in> B" using FieldB by auto
106.232 - }
106.233 - thus "A \<le> B" by blast
106.234 - qed
106.235 -qed
106.236 -
106.237 -
106.238 -lemma ofilter_subset_embedS_iso:
106.239 -assumes WELL: "Well_order r" and
106.240 - OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
106.241 -shows "((A < B) = (embedS (Restr r A) (Restr r B) id)) \<and>
106.242 - ((A = B) = (iso (Restr r A) (Restr r B) id))"
106.243 -proof-
106.244 - let ?rA = "Restr r A" let ?rB = "Restr r B"
106.245 - have Well: "wo_rel r" unfolding wo_rel_def using WELL .
106.246 - hence Refl: "Refl r" by (simp add: wo_rel.REFL)
106.247 - hence "Field ?rA = Field r Int A"
106.248 - using Refl_Field_Restr by blast
106.249 - hence FieldA: "Field ?rA = A" using OFA Well
106.250 - by (auto simp add: wo_rel.ofilter_def)
106.251 - have "Field ?rB = Field r Int B"
106.252 - using Refl Refl_Field_Restr by blast
106.253 - hence FieldB: "Field ?rB = B" using OFB Well
106.254 - by (auto simp add: wo_rel.ofilter_def)
106.255 - (* Main proof *)
106.256 - show ?thesis unfolding embedS_def iso_def
106.257 - using assms ofilter_subset_embed[of r A B]
106.258 - FieldA FieldB bij_betw_id_iff[of A B] by auto
106.259 -qed
106.260 -
106.261 -
106.262 -lemma ofilter_subset_embedS:
106.263 -assumes WELL: "Well_order r" and
106.264 - OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
106.265 -shows "(A < B) = embedS (Restr r A) (Restr r B) id"
106.266 -using assms by (simp add: ofilter_subset_embedS_iso)
106.267 -
106.268 -
106.269 -lemma embed_implies_iso_Restr:
106.270 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and
106.271 - EMB: "embed r' r f"
106.272 -shows "iso r' (Restr r (f ` (Field r'))) f"
106.273 -proof-
106.274 - let ?A' = "Field r'"
106.275 - let ?r'' = "Restr r (f ` ?A')"
106.276 - have 0: "Well_order ?r''" using WELL Well_order_Restr by blast
106.277 - have 1: "wo_rel.ofilter r (f ` ?A')" using assms embed_Field_ofilter by blast
106.278 - hence "Field ?r'' = f ` (Field r')" using WELL Field_Restr_ofilter by blast
106.279 - hence "bij_betw f ?A' (Field ?r'')"
106.280 - using EMB embed_inj_on WELL' unfolding bij_betw_def by blast
106.281 - moreover
106.282 - {have "\<forall>a b. (a,b) \<in> r' \<longrightarrow> a \<in> Field r' \<and> b \<in> Field r'"
106.283 - unfolding Field_def by auto
106.284 - hence "compat r' ?r'' f"
106.285 - using assms embed_iff_compat_inj_on_ofilter
106.286 - unfolding compat_def by blast
106.287 - }
106.288 - ultimately show ?thesis using WELL' 0 iso_iff3 by blast
106.289 -qed
106.290 -
106.291 -
106.292 -subsection {* The strict inclusion on proper ofilters is well-founded *}
106.293 -
106.294 -
106.295 -definition ofilterIncl :: "'a rel \<Rightarrow> 'a set rel"
106.296 -where
106.297 -"ofilterIncl r \<equiv> {(A,B). wo_rel.ofilter r A \<and> A \<noteq> Field r \<and>
106.298 - wo_rel.ofilter r B \<and> B \<noteq> Field r \<and> A < B}"
106.299 -
106.300 -
106.301 -lemma wf_ofilterIncl:
106.302 -assumes WELL: "Well_order r"
106.303 -shows "wf(ofilterIncl r)"
106.304 -proof-
106.305 - have Well: "wo_rel r" using WELL by (simp add: wo_rel_def)
106.306 - hence Lo: "Linear_order r" by (simp add: wo_rel.LIN)
106.307 - let ?h = "(\<lambda> A. wo_rel.suc r A)"
106.308 - let ?rS = "r - Id"
106.309 - have "wf ?rS" using WELL by (simp add: order_on_defs)
106.310 - moreover
106.311 - have "compat (ofilterIncl r) ?rS ?h"
106.312 - proof(unfold compat_def ofilterIncl_def,
106.313 - intro allI impI, simp, elim conjE)
106.314 - fix A B
106.315 - assume *: "wo_rel.ofilter r A" "A \<noteq> Field r" and
106.316 - **: "wo_rel.ofilter r B" "B \<noteq> Field r" and ***: "A < B"
106.317 - then obtain a and b where 0: "a \<in> Field r \<and> b \<in> Field r" and
106.318 - 1: "A = rel.underS r a \<and> B = rel.underS r b"
106.319 - using Well by (auto simp add: wo_rel.ofilter_underS_Field)
106.320 - hence "a \<noteq> b" using *** by auto
106.321 - moreover
106.322 - have "(a,b) \<in> r" using 0 1 Lo ***
106.323 - by (auto simp add: rel.underS_incl_iff)
106.324 - moreover
106.325 - have "a = wo_rel.suc r A \<and> b = wo_rel.suc r B"
106.326 - using Well 0 1 by (simp add: wo_rel.suc_underS)
106.327 - ultimately
106.328 - show "(wo_rel.suc r A, wo_rel.suc r B) \<in> r \<and> wo_rel.suc r A \<noteq> wo_rel.suc r B"
106.329 - by simp
106.330 - qed
106.331 - ultimately show "wf (ofilterIncl r)" by (simp add: compat_wf)
106.332 -qed
106.333 -
106.334 -
106.335 -
106.336 -subsection {* Ordering the well-orders by existence of embeddings *}
106.337 -
106.338 -
106.339 -text {* We define three relations between well-orders:
106.340 -\begin{itemize}
106.341 -\item @{text "ordLeq"}, of being embedded (abbreviated @{text "\<le>o"});
106.342 -\item @{text "ordLess"}, of being strictly embedded (abbreviated @{text "<o"});
106.343 -\item @{text "ordIso"}, of being isomorphic (abbreviated @{text "=o"}).
106.344 -\end{itemize}
106.345 -%
106.346 -The prefix "ord" and the index "o" in these names stand for "ordinal-like".
106.347 -These relations shall be proved to be inter-connected in a similar fashion as the trio
106.348 -@{text "\<le>"}, @{text "<"}, @{text "="} associated to a total order on a set.
106.349 -*}
106.350 -
106.351 -
106.352 -definition ordLeq :: "('a rel * 'a' rel) set"
106.353 -where
106.354 -"ordLeq = {(r,r'). Well_order r \<and> Well_order r' \<and> (\<exists>f. embed r r' f)}"
106.355 -
106.356 -
106.357 -abbreviation ordLeq2 :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> bool" (infix "<=o" 50)
106.358 -where "r <=o r' \<equiv> (r,r') \<in> ordLeq"
106.359 -
106.360 -
106.361 -abbreviation ordLeq3 :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> bool" (infix "\<le>o" 50)
106.362 -where "r \<le>o r' \<equiv> r <=o r'"
106.363 -
106.364 -
106.365 -definition ordLess :: "('a rel * 'a' rel) set"
106.366 -where
106.367 -"ordLess = {(r,r'). Well_order r \<and> Well_order r' \<and> (\<exists>f. embedS r r' f)}"
106.368 -
106.369 -abbreviation ordLess2 :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> bool" (infix "<o" 50)
106.370 -where "r <o r' \<equiv> (r,r') \<in> ordLess"
106.371 -
106.372 -
106.373 -definition ordIso :: "('a rel * 'a' rel) set"
106.374 -where
106.375 -"ordIso = {(r,r'). Well_order r \<and> Well_order r' \<and> (\<exists>f. iso r r' f)}"
106.376 -
106.377 -abbreviation ordIso2 :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> bool" (infix "=o" 50)
106.378 -where "r =o r' \<equiv> (r,r') \<in> ordIso"
106.379 -
106.380 -
106.381 -lemmas ordRels_def = ordLeq_def ordLess_def ordIso_def
106.382 -
106.383 -lemma ordLeq_Well_order_simp:
106.384 -assumes "r \<le>o r'"
106.385 -shows "Well_order r \<and> Well_order r'"
106.386 -using assms unfolding ordLeq_def by simp
106.387 -
106.388 -
106.389 -lemma ordLess_Well_order_simp:
106.390 -assumes "r <o r'"
106.391 -shows "Well_order r \<and> Well_order r'"
106.392 -using assms unfolding ordLess_def by simp
106.393 -
106.394 -
106.395 -lemma ordIso_Well_order_simp:
106.396 -assumes "r =o r'"
106.397 -shows "Well_order r \<and> Well_order r'"
106.398 -using assms unfolding ordIso_def by simp
106.399 -
106.400 -
106.401 -text{* Notice that the relations @{text "\<le>o"}, @{text "<o"}, @{text "=o"} connect well-orders
106.402 -on potentially {\em distinct} types. However, some of the lemmas below, including the next one,
106.403 -restrict implicitly the type of these relations to @{text "(('a rel) * ('a rel)) set"} , i.e.,
106.404 -to @{text "'a rel rel"}. *}
106.405 -
106.406 -
106.407 -lemma ordLeq_reflexive:
106.408 -"Well_order r \<Longrightarrow> r \<le>o r"
106.409 -unfolding ordLeq_def using id_embed[of r] by blast
106.410 -
106.411 -
106.412 -lemma ordLeq_transitive[trans]:
106.413 -assumes *: "r \<le>o r'" and **: "r' \<le>o r''"
106.414 -shows "r \<le>o r''"
106.415 -proof-
106.416 - obtain f and f'
106.417 - where 1: "Well_order r \<and> Well_order r' \<and> Well_order r''" and
106.418 - "embed r r' f" and "embed r' r'' f'"
106.419 - using * ** unfolding ordLeq_def by blast
106.420 - hence "embed r r'' (f' o f)"
106.421 - using comp_embed[of r r' f r'' f'] by auto
106.422 - thus "r \<le>o r''" unfolding ordLeq_def using 1 by auto
106.423 -qed
106.424 -
106.425 -
106.426 -lemma ordLeq_total:
106.427 -"\<lbrakk>Well_order r; Well_order r'\<rbrakk> \<Longrightarrow> r \<le>o r' \<or> r' \<le>o r"
106.428 -unfolding ordLeq_def using wellorders_totally_ordered by blast
106.429 -
106.430 -
106.431 -lemma ordIso_reflexive:
106.432 -"Well_order r \<Longrightarrow> r =o r"
106.433 -unfolding ordIso_def using id_iso[of r] by blast
106.434 -
106.435 -
106.436 -lemma ordIso_transitive[trans]:
106.437 -assumes *: "r =o r'" and **: "r' =o r''"
106.438 -shows "r =o r''"
106.439 -proof-
106.440 - obtain f and f'
106.441 - where 1: "Well_order r \<and> Well_order r' \<and> Well_order r''" and
106.442 - "iso r r' f" and 3: "iso r' r'' f'"
106.443 - using * ** unfolding ordIso_def by auto
106.444 - hence "iso r r'' (f' o f)"
106.445 - using comp_iso[of r r' f r'' f'] by auto
106.446 - thus "r =o r''" unfolding ordIso_def using 1 by auto
106.447 -qed
106.448 -
106.449 -
106.450 -lemma ordIso_symmetric:
106.451 -assumes *: "r =o r'"
106.452 -shows "r' =o r"
106.453 -proof-
106.454 - obtain f where 1: "Well_order r \<and> Well_order r'" and
106.455 - 2: "embed r r' f \<and> bij_betw f (Field r) (Field r')"
106.456 - using * by (auto simp add: ordIso_def iso_def)
106.457 - let ?f' = "inv_into (Field r) f"
106.458 - have "embed r' r ?f' \<and> bij_betw ?f' (Field r') (Field r)"
106.459 - using 1 2 by (simp add: bij_betw_inv_into inv_into_Field_embed_bij_betw)
106.460 - thus "r' =o r" unfolding ordIso_def using 1 by (auto simp add: iso_def)
106.461 -qed
106.462 -
106.463 -
106.464 -lemma ordLeq_ordLess_trans[trans]:
106.465 -assumes "r \<le>o r'" and " r' <o r''"
106.466 -shows "r <o r''"
106.467 -proof-
106.468 - have "Well_order r \<and> Well_order r''"
106.469 - using assms unfolding ordLeq_def ordLess_def by auto
106.470 - thus ?thesis using assms unfolding ordLeq_def ordLess_def
106.471 - using embed_comp_embedS by blast
106.472 -qed
106.473 -
106.474 -
106.475 -lemma ordLess_ordLeq_trans[trans]:
106.476 -assumes "r <o r'" and " r' \<le>o r''"
106.477 -shows "r <o r''"
106.478 -proof-
106.479 - have "Well_order r \<and> Well_order r''"
106.480 - using assms unfolding ordLeq_def ordLess_def by auto
106.481 - thus ?thesis using assms unfolding ordLeq_def ordLess_def
106.482 - using embedS_comp_embed by blast
106.483 -qed
106.484 -
106.485 -
106.486 -lemma ordLeq_ordIso_trans[trans]:
106.487 -assumes "r \<le>o r'" and " r' =o r''"
106.488 -shows "r \<le>o r''"
106.489 -proof-
106.490 - have "Well_order r \<and> Well_order r''"
106.491 - using assms unfolding ordLeq_def ordIso_def by auto
106.492 - thus ?thesis using assms unfolding ordLeq_def ordIso_def
106.493 - using embed_comp_iso by blast
106.494 -qed
106.495 -
106.496 -
106.497 -lemma ordIso_ordLeq_trans[trans]:
106.498 -assumes "r =o r'" and " r' \<le>o r''"
106.499 -shows "r \<le>o r''"
106.500 -proof-
106.501 - have "Well_order r \<and> Well_order r''"
106.502 - using assms unfolding ordLeq_def ordIso_def by auto
106.503 - thus ?thesis using assms unfolding ordLeq_def ordIso_def
106.504 - using iso_comp_embed by blast
106.505 -qed
106.506 -
106.507 -
106.508 -lemma ordLess_ordIso_trans[trans]:
106.509 -assumes "r <o r'" and " r' =o r''"
106.510 -shows "r <o r''"
106.511 -proof-
106.512 - have "Well_order r \<and> Well_order r''"
106.513 - using assms unfolding ordLess_def ordIso_def by auto
106.514 - thus ?thesis using assms unfolding ordLess_def ordIso_def
106.515 - using embedS_comp_iso by blast
106.516 -qed
106.517 -
106.518 -
106.519 -lemma ordIso_ordLess_trans[trans]:
106.520 -assumes "r =o r'" and " r' <o r''"
106.521 -shows "r <o r''"
106.522 -proof-
106.523 - have "Well_order r \<and> Well_order r''"
106.524 - using assms unfolding ordLess_def ordIso_def by auto
106.525 - thus ?thesis using assms unfolding ordLess_def ordIso_def
106.526 - using iso_comp_embedS by blast
106.527 -qed
106.528 -
106.529 -
106.530 -lemma ordLess_not_embed:
106.531 -assumes "r <o r'"
106.532 -shows "\<not>(\<exists>f'. embed r' r f')"
106.533 -proof-
106.534 - obtain f where 1: "Well_order r \<and> Well_order r'" and 2: "embed r r' f" and
106.535 - 3: " \<not> bij_betw f (Field r) (Field r')"
106.536 - using assms unfolding ordLess_def by (auto simp add: embedS_def)
106.537 - {fix f' assume *: "embed r' r f'"
106.538 - hence "bij_betw f (Field r) (Field r')" using 1 2
106.539 - by (simp add: embed_bothWays_Field_bij_betw)
106.540 - with 3 have False by contradiction
106.541 - }
106.542 - thus ?thesis by blast
106.543 -qed
106.544 -
106.545 -
106.546 -lemma ordLess_Field:
106.547 -assumes OL: "r1 <o r2" and EMB: "embed r1 r2 f"
106.548 -shows "\<not> (f`(Field r1) = Field r2)"
106.549 -proof-
106.550 - let ?A1 = "Field r1" let ?A2 = "Field r2"
106.551 - obtain g where
106.552 - 0: "Well_order r1 \<and> Well_order r2" and
106.553 - 1: "embed r1 r2 g \<and> \<not>(bij_betw g ?A1 ?A2)"
106.554 - using OL unfolding ordLess_def by (auto simp add: embedS_def)
106.555 - hence "\<forall>a \<in> ?A1. f a = g a"
106.556 - using 0 EMB embed_unique[of r1] by auto
106.557 - hence "\<not>(bij_betw f ?A1 ?A2)"
106.558 - using 1 bij_betw_cong[of ?A1] by blast
106.559 - moreover
106.560 - have "inj_on f ?A1" using EMB 0 by (simp add: embed_inj_on)
106.561 - ultimately show ?thesis by (simp add: bij_betw_def)
106.562 -qed
106.563 -
106.564 -
106.565 -lemma ordLess_iff:
106.566 -"r <o r' = (Well_order r \<and> Well_order r' \<and> \<not>(\<exists>f'. embed r' r f'))"
106.567 -proof
106.568 - assume *: "r <o r'"
106.569 - hence "\<not>(\<exists>f'. embed r' r f')" using ordLess_not_embed[of r r'] by simp
106.570 - with * show "Well_order r \<and> Well_order r' \<and> \<not> (\<exists>f'. embed r' r f')"
106.571 - unfolding ordLess_def by auto
106.572 -next
106.573 - assume *: "Well_order r \<and> Well_order r' \<and> \<not> (\<exists>f'. embed r' r f')"
106.574 - then obtain f where 1: "embed r r' f"
106.575 - using wellorders_totally_ordered[of r r'] by blast
106.576 - moreover
106.577 - {assume "bij_betw f (Field r) (Field r')"
106.578 - with * 1 have "embed r' r (inv_into (Field r) f) "
106.579 - using inv_into_Field_embed_bij_betw[of r r' f] by auto
106.580 - with * have False by blast
106.581 - }
106.582 - ultimately show "(r,r') \<in> ordLess"
106.583 - unfolding ordLess_def using * by (fastforce simp add: embedS_def)
106.584 -qed
106.585 -
106.586 -
106.587 -lemma ordLess_irreflexive: "\<not> r <o r"
106.588 -proof
106.589 - assume "r <o r"
106.590 - hence "Well_order r \<and> \<not>(\<exists>f. embed r r f)"
106.591 - unfolding ordLess_iff ..
106.592 - moreover have "embed r r id" using id_embed[of r] .
106.593 - ultimately show False by blast
106.594 -qed
106.595 -
106.596 -
106.597 -lemma ordLeq_iff_ordLess_or_ordIso:
106.598 -"r \<le>o r' = (r <o r' \<or> r =o r')"
106.599 -unfolding ordRels_def embedS_defs iso_defs by blast
106.600 -
106.601 -
106.602 -lemma ordIso_iff_ordLeq:
106.603 -"(r =o r') = (r \<le>o r' \<and> r' \<le>o r)"
106.604 -proof
106.605 - assume "r =o r'"
106.606 - then obtain f where 1: "Well_order r \<and> Well_order r' \<and>
106.607 - embed r r' f \<and> bij_betw f (Field r) (Field r')"
106.608 - unfolding ordIso_def iso_defs by auto
106.609 - hence "embed r r' f \<and> embed r' r (inv_into (Field r) f)"
106.610 - by (simp add: inv_into_Field_embed_bij_betw)
106.611 - thus "r \<le>o r' \<and> r' \<le>o r"
106.612 - unfolding ordLeq_def using 1 by auto
106.613 -next
106.614 - assume "r \<le>o r' \<and> r' \<le>o r"
106.615 - then obtain f and g where 1: "Well_order r \<and> Well_order r' \<and>
106.616 - embed r r' f \<and> embed r' r g"
106.617 - unfolding ordLeq_def by auto
106.618 - hence "iso r r' f" by (auto simp add: embed_bothWays_iso)
106.619 - thus "r =o r'" unfolding ordIso_def using 1 by auto
106.620 -qed
106.621 -
106.622 -
106.623 -lemma not_ordLess_ordLeq:
106.624 -"r <o r' \<Longrightarrow> \<not> r' \<le>o r"
106.625 -using ordLess_ordLeq_trans ordLess_irreflexive by blast
106.626 -
106.627 -
106.628 -lemma ordLess_or_ordLeq:
106.629 -assumes WELL: "Well_order r" and WELL': "Well_order r'"
106.630 -shows "r <o r' \<or> r' \<le>o r"
106.631 -proof-
106.632 - have "r \<le>o r' \<or> r' \<le>o r"
106.633 - using assms by (simp add: ordLeq_total)
106.634 - moreover
106.635 - {assume "\<not> r <o r' \<and> r \<le>o r'"
106.636 - hence "r =o r'" using ordLeq_iff_ordLess_or_ordIso by blast
106.637 - hence "r' \<le>o r" using ordIso_symmetric ordIso_iff_ordLeq by blast
106.638 - }
106.639 - ultimately show ?thesis by blast
106.640 -qed
106.641 -
106.642 -
106.643 -lemma not_ordLess_ordIso:
106.644 -"r <o r' \<Longrightarrow> \<not> r =o r'"
106.645 -using assms ordLess_ordIso_trans ordIso_symmetric ordLess_irreflexive by blast
106.646 -
106.647 -
106.648 -lemma not_ordLeq_iff_ordLess:
106.649 -assumes WELL: "Well_order r" and WELL': "Well_order r'"
106.650 -shows "(\<not> r' \<le>o r) = (r <o r')"
106.651 -using assms not_ordLess_ordLeq ordLess_or_ordLeq by blast
106.652 -
106.653 -
106.654 -lemma not_ordLess_iff_ordLeq:
106.655 -assumes WELL: "Well_order r" and WELL': "Well_order r'"
106.656 -shows "(\<not> r' <o r) = (r \<le>o r')"
106.657 -using assms not_ordLess_ordLeq ordLess_or_ordLeq by blast
106.658 -
106.659 -
106.660 -lemma ordLess_transitive[trans]:
106.661 -"\<lbrakk>r <o r'; r' <o r''\<rbrakk> \<Longrightarrow> r <o r''"
106.662 -using assms ordLess_ordLeq_trans ordLeq_iff_ordLess_or_ordIso by blast
106.663 -
106.664 -
106.665 -corollary ordLess_trans: "trans ordLess"
106.666 -unfolding trans_def using ordLess_transitive by blast
106.667 -
106.668 -
106.669 -lemmas ordIso_equivalence = ordIso_transitive ordIso_reflexive ordIso_symmetric
106.670 -
106.671 -
106.672 -lemma ordIso_imp_ordLeq:
106.673 -"r =o r' \<Longrightarrow> r \<le>o r'"
106.674 -using ordIso_iff_ordLeq by blast
106.675 -
106.676 -
106.677 -lemma ordLess_imp_ordLeq:
106.678 -"r <o r' \<Longrightarrow> r \<le>o r'"
106.679 -using ordLeq_iff_ordLess_or_ordIso by blast
106.680 -
106.681 -
106.682 -lemma ofilter_subset_ordLeq:
106.683 -assumes WELL: "Well_order r" and
106.684 - OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
106.685 -shows "(A \<le> B) = (Restr r A \<le>o Restr r B)"
106.686 -proof
106.687 - assume "A \<le> B"
106.688 - thus "Restr r A \<le>o Restr r B"
106.689 - unfolding ordLeq_def using assms
106.690 - Well_order_Restr Well_order_Restr ofilter_subset_embed by blast
106.691 -next
106.692 - assume *: "Restr r A \<le>o Restr r B"
106.693 - then obtain f where "embed (Restr r A) (Restr r B) f"
106.694 - unfolding ordLeq_def by blast
106.695 - {assume "B < A"
106.696 - hence "Restr r B <o Restr r A"
106.697 - unfolding ordLess_def using assms
106.698 - Well_order_Restr Well_order_Restr ofilter_subset_embedS by blast
106.699 - hence False using * not_ordLess_ordLeq by blast
106.700 - }
106.701 - thus "A \<le> B" using OFA OFB WELL
106.702 - wo_rel_def[of r] wo_rel.ofilter_linord[of r A B] by blast
106.703 -qed
106.704 -
106.705 -
106.706 -lemma ofilter_subset_ordLess:
106.707 -assumes WELL: "Well_order r" and
106.708 - OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
106.709 -shows "(A < B) = (Restr r A <o Restr r B)"
106.710 -proof-
106.711 - let ?rA = "Restr r A" let ?rB = "Restr r B"
106.712 - have 1: "Well_order ?rA \<and> Well_order ?rB"
106.713 - using WELL Well_order_Restr by blast
106.714 - have "(A < B) = (\<not> B \<le> A)" using assms
106.715 - wo_rel_def wo_rel.ofilter_linord[of r A B] by blast
106.716 - also have "\<dots> = (\<not> Restr r B \<le>o Restr r A)"
106.717 - using assms ofilter_subset_ordLeq by blast
106.718 - also have "\<dots> = (Restr r A <o Restr r B)"
106.719 - using 1 not_ordLeq_iff_ordLess by blast
106.720 - finally show ?thesis .
106.721 -qed
106.722 -
106.723 -
106.724 -lemma ofilter_ordLess:
106.725 -"\<lbrakk>Well_order r; wo_rel.ofilter r A\<rbrakk> \<Longrightarrow> (A < Field r) = (Restr r A <o r)"
106.726 -by (simp add: ofilter_subset_ordLess wo_rel.Field_ofilter
106.727 - wo_rel_def Restr_Field)
106.728 -
106.729 -
106.730 -corollary underS_Restr_ordLess:
106.731 -assumes "Well_order r" and "Field r \<noteq> {}"
106.732 -shows "Restr r (rel.underS r a) <o r"
106.733 -proof-
106.734 - have "rel.underS r a < Field r" using assms
106.735 - by (simp add: rel.underS_Field3)
106.736 - thus ?thesis using assms
106.737 - by (simp add: ofilter_ordLess wo_rel.underS_ofilter wo_rel_def)
106.738 -qed
106.739 -
106.740 -
106.741 -lemma embed_ordLess_ofilterIncl:
106.742 -assumes
106.743 - OL12: "r1 <o r2" and OL23: "r2 <o r3" and
106.744 - EMB13: "embed r1 r3 f13" and EMB23: "embed r2 r3 f23"
106.745 -shows "(f13`(Field r1), f23`(Field r2)) \<in> (ofilterIncl r3)"
106.746 -proof-
106.747 - have OL13: "r1 <o r3"
106.748 - using OL12 OL23 using ordLess_transitive by auto
106.749 - let ?A1 = "Field r1" let ?A2 ="Field r2" let ?A3 ="Field r3"
106.750 - obtain f12 g23 where
106.751 - 0: "Well_order r1 \<and> Well_order r2 \<and> Well_order r3" and
106.752 - 1: "embed r1 r2 f12 \<and> \<not>(bij_betw f12 ?A1 ?A2)" and
106.753 - 2: "embed r2 r3 g23 \<and> \<not>(bij_betw g23 ?A2 ?A3)"
106.754 - using OL12 OL23 by (auto simp add: ordLess_def embedS_def)
106.755 - hence "\<forall>a \<in> ?A2. f23 a = g23 a"
106.756 - using EMB23 embed_unique[of r2 r3] by blast
106.757 - hence 3: "\<not>(bij_betw f23 ?A2 ?A3)"
106.758 - using 2 bij_betw_cong[of ?A2 f23 g23] by blast
106.759 - (* *)
106.760 - have 4: "wo_rel.ofilter r2 (f12 ` ?A1) \<and> f12 ` ?A1 \<noteq> ?A2"
106.761 - using 0 1 OL12 by (simp add: embed_Field_ofilter ordLess_Field)
106.762 - have 5: "wo_rel.ofilter r3 (f23 ` ?A2) \<and> f23 ` ?A2 \<noteq> ?A3"
106.763 - using 0 EMB23 OL23 by (simp add: embed_Field_ofilter ordLess_Field)
106.764 - have 6: "wo_rel.ofilter r3 (f13 ` ?A1) \<and> f13 ` ?A1 \<noteq> ?A3"
106.765 - using 0 EMB13 OL13 by (simp add: embed_Field_ofilter ordLess_Field)
106.766 - (* *)
106.767 - have "f12 ` ?A1 < ?A2"
106.768 - using 0 4 by (auto simp add: wo_rel_def wo_rel.ofilter_def)
106.769 - moreover have "inj_on f23 ?A2"
106.770 - using EMB23 0 by (simp add: wo_rel_def embed_inj_on)
106.771 - ultimately
106.772 - have "f23 ` (f12 ` ?A1) < f23 ` ?A2" by (simp add: inj_on_strict_subset)
106.773 - moreover
106.774 - {have "embed r1 r3 (f23 o f12)"
106.775 - using 1 EMB23 0 by (auto simp add: comp_embed)
106.776 - hence "\<forall>a \<in> ?A1. f23(f12 a) = f13 a"
106.777 - using EMB13 0 embed_unique[of r1 r3 "f23 o f12" f13] by auto
106.778 - hence "f23 ` (f12 ` ?A1) = f13 ` ?A1" by force
106.779 - }
106.780 - ultimately
106.781 - have "f13 ` ?A1 < f23 ` ?A2" by simp
106.782 - (* *)
106.783 - with 5 6 show ?thesis
106.784 - unfolding ofilterIncl_def by auto
106.785 -qed
106.786 -
106.787 -
106.788 -lemma ordLess_iff_ordIso_Restr:
106.789 -assumes WELL: "Well_order r" and WELL': "Well_order r'"
106.790 -shows "(r' <o r) = (\<exists>a \<in> Field r. r' =o Restr r (rel.underS r a))"
106.791 -proof(auto)
106.792 - fix a assume *: "a \<in> Field r" and **: "r' =o Restr r (rel.underS r a)"
106.793 - hence "Restr r (rel.underS r a) <o r" using WELL underS_Restr_ordLess[of r] by blast
106.794 - thus "r' <o r" using ** ordIso_ordLess_trans by blast
106.795 -next
106.796 - assume "r' <o r"
106.797 - then obtain f where 1: "Well_order r \<and> Well_order r'" and
106.798 - 2: "embed r' r f \<and> f ` (Field r') \<noteq> Field r"
106.799 - unfolding ordLess_def embedS_def[abs_def] bij_betw_def using embed_inj_on by blast
106.800 - hence "wo_rel.ofilter r (f ` (Field r'))" using embed_Field_ofilter by blast
106.801 - then obtain a where 3: "a \<in> Field r" and 4: "rel.underS r a = f ` (Field r')"
106.802 - using 1 2 by (auto simp add: wo_rel.ofilter_underS_Field wo_rel_def)
106.803 - have "iso r' (Restr r (f ` (Field r'))) f"
106.804 - using embed_implies_iso_Restr 2 assms by blast
106.805 - moreover have "Well_order (Restr r (f ` (Field r')))"
106.806 - using WELL Well_order_Restr by blast
106.807 - ultimately have "r' =o Restr r (f ` (Field r'))"
106.808 - using WELL' unfolding ordIso_def by auto
106.809 - hence "r' =o Restr r (rel.underS r a)" using 4 by auto
106.810 - thus "\<exists>a \<in> Field r. r' =o Restr r (rel.underS r a)" using 3 by auto
106.811 -qed
106.812 -
106.813 -
106.814 -lemma internalize_ordLess:
106.815 -"(r' <o r) = (\<exists>p. Field p < Field r \<and> r' =o p \<and> p <o r)"
106.816 -proof
106.817 - assume *: "r' <o r"
106.818 - hence 0: "Well_order r \<and> Well_order r'" unfolding ordLess_def by auto
106.819 - with * obtain a where 1: "a \<in> Field r" and 2: "r' =o Restr r (rel.underS r a)"
106.820 - using ordLess_iff_ordIso_Restr by blast
106.821 - let ?p = "Restr r (rel.underS r a)"
106.822 - have "wo_rel.ofilter r (rel.underS r a)" using 0
106.823 - by (simp add: wo_rel_def wo_rel.underS_ofilter)
106.824 - hence "Field ?p = rel.underS r a" using 0 Field_Restr_ofilter by blast
106.825 - hence "Field ?p < Field r" using rel.underS_Field2 1 by fastforce
106.826 - moreover have "?p <o r" using underS_Restr_ordLess[of r a] 0 1 by blast
106.827 - ultimately
106.828 - show "\<exists>p. Field p < Field r \<and> r' =o p \<and> p <o r" using 2 by blast
106.829 -next
106.830 - assume "\<exists>p. Field p < Field r \<and> r' =o p \<and> p <o r"
106.831 - thus "r' <o r" using ordIso_ordLess_trans by blast
106.832 -qed
106.833 -
106.834 -
106.835 -lemma internalize_ordLeq:
106.836 -"(r' \<le>o r) = (\<exists>p. Field p \<le> Field r \<and> r' =o p \<and> p \<le>o r)"
106.837 -proof
106.838 - assume *: "r' \<le>o r"
106.839 - moreover
106.840 - {assume "r' <o r"
106.841 - then obtain p where "Field p < Field r \<and> r' =o p \<and> p <o r"
106.842 - using internalize_ordLess[of r' r] by blast
106.843 - hence "\<exists>p. Field p \<le> Field r \<and> r' =o p \<and> p \<le>o r"
106.844 - using ordLeq_iff_ordLess_or_ordIso by blast
106.845 - }
106.846 - moreover
106.847 - have "r \<le>o r" using * ordLeq_def ordLeq_reflexive by blast
106.848 - ultimately show "\<exists>p. Field p \<le> Field r \<and> r' =o p \<and> p \<le>o r"
106.849 - using ordLeq_iff_ordLess_or_ordIso by blast
106.850 -next
106.851 - assume "\<exists>p. Field p \<le> Field r \<and> r' =o p \<and> p \<le>o r"
106.852 - thus "r' \<le>o r" using ordIso_ordLeq_trans by blast
106.853 -qed
106.854 -
106.855 -
106.856 -lemma ordLeq_iff_ordLess_Restr:
106.857 -assumes WELL: "Well_order r" and WELL': "Well_order r'"
106.858 -shows "(r \<le>o r') = (\<forall>a \<in> Field r. Restr r (rel.underS r a) <o r')"
106.859 -proof(auto)
106.860 - assume *: "r \<le>o r'"
106.861 - fix a assume "a \<in> Field r"
106.862 - hence "Restr r (rel.underS r a) <o r"
106.863 - using WELL underS_Restr_ordLess[of r] by blast
106.864 - thus "Restr r (rel.underS r a) <o r'"
106.865 - using * ordLess_ordLeq_trans by blast
106.866 -next
106.867 - assume *: "\<forall>a \<in> Field r. Restr r (rel.underS r a) <o r'"
106.868 - {assume "r' <o r"
106.869 - then obtain a where "a \<in> Field r \<and> r' =o Restr r (rel.underS r a)"
106.870 - using assms ordLess_iff_ordIso_Restr by blast
106.871 - hence False using * not_ordLess_ordIso ordIso_symmetric by blast
106.872 - }
106.873 - thus "r \<le>o r'" using ordLess_or_ordLeq assms by blast
106.874 -qed
106.875 -
106.876 -
106.877 -lemma finite_ordLess_infinite:
106.878 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and
106.879 - FIN: "finite(Field r)" and INF: "infinite(Field r')"
106.880 -shows "r <o r'"
106.881 -proof-
106.882 - {assume "r' \<le>o r"
106.883 - then obtain h where "inj_on h (Field r') \<and> h ` (Field r') \<le> Field r"
106.884 - unfolding ordLeq_def using assms embed_inj_on embed_Field by blast
106.885 - hence False using finite_imageD finite_subset FIN INF by metis
106.886 - }
106.887 - thus ?thesis using WELL WELL' ordLess_or_ordLeq by blast
106.888 -qed
106.889 -
106.890 -
106.891 -lemma finite_well_order_on_ordIso:
106.892 -assumes FIN: "finite A" and
106.893 - WELL: "well_order_on A r" and WELL': "well_order_on A r'"
106.894 -shows "r =o r'"
106.895 -proof-
106.896 - have 0: "Well_order r \<and> Well_order r' \<and> Field r = A \<and> Field r' = A"
106.897 - using assms rel.well_order_on_Well_order by blast
106.898 - moreover
106.899 - have "\<forall>r r'. well_order_on A r \<and> well_order_on A r' \<and> r \<le>o r'
106.900 - \<longrightarrow> r =o r'"
106.901 - proof(clarify)
106.902 - fix r r' assume *: "well_order_on A r" and **: "well_order_on A r'"
106.903 - have 2: "Well_order r \<and> Well_order r' \<and> Field r = A \<and> Field r' = A"
106.904 - using * ** rel.well_order_on_Well_order by blast
106.905 - assume "r \<le>o r'"
106.906 - then obtain f where 1: "embed r r' f" and
106.907 - "inj_on f A \<and> f ` A \<le> A"
106.908 - unfolding ordLeq_def using 2 embed_inj_on embed_Field by blast
106.909 - hence "bij_betw f A A" unfolding bij_betw_def using FIN endo_inj_surj by blast
106.910 - thus "r =o r'" unfolding ordIso_def iso_def[abs_def] using 1 2 by auto
106.911 - qed
106.912 - ultimately show ?thesis using assms ordLeq_total ordIso_symmetric by blast
106.913 -qed
106.914 -
106.915 -
106.916 -subsection{* @{text "<o"} is well-founded *}
106.917 -
106.918 -
106.919 -text {* Of course, it only makes sense to state that the @{text "<o"} is well-founded
106.920 -on the restricted type @{text "'a rel rel"}. We prove this by first showing that, for any set
106.921 -of well-orders all embedded in a fixed well-order, the function mapping each well-order
106.922 -in the set to an order filter of the fixed well-order is compatible w.r.t. to @{text "<o"} versus
106.923 -{\em strict inclusion}; and we already know that strict inclusion of order filters is well-founded. *}
106.924 -
106.925 -
106.926 -definition ord_to_filter :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a set"
106.927 -where "ord_to_filter r0 r \<equiv> (SOME f. embed r r0 f) ` (Field r)"
106.928 -
106.929 -
106.930 -lemma ord_to_filter_compat:
106.931 -"compat (ordLess Int (ordLess^-1``{r0} \<times> ordLess^-1``{r0}))
106.932 - (ofilterIncl r0)
106.933 - (ord_to_filter r0)"
106.934 -proof(unfold compat_def ord_to_filter_def, clarify)
106.935 - fix r1::"'a rel" and r2::"'a rel"
106.936 - let ?A1 = "Field r1" let ?A2 ="Field r2" let ?A0 ="Field r0"
106.937 - let ?phi10 = "\<lambda> f10. embed r1 r0 f10" let ?f10 = "SOME f. ?phi10 f"
106.938 - let ?phi20 = "\<lambda> f20. embed r2 r0 f20" let ?f20 = "SOME f. ?phi20 f"
106.939 - assume *: "r1 <o r0" "r2 <o r0" and **: "r1 <o r2"
106.940 - hence "(\<exists>f. ?phi10 f) \<and> (\<exists>f. ?phi20 f)"
106.941 - by (auto simp add: ordLess_def embedS_def)
106.942 - hence "?phi10 ?f10 \<and> ?phi20 ?f20" by (auto simp add: someI_ex)
106.943 - thus "(?f10 ` ?A1, ?f20 ` ?A2) \<in> ofilterIncl r0"
106.944 - using * ** by (simp add: embed_ordLess_ofilterIncl)
106.945 -qed
106.946 -
106.947 -
106.948 -theorem wf_ordLess: "wf ordLess"
106.949 -proof-
106.950 - {fix r0 :: "('a \<times> 'a) set"
106.951 - (* need to annotate here!*)
106.952 - let ?ordLess = "ordLess::('d rel * 'd rel) set"
106.953 - let ?R = "?ordLess Int (?ordLess^-1``{r0} \<times> ?ordLess^-1``{r0})"
106.954 - {assume Case1: "Well_order r0"
106.955 - hence "wf ?R"
106.956 - using wf_ofilterIncl[of r0]
106.957 - compat_wf[of ?R "ofilterIncl r0" "ord_to_filter r0"]
106.958 - ord_to_filter_compat[of r0] by auto
106.959 - }
106.960 - moreover
106.961 - {assume Case2: "\<not> Well_order r0"
106.962 - hence "?R = {}" unfolding ordLess_def by auto
106.963 - hence "wf ?R" using wf_empty by simp
106.964 - }
106.965 - ultimately have "wf ?R" by blast
106.966 - }
106.967 - thus ?thesis by (simp add: trans_wf_iff ordLess_trans)
106.968 -qed
106.969 -
106.970 -corollary exists_minim_Well_order:
106.971 -assumes NE: "R \<noteq> {}" and WELL: "\<forall>r \<in> R. Well_order r"
106.972 -shows "\<exists>r \<in> R. \<forall>r' \<in> R. r \<le>o r'"
106.973 -proof-
106.974 - obtain r where "r \<in> R \<and> (\<forall>r' \<in> R. \<not> r' <o r)"
106.975 - using NE spec[OF spec[OF subst[OF wf_eq_minimal, of "%x. x", OF wf_ordLess]], of _ R]
106.976 - equals0I[of R] by blast
106.977 - with not_ordLeq_iff_ordLess WELL show ?thesis by blast
106.978 -qed
106.979 -
106.980 -
106.981 -
106.982 -subsection {* Copy via direct images *}
106.983 -
106.984 -
106.985 -text{* The direct image operator is the dual of the inverse image operator @{text "inv_image"}
106.986 -from @{text "Relation.thy"}. It is useful for transporting a well-order between
106.987 -different types. *}
106.988 -
106.989 -
106.990 -definition dir_image :: "'a rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> 'a' rel"
106.991 -where
106.992 -"dir_image r f = {(f a, f b)| a b. (a,b) \<in> r}"
106.993 -
106.994 -
106.995 -lemma dir_image_Field:
106.996 -"Field(dir_image r f) \<le> f ` (Field r)"
106.997 -unfolding dir_image_def Field_def by auto
106.998 -
106.999 -
106.1000 -lemma dir_image_minus_Id:
106.1001 -"inj_on f (Field r) \<Longrightarrow> (dir_image r f) - Id = dir_image (r - Id) f"
106.1002 -unfolding inj_on_def Field_def dir_image_def by auto
106.1003 -
106.1004 -
106.1005 -lemma Refl_dir_image:
106.1006 -assumes "Refl r"
106.1007 -shows "Refl(dir_image r f)"
106.1008 -proof-
106.1009 - {fix a' b'
106.1010 - assume "(a',b') \<in> dir_image r f"
106.1011 - then obtain a b where 1: "a' = f a \<and> b' = f b \<and> (a,b) \<in> r"
106.1012 - unfolding dir_image_def by blast
106.1013 - hence "a \<in> Field r \<and> b \<in> Field r" using Field_def by fastforce
106.1014 - hence "(a,a) \<in> r \<and> (b,b) \<in> r" using assms by (simp add: refl_on_def)
106.1015 - with 1 have "(a',a') \<in> dir_image r f \<and> (b',b') \<in> dir_image r f"
106.1016 - unfolding dir_image_def by auto
106.1017 - }
106.1018 - thus ?thesis
106.1019 - by(unfold refl_on_def Field_def Domain_def Range_def, auto)
106.1020 -qed
106.1021 -
106.1022 -
106.1023 -lemma trans_dir_image:
106.1024 -assumes TRANS: "trans r" and INJ: "inj_on f (Field r)"
106.1025 -shows "trans(dir_image r f)"
106.1026 -proof(unfold trans_def, auto)
106.1027 - fix a' b' c'
106.1028 - assume "(a',b') \<in> dir_image r f" "(b',c') \<in> dir_image r f"
106.1029 - then obtain a b1 b2 c where 1: "a' = f a \<and> b' = f b1 \<and> b' = f b2 \<and> c' = f c" and
106.1030 - 2: "(a,b1) \<in> r \<and> (b2,c) \<in> r"
106.1031 - unfolding dir_image_def by blast
106.1032 - hence "b1 \<in> Field r \<and> b2 \<in> Field r"
106.1033 - unfolding Field_def by auto
106.1034 - hence "b1 = b2" using 1 INJ unfolding inj_on_def by auto
106.1035 - hence "(a,c): r" using 2 TRANS unfolding trans_def by blast
106.1036 - thus "(a',c') \<in> dir_image r f"
106.1037 - unfolding dir_image_def using 1 by auto
106.1038 -qed
106.1039 -
106.1040 -
106.1041 -lemma Preorder_dir_image:
106.1042 -"\<lbrakk>Preorder r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> Preorder (dir_image r f)"
106.1043 -by (simp add: preorder_on_def Refl_dir_image trans_dir_image)
106.1044 -
106.1045 -
106.1046 -lemma antisym_dir_image:
106.1047 -assumes AN: "antisym r" and INJ: "inj_on f (Field r)"
106.1048 -shows "antisym(dir_image r f)"
106.1049 -proof(unfold antisym_def, auto)
106.1050 - fix a' b'
106.1051 - assume "(a',b') \<in> dir_image r f" "(b',a') \<in> dir_image r f"
106.1052 - then obtain a1 b1 a2 b2 where 1: "a' = f a1 \<and> a' = f a2 \<and> b' = f b1 \<and> b' = f b2" and
106.1053 - 2: "(a1,b1) \<in> r \<and> (b2,a2) \<in> r " and
106.1054 - 3: "{a1,a2,b1,b2} \<le> Field r"
106.1055 - unfolding dir_image_def Field_def by blast
106.1056 - hence "a1 = a2 \<and> b1 = b2" using INJ unfolding inj_on_def by auto
106.1057 - hence "a1 = b2" using 2 AN unfolding antisym_def by auto
106.1058 - thus "a' = b'" using 1 by auto
106.1059 -qed
106.1060 -
106.1061 -
106.1062 -lemma Partial_order_dir_image:
106.1063 -"\<lbrakk>Partial_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> Partial_order (dir_image r f)"
106.1064 -by (simp add: partial_order_on_def Preorder_dir_image antisym_dir_image)
106.1065 -
106.1066 -
106.1067 -lemma Total_dir_image:
106.1068 -assumes TOT: "Total r" and INJ: "inj_on f (Field r)"
106.1069 -shows "Total(dir_image r f)"
106.1070 -proof(unfold total_on_def, intro ballI impI)
106.1071 - fix a' b'
106.1072 - assume "a' \<in> Field (dir_image r f)" "b' \<in> Field (dir_image r f)"
106.1073 - then obtain a and b where 1: "a \<in> Field r \<and> b \<in> Field r \<and> f a = a' \<and> f b = b'"
106.1074 - using dir_image_Field[of r f] by blast
106.1075 - moreover assume "a' \<noteq> b'"
106.1076 - ultimately have "a \<noteq> b" using INJ unfolding inj_on_def by auto
106.1077 - hence "(a,b) \<in> r \<or> (b,a) \<in> r" using 1 TOT unfolding total_on_def by auto
106.1078 - thus "(a',b') \<in> dir_image r f \<or> (b',a') \<in> dir_image r f"
106.1079 - using 1 unfolding dir_image_def by auto
106.1080 -qed
106.1081 -
106.1082 -
106.1083 -lemma Linear_order_dir_image:
106.1084 -"\<lbrakk>Linear_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> Linear_order (dir_image r f)"
106.1085 -by (simp add: linear_order_on_def Partial_order_dir_image Total_dir_image)
106.1086 -
106.1087 -
106.1088 -lemma wf_dir_image:
106.1089 -assumes WF: "wf r" and INJ: "inj_on f (Field r)"
106.1090 -shows "wf(dir_image r f)"
106.1091 -proof(unfold wf_eq_minimal2, intro allI impI, elim conjE)
106.1092 - fix A'::"'b set"
106.1093 - assume SUB: "A' \<le> Field(dir_image r f)" and NE: "A' \<noteq> {}"
106.1094 - obtain A where A_def: "A = {a \<in> Field r. f a \<in> A'}" by blast
106.1095 - have "A \<noteq> {} \<and> A \<le> Field r"
106.1096 - using A_def dir_image_Field[of r f] SUB NE by blast
106.1097 - then obtain a where 1: "a \<in> A \<and> (\<forall>b \<in> A. (b,a) \<notin> r)"
106.1098 - using WF unfolding wf_eq_minimal2 by metis
106.1099 - have "\<forall>b' \<in> A'. (b',f a) \<notin> dir_image r f"
106.1100 - proof(clarify)
106.1101 - fix b' assume *: "b' \<in> A'" and **: "(b',f a) \<in> dir_image r f"
106.1102 - obtain b1 a1 where 2: "b' = f b1 \<and> f a = f a1" and
106.1103 - 3: "(b1,a1) \<in> r \<and> {a1,b1} \<le> Field r"
106.1104 - using ** unfolding dir_image_def Field_def by blast
106.1105 - hence "a = a1" using 1 A_def INJ unfolding inj_on_def by auto
106.1106 - hence "b1 \<in> A \<and> (b1,a) \<in> r" using 2 3 A_def * by auto
106.1107 - with 1 show False by auto
106.1108 - qed
106.1109 - thus "\<exists>a'\<in>A'. \<forall>b'\<in>A'. (b', a') \<notin> dir_image r f"
106.1110 - using A_def 1 by blast
106.1111 -qed
106.1112 -
106.1113 -
106.1114 -lemma Well_order_dir_image:
106.1115 -"\<lbrakk>Well_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> Well_order (dir_image r f)"
106.1116 -using assms unfolding well_order_on_def
106.1117 -using Linear_order_dir_image[of r f] wf_dir_image[of "r - Id" f]
106.1118 - dir_image_minus_Id[of f r]
106.1119 - subset_inj_on[of f "Field r" "Field(r - Id)"]
106.1120 - mono_Field[of "r - Id" r] by auto
106.1121 -
106.1122 -
106.1123 -lemma dir_image_Field2:
106.1124 -"Refl r \<Longrightarrow> Field(dir_image r f) = f ` (Field r)"
106.1125 -unfolding Field_def dir_image_def refl_on_def Domain_def Range_def by blast
106.1126 -
106.1127 -
106.1128 -lemma dir_image_bij_betw:
106.1129 -"\<lbrakk>Well_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> bij_betw f (Field r) (Field (dir_image r f))"
106.1130 -unfolding bij_betw_def
106.1131 -by (simp add: dir_image_Field2 order_on_defs)
106.1132 -
106.1133 -
106.1134 -lemma dir_image_compat:
106.1135 -"compat r (dir_image r f) f"
106.1136 -unfolding compat_def dir_image_def by auto
106.1137 -
106.1138 -
106.1139 -lemma dir_image_iso:
106.1140 -"\<lbrakk>Well_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> iso r (dir_image r f) f"
106.1141 -using iso_iff3 dir_image_compat dir_image_bij_betw Well_order_dir_image by blast
106.1142 -
106.1143 -
106.1144 -lemma dir_image_ordIso:
106.1145 -"\<lbrakk>Well_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> r =o dir_image r f"
106.1146 -unfolding ordIso_def using dir_image_iso Well_order_dir_image by blast
106.1147 -
106.1148 -
106.1149 -lemma Well_order_iso_copy:
106.1150 -assumes WELL: "well_order_on A r" and BIJ: "bij_betw f A A'"
106.1151 -shows "\<exists>r'. well_order_on A' r' \<and> r =o r'"
106.1152 -proof-
106.1153 - let ?r' = "dir_image r f"
106.1154 - have 1: "A = Field r \<and> Well_order r"
106.1155 - using WELL rel.well_order_on_Well_order by blast
106.1156 - hence 2: "iso r ?r' f"
106.1157 - using dir_image_iso using BIJ unfolding bij_betw_def by auto
106.1158 - hence "f ` (Field r) = Field ?r'" using 1 iso_iff[of r ?r'] by blast
106.1159 - hence "Field ?r' = A'"
106.1160 - using 1 BIJ unfolding bij_betw_def by auto
106.1161 - moreover have "Well_order ?r'"
106.1162 - using 1 Well_order_dir_image BIJ unfolding bij_betw_def by blast
106.1163 - ultimately show ?thesis unfolding ordIso_def using 1 2 by blast
106.1164 -qed
106.1165 -
106.1166 -
106.1167 -
106.1168 -subsection {* Bounded square *}
106.1169 -
106.1170 -
106.1171 -text{* This construction essentially defines, for an order relation @{text "r"}, a lexicographic
106.1172 -order @{text "bsqr r"} on @{text "(Field r) \<times> (Field r)"}, applying the
106.1173 -following criteria (in this order):
106.1174 -\begin{itemize}
106.1175 -\item compare the maximums;
106.1176 -\item compare the first components;
106.1177 -\item compare the second components.
106.1178 -\end{itemize}
106.1179 -%
106.1180 -The only application of this construction that we are aware of is
106.1181 -at proving that the square of an infinite set has the same cardinal
106.1182 -as that set. The essential property required there (and which is ensured by this
106.1183 -construction) is that any proper order filter of the product order is included in a rectangle, i.e.,
106.1184 -in a product of proper filters on the original relation (assumed to be a well-order). *}
106.1185 -
106.1186 -
106.1187 -definition bsqr :: "'a rel => ('a * 'a)rel"
106.1188 -where
106.1189 -"bsqr r = {((a1,a2),(b1,b2)).
106.1190 - {a1,a2,b1,b2} \<le> Field r \<and>
106.1191 - (a1 = b1 \<and> a2 = b2 \<or>
106.1192 - (wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id \<or>
106.1193 - wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id \<or>
106.1194 - wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id
106.1195 - )}"
106.1196 -
106.1197 -
106.1198 -lemma Field_bsqr:
106.1199 -"Field (bsqr r) = Field r \<times> Field r"
106.1200 -proof
106.1201 - show "Field (bsqr r) \<le> Field r \<times> Field r"
106.1202 - proof-
106.1203 - {fix a1 a2 assume "(a1,a2) \<in> Field (bsqr r)"
106.1204 - moreover
106.1205 - have "\<And> b1 b2. ((a1,a2),(b1,b2)) \<in> bsqr r \<or> ((b1,b2),(a1,a2)) \<in> bsqr r \<Longrightarrow>
106.1206 - a1 \<in> Field r \<and> a2 \<in> Field r" unfolding bsqr_def by auto
106.1207 - ultimately have "a1 \<in> Field r \<and> a2 \<in> Field r" unfolding Field_def by auto
106.1208 - }
106.1209 - thus ?thesis unfolding Field_def by force
106.1210 - qed
106.1211 -next
106.1212 - show "Field r \<times> Field r \<le> Field (bsqr r)"
106.1213 - proof(auto)
106.1214 - fix a1 a2 assume "a1 \<in> Field r" and "a2 \<in> Field r"
106.1215 - hence "((a1,a2),(a1,a2)) \<in> bsqr r" unfolding bsqr_def by blast
106.1216 - thus "(a1,a2) \<in> Field (bsqr r)" unfolding Field_def by auto
106.1217 - qed
106.1218 -qed
106.1219 -
106.1220 -
106.1221 -lemma bsqr_Refl: "Refl(bsqr r)"
106.1222 -by(unfold refl_on_def Field_bsqr, auto simp add: bsqr_def)
106.1223 -
106.1224 -
106.1225 -lemma bsqr_Trans:
106.1226 -assumes "Well_order r"
106.1227 -shows "trans (bsqr r)"
106.1228 -proof(unfold trans_def, auto)
106.1229 - (* Preliminary facts *)
106.1230 - have Well: "wo_rel r" using assms wo_rel_def by auto
106.1231 - hence Trans: "trans r" using wo_rel.TRANS by auto
106.1232 - have Anti: "antisym r" using wo_rel.ANTISYM Well by auto
106.1233 - hence TransS: "trans(r - Id)" using Trans by (simp add: trans_diff_Id)
106.1234 - (* Main proof *)
106.1235 - fix a1 a2 b1 b2 c1 c2
106.1236 - assume *: "((a1,a2),(b1,b2)) \<in> bsqr r" and **: "((b1,b2),(c1,c2)) \<in> bsqr r"
106.1237 - hence 0: "{a1,a2,b1,b2,c1,c2} \<le> Field r" unfolding bsqr_def by auto
106.1238 - have 1: "a1 = b1 \<and> a2 = b2 \<or> (wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id \<or>
106.1239 - wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id \<or>
106.1240 - wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id"
106.1241 - using * unfolding bsqr_def by auto
106.1242 - have 2: "b1 = c1 \<and> b2 = c2 \<or> (wo_rel.max2 r b1 b2, wo_rel.max2 r c1 c2) \<in> r - Id \<or>
106.1243 - wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> (b1,c1) \<in> r - Id \<or>
106.1244 - wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> b1 = c1 \<and> (b2,c2) \<in> r - Id"
106.1245 - using ** unfolding bsqr_def by auto
106.1246 - show "((a1,a2),(c1,c2)) \<in> bsqr r"
106.1247 - proof-
106.1248 - {assume Case1: "a1 = b1 \<and> a2 = b2"
106.1249 - hence ?thesis using ** by simp
106.1250 - }
106.1251 - moreover
106.1252 - {assume Case2: "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id"
106.1253 - {assume Case21: "b1 = c1 \<and> b2 = c2"
106.1254 - hence ?thesis using * by simp
106.1255 - }
106.1256 - moreover
106.1257 - {assume Case22: "(wo_rel.max2 r b1 b2, wo_rel.max2 r c1 c2) \<in> r - Id"
106.1258 - hence "(wo_rel.max2 r a1 a2, wo_rel.max2 r c1 c2) \<in> r - Id"
106.1259 - using Case2 TransS trans_def[of "r - Id"] by blast
106.1260 - hence ?thesis using 0 unfolding bsqr_def by auto
106.1261 - }
106.1262 - moreover
106.1263 - {assume Case23_4: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2"
106.1264 - hence ?thesis using Case2 0 unfolding bsqr_def by auto
106.1265 - }
106.1266 - ultimately have ?thesis using 0 2 by auto
106.1267 - }
106.1268 - moreover
106.1269 - {assume Case3: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id"
106.1270 - {assume Case31: "b1 = c1 \<and> b2 = c2"
106.1271 - hence ?thesis using * by simp
106.1272 - }
106.1273 - moreover
106.1274 - {assume Case32: "(wo_rel.max2 r b1 b2, wo_rel.max2 r c1 c2) \<in> r - Id"
106.1275 - hence ?thesis using Case3 0 unfolding bsqr_def by auto
106.1276 - }
106.1277 - moreover
106.1278 - {assume Case33: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> (b1,c1) \<in> r - Id"
106.1279 - hence "(a1,c1) \<in> r - Id"
106.1280 - using Case3 TransS trans_def[of "r - Id"] by blast
106.1281 - hence ?thesis using Case3 Case33 0 unfolding bsqr_def by auto
106.1282 - }
106.1283 - moreover
106.1284 - {assume Case33: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> b1 = c1"
106.1285 - hence ?thesis using Case3 0 unfolding bsqr_def by auto
106.1286 - }
106.1287 - ultimately have ?thesis using 0 2 by auto
106.1288 - }
106.1289 - moreover
106.1290 - {assume Case4: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id"
106.1291 - {assume Case41: "b1 = c1 \<and> b2 = c2"
106.1292 - hence ?thesis using * by simp
106.1293 - }
106.1294 - moreover
106.1295 - {assume Case42: "(wo_rel.max2 r b1 b2, wo_rel.max2 r c1 c2) \<in> r - Id"
106.1296 - hence ?thesis using Case4 0 unfolding bsqr_def by force
106.1297 - }
106.1298 - moreover
106.1299 - {assume Case43: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> (b1,c1) \<in> r - Id"
106.1300 - hence ?thesis using Case4 0 unfolding bsqr_def by auto
106.1301 - }
106.1302 - moreover
106.1303 - {assume Case44: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> b1 = c1 \<and> (b2,c2) \<in> r - Id"
106.1304 - hence "(a2,c2) \<in> r - Id"
106.1305 - using Case4 TransS trans_def[of "r - Id"] by blast
106.1306 - hence ?thesis using Case4 Case44 0 unfolding bsqr_def by auto
106.1307 - }
106.1308 - ultimately have ?thesis using 0 2 by auto
106.1309 - }
106.1310 - ultimately show ?thesis using 0 1 by auto
106.1311 - qed
106.1312 -qed
106.1313 -
106.1314 -
106.1315 -lemma bsqr_antisym:
106.1316 -assumes "Well_order r"
106.1317 -shows "antisym (bsqr r)"
106.1318 -proof(unfold antisym_def, clarify)
106.1319 - (* Preliminary facts *)
106.1320 - have Well: "wo_rel r" using assms wo_rel_def by auto
106.1321 - hence Trans: "trans r" using wo_rel.TRANS by auto
106.1322 - have Anti: "antisym r" using wo_rel.ANTISYM Well by auto
106.1323 - hence TransS: "trans(r - Id)" using Trans by (simp add: trans_diff_Id)
106.1324 - hence IrrS: "\<forall>a b. \<not>((a,b) \<in> r - Id \<and> (b,a) \<in> r - Id)"
106.1325 - using Anti trans_def[of "r - Id"] antisym_def[of "r - Id"] by blast
106.1326 - (* Main proof *)
106.1327 - fix a1 a2 b1 b2
106.1328 - assume *: "((a1,a2),(b1,b2)) \<in> bsqr r" and **: "((b1,b2),(a1,a2)) \<in> bsqr r"
106.1329 - hence 0: "{a1,a2,b1,b2} \<le> Field r" unfolding bsqr_def by auto
106.1330 - have 1: "a1 = b1 \<and> a2 = b2 \<or> (wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id \<or>
106.1331 - wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id \<or>
106.1332 - wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id"
106.1333 - using * unfolding bsqr_def by auto
106.1334 - have 2: "b1 = a1 \<and> b2 = a2 \<or> (wo_rel.max2 r b1 b2, wo_rel.max2 r a1 a2) \<in> r - Id \<or>
106.1335 - wo_rel.max2 r b1 b2 = wo_rel.max2 r a1 a2 \<and> (b1,a1) \<in> r - Id \<or>
106.1336 - wo_rel.max2 r b1 b2 = wo_rel.max2 r a1 a2 \<and> b1 = a1 \<and> (b2,a2) \<in> r - Id"
106.1337 - using ** unfolding bsqr_def by auto
106.1338 - show "a1 = b1 \<and> a2 = b2"
106.1339 - proof-
106.1340 - {assume Case1: "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id"
106.1341 - {assume Case11: "(wo_rel.max2 r b1 b2, wo_rel.max2 r a1 a2) \<in> r - Id"
106.1342 - hence False using Case1 IrrS by blast
106.1343 - }
106.1344 - moreover
106.1345 - {assume Case12_3: "wo_rel.max2 r b1 b2 = wo_rel.max2 r a1 a2"
106.1346 - hence False using Case1 by auto
106.1347 - }
106.1348 - ultimately have ?thesis using 0 2 by auto
106.1349 - }
106.1350 - moreover
106.1351 - {assume Case2: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id"
106.1352 - {assume Case21: "(wo_rel.max2 r b1 b2, wo_rel.max2 r a1 a2) \<in> r - Id"
106.1353 - hence False using Case2 by auto
106.1354 - }
106.1355 - moreover
106.1356 - {assume Case22: "(b1,a1) \<in> r - Id"
106.1357 - hence False using Case2 IrrS by blast
106.1358 - }
106.1359 - moreover
106.1360 - {assume Case23: "b1 = a1"
106.1361 - hence False using Case2 by auto
106.1362 - }
106.1363 - ultimately have ?thesis using 0 2 by auto
106.1364 - }
106.1365 - moreover
106.1366 - {assume Case3: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id"
106.1367 - moreover
106.1368 - {assume Case31: "(wo_rel.max2 r b1 b2, wo_rel.max2 r a1 a2) \<in> r - Id"
106.1369 - hence False using Case3 by auto
106.1370 - }
106.1371 - moreover
106.1372 - {assume Case32: "(b1,a1) \<in> r - Id"
106.1373 - hence False using Case3 by auto
106.1374 - }
106.1375 - moreover
106.1376 - {assume Case33: "(b2,a2) \<in> r - Id"
106.1377 - hence False using Case3 IrrS by blast
106.1378 - }
106.1379 - ultimately have ?thesis using 0 2 by auto
106.1380 - }
106.1381 - ultimately show ?thesis using 0 1 by blast
106.1382 - qed
106.1383 -qed
106.1384 -
106.1385 -
106.1386 -lemma bsqr_Total:
106.1387 -assumes "Well_order r"
106.1388 -shows "Total(bsqr r)"
106.1389 -proof-
106.1390 - (* Preliminary facts *)
106.1391 - have Well: "wo_rel r" using assms wo_rel_def by auto
106.1392 - hence Total: "\<forall>a \<in> Field r. \<forall>b \<in> Field r. (a,b) \<in> r \<or> (b,a) \<in> r"
106.1393 - using wo_rel.TOTALS by auto
106.1394 - (* Main proof *)
106.1395 - {fix a1 a2 b1 b2 assume "{(a1,a2), (b1,b2)} \<le> Field(bsqr r)"
106.1396 - hence 0: "a1 \<in> Field r \<and> a2 \<in> Field r \<and> b1 \<in> Field r \<and> b2 \<in> Field r"
106.1397 - using Field_bsqr by blast
106.1398 - have "((a1,a2) = (b1,b2) \<or> ((a1,a2),(b1,b2)) \<in> bsqr r \<or> ((b1,b2),(a1,a2)) \<in> bsqr r)"
106.1399 - proof(rule wo_rel.cases_Total[of r a1 a2], clarsimp simp add: Well, simp add: 0)
106.1400 - (* Why didn't clarsimp simp add: Well 0 do the same job? *)
106.1401 - assume Case1: "(a1,a2) \<in> r"
106.1402 - hence 1: "wo_rel.max2 r a1 a2 = a2"
106.1403 - using Well 0 by (simp add: wo_rel.max2_equals2)
106.1404 - show ?thesis
106.1405 - proof(rule wo_rel.cases_Total[of r b1 b2], clarsimp simp add: Well, simp add: 0)
106.1406 - assume Case11: "(b1,b2) \<in> r"
106.1407 - hence 2: "wo_rel.max2 r b1 b2 = b2"
106.1408 - using Well 0 by (simp add: wo_rel.max2_equals2)
106.1409 - show ?thesis
106.1410 - proof(rule wo_rel.cases_Total3[of r a2 b2], clarsimp simp add: Well, simp add: 0)
106.1411 - assume Case111: "(a2,b2) \<in> r - Id \<or> (b2,a2) \<in> r - Id"
106.1412 - thus ?thesis using 0 1 2 unfolding bsqr_def by auto
106.1413 - next
106.1414 - assume Case112: "a2 = b2"
106.1415 - show ?thesis
106.1416 - proof(rule wo_rel.cases_Total3[of r a1 b1], clarsimp simp add: Well, simp add: 0)
106.1417 - assume Case1121: "(a1,b1) \<in> r - Id \<or> (b1,a1) \<in> r - Id"
106.1418 - thus ?thesis using 0 1 2 Case112 unfolding bsqr_def by auto
106.1419 - next
106.1420 - assume Case1122: "a1 = b1"
106.1421 - thus ?thesis using Case112 by auto
106.1422 - qed
106.1423 - qed
106.1424 - next
106.1425 - assume Case12: "(b2,b1) \<in> r"
106.1426 - hence 3: "wo_rel.max2 r b1 b2 = b1" using Well 0 by (simp add: wo_rel.max2_equals1)
106.1427 - show ?thesis
106.1428 - proof(rule wo_rel.cases_Total3[of r a2 b1], clarsimp simp add: Well, simp add: 0)
106.1429 - assume Case121: "(a2,b1) \<in> r - Id \<or> (b1,a2) \<in> r - Id"
106.1430 - thus ?thesis using 0 1 3 unfolding bsqr_def by auto
106.1431 - next
106.1432 - assume Case122: "a2 = b1"
106.1433 - show ?thesis
106.1434 - proof(rule wo_rel.cases_Total3[of r a1 b1], clarsimp simp add: Well, simp add: 0)
106.1435 - assume Case1221: "(a1,b1) \<in> r - Id \<or> (b1,a1) \<in> r - Id"
106.1436 - thus ?thesis using 0 1 3 Case122 unfolding bsqr_def by auto
106.1437 - next
106.1438 - assume Case1222: "a1 = b1"
106.1439 - show ?thesis
106.1440 - proof(rule wo_rel.cases_Total3[of r a2 b2], clarsimp simp add: Well, simp add: 0)
106.1441 - assume Case12221: "(a2,b2) \<in> r - Id \<or> (b2,a2) \<in> r - Id"
106.1442 - thus ?thesis using 0 1 3 Case122 Case1222 unfolding bsqr_def by auto
106.1443 - next
106.1444 - assume Case12222: "a2 = b2"
106.1445 - thus ?thesis using Case122 Case1222 by auto
106.1446 - qed
106.1447 - qed
106.1448 - qed
106.1449 - qed
106.1450 - next
106.1451 - assume Case2: "(a2,a1) \<in> r"
106.1452 - hence 1: "wo_rel.max2 r a1 a2 = a1" using Well 0 by (simp add: wo_rel.max2_equals1)
106.1453 - show ?thesis
106.1454 - proof(rule wo_rel.cases_Total[of r b1 b2], clarsimp simp add: Well, simp add: 0)
106.1455 - assume Case21: "(b1,b2) \<in> r"
106.1456 - hence 2: "wo_rel.max2 r b1 b2 = b2" using Well 0 by (simp add: wo_rel.max2_equals2)
106.1457 - show ?thesis
106.1458 - proof(rule wo_rel.cases_Total3[of r a1 b2], clarsimp simp add: Well, simp add: 0)
106.1459 - assume Case211: "(a1,b2) \<in> r - Id \<or> (b2,a1) \<in> r - Id"
106.1460 - thus ?thesis using 0 1 2 unfolding bsqr_def by auto
106.1461 - next
106.1462 - assume Case212: "a1 = b2"
106.1463 - show ?thesis
106.1464 - proof(rule wo_rel.cases_Total3[of r a1 b1], clarsimp simp add: Well, simp add: 0)
106.1465 - assume Case2121: "(a1,b1) \<in> r - Id \<or> (b1,a1) \<in> r - Id"
106.1466 - thus ?thesis using 0 1 2 Case212 unfolding bsqr_def by auto
106.1467 - next
106.1468 - assume Case2122: "a1 = b1"
106.1469 - show ?thesis
106.1470 - proof(rule wo_rel.cases_Total3[of r a2 b2], clarsimp simp add: Well, simp add: 0)
106.1471 - assume Case21221: "(a2,b2) \<in> r - Id \<or> (b2,a2) \<in> r - Id"
106.1472 - thus ?thesis using 0 1 2 Case212 Case2122 unfolding bsqr_def by auto
106.1473 - next
106.1474 - assume Case21222: "a2 = b2"
106.1475 - thus ?thesis using Case2122 Case212 by auto
106.1476 - qed
106.1477 - qed
106.1478 - qed
106.1479 - next
106.1480 - assume Case22: "(b2,b1) \<in> r"
106.1481 - hence 3: "wo_rel.max2 r b1 b2 = b1" using Well 0 by (simp add: wo_rel.max2_equals1)
106.1482 - show ?thesis
106.1483 - proof(rule wo_rel.cases_Total3[of r a1 b1], clarsimp simp add: Well, simp add: 0)
106.1484 - assume Case221: "(a1,b1) \<in> r - Id \<or> (b1,a1) \<in> r - Id"
106.1485 - thus ?thesis using 0 1 3 unfolding bsqr_def by auto
106.1486 - next
106.1487 - assume Case222: "a1 = b1"
106.1488 - show ?thesis
106.1489 - proof(rule wo_rel.cases_Total3[of r a2 b2], clarsimp simp add: Well, simp add: 0)
106.1490 - assume Case2221: "(a2,b2) \<in> r - Id \<or> (b2,a2) \<in> r - Id"
106.1491 - thus ?thesis using 0 1 3 Case222 unfolding bsqr_def by auto
106.1492 - next
106.1493 - assume Case2222: "a2 = b2"
106.1494 - thus ?thesis using Case222 by auto
106.1495 - qed
106.1496 - qed
106.1497 - qed
106.1498 - qed
106.1499 - }
106.1500 - thus ?thesis unfolding total_on_def by fast
106.1501 -qed
106.1502 -
106.1503 -
106.1504 -lemma bsqr_Linear_order:
106.1505 -assumes "Well_order r"
106.1506 -shows "Linear_order(bsqr r)"
106.1507 -unfolding order_on_defs
106.1508 -using assms bsqr_Refl bsqr_Trans bsqr_antisym bsqr_Total by blast
106.1509 -
106.1510 -
106.1511 -lemma bsqr_Well_order:
106.1512 -assumes "Well_order r"
106.1513 -shows "Well_order(bsqr r)"
106.1514 -using assms
106.1515 -proof(simp add: bsqr_Linear_order Linear_order_Well_order_iff, intro allI impI)
106.1516 - have 0: "\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r)"
106.1517 - using assms well_order_on_def Linear_order_Well_order_iff by blast
106.1518 - fix D assume *: "D \<le> Field (bsqr r)" and **: "D \<noteq> {}"
106.1519 - hence 1: "D \<le> Field r \<times> Field r" unfolding Field_bsqr by simp
106.1520 - (* *)
106.1521 - obtain M where M_def: "M = {wo_rel.max2 r a1 a2| a1 a2. (a1,a2) \<in> D}" by blast
106.1522 - have "M \<noteq> {}" using 1 M_def ** by auto
106.1523 - moreover
106.1524 - have "M \<le> Field r" unfolding M_def
106.1525 - using 1 assms wo_rel_def[of r] wo_rel.max2_among[of r] by fastforce
106.1526 - ultimately obtain m where m_min: "m \<in> M \<and> (\<forall>a \<in> M. (m,a) \<in> r)"
106.1527 - using 0 by blast
106.1528 - (* *)
106.1529 - obtain A1 where A1_def: "A1 = {a1. \<exists>a2. (a1,a2) \<in> D \<and> wo_rel.max2 r a1 a2 = m}" by blast
106.1530 - have "A1 \<le> Field r" unfolding A1_def using 1 by auto
106.1531 - moreover have "A1 \<noteq> {}" unfolding A1_def using m_min unfolding M_def by blast
106.1532 - ultimately obtain a1 where a1_min: "a1 \<in> A1 \<and> (\<forall>a \<in> A1. (a1,a) \<in> r)"
106.1533 - using 0 by blast
106.1534 - (* *)
106.1535 - obtain A2 where A2_def: "A2 = {a2. (a1,a2) \<in> D \<and> wo_rel.max2 r a1 a2 = m}" by blast
106.1536 - have "A2 \<le> Field r" unfolding A2_def using 1 by auto
106.1537 - moreover have "A2 \<noteq> {}" unfolding A2_def
106.1538 - using m_min a1_min unfolding A1_def M_def by blast
106.1539 - ultimately obtain a2 where a2_min: "a2 \<in> A2 \<and> (\<forall>a \<in> A2. (a2,a) \<in> r)"
106.1540 - using 0 by blast
106.1541 - (* *)
106.1542 - have 2: "wo_rel.max2 r a1 a2 = m"
106.1543 - using a1_min a2_min unfolding A1_def A2_def by auto
106.1544 - have 3: "(a1,a2) \<in> D" using a2_min unfolding A2_def by auto
106.1545 - (* *)
106.1546 - moreover
106.1547 - {fix b1 b2 assume ***: "(b1,b2) \<in> D"
106.1548 - hence 4: "{a1,a2,b1,b2} \<le> Field r" using 1 3 by blast
106.1549 - have 5: "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r"
106.1550 - using *** a1_min a2_min m_min unfolding A1_def A2_def M_def by auto
106.1551 - have "((a1,a2),(b1,b2)) \<in> bsqr r"
106.1552 - proof(cases "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2")
106.1553 - assume Case1: "wo_rel.max2 r a1 a2 \<noteq> wo_rel.max2 r b1 b2"
106.1554 - thus ?thesis unfolding bsqr_def using 4 5 by auto
106.1555 - next
106.1556 - assume Case2: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2"
106.1557 - hence "b1 \<in> A1" unfolding A1_def using 2 *** by auto
106.1558 - hence 6: "(a1,b1) \<in> r" using a1_min by auto
106.1559 - show ?thesis
106.1560 - proof(cases "a1 = b1")
106.1561 - assume Case21: "a1 \<noteq> b1"
106.1562 - thus ?thesis unfolding bsqr_def using 4 Case2 6 by auto
106.1563 - next
106.1564 - assume Case22: "a1 = b1"
106.1565 - hence "b2 \<in> A2" unfolding A2_def using 2 *** Case2 by auto
106.1566 - hence 7: "(a2,b2) \<in> r" using a2_min by auto
106.1567 - thus ?thesis unfolding bsqr_def using 4 7 Case2 Case22 by auto
106.1568 - qed
106.1569 - qed
106.1570 - }
106.1571 - (* *)
106.1572 - ultimately show "\<exists>d \<in> D. \<forall>d' \<in> D. (d,d') \<in> bsqr r" by fastforce
106.1573 -qed
106.1574 -
106.1575 -
106.1576 -lemma bsqr_max2:
106.1577 -assumes WELL: "Well_order r" and LEQ: "((a1,a2),(b1,b2)) \<in> bsqr r"
106.1578 -shows "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r"
106.1579 -proof-
106.1580 - have "{(a1,a2),(b1,b2)} \<le> Field(bsqr r)"
106.1581 - using LEQ unfolding Field_def by auto
106.1582 - hence "{a1,a2,b1,b2} \<le> Field r" unfolding Field_bsqr by auto
106.1583 - hence "{wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2} \<le> Field r"
106.1584 - using WELL wo_rel_def[of r] wo_rel.max2_among[of r] by fastforce
106.1585 - moreover have "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r \<or> wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2"
106.1586 - using LEQ unfolding bsqr_def by auto
106.1587 - ultimately show ?thesis using WELL unfolding order_on_defs refl_on_def by auto
106.1588 -qed
106.1589 -
106.1590 -
106.1591 -lemma bsqr_ofilter:
106.1592 -assumes WELL: "Well_order r" and
106.1593 - OF: "wo_rel.ofilter (bsqr r) D" and SUB: "D < Field r \<times> Field r" and
106.1594 - NE: "\<not> (\<exists>a. Field r = rel.under r a)"
106.1595 -shows "\<exists>A. wo_rel.ofilter r A \<and> A < Field r \<and> D \<le> A \<times> A"
106.1596 -proof-
106.1597 - let ?r' = "bsqr r"
106.1598 - have Well: "wo_rel r" using WELL wo_rel_def by blast
106.1599 - hence Trans: "trans r" using wo_rel.TRANS by blast
106.1600 - have Well': "Well_order ?r' \<and> wo_rel ?r'"
106.1601 - using WELL bsqr_Well_order wo_rel_def by blast
106.1602 - (* *)
106.1603 - have "D < Field ?r'" unfolding Field_bsqr using SUB .
106.1604 - with OF obtain a1 and a2 where
106.1605 - "(a1,a2) \<in> Field ?r'" and 1: "D = rel.underS ?r' (a1,a2)"
106.1606 - using Well' wo_rel.ofilter_underS_Field[of ?r' D] by auto
106.1607 - hence 2: "{a1,a2} \<le> Field r" unfolding Field_bsqr by auto
106.1608 - let ?m = "wo_rel.max2 r a1 a2"
106.1609 - have "D \<le> (rel.under r ?m) \<times> (rel.under r ?m)"
106.1610 - proof(unfold 1)
106.1611 - {fix b1 b2
106.1612 - let ?n = "wo_rel.max2 r b1 b2"
106.1613 - assume "(b1,b2) \<in> rel.underS ?r' (a1,a2)"
106.1614 - hence 3: "((b1,b2),(a1,a2)) \<in> ?r'"
106.1615 - unfolding rel.underS_def by blast
106.1616 - hence "(?n,?m) \<in> r" using WELL by (simp add: bsqr_max2)
106.1617 - moreover
106.1618 - {have "(b1,b2) \<in> Field ?r'" using 3 unfolding Field_def by auto
106.1619 - hence "{b1,b2} \<le> Field r" unfolding Field_bsqr by auto
106.1620 - hence "(b1,?n) \<in> r \<and> (b2,?n) \<in> r"
106.1621 - using Well by (simp add: wo_rel.max2_greater)
106.1622 - }
106.1623 - ultimately have "(b1,?m) \<in> r \<and> (b2,?m) \<in> r"
106.1624 - using Trans trans_def[of r] by blast
106.1625 - hence "(b1,b2) \<in> (rel.under r ?m) \<times> (rel.under r ?m)" unfolding rel.under_def by simp}
106.1626 - thus "rel.underS ?r' (a1,a2) \<le> (rel.under r ?m) \<times> (rel.under r ?m)" by auto
106.1627 - qed
106.1628 - moreover have "wo_rel.ofilter r (rel.under r ?m)"
106.1629 - using Well by (simp add: wo_rel.under_ofilter)
106.1630 - moreover have "rel.under r ?m < Field r"
106.1631 - using NE rel.under_Field[of r ?m] by blast
106.1632 - ultimately show ?thesis by blast
106.1633 -qed
106.1634 -
106.1635 -
106.1636 -end
107.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
107.2 +++ b/src/HOL/Cardinals/Constructions_on_Wellorders_FP.thy Thu Dec 05 17:58:03 2013 +0100
107.3 @@ -0,0 +1,1621 @@
107.4 +(* Title: HOL/Cardinals/Constructions_on_Wellorders_FP.thy
107.5 + Author: Andrei Popescu, TU Muenchen
107.6 + Copyright 2012
107.7 +
107.8 +Constructions on wellorders (FP).
107.9 +*)
107.10 +
107.11 +header {* Constructions on Wellorders (FP) *}
107.12 +
107.13 +theory Constructions_on_Wellorders_FP
107.14 +imports Wellorder_Embedding_FP
107.15 +begin
107.16 +
107.17 +
107.18 +text {* In this section, we study basic constructions on well-orders, such as restriction to
107.19 +a set/order filter, copy via direct images, ordinal-like sum of disjoint well-orders,
107.20 +and bounded square. We also define between well-orders
107.21 +the relations @{text "ordLeq"}, of being embedded (abbreviated @{text "\<le>o"}),
107.22 +@{text "ordLess"}, of being strictly embedded (abbreviated @{text "<o"}), and
107.23 +@{text "ordIso"}, of being isomorphic (abbreviated @{text "=o"}). We study the
107.24 +connections between these relations, order filters, and the aforementioned constructions.
107.25 +A main result of this section is that @{text "<o"} is well-founded. *}
107.26 +
107.27 +
107.28 +subsection {* Restriction to a set *}
107.29 +
107.30 +
107.31 +abbreviation Restr :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a rel"
107.32 +where "Restr r A \<equiv> r Int (A \<times> A)"
107.33 +
107.34 +
107.35 +lemma Restr_subset:
107.36 +"A \<le> B \<Longrightarrow> Restr (Restr r B) A = Restr r A"
107.37 +by blast
107.38 +
107.39 +
107.40 +lemma Restr_Field: "Restr r (Field r) = r"
107.41 +unfolding Field_def by auto
107.42 +
107.43 +
107.44 +lemma Refl_Restr: "Refl r \<Longrightarrow> Refl(Restr r A)"
107.45 +unfolding refl_on_def Field_def by auto
107.46 +
107.47 +
107.48 +lemma antisym_Restr:
107.49 +"antisym r \<Longrightarrow> antisym(Restr r A)"
107.50 +unfolding antisym_def Field_def by auto
107.51 +
107.52 +
107.53 +lemma Total_Restr:
107.54 +"Total r \<Longrightarrow> Total(Restr r A)"
107.55 +unfolding total_on_def Field_def by auto
107.56 +
107.57 +
107.58 +lemma trans_Restr:
107.59 +"trans r \<Longrightarrow> trans(Restr r A)"
107.60 +unfolding trans_def Field_def by blast
107.61 +
107.62 +
107.63 +lemma Preorder_Restr:
107.64 +"Preorder r \<Longrightarrow> Preorder(Restr r A)"
107.65 +unfolding preorder_on_def by (simp add: Refl_Restr trans_Restr)
107.66 +
107.67 +
107.68 +lemma Partial_order_Restr:
107.69 +"Partial_order r \<Longrightarrow> Partial_order(Restr r A)"
107.70 +unfolding partial_order_on_def by (simp add: Preorder_Restr antisym_Restr)
107.71 +
107.72 +
107.73 +lemma Linear_order_Restr:
107.74 +"Linear_order r \<Longrightarrow> Linear_order(Restr r A)"
107.75 +unfolding linear_order_on_def by (simp add: Partial_order_Restr Total_Restr)
107.76 +
107.77 +
107.78 +lemma Well_order_Restr:
107.79 +assumes "Well_order r"
107.80 +shows "Well_order(Restr r A)"
107.81 +proof-
107.82 + have "Restr r A - Id \<le> r - Id" using Restr_subset by blast
107.83 + hence "wf(Restr r A - Id)" using assms
107.84 + using well_order_on_def wf_subset by blast
107.85 + thus ?thesis using assms unfolding well_order_on_def
107.86 + by (simp add: Linear_order_Restr)
107.87 +qed
107.88 +
107.89 +
107.90 +lemma Field_Restr_subset: "Field(Restr r A) \<le> A"
107.91 +by (auto simp add: Field_def)
107.92 +
107.93 +
107.94 +lemma Refl_Field_Restr:
107.95 +"Refl r \<Longrightarrow> Field(Restr r A) = (Field r) Int A"
107.96 +unfolding refl_on_def Field_def by blast
107.97 +
107.98 +
107.99 +lemma Refl_Field_Restr2:
107.100 +"\<lbrakk>Refl r; A \<le> Field r\<rbrakk> \<Longrightarrow> Field(Restr r A) = A"
107.101 +by (auto simp add: Refl_Field_Restr)
107.102 +
107.103 +
107.104 +lemma well_order_on_Restr:
107.105 +assumes WELL: "Well_order r" and SUB: "A \<le> Field r"
107.106 +shows "well_order_on A (Restr r A)"
107.107 +using assms
107.108 +using Well_order_Restr[of r A] Refl_Field_Restr2[of r A]
107.109 + order_on_defs[of "Field r" r] by auto
107.110 +
107.111 +
107.112 +subsection {* Order filters versus restrictions and embeddings *}
107.113 +
107.114 +
107.115 +lemma Field_Restr_ofilter:
107.116 +"\<lbrakk>Well_order r; wo_rel.ofilter r A\<rbrakk> \<Longrightarrow> Field(Restr r A) = A"
107.117 +by (auto simp add: wo_rel_def wo_rel.ofilter_def wo_rel.REFL Refl_Field_Restr2)
107.118 +
107.119 +
107.120 +lemma ofilter_Restr_under:
107.121 +assumes WELL: "Well_order r" and OF: "wo_rel.ofilter r A" and IN: "a \<in> A"
107.122 +shows "rel.under (Restr r A) a = rel.under r a"
107.123 +using assms wo_rel_def
107.124 +proof(auto simp add: wo_rel.ofilter_def rel.under_def)
107.125 + fix b assume *: "a \<in> A" and "(b,a) \<in> r"
107.126 + hence "b \<in> rel.under r a \<and> a \<in> Field r"
107.127 + unfolding rel.under_def using Field_def by fastforce
107.128 + thus "b \<in> A" using * assms by (auto simp add: wo_rel_def wo_rel.ofilter_def)
107.129 +qed
107.130 +
107.131 +
107.132 +lemma ofilter_embed:
107.133 +assumes "Well_order r"
107.134 +shows "wo_rel.ofilter r A = (A \<le> Field r \<and> embed (Restr r A) r id)"
107.135 +proof
107.136 + assume *: "wo_rel.ofilter r A"
107.137 + show "A \<le> Field r \<and> embed (Restr r A) r id"
107.138 + proof(unfold embed_def, auto)
107.139 + fix a assume "a \<in> A" thus "a \<in> Field r" using assms *
107.140 + by (auto simp add: wo_rel_def wo_rel.ofilter_def)
107.141 + next
107.142 + fix a assume "a \<in> Field (Restr r A)"
107.143 + thus "bij_betw id (rel.under (Restr r A) a) (rel.under r a)" using assms *
107.144 + by (simp add: ofilter_Restr_under Field_Restr_ofilter)
107.145 + qed
107.146 +next
107.147 + assume *: "A \<le> Field r \<and> embed (Restr r A) r id"
107.148 + hence "Field(Restr r A) \<le> Field r"
107.149 + using assms embed_Field[of "Restr r A" r id] id_def
107.150 + Well_order_Restr[of r] by auto
107.151 + {fix a assume "a \<in> A"
107.152 + hence "a \<in> Field(Restr r A)" using * assms
107.153 + by (simp add: order_on_defs Refl_Field_Restr2)
107.154 + hence "bij_betw id (rel.under (Restr r A) a) (rel.under r a)"
107.155 + using * unfolding embed_def by auto
107.156 + hence "rel.under r a \<le> rel.under (Restr r A) a"
107.157 + unfolding bij_betw_def by auto
107.158 + also have "\<dots> \<le> Field(Restr r A)" by (simp add: rel.under_Field)
107.159 + also have "\<dots> \<le> A" by (simp add: Field_Restr_subset)
107.160 + finally have "rel.under r a \<le> A" .
107.161 + }
107.162 + thus "wo_rel.ofilter r A" using assms * by (simp add: wo_rel_def wo_rel.ofilter_def)
107.163 +qed
107.164 +
107.165 +
107.166 +lemma ofilter_Restr_Int:
107.167 +assumes WELL: "Well_order r" and OFA: "wo_rel.ofilter r A"
107.168 +shows "wo_rel.ofilter (Restr r B) (A Int B)"
107.169 +proof-
107.170 + let ?rB = "Restr r B"
107.171 + have Well: "wo_rel r" unfolding wo_rel_def using WELL .
107.172 + hence Refl: "Refl r" by (simp add: wo_rel.REFL)
107.173 + hence Field: "Field ?rB = Field r Int B"
107.174 + using Refl_Field_Restr by blast
107.175 + have WellB: "wo_rel ?rB \<and> Well_order ?rB" using WELL
107.176 + by (simp add: Well_order_Restr wo_rel_def)
107.177 + (* Main proof *)
107.178 + show ?thesis using WellB assms
107.179 + proof(auto simp add: wo_rel.ofilter_def rel.under_def)
107.180 + fix a assume "a \<in> A" and *: "a \<in> B"
107.181 + hence "a \<in> Field r" using OFA Well by (auto simp add: wo_rel.ofilter_def)
107.182 + with * show "a \<in> Field ?rB" using Field by auto
107.183 + next
107.184 + fix a b assume "a \<in> A" and "(b,a) \<in> r"
107.185 + thus "b \<in> A" using Well OFA by (auto simp add: wo_rel.ofilter_def rel.under_def)
107.186 + qed
107.187 +qed
107.188 +
107.189 +
107.190 +lemma ofilter_Restr_subset:
107.191 +assumes WELL: "Well_order r" and OFA: "wo_rel.ofilter r A" and SUB: "A \<le> B"
107.192 +shows "wo_rel.ofilter (Restr r B) A"
107.193 +proof-
107.194 + have "A Int B = A" using SUB by blast
107.195 + thus ?thesis using assms ofilter_Restr_Int[of r A B] by auto
107.196 +qed
107.197 +
107.198 +
107.199 +lemma ofilter_subset_embed:
107.200 +assumes WELL: "Well_order r" and
107.201 + OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
107.202 +shows "(A \<le> B) = (embed (Restr r A) (Restr r B) id)"
107.203 +proof-
107.204 + let ?rA = "Restr r A" let ?rB = "Restr r B"
107.205 + have Well: "wo_rel r" unfolding wo_rel_def using WELL .
107.206 + hence Refl: "Refl r" by (simp add: wo_rel.REFL)
107.207 + hence FieldA: "Field ?rA = Field r Int A"
107.208 + using Refl_Field_Restr by blast
107.209 + have FieldB: "Field ?rB = Field r Int B"
107.210 + using Refl Refl_Field_Restr by blast
107.211 + have WellA: "wo_rel ?rA \<and> Well_order ?rA" using WELL
107.212 + by (simp add: Well_order_Restr wo_rel_def)
107.213 + have WellB: "wo_rel ?rB \<and> Well_order ?rB" using WELL
107.214 + by (simp add: Well_order_Restr wo_rel_def)
107.215 + (* Main proof *)
107.216 + show ?thesis
107.217 + proof
107.218 + assume *: "A \<le> B"
107.219 + hence "wo_rel.ofilter (Restr r B) A" using assms
107.220 + by (simp add: ofilter_Restr_subset)
107.221 + hence "embed (Restr ?rB A) (Restr r B) id"
107.222 + using WellB ofilter_embed[of "?rB" A] by auto
107.223 + thus "embed (Restr r A) (Restr r B) id"
107.224 + using * by (simp add: Restr_subset)
107.225 + next
107.226 + assume *: "embed (Restr r A) (Restr r B) id"
107.227 + {fix a assume **: "a \<in> A"
107.228 + hence "a \<in> Field r" using Well OFA by (auto simp add: wo_rel.ofilter_def)
107.229 + with ** FieldA have "a \<in> Field ?rA" by auto
107.230 + hence "a \<in> Field ?rB" using * WellA embed_Field[of ?rA ?rB id] by auto
107.231 + hence "a \<in> B" using FieldB by auto
107.232 + }
107.233 + thus "A \<le> B" by blast
107.234 + qed
107.235 +qed
107.236 +
107.237 +
107.238 +lemma ofilter_subset_embedS_iso:
107.239 +assumes WELL: "Well_order r" and
107.240 + OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
107.241 +shows "((A < B) = (embedS (Restr r A) (Restr r B) id)) \<and>
107.242 + ((A = B) = (iso (Restr r A) (Restr r B) id))"
107.243 +proof-
107.244 + let ?rA = "Restr r A" let ?rB = "Restr r B"
107.245 + have Well: "wo_rel r" unfolding wo_rel_def using WELL .
107.246 + hence Refl: "Refl r" by (simp add: wo_rel.REFL)
107.247 + hence "Field ?rA = Field r Int A"
107.248 + using Refl_Field_Restr by blast
107.249 + hence FieldA: "Field ?rA = A" using OFA Well
107.250 + by (auto simp add: wo_rel.ofilter_def)
107.251 + have "Field ?rB = Field r Int B"
107.252 + using Refl Refl_Field_Restr by blast
107.253 + hence FieldB: "Field ?rB = B" using OFB Well
107.254 + by (auto simp add: wo_rel.ofilter_def)
107.255 + (* Main proof *)
107.256 + show ?thesis unfolding embedS_def iso_def
107.257 + using assms ofilter_subset_embed[of r A B]
107.258 + FieldA FieldB bij_betw_id_iff[of A B] by auto
107.259 +qed
107.260 +
107.261 +
107.262 +lemma ofilter_subset_embedS:
107.263 +assumes WELL: "Well_order r" and
107.264 + OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
107.265 +shows "(A < B) = embedS (Restr r A) (Restr r B) id"
107.266 +using assms by (simp add: ofilter_subset_embedS_iso)
107.267 +
107.268 +
107.269 +lemma embed_implies_iso_Restr:
107.270 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and
107.271 + EMB: "embed r' r f"
107.272 +shows "iso r' (Restr r (f ` (Field r'))) f"
107.273 +proof-
107.274 + let ?A' = "Field r'"
107.275 + let ?r'' = "Restr r (f ` ?A')"
107.276 + have 0: "Well_order ?r''" using WELL Well_order_Restr by blast
107.277 + have 1: "wo_rel.ofilter r (f ` ?A')" using assms embed_Field_ofilter by blast
107.278 + hence "Field ?r'' = f ` (Field r')" using WELL Field_Restr_ofilter by blast
107.279 + hence "bij_betw f ?A' (Field ?r'')"
107.280 + using EMB embed_inj_on WELL' unfolding bij_betw_def by blast
107.281 + moreover
107.282 + {have "\<forall>a b. (a,b) \<in> r' \<longrightarrow> a \<in> Field r' \<and> b \<in> Field r'"
107.283 + unfolding Field_def by auto
107.284 + hence "compat r' ?r'' f"
107.285 + using assms embed_iff_compat_inj_on_ofilter
107.286 + unfolding compat_def by blast
107.287 + }
107.288 + ultimately show ?thesis using WELL' 0 iso_iff3 by blast
107.289 +qed
107.290 +
107.291 +
107.292 +subsection {* The strict inclusion on proper ofilters is well-founded *}
107.293 +
107.294 +
107.295 +definition ofilterIncl :: "'a rel \<Rightarrow> 'a set rel"
107.296 +where
107.297 +"ofilterIncl r \<equiv> {(A,B). wo_rel.ofilter r A \<and> A \<noteq> Field r \<and>
107.298 + wo_rel.ofilter r B \<and> B \<noteq> Field r \<and> A < B}"
107.299 +
107.300 +
107.301 +lemma wf_ofilterIncl:
107.302 +assumes WELL: "Well_order r"
107.303 +shows "wf(ofilterIncl r)"
107.304 +proof-
107.305 + have Well: "wo_rel r" using WELL by (simp add: wo_rel_def)
107.306 + hence Lo: "Linear_order r" by (simp add: wo_rel.LIN)
107.307 + let ?h = "(\<lambda> A. wo_rel.suc r A)"
107.308 + let ?rS = "r - Id"
107.309 + have "wf ?rS" using WELL by (simp add: order_on_defs)
107.310 + moreover
107.311 + have "compat (ofilterIncl r) ?rS ?h"
107.312 + proof(unfold compat_def ofilterIncl_def,
107.313 + intro allI impI, simp, elim conjE)
107.314 + fix A B
107.315 + assume *: "wo_rel.ofilter r A" "A \<noteq> Field r" and
107.316 + **: "wo_rel.ofilter r B" "B \<noteq> Field r" and ***: "A < B"
107.317 + then obtain a and b where 0: "a \<in> Field r \<and> b \<in> Field r" and
107.318 + 1: "A = rel.underS r a \<and> B = rel.underS r b"
107.319 + using Well by (auto simp add: wo_rel.ofilter_underS_Field)
107.320 + hence "a \<noteq> b" using *** by auto
107.321 + moreover
107.322 + have "(a,b) \<in> r" using 0 1 Lo ***
107.323 + by (auto simp add: rel.underS_incl_iff)
107.324 + moreover
107.325 + have "a = wo_rel.suc r A \<and> b = wo_rel.suc r B"
107.326 + using Well 0 1 by (simp add: wo_rel.suc_underS)
107.327 + ultimately
107.328 + show "(wo_rel.suc r A, wo_rel.suc r B) \<in> r \<and> wo_rel.suc r A \<noteq> wo_rel.suc r B"
107.329 + by simp
107.330 + qed
107.331 + ultimately show "wf (ofilterIncl r)" by (simp add: compat_wf)
107.332 +qed
107.333 +
107.334 +
107.335 +
107.336 +subsection {* Ordering the well-orders by existence of embeddings *}
107.337 +
107.338 +
107.339 +text {* We define three relations between well-orders:
107.340 +\begin{itemize}
107.341 +\item @{text "ordLeq"}, of being embedded (abbreviated @{text "\<le>o"});
107.342 +\item @{text "ordLess"}, of being strictly embedded (abbreviated @{text "<o"});
107.343 +\item @{text "ordIso"}, of being isomorphic (abbreviated @{text "=o"}).
107.344 +\end{itemize}
107.345 +%
107.346 +The prefix "ord" and the index "o" in these names stand for "ordinal-like".
107.347 +These relations shall be proved to be inter-connected in a similar fashion as the trio
107.348 +@{text "\<le>"}, @{text "<"}, @{text "="} associated to a total order on a set.
107.349 +*}
107.350 +
107.351 +
107.352 +definition ordLeq :: "('a rel * 'a' rel) set"
107.353 +where
107.354 +"ordLeq = {(r,r'). Well_order r \<and> Well_order r' \<and> (\<exists>f. embed r r' f)}"
107.355 +
107.356 +
107.357 +abbreviation ordLeq2 :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> bool" (infix "<=o" 50)
107.358 +where "r <=o r' \<equiv> (r,r') \<in> ordLeq"
107.359 +
107.360 +
107.361 +abbreviation ordLeq3 :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> bool" (infix "\<le>o" 50)
107.362 +where "r \<le>o r' \<equiv> r <=o r'"
107.363 +
107.364 +
107.365 +definition ordLess :: "('a rel * 'a' rel) set"
107.366 +where
107.367 +"ordLess = {(r,r'). Well_order r \<and> Well_order r' \<and> (\<exists>f. embedS r r' f)}"
107.368 +
107.369 +abbreviation ordLess2 :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> bool" (infix "<o" 50)
107.370 +where "r <o r' \<equiv> (r,r') \<in> ordLess"
107.371 +
107.372 +
107.373 +definition ordIso :: "('a rel * 'a' rel) set"
107.374 +where
107.375 +"ordIso = {(r,r'). Well_order r \<and> Well_order r' \<and> (\<exists>f. iso r r' f)}"
107.376 +
107.377 +abbreviation ordIso2 :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> bool" (infix "=o" 50)
107.378 +where "r =o r' \<equiv> (r,r') \<in> ordIso"
107.379 +
107.380 +
107.381 +lemmas ordRels_def = ordLeq_def ordLess_def ordIso_def
107.382 +
107.383 +lemma ordLeq_Well_order_simp:
107.384 +assumes "r \<le>o r'"
107.385 +shows "Well_order r \<and> Well_order r'"
107.386 +using assms unfolding ordLeq_def by simp
107.387 +
107.388 +
107.389 +text{* Notice that the relations @{text "\<le>o"}, @{text "<o"}, @{text "=o"} connect well-orders
107.390 +on potentially {\em distinct} types. However, some of the lemmas below, including the next one,
107.391 +restrict implicitly the type of these relations to @{text "(('a rel) * ('a rel)) set"} , i.e.,
107.392 +to @{text "'a rel rel"}. *}
107.393 +
107.394 +
107.395 +lemma ordLeq_reflexive:
107.396 +"Well_order r \<Longrightarrow> r \<le>o r"
107.397 +unfolding ordLeq_def using id_embed[of r] by blast
107.398 +
107.399 +
107.400 +lemma ordLeq_transitive[trans]:
107.401 +assumes *: "r \<le>o r'" and **: "r' \<le>o r''"
107.402 +shows "r \<le>o r''"
107.403 +proof-
107.404 + obtain f and f'
107.405 + where 1: "Well_order r \<and> Well_order r' \<and> Well_order r''" and
107.406 + "embed r r' f" and "embed r' r'' f'"
107.407 + using * ** unfolding ordLeq_def by blast
107.408 + hence "embed r r'' (f' o f)"
107.409 + using comp_embed[of r r' f r'' f'] by auto
107.410 + thus "r \<le>o r''" unfolding ordLeq_def using 1 by auto
107.411 +qed
107.412 +
107.413 +
107.414 +lemma ordLeq_total:
107.415 +"\<lbrakk>Well_order r; Well_order r'\<rbrakk> \<Longrightarrow> r \<le>o r' \<or> r' \<le>o r"
107.416 +unfolding ordLeq_def using wellorders_totally_ordered by blast
107.417 +
107.418 +
107.419 +lemma ordIso_reflexive:
107.420 +"Well_order r \<Longrightarrow> r =o r"
107.421 +unfolding ordIso_def using id_iso[of r] by blast
107.422 +
107.423 +
107.424 +lemma ordIso_transitive[trans]:
107.425 +assumes *: "r =o r'" and **: "r' =o r''"
107.426 +shows "r =o r''"
107.427 +proof-
107.428 + obtain f and f'
107.429 + where 1: "Well_order r \<and> Well_order r' \<and> Well_order r''" and
107.430 + "iso r r' f" and 3: "iso r' r'' f'"
107.431 + using * ** unfolding ordIso_def by auto
107.432 + hence "iso r r'' (f' o f)"
107.433 + using comp_iso[of r r' f r'' f'] by auto
107.434 + thus "r =o r''" unfolding ordIso_def using 1 by auto
107.435 +qed
107.436 +
107.437 +
107.438 +lemma ordIso_symmetric:
107.439 +assumes *: "r =o r'"
107.440 +shows "r' =o r"
107.441 +proof-
107.442 + obtain f where 1: "Well_order r \<and> Well_order r'" and
107.443 + 2: "embed r r' f \<and> bij_betw f (Field r) (Field r')"
107.444 + using * by (auto simp add: ordIso_def iso_def)
107.445 + let ?f' = "inv_into (Field r) f"
107.446 + have "embed r' r ?f' \<and> bij_betw ?f' (Field r') (Field r)"
107.447 + using 1 2 by (simp add: bij_betw_inv_into inv_into_Field_embed_bij_betw)
107.448 + thus "r' =o r" unfolding ordIso_def using 1 by (auto simp add: iso_def)
107.449 +qed
107.450 +
107.451 +
107.452 +lemma ordLeq_ordLess_trans[trans]:
107.453 +assumes "r \<le>o r'" and " r' <o r''"
107.454 +shows "r <o r''"
107.455 +proof-
107.456 + have "Well_order r \<and> Well_order r''"
107.457 + using assms unfolding ordLeq_def ordLess_def by auto
107.458 + thus ?thesis using assms unfolding ordLeq_def ordLess_def
107.459 + using embed_comp_embedS by blast
107.460 +qed
107.461 +
107.462 +
107.463 +lemma ordLess_ordLeq_trans[trans]:
107.464 +assumes "r <o r'" and " r' \<le>o r''"
107.465 +shows "r <o r''"
107.466 +proof-
107.467 + have "Well_order r \<and> Well_order r''"
107.468 + using assms unfolding ordLeq_def ordLess_def by auto
107.469 + thus ?thesis using assms unfolding ordLeq_def ordLess_def
107.470 + using embedS_comp_embed by blast
107.471 +qed
107.472 +
107.473 +
107.474 +lemma ordLeq_ordIso_trans[trans]:
107.475 +assumes "r \<le>o r'" and " r' =o r''"
107.476 +shows "r \<le>o r''"
107.477 +proof-
107.478 + have "Well_order r \<and> Well_order r''"
107.479 + using assms unfolding ordLeq_def ordIso_def by auto
107.480 + thus ?thesis using assms unfolding ordLeq_def ordIso_def
107.481 + using embed_comp_iso by blast
107.482 +qed
107.483 +
107.484 +
107.485 +lemma ordIso_ordLeq_trans[trans]:
107.486 +assumes "r =o r'" and " r' \<le>o r''"
107.487 +shows "r \<le>o r''"
107.488 +proof-
107.489 + have "Well_order r \<and> Well_order r''"
107.490 + using assms unfolding ordLeq_def ordIso_def by auto
107.491 + thus ?thesis using assms unfolding ordLeq_def ordIso_def
107.492 + using iso_comp_embed by blast
107.493 +qed
107.494 +
107.495 +
107.496 +lemma ordLess_ordIso_trans[trans]:
107.497 +assumes "r <o r'" and " r' =o r''"
107.498 +shows "r <o r''"
107.499 +proof-
107.500 + have "Well_order r \<and> Well_order r''"
107.501 + using assms unfolding ordLess_def ordIso_def by auto
107.502 + thus ?thesis using assms unfolding ordLess_def ordIso_def
107.503 + using embedS_comp_iso by blast
107.504 +qed
107.505 +
107.506 +
107.507 +lemma ordIso_ordLess_trans[trans]:
107.508 +assumes "r =o r'" and " r' <o r''"
107.509 +shows "r <o r''"
107.510 +proof-
107.511 + have "Well_order r \<and> Well_order r''"
107.512 + using assms unfolding ordLess_def ordIso_def by auto
107.513 + thus ?thesis using assms unfolding ordLess_def ordIso_def
107.514 + using iso_comp_embedS by blast
107.515 +qed
107.516 +
107.517 +
107.518 +lemma ordLess_not_embed:
107.519 +assumes "r <o r'"
107.520 +shows "\<not>(\<exists>f'. embed r' r f')"
107.521 +proof-
107.522 + obtain f where 1: "Well_order r \<and> Well_order r'" and 2: "embed r r' f" and
107.523 + 3: " \<not> bij_betw f (Field r) (Field r')"
107.524 + using assms unfolding ordLess_def by (auto simp add: embedS_def)
107.525 + {fix f' assume *: "embed r' r f'"
107.526 + hence "bij_betw f (Field r) (Field r')" using 1 2
107.527 + by (simp add: embed_bothWays_Field_bij_betw)
107.528 + with 3 have False by contradiction
107.529 + }
107.530 + thus ?thesis by blast
107.531 +qed
107.532 +
107.533 +
107.534 +lemma ordLess_Field:
107.535 +assumes OL: "r1 <o r2" and EMB: "embed r1 r2 f"
107.536 +shows "\<not> (f`(Field r1) = Field r2)"
107.537 +proof-
107.538 + let ?A1 = "Field r1" let ?A2 = "Field r2"
107.539 + obtain g where
107.540 + 0: "Well_order r1 \<and> Well_order r2" and
107.541 + 1: "embed r1 r2 g \<and> \<not>(bij_betw g ?A1 ?A2)"
107.542 + using OL unfolding ordLess_def by (auto simp add: embedS_def)
107.543 + hence "\<forall>a \<in> ?A1. f a = g a"
107.544 + using 0 EMB embed_unique[of r1] by auto
107.545 + hence "\<not>(bij_betw f ?A1 ?A2)"
107.546 + using 1 bij_betw_cong[of ?A1] by blast
107.547 + moreover
107.548 + have "inj_on f ?A1" using EMB 0 by (simp add: embed_inj_on)
107.549 + ultimately show ?thesis by (simp add: bij_betw_def)
107.550 +qed
107.551 +
107.552 +
107.553 +lemma ordLess_iff:
107.554 +"r <o r' = (Well_order r \<and> Well_order r' \<and> \<not>(\<exists>f'. embed r' r f'))"
107.555 +proof
107.556 + assume *: "r <o r'"
107.557 + hence "\<not>(\<exists>f'. embed r' r f')" using ordLess_not_embed[of r r'] by simp
107.558 + with * show "Well_order r \<and> Well_order r' \<and> \<not> (\<exists>f'. embed r' r f')"
107.559 + unfolding ordLess_def by auto
107.560 +next
107.561 + assume *: "Well_order r \<and> Well_order r' \<and> \<not> (\<exists>f'. embed r' r f')"
107.562 + then obtain f where 1: "embed r r' f"
107.563 + using wellorders_totally_ordered[of r r'] by blast
107.564 + moreover
107.565 + {assume "bij_betw f (Field r) (Field r')"
107.566 + with * 1 have "embed r' r (inv_into (Field r) f) "
107.567 + using inv_into_Field_embed_bij_betw[of r r' f] by auto
107.568 + with * have False by blast
107.569 + }
107.570 + ultimately show "(r,r') \<in> ordLess"
107.571 + unfolding ordLess_def using * by (fastforce simp add: embedS_def)
107.572 +qed
107.573 +
107.574 +
107.575 +lemma ordLess_irreflexive: "\<not> r <o r"
107.576 +proof
107.577 + assume "r <o r"
107.578 + hence "Well_order r \<and> \<not>(\<exists>f. embed r r f)"
107.579 + unfolding ordLess_iff ..
107.580 + moreover have "embed r r id" using id_embed[of r] .
107.581 + ultimately show False by blast
107.582 +qed
107.583 +
107.584 +
107.585 +lemma ordLeq_iff_ordLess_or_ordIso:
107.586 +"r \<le>o r' = (r <o r' \<or> r =o r')"
107.587 +unfolding ordRels_def embedS_defs iso_defs by blast
107.588 +
107.589 +
107.590 +lemma ordIso_iff_ordLeq:
107.591 +"(r =o r') = (r \<le>o r' \<and> r' \<le>o r)"
107.592 +proof
107.593 + assume "r =o r'"
107.594 + then obtain f where 1: "Well_order r \<and> Well_order r' \<and>
107.595 + embed r r' f \<and> bij_betw f (Field r) (Field r')"
107.596 + unfolding ordIso_def iso_defs by auto
107.597 + hence "embed r r' f \<and> embed r' r (inv_into (Field r) f)"
107.598 + by (simp add: inv_into_Field_embed_bij_betw)
107.599 + thus "r \<le>o r' \<and> r' \<le>o r"
107.600 + unfolding ordLeq_def using 1 by auto
107.601 +next
107.602 + assume "r \<le>o r' \<and> r' \<le>o r"
107.603 + then obtain f and g where 1: "Well_order r \<and> Well_order r' \<and>
107.604 + embed r r' f \<and> embed r' r g"
107.605 + unfolding ordLeq_def by auto
107.606 + hence "iso r r' f" by (auto simp add: embed_bothWays_iso)
107.607 + thus "r =o r'" unfolding ordIso_def using 1 by auto
107.608 +qed
107.609 +
107.610 +
107.611 +lemma not_ordLess_ordLeq:
107.612 +"r <o r' \<Longrightarrow> \<not> r' \<le>o r"
107.613 +using ordLess_ordLeq_trans ordLess_irreflexive by blast
107.614 +
107.615 +
107.616 +lemma ordLess_or_ordLeq:
107.617 +assumes WELL: "Well_order r" and WELL': "Well_order r'"
107.618 +shows "r <o r' \<or> r' \<le>o r"
107.619 +proof-
107.620 + have "r \<le>o r' \<or> r' \<le>o r"
107.621 + using assms by (simp add: ordLeq_total)
107.622 + moreover
107.623 + {assume "\<not> r <o r' \<and> r \<le>o r'"
107.624 + hence "r =o r'" using ordLeq_iff_ordLess_or_ordIso by blast
107.625 + hence "r' \<le>o r" using ordIso_symmetric ordIso_iff_ordLeq by blast
107.626 + }
107.627 + ultimately show ?thesis by blast
107.628 +qed
107.629 +
107.630 +
107.631 +lemma not_ordLess_ordIso:
107.632 +"r <o r' \<Longrightarrow> \<not> r =o r'"
107.633 +using assms ordLess_ordIso_trans ordIso_symmetric ordLess_irreflexive by blast
107.634 +
107.635 +
107.636 +lemma not_ordLeq_iff_ordLess:
107.637 +assumes WELL: "Well_order r" and WELL': "Well_order r'"
107.638 +shows "(\<not> r' \<le>o r) = (r <o r')"
107.639 +using assms not_ordLess_ordLeq ordLess_or_ordLeq by blast
107.640 +
107.641 +
107.642 +lemma not_ordLess_iff_ordLeq:
107.643 +assumes WELL: "Well_order r" and WELL': "Well_order r'"
107.644 +shows "(\<not> r' <o r) = (r \<le>o r')"
107.645 +using assms not_ordLess_ordLeq ordLess_or_ordLeq by blast
107.646 +
107.647 +
107.648 +lemma ordLess_transitive[trans]:
107.649 +"\<lbrakk>r <o r'; r' <o r''\<rbrakk> \<Longrightarrow> r <o r''"
107.650 +using assms ordLess_ordLeq_trans ordLeq_iff_ordLess_or_ordIso by blast
107.651 +
107.652 +
107.653 +corollary ordLess_trans: "trans ordLess"
107.654 +unfolding trans_def using ordLess_transitive by blast
107.655 +
107.656 +
107.657 +lemmas ordIso_equivalence = ordIso_transitive ordIso_reflexive ordIso_symmetric
107.658 +
107.659 +
107.660 +lemma ordIso_imp_ordLeq:
107.661 +"r =o r' \<Longrightarrow> r \<le>o r'"
107.662 +using ordIso_iff_ordLeq by blast
107.663 +
107.664 +
107.665 +lemma ordLess_imp_ordLeq:
107.666 +"r <o r' \<Longrightarrow> r \<le>o r'"
107.667 +using ordLeq_iff_ordLess_or_ordIso by blast
107.668 +
107.669 +
107.670 +lemma ofilter_subset_ordLeq:
107.671 +assumes WELL: "Well_order r" and
107.672 + OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
107.673 +shows "(A \<le> B) = (Restr r A \<le>o Restr r B)"
107.674 +proof
107.675 + assume "A \<le> B"
107.676 + thus "Restr r A \<le>o Restr r B"
107.677 + unfolding ordLeq_def using assms
107.678 + Well_order_Restr Well_order_Restr ofilter_subset_embed by blast
107.679 +next
107.680 + assume *: "Restr r A \<le>o Restr r B"
107.681 + then obtain f where "embed (Restr r A) (Restr r B) f"
107.682 + unfolding ordLeq_def by blast
107.683 + {assume "B < A"
107.684 + hence "Restr r B <o Restr r A"
107.685 + unfolding ordLess_def using assms
107.686 + Well_order_Restr Well_order_Restr ofilter_subset_embedS by blast
107.687 + hence False using * not_ordLess_ordLeq by blast
107.688 + }
107.689 + thus "A \<le> B" using OFA OFB WELL
107.690 + wo_rel_def[of r] wo_rel.ofilter_linord[of r A B] by blast
107.691 +qed
107.692 +
107.693 +
107.694 +lemma ofilter_subset_ordLess:
107.695 +assumes WELL: "Well_order r" and
107.696 + OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
107.697 +shows "(A < B) = (Restr r A <o Restr r B)"
107.698 +proof-
107.699 + let ?rA = "Restr r A" let ?rB = "Restr r B"
107.700 + have 1: "Well_order ?rA \<and> Well_order ?rB"
107.701 + using WELL Well_order_Restr by blast
107.702 + have "(A < B) = (\<not> B \<le> A)" using assms
107.703 + wo_rel_def wo_rel.ofilter_linord[of r A B] by blast
107.704 + also have "\<dots> = (\<not> Restr r B \<le>o Restr r A)"
107.705 + using assms ofilter_subset_ordLeq by blast
107.706 + also have "\<dots> = (Restr r A <o Restr r B)"
107.707 + using 1 not_ordLeq_iff_ordLess by blast
107.708 + finally show ?thesis .
107.709 +qed
107.710 +
107.711 +
107.712 +lemma ofilter_ordLess:
107.713 +"\<lbrakk>Well_order r; wo_rel.ofilter r A\<rbrakk> \<Longrightarrow> (A < Field r) = (Restr r A <o r)"
107.714 +by (simp add: ofilter_subset_ordLess wo_rel.Field_ofilter
107.715 + wo_rel_def Restr_Field)
107.716 +
107.717 +
107.718 +corollary underS_Restr_ordLess:
107.719 +assumes "Well_order r" and "Field r \<noteq> {}"
107.720 +shows "Restr r (rel.underS r a) <o r"
107.721 +proof-
107.722 + have "rel.underS r a < Field r" using assms
107.723 + by (simp add: rel.underS_Field3)
107.724 + thus ?thesis using assms
107.725 + by (simp add: ofilter_ordLess wo_rel.underS_ofilter wo_rel_def)
107.726 +qed
107.727 +
107.728 +
107.729 +lemma embed_ordLess_ofilterIncl:
107.730 +assumes
107.731 + OL12: "r1 <o r2" and OL23: "r2 <o r3" and
107.732 + EMB13: "embed r1 r3 f13" and EMB23: "embed r2 r3 f23"
107.733 +shows "(f13`(Field r1), f23`(Field r2)) \<in> (ofilterIncl r3)"
107.734 +proof-
107.735 + have OL13: "r1 <o r3"
107.736 + using OL12 OL23 using ordLess_transitive by auto
107.737 + let ?A1 = "Field r1" let ?A2 ="Field r2" let ?A3 ="Field r3"
107.738 + obtain f12 g23 where
107.739 + 0: "Well_order r1 \<and> Well_order r2 \<and> Well_order r3" and
107.740 + 1: "embed r1 r2 f12 \<and> \<not>(bij_betw f12 ?A1 ?A2)" and
107.741 + 2: "embed r2 r3 g23 \<and> \<not>(bij_betw g23 ?A2 ?A3)"
107.742 + using OL12 OL23 by (auto simp add: ordLess_def embedS_def)
107.743 + hence "\<forall>a \<in> ?A2. f23 a = g23 a"
107.744 + using EMB23 embed_unique[of r2 r3] by blast
107.745 + hence 3: "\<not>(bij_betw f23 ?A2 ?A3)"
107.746 + using 2 bij_betw_cong[of ?A2 f23 g23] by blast
107.747 + (* *)
107.748 + have 4: "wo_rel.ofilter r2 (f12 ` ?A1) \<and> f12 ` ?A1 \<noteq> ?A2"
107.749 + using 0 1 OL12 by (simp add: embed_Field_ofilter ordLess_Field)
107.750 + have 5: "wo_rel.ofilter r3 (f23 ` ?A2) \<and> f23 ` ?A2 \<noteq> ?A3"
107.751 + using 0 EMB23 OL23 by (simp add: embed_Field_ofilter ordLess_Field)
107.752 + have 6: "wo_rel.ofilter r3 (f13 ` ?A1) \<and> f13 ` ?A1 \<noteq> ?A3"
107.753 + using 0 EMB13 OL13 by (simp add: embed_Field_ofilter ordLess_Field)
107.754 + (* *)
107.755 + have "f12 ` ?A1 < ?A2"
107.756 + using 0 4 by (auto simp add: wo_rel_def wo_rel.ofilter_def)
107.757 + moreover have "inj_on f23 ?A2"
107.758 + using EMB23 0 by (simp add: wo_rel_def embed_inj_on)
107.759 + ultimately
107.760 + have "f23 ` (f12 ` ?A1) < f23 ` ?A2" by (simp add: inj_on_strict_subset)
107.761 + moreover
107.762 + {have "embed r1 r3 (f23 o f12)"
107.763 + using 1 EMB23 0 by (auto simp add: comp_embed)
107.764 + hence "\<forall>a \<in> ?A1. f23(f12 a) = f13 a"
107.765 + using EMB13 0 embed_unique[of r1 r3 "f23 o f12" f13] by auto
107.766 + hence "f23 ` (f12 ` ?A1) = f13 ` ?A1" by force
107.767 + }
107.768 + ultimately
107.769 + have "f13 ` ?A1 < f23 ` ?A2" by simp
107.770 + (* *)
107.771 + with 5 6 show ?thesis
107.772 + unfolding ofilterIncl_def by auto
107.773 +qed
107.774 +
107.775 +
107.776 +lemma ordLess_iff_ordIso_Restr:
107.777 +assumes WELL: "Well_order r" and WELL': "Well_order r'"
107.778 +shows "(r' <o r) = (\<exists>a \<in> Field r. r' =o Restr r (rel.underS r a))"
107.779 +proof(auto)
107.780 + fix a assume *: "a \<in> Field r" and **: "r' =o Restr r (rel.underS r a)"
107.781 + hence "Restr r (rel.underS r a) <o r" using WELL underS_Restr_ordLess[of r] by blast
107.782 + thus "r' <o r" using ** ordIso_ordLess_trans by blast
107.783 +next
107.784 + assume "r' <o r"
107.785 + then obtain f where 1: "Well_order r \<and> Well_order r'" and
107.786 + 2: "embed r' r f \<and> f ` (Field r') \<noteq> Field r"
107.787 + unfolding ordLess_def embedS_def[abs_def] bij_betw_def using embed_inj_on by blast
107.788 + hence "wo_rel.ofilter r (f ` (Field r'))" using embed_Field_ofilter by blast
107.789 + then obtain a where 3: "a \<in> Field r" and 4: "rel.underS r a = f ` (Field r')"
107.790 + using 1 2 by (auto simp add: wo_rel.ofilter_underS_Field wo_rel_def)
107.791 + have "iso r' (Restr r (f ` (Field r'))) f"
107.792 + using embed_implies_iso_Restr 2 assms by blast
107.793 + moreover have "Well_order (Restr r (f ` (Field r')))"
107.794 + using WELL Well_order_Restr by blast
107.795 + ultimately have "r' =o Restr r (f ` (Field r'))"
107.796 + using WELL' unfolding ordIso_def by auto
107.797 + hence "r' =o Restr r (rel.underS r a)" using 4 by auto
107.798 + thus "\<exists>a \<in> Field r. r' =o Restr r (rel.underS r a)" using 3 by auto
107.799 +qed
107.800 +
107.801 +
107.802 +lemma internalize_ordLess:
107.803 +"(r' <o r) = (\<exists>p. Field p < Field r \<and> r' =o p \<and> p <o r)"
107.804 +proof
107.805 + assume *: "r' <o r"
107.806 + hence 0: "Well_order r \<and> Well_order r'" unfolding ordLess_def by auto
107.807 + with * obtain a where 1: "a \<in> Field r" and 2: "r' =o Restr r (rel.underS r a)"
107.808 + using ordLess_iff_ordIso_Restr by blast
107.809 + let ?p = "Restr r (rel.underS r a)"
107.810 + have "wo_rel.ofilter r (rel.underS r a)" using 0
107.811 + by (simp add: wo_rel_def wo_rel.underS_ofilter)
107.812 + hence "Field ?p = rel.underS r a" using 0 Field_Restr_ofilter by blast
107.813 + hence "Field ?p < Field r" using rel.underS_Field2 1 by fast
107.814 + moreover have "?p <o r" using underS_Restr_ordLess[of r a] 0 1 by blast
107.815 + ultimately
107.816 + show "\<exists>p. Field p < Field r \<and> r' =o p \<and> p <o r" using 2 by blast
107.817 +next
107.818 + assume "\<exists>p. Field p < Field r \<and> r' =o p \<and> p <o r"
107.819 + thus "r' <o r" using ordIso_ordLess_trans by blast
107.820 +qed
107.821 +
107.822 +
107.823 +lemma internalize_ordLeq:
107.824 +"(r' \<le>o r) = (\<exists>p. Field p \<le> Field r \<and> r' =o p \<and> p \<le>o r)"
107.825 +proof
107.826 + assume *: "r' \<le>o r"
107.827 + moreover
107.828 + {assume "r' <o r"
107.829 + then obtain p where "Field p < Field r \<and> r' =o p \<and> p <o r"
107.830 + using internalize_ordLess[of r' r] by blast
107.831 + hence "\<exists>p. Field p \<le> Field r \<and> r' =o p \<and> p \<le>o r"
107.832 + using ordLeq_iff_ordLess_or_ordIso by blast
107.833 + }
107.834 + moreover
107.835 + have "r \<le>o r" using * ordLeq_def ordLeq_reflexive by blast
107.836 + ultimately show "\<exists>p. Field p \<le> Field r \<and> r' =o p \<and> p \<le>o r"
107.837 + using ordLeq_iff_ordLess_or_ordIso by blast
107.838 +next
107.839 + assume "\<exists>p. Field p \<le> Field r \<and> r' =o p \<and> p \<le>o r"
107.840 + thus "r' \<le>o r" using ordIso_ordLeq_trans by blast
107.841 +qed
107.842 +
107.843 +
107.844 +lemma ordLeq_iff_ordLess_Restr:
107.845 +assumes WELL: "Well_order r" and WELL': "Well_order r'"
107.846 +shows "(r \<le>o r') = (\<forall>a \<in> Field r. Restr r (rel.underS r a) <o r')"
107.847 +proof(auto)
107.848 + assume *: "r \<le>o r'"
107.849 + fix a assume "a \<in> Field r"
107.850 + hence "Restr r (rel.underS r a) <o r"
107.851 + using WELL underS_Restr_ordLess[of r] by blast
107.852 + thus "Restr r (rel.underS r a) <o r'"
107.853 + using * ordLess_ordLeq_trans by blast
107.854 +next
107.855 + assume *: "\<forall>a \<in> Field r. Restr r (rel.underS r a) <o r'"
107.856 + {assume "r' <o r"
107.857 + then obtain a where "a \<in> Field r \<and> r' =o Restr r (rel.underS r a)"
107.858 + using assms ordLess_iff_ordIso_Restr by blast
107.859 + hence False using * not_ordLess_ordIso ordIso_symmetric by blast
107.860 + }
107.861 + thus "r \<le>o r'" using ordLess_or_ordLeq assms by blast
107.862 +qed
107.863 +
107.864 +
107.865 +lemma finite_ordLess_infinite:
107.866 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and
107.867 + FIN: "finite(Field r)" and INF: "\<not>finite(Field r')"
107.868 +shows "r <o r'"
107.869 +proof-
107.870 + {assume "r' \<le>o r"
107.871 + then obtain h where "inj_on h (Field r') \<and> h ` (Field r') \<le> Field r"
107.872 + unfolding ordLeq_def using assms embed_inj_on embed_Field by blast
107.873 + hence False using finite_imageD finite_subset FIN INF by metis
107.874 + }
107.875 + thus ?thesis using WELL WELL' ordLess_or_ordLeq by blast
107.876 +qed
107.877 +
107.878 +
107.879 +lemma finite_well_order_on_ordIso:
107.880 +assumes FIN: "finite A" and
107.881 + WELL: "well_order_on A r" and WELL': "well_order_on A r'"
107.882 +shows "r =o r'"
107.883 +proof-
107.884 + have 0: "Well_order r \<and> Well_order r' \<and> Field r = A \<and> Field r' = A"
107.885 + using assms rel.well_order_on_Well_order by blast
107.886 + moreover
107.887 + have "\<forall>r r'. well_order_on A r \<and> well_order_on A r' \<and> r \<le>o r'
107.888 + \<longrightarrow> r =o r'"
107.889 + proof(clarify)
107.890 + fix r r' assume *: "well_order_on A r" and **: "well_order_on A r'"
107.891 + have 2: "Well_order r \<and> Well_order r' \<and> Field r = A \<and> Field r' = A"
107.892 + using * ** rel.well_order_on_Well_order by blast
107.893 + assume "r \<le>o r'"
107.894 + then obtain f where 1: "embed r r' f" and
107.895 + "inj_on f A \<and> f ` A \<le> A"
107.896 + unfolding ordLeq_def using 2 embed_inj_on embed_Field by blast
107.897 + hence "bij_betw f A A" unfolding bij_betw_def using FIN endo_inj_surj by blast
107.898 + thus "r =o r'" unfolding ordIso_def iso_def[abs_def] using 1 2 by auto
107.899 + qed
107.900 + ultimately show ?thesis using assms ordLeq_total ordIso_symmetric by metis
107.901 +qed
107.902 +
107.903 +
107.904 +subsection{* @{text "<o"} is well-founded *}
107.905 +
107.906 +
107.907 +text {* Of course, it only makes sense to state that the @{text "<o"} is well-founded
107.908 +on the restricted type @{text "'a rel rel"}. We prove this by first showing that, for any set
107.909 +of well-orders all embedded in a fixed well-order, the function mapping each well-order
107.910 +in the set to an order filter of the fixed well-order is compatible w.r.t. to @{text "<o"} versus
107.911 +{\em strict inclusion}; and we already know that strict inclusion of order filters is well-founded. *}
107.912 +
107.913 +
107.914 +definition ord_to_filter :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a set"
107.915 +where "ord_to_filter r0 r \<equiv> (SOME f. embed r r0 f) ` (Field r)"
107.916 +
107.917 +
107.918 +lemma ord_to_filter_compat:
107.919 +"compat (ordLess Int (ordLess^-1``{r0} \<times> ordLess^-1``{r0}))
107.920 + (ofilterIncl r0)
107.921 + (ord_to_filter r0)"
107.922 +proof(unfold compat_def ord_to_filter_def, clarify)
107.923 + fix r1::"'a rel" and r2::"'a rel"
107.924 + let ?A1 = "Field r1" let ?A2 ="Field r2" let ?A0 ="Field r0"
107.925 + let ?phi10 = "\<lambda> f10. embed r1 r0 f10" let ?f10 = "SOME f. ?phi10 f"
107.926 + let ?phi20 = "\<lambda> f20. embed r2 r0 f20" let ?f20 = "SOME f. ?phi20 f"
107.927 + assume *: "r1 <o r0" "r2 <o r0" and **: "r1 <o r2"
107.928 + hence "(\<exists>f. ?phi10 f) \<and> (\<exists>f. ?phi20 f)"
107.929 + by (auto simp add: ordLess_def embedS_def)
107.930 + hence "?phi10 ?f10 \<and> ?phi20 ?f20" by (auto simp add: someI_ex)
107.931 + thus "(?f10 ` ?A1, ?f20 ` ?A2) \<in> ofilterIncl r0"
107.932 + using * ** by (simp add: embed_ordLess_ofilterIncl)
107.933 +qed
107.934 +
107.935 +
107.936 +theorem wf_ordLess: "wf ordLess"
107.937 +proof-
107.938 + {fix r0 :: "('a \<times> 'a) set"
107.939 + (* need to annotate here!*)
107.940 + let ?ordLess = "ordLess::('d rel * 'd rel) set"
107.941 + let ?R = "?ordLess Int (?ordLess^-1``{r0} \<times> ?ordLess^-1``{r0})"
107.942 + {assume Case1: "Well_order r0"
107.943 + hence "wf ?R"
107.944 + using wf_ofilterIncl[of r0]
107.945 + compat_wf[of ?R "ofilterIncl r0" "ord_to_filter r0"]
107.946 + ord_to_filter_compat[of r0] by auto
107.947 + }
107.948 + moreover
107.949 + {assume Case2: "\<not> Well_order r0"
107.950 + hence "?R = {}" unfolding ordLess_def by auto
107.951 + hence "wf ?R" using wf_empty by simp
107.952 + }
107.953 + ultimately have "wf ?R" by blast
107.954 + }
107.955 + thus ?thesis by (simp add: trans_wf_iff ordLess_trans)
107.956 +qed
107.957 +
107.958 +corollary exists_minim_Well_order:
107.959 +assumes NE: "R \<noteq> {}" and WELL: "\<forall>r \<in> R. Well_order r"
107.960 +shows "\<exists>r \<in> R. \<forall>r' \<in> R. r \<le>o r'"
107.961 +proof-
107.962 + obtain r where "r \<in> R \<and> (\<forall>r' \<in> R. \<not> r' <o r)"
107.963 + using NE spec[OF spec[OF subst[OF wf_eq_minimal, of "%x. x", OF wf_ordLess]], of _ R]
107.964 + equals0I[of R] by blast
107.965 + with not_ordLeq_iff_ordLess WELL show ?thesis by blast
107.966 +qed
107.967 +
107.968 +
107.969 +
107.970 +subsection {* Copy via direct images *}
107.971 +
107.972 +
107.973 +text{* The direct image operator is the dual of the inverse image operator @{text "inv_image"}
107.974 +from @{text "Relation.thy"}. It is useful for transporting a well-order between
107.975 +different types. *}
107.976 +
107.977 +
107.978 +definition dir_image :: "'a rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> 'a' rel"
107.979 +where
107.980 +"dir_image r f = {(f a, f b)| a b. (a,b) \<in> r}"
107.981 +
107.982 +
107.983 +lemma dir_image_Field:
107.984 +"Field(dir_image r f) \<le> f ` (Field r)"
107.985 +unfolding dir_image_def Field_def by auto
107.986 +
107.987 +
107.988 +lemma dir_image_minus_Id:
107.989 +"inj_on f (Field r) \<Longrightarrow> (dir_image r f) - Id = dir_image (r - Id) f"
107.990 +unfolding inj_on_def Field_def dir_image_def by auto
107.991 +
107.992 +
107.993 +lemma Refl_dir_image:
107.994 +assumes "Refl r"
107.995 +shows "Refl(dir_image r f)"
107.996 +proof-
107.997 + {fix a' b'
107.998 + assume "(a',b') \<in> dir_image r f"
107.999 + then obtain a b where 1: "a' = f a \<and> b' = f b \<and> (a,b) \<in> r"
107.1000 + unfolding dir_image_def by blast
107.1001 + hence "a \<in> Field r \<and> b \<in> Field r" using Field_def by fastforce
107.1002 + hence "(a,a) \<in> r \<and> (b,b) \<in> r" using assms by (simp add: refl_on_def)
107.1003 + with 1 have "(a',a') \<in> dir_image r f \<and> (b',b') \<in> dir_image r f"
107.1004 + unfolding dir_image_def by auto
107.1005 + }
107.1006 + thus ?thesis
107.1007 + by(unfold refl_on_def Field_def Domain_def Range_def, auto)
107.1008 +qed
107.1009 +
107.1010 +
107.1011 +lemma trans_dir_image:
107.1012 +assumes TRANS: "trans r" and INJ: "inj_on f (Field r)"
107.1013 +shows "trans(dir_image r f)"
107.1014 +proof(unfold trans_def, auto)
107.1015 + fix a' b' c'
107.1016 + assume "(a',b') \<in> dir_image r f" "(b',c') \<in> dir_image r f"
107.1017 + then obtain a b1 b2 c where 1: "a' = f a \<and> b' = f b1 \<and> b' = f b2 \<and> c' = f c" and
107.1018 + 2: "(a,b1) \<in> r \<and> (b2,c) \<in> r"
107.1019 + unfolding dir_image_def by blast
107.1020 + hence "b1 \<in> Field r \<and> b2 \<in> Field r"
107.1021 + unfolding Field_def by auto
107.1022 + hence "b1 = b2" using 1 INJ unfolding inj_on_def by auto
107.1023 + hence "(a,c): r" using 2 TRANS unfolding trans_def by blast
107.1024 + thus "(a',c') \<in> dir_image r f"
107.1025 + unfolding dir_image_def using 1 by auto
107.1026 +qed
107.1027 +
107.1028 +
107.1029 +lemma Preorder_dir_image:
107.1030 +"\<lbrakk>Preorder r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> Preorder (dir_image r f)"
107.1031 +by (simp add: preorder_on_def Refl_dir_image trans_dir_image)
107.1032 +
107.1033 +
107.1034 +lemma antisym_dir_image:
107.1035 +assumes AN: "antisym r" and INJ: "inj_on f (Field r)"
107.1036 +shows "antisym(dir_image r f)"
107.1037 +proof(unfold antisym_def, auto)
107.1038 + fix a' b'
107.1039 + assume "(a',b') \<in> dir_image r f" "(b',a') \<in> dir_image r f"
107.1040 + then obtain a1 b1 a2 b2 where 1: "a' = f a1 \<and> a' = f a2 \<and> b' = f b1 \<and> b' = f b2" and
107.1041 + 2: "(a1,b1) \<in> r \<and> (b2,a2) \<in> r " and
107.1042 + 3: "{a1,a2,b1,b2} \<le> Field r"
107.1043 + unfolding dir_image_def Field_def by blast
107.1044 + hence "a1 = a2 \<and> b1 = b2" using INJ unfolding inj_on_def by auto
107.1045 + hence "a1 = b2" using 2 AN unfolding antisym_def by auto
107.1046 + thus "a' = b'" using 1 by auto
107.1047 +qed
107.1048 +
107.1049 +
107.1050 +lemma Partial_order_dir_image:
107.1051 +"\<lbrakk>Partial_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> Partial_order (dir_image r f)"
107.1052 +by (simp add: partial_order_on_def Preorder_dir_image antisym_dir_image)
107.1053 +
107.1054 +
107.1055 +lemma Total_dir_image:
107.1056 +assumes TOT: "Total r" and INJ: "inj_on f (Field r)"
107.1057 +shows "Total(dir_image r f)"
107.1058 +proof(unfold total_on_def, intro ballI impI)
107.1059 + fix a' b'
107.1060 + assume "a' \<in> Field (dir_image r f)" "b' \<in> Field (dir_image r f)"
107.1061 + then obtain a and b where 1: "a \<in> Field r \<and> b \<in> Field r \<and> f a = a' \<and> f b = b'"
107.1062 + using dir_image_Field[of r f] by blast
107.1063 + moreover assume "a' \<noteq> b'"
107.1064 + ultimately have "a \<noteq> b" using INJ unfolding inj_on_def by auto
107.1065 + hence "(a,b) \<in> r \<or> (b,a) \<in> r" using 1 TOT unfolding total_on_def by auto
107.1066 + thus "(a',b') \<in> dir_image r f \<or> (b',a') \<in> dir_image r f"
107.1067 + using 1 unfolding dir_image_def by auto
107.1068 +qed
107.1069 +
107.1070 +
107.1071 +lemma Linear_order_dir_image:
107.1072 +"\<lbrakk>Linear_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> Linear_order (dir_image r f)"
107.1073 +by (simp add: linear_order_on_def Partial_order_dir_image Total_dir_image)
107.1074 +
107.1075 +
107.1076 +lemma wf_dir_image:
107.1077 +assumes WF: "wf r" and INJ: "inj_on f (Field r)"
107.1078 +shows "wf(dir_image r f)"
107.1079 +proof(unfold wf_eq_minimal2, intro allI impI, elim conjE)
107.1080 + fix A'::"'b set"
107.1081 + assume SUB: "A' \<le> Field(dir_image r f)" and NE: "A' \<noteq> {}"
107.1082 + obtain A where A_def: "A = {a \<in> Field r. f a \<in> A'}" by blast
107.1083 + have "A \<noteq> {} \<and> A \<le> Field r"
107.1084 + using A_def dir_image_Field[of r f] SUB NE by blast
107.1085 + then obtain a where 1: "a \<in> A \<and> (\<forall>b \<in> A. (b,a) \<notin> r)"
107.1086 + using WF unfolding wf_eq_minimal2 by metis
107.1087 + have "\<forall>b' \<in> A'. (b',f a) \<notin> dir_image r f"
107.1088 + proof(clarify)
107.1089 + fix b' assume *: "b' \<in> A'" and **: "(b',f a) \<in> dir_image r f"
107.1090 + obtain b1 a1 where 2: "b' = f b1 \<and> f a = f a1" and
107.1091 + 3: "(b1,a1) \<in> r \<and> {a1,b1} \<le> Field r"
107.1092 + using ** unfolding dir_image_def Field_def by blast
107.1093 + hence "a = a1" using 1 A_def INJ unfolding inj_on_def by auto
107.1094 + hence "b1 \<in> A \<and> (b1,a) \<in> r" using 2 3 A_def * by auto
107.1095 + with 1 show False by auto
107.1096 + qed
107.1097 + thus "\<exists>a'\<in>A'. \<forall>b'\<in>A'. (b', a') \<notin> dir_image r f"
107.1098 + using A_def 1 by blast
107.1099 +qed
107.1100 +
107.1101 +
107.1102 +lemma Well_order_dir_image:
107.1103 +"\<lbrakk>Well_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> Well_order (dir_image r f)"
107.1104 +using assms unfolding well_order_on_def
107.1105 +using Linear_order_dir_image[of r f] wf_dir_image[of "r - Id" f]
107.1106 + dir_image_minus_Id[of f r]
107.1107 + subset_inj_on[of f "Field r" "Field(r - Id)"]
107.1108 + mono_Field[of "r - Id" r] by auto
107.1109 +
107.1110 +
107.1111 +lemma dir_image_Field2:
107.1112 +"Refl r \<Longrightarrow> Field(dir_image r f) = f ` (Field r)"
107.1113 +unfolding Field_def dir_image_def refl_on_def Domain_def Range_def by blast
107.1114 +
107.1115 +
107.1116 +lemma dir_image_bij_betw:
107.1117 +"\<lbrakk>Well_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> bij_betw f (Field r) (Field (dir_image r f))"
107.1118 +unfolding bij_betw_def
107.1119 +by (simp add: dir_image_Field2 order_on_defs)
107.1120 +
107.1121 +
107.1122 +lemma dir_image_compat:
107.1123 +"compat r (dir_image r f) f"
107.1124 +unfolding compat_def dir_image_def by auto
107.1125 +
107.1126 +
107.1127 +lemma dir_image_iso:
107.1128 +"\<lbrakk>Well_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> iso r (dir_image r f) f"
107.1129 +using iso_iff3 dir_image_compat dir_image_bij_betw Well_order_dir_image by blast
107.1130 +
107.1131 +
107.1132 +lemma dir_image_ordIso:
107.1133 +"\<lbrakk>Well_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> r =o dir_image r f"
107.1134 +unfolding ordIso_def using dir_image_iso Well_order_dir_image by blast
107.1135 +
107.1136 +
107.1137 +lemma Well_order_iso_copy:
107.1138 +assumes WELL: "well_order_on A r" and BIJ: "bij_betw f A A'"
107.1139 +shows "\<exists>r'. well_order_on A' r' \<and> r =o r'"
107.1140 +proof-
107.1141 + let ?r' = "dir_image r f"
107.1142 + have 1: "A = Field r \<and> Well_order r"
107.1143 + using WELL rel.well_order_on_Well_order by blast
107.1144 + hence 2: "iso r ?r' f"
107.1145 + using dir_image_iso using BIJ unfolding bij_betw_def by auto
107.1146 + hence "f ` (Field r) = Field ?r'" using 1 iso_iff[of r ?r'] by blast
107.1147 + hence "Field ?r' = A'"
107.1148 + using 1 BIJ unfolding bij_betw_def by auto
107.1149 + moreover have "Well_order ?r'"
107.1150 + using 1 Well_order_dir_image BIJ unfolding bij_betw_def by blast
107.1151 + ultimately show ?thesis unfolding ordIso_def using 1 2 by blast
107.1152 +qed
107.1153 +
107.1154 +
107.1155 +
107.1156 +subsection {* Bounded square *}
107.1157 +
107.1158 +
107.1159 +text{* This construction essentially defines, for an order relation @{text "r"}, a lexicographic
107.1160 +order @{text "bsqr r"} on @{text "(Field r) \<times> (Field r)"}, applying the
107.1161 +following criteria (in this order):
107.1162 +\begin{itemize}
107.1163 +\item compare the maximums;
107.1164 +\item compare the first components;
107.1165 +\item compare the second components.
107.1166 +\end{itemize}
107.1167 +%
107.1168 +The only application of this construction that we are aware of is
107.1169 +at proving that the square of an infinite set has the same cardinal
107.1170 +as that set. The essential property required there (and which is ensured by this
107.1171 +construction) is that any proper order filter of the product order is included in a rectangle, i.e.,
107.1172 +in a product of proper filters on the original relation (assumed to be a well-order). *}
107.1173 +
107.1174 +
107.1175 +definition bsqr :: "'a rel => ('a * 'a)rel"
107.1176 +where
107.1177 +"bsqr r = {((a1,a2),(b1,b2)).
107.1178 + {a1,a2,b1,b2} \<le> Field r \<and>
107.1179 + (a1 = b1 \<and> a2 = b2 \<or>
107.1180 + (wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id \<or>
107.1181 + wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id \<or>
107.1182 + wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id
107.1183 + )}"
107.1184 +
107.1185 +
107.1186 +lemma Field_bsqr:
107.1187 +"Field (bsqr r) = Field r \<times> Field r"
107.1188 +proof
107.1189 + show "Field (bsqr r) \<le> Field r \<times> Field r"
107.1190 + proof-
107.1191 + {fix a1 a2 assume "(a1,a2) \<in> Field (bsqr r)"
107.1192 + moreover
107.1193 + have "\<And> b1 b2. ((a1,a2),(b1,b2)) \<in> bsqr r \<or> ((b1,b2),(a1,a2)) \<in> bsqr r \<Longrightarrow>
107.1194 + a1 \<in> Field r \<and> a2 \<in> Field r" unfolding bsqr_def by auto
107.1195 + ultimately have "a1 \<in> Field r \<and> a2 \<in> Field r" unfolding Field_def by auto
107.1196 + }
107.1197 + thus ?thesis unfolding Field_def by force
107.1198 + qed
107.1199 +next
107.1200 + show "Field r \<times> Field r \<le> Field (bsqr r)"
107.1201 + proof(auto)
107.1202 + fix a1 a2 assume "a1 \<in> Field r" and "a2 \<in> Field r"
107.1203 + hence "((a1,a2),(a1,a2)) \<in> bsqr r" unfolding bsqr_def by blast
107.1204 + thus "(a1,a2) \<in> Field (bsqr r)" unfolding Field_def by auto
107.1205 + qed
107.1206 +qed
107.1207 +
107.1208 +
107.1209 +lemma bsqr_Refl: "Refl(bsqr r)"
107.1210 +by(unfold refl_on_def Field_bsqr, auto simp add: bsqr_def)
107.1211 +
107.1212 +
107.1213 +lemma bsqr_Trans:
107.1214 +assumes "Well_order r"
107.1215 +shows "trans (bsqr r)"
107.1216 +proof(unfold trans_def, auto)
107.1217 + (* Preliminary facts *)
107.1218 + have Well: "wo_rel r" using assms wo_rel_def by auto
107.1219 + hence Trans: "trans r" using wo_rel.TRANS by auto
107.1220 + have Anti: "antisym r" using wo_rel.ANTISYM Well by auto
107.1221 + hence TransS: "trans(r - Id)" using Trans by (simp add: trans_diff_Id)
107.1222 + (* Main proof *)
107.1223 + fix a1 a2 b1 b2 c1 c2
107.1224 + assume *: "((a1,a2),(b1,b2)) \<in> bsqr r" and **: "((b1,b2),(c1,c2)) \<in> bsqr r"
107.1225 + hence 0: "{a1,a2,b1,b2,c1,c2} \<le> Field r" unfolding bsqr_def by auto
107.1226 + have 1: "a1 = b1 \<and> a2 = b2 \<or> (wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id \<or>
107.1227 + wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id \<or>
107.1228 + wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id"
107.1229 + using * unfolding bsqr_def by auto
107.1230 + have 2: "b1 = c1 \<and> b2 = c2 \<or> (wo_rel.max2 r b1 b2, wo_rel.max2 r c1 c2) \<in> r - Id \<or>
107.1231 + wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> (b1,c1) \<in> r - Id \<or>
107.1232 + wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> b1 = c1 \<and> (b2,c2) \<in> r - Id"
107.1233 + using ** unfolding bsqr_def by auto
107.1234 + show "((a1,a2),(c1,c2)) \<in> bsqr r"
107.1235 + proof-
107.1236 + {assume Case1: "a1 = b1 \<and> a2 = b2"
107.1237 + hence ?thesis using ** by simp
107.1238 + }
107.1239 + moreover
107.1240 + {assume Case2: "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id"
107.1241 + {assume Case21: "b1 = c1 \<and> b2 = c2"
107.1242 + hence ?thesis using * by simp
107.1243 + }
107.1244 + moreover
107.1245 + {assume Case22: "(wo_rel.max2 r b1 b2, wo_rel.max2 r c1 c2) \<in> r - Id"
107.1246 + hence "(wo_rel.max2 r a1 a2, wo_rel.max2 r c1 c2) \<in> r - Id"
107.1247 + using Case2 TransS trans_def[of "r - Id"] by blast
107.1248 + hence ?thesis using 0 unfolding bsqr_def by auto
107.1249 + }
107.1250 + moreover
107.1251 + {assume Case23_4: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2"
107.1252 + hence ?thesis using Case2 0 unfolding bsqr_def by auto
107.1253 + }
107.1254 + ultimately have ?thesis using 0 2 by auto
107.1255 + }
107.1256 + moreover
107.1257 + {assume Case3: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id"
107.1258 + {assume Case31: "b1 = c1 \<and> b2 = c2"
107.1259 + hence ?thesis using * by simp
107.1260 + }
107.1261 + moreover
107.1262 + {assume Case32: "(wo_rel.max2 r b1 b2, wo_rel.max2 r c1 c2) \<in> r - Id"
107.1263 + hence ?thesis using Case3 0 unfolding bsqr_def by auto
107.1264 + }
107.1265 + moreover
107.1266 + {assume Case33: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> (b1,c1) \<in> r - Id"
107.1267 + hence "(a1,c1) \<in> r - Id"
107.1268 + using Case3 TransS trans_def[of "r - Id"] by blast
107.1269 + hence ?thesis using Case3 Case33 0 unfolding bsqr_def by auto
107.1270 + }
107.1271 + moreover
107.1272 + {assume Case33: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> b1 = c1"
107.1273 + hence ?thesis using Case3 0 unfolding bsqr_def by auto
107.1274 + }
107.1275 + ultimately have ?thesis using 0 2 by auto
107.1276 + }
107.1277 + moreover
107.1278 + {assume Case4: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id"
107.1279 + {assume Case41: "b1 = c1 \<and> b2 = c2"
107.1280 + hence ?thesis using * by simp
107.1281 + }
107.1282 + moreover
107.1283 + {assume Case42: "(wo_rel.max2 r b1 b2, wo_rel.max2 r c1 c2) \<in> r - Id"
107.1284 + hence ?thesis using Case4 0 unfolding bsqr_def by force
107.1285 + }
107.1286 + moreover
107.1287 + {assume Case43: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> (b1,c1) \<in> r - Id"
107.1288 + hence ?thesis using Case4 0 unfolding bsqr_def by auto
107.1289 + }
107.1290 + moreover
107.1291 + {assume Case44: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> b1 = c1 \<and> (b2,c2) \<in> r - Id"
107.1292 + hence "(a2,c2) \<in> r - Id"
107.1293 + using Case4 TransS trans_def[of "r - Id"] by blast
107.1294 + hence ?thesis using Case4 Case44 0 unfolding bsqr_def by auto
107.1295 + }
107.1296 + ultimately have ?thesis using 0 2 by auto
107.1297 + }
107.1298 + ultimately show ?thesis using 0 1 by auto
107.1299 + qed
107.1300 +qed
107.1301 +
107.1302 +
107.1303 +lemma bsqr_antisym:
107.1304 +assumes "Well_order r"
107.1305 +shows "antisym (bsqr r)"
107.1306 +proof(unfold antisym_def, clarify)
107.1307 + (* Preliminary facts *)
107.1308 + have Well: "wo_rel r" using assms wo_rel_def by auto
107.1309 + hence Trans: "trans r" using wo_rel.TRANS by auto
107.1310 + have Anti: "antisym r" using wo_rel.ANTISYM Well by auto
107.1311 + hence TransS: "trans(r - Id)" using Trans by (simp add: trans_diff_Id)
107.1312 + hence IrrS: "\<forall>a b. \<not>((a,b) \<in> r - Id \<and> (b,a) \<in> r - Id)"
107.1313 + using Anti trans_def[of "r - Id"] antisym_def[of "r - Id"] by blast
107.1314 + (* Main proof *)
107.1315 + fix a1 a2 b1 b2
107.1316 + assume *: "((a1,a2),(b1,b2)) \<in> bsqr r" and **: "((b1,b2),(a1,a2)) \<in> bsqr r"
107.1317 + hence 0: "{a1,a2,b1,b2} \<le> Field r" unfolding bsqr_def by auto
107.1318 + have 1: "a1 = b1 \<and> a2 = b2 \<or> (wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id \<or>
107.1319 + wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id \<or>
107.1320 + wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id"
107.1321 + using * unfolding bsqr_def by auto
107.1322 + have 2: "b1 = a1 \<and> b2 = a2 \<or> (wo_rel.max2 r b1 b2, wo_rel.max2 r a1 a2) \<in> r - Id \<or>
107.1323 + wo_rel.max2 r b1 b2 = wo_rel.max2 r a1 a2 \<and> (b1,a1) \<in> r - Id \<or>
107.1324 + wo_rel.max2 r b1 b2 = wo_rel.max2 r a1 a2 \<and> b1 = a1 \<and> (b2,a2) \<in> r - Id"
107.1325 + using ** unfolding bsqr_def by auto
107.1326 + show "a1 = b1 \<and> a2 = b2"
107.1327 + proof-
107.1328 + {assume Case1: "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id"
107.1329 + {assume Case11: "(wo_rel.max2 r b1 b2, wo_rel.max2 r a1 a2) \<in> r - Id"
107.1330 + hence False using Case1 IrrS by blast
107.1331 + }
107.1332 + moreover
107.1333 + {assume Case12_3: "wo_rel.max2 r b1 b2 = wo_rel.max2 r a1 a2"
107.1334 + hence False using Case1 by auto
107.1335 + }
107.1336 + ultimately have ?thesis using 0 2 by auto
107.1337 + }
107.1338 + moreover
107.1339 + {assume Case2: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id"
107.1340 + {assume Case21: "(wo_rel.max2 r b1 b2, wo_rel.max2 r a1 a2) \<in> r - Id"
107.1341 + hence False using Case2 by auto
107.1342 + }
107.1343 + moreover
107.1344 + {assume Case22: "(b1,a1) \<in> r - Id"
107.1345 + hence False using Case2 IrrS by blast
107.1346 + }
107.1347 + moreover
107.1348 + {assume Case23: "b1 = a1"
107.1349 + hence False using Case2 by auto
107.1350 + }
107.1351 + ultimately have ?thesis using 0 2 by auto
107.1352 + }
107.1353 + moreover
107.1354 + {assume Case3: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id"
107.1355 + moreover
107.1356 + {assume Case31: "(wo_rel.max2 r b1 b2, wo_rel.max2 r a1 a2) \<in> r - Id"
107.1357 + hence False using Case3 by auto
107.1358 + }
107.1359 + moreover
107.1360 + {assume Case32: "(b1,a1) \<in> r - Id"
107.1361 + hence False using Case3 by auto
107.1362 + }
107.1363 + moreover
107.1364 + {assume Case33: "(b2,a2) \<in> r - Id"
107.1365 + hence False using Case3 IrrS by blast
107.1366 + }
107.1367 + ultimately have ?thesis using 0 2 by auto
107.1368 + }
107.1369 + ultimately show ?thesis using 0 1 by blast
107.1370 + qed
107.1371 +qed
107.1372 +
107.1373 +
107.1374 +lemma bsqr_Total:
107.1375 +assumes "Well_order r"
107.1376 +shows "Total(bsqr r)"
107.1377 +proof-
107.1378 + (* Preliminary facts *)
107.1379 + have Well: "wo_rel r" using assms wo_rel_def by auto
107.1380 + hence Total: "\<forall>a \<in> Field r. \<forall>b \<in> Field r. (a,b) \<in> r \<or> (b,a) \<in> r"
107.1381 + using wo_rel.TOTALS by auto
107.1382 + (* Main proof *)
107.1383 + {fix a1 a2 b1 b2 assume "{(a1,a2), (b1,b2)} \<le> Field(bsqr r)"
107.1384 + hence 0: "a1 \<in> Field r \<and> a2 \<in> Field r \<and> b1 \<in> Field r \<and> b2 \<in> Field r"
107.1385 + using Field_bsqr by blast
107.1386 + have "((a1,a2) = (b1,b2) \<or> ((a1,a2),(b1,b2)) \<in> bsqr r \<or> ((b1,b2),(a1,a2)) \<in> bsqr r)"
107.1387 + proof(rule wo_rel.cases_Total[of r a1 a2], clarsimp simp add: Well, simp add: 0)
107.1388 + (* Why didn't clarsimp simp add: Well 0 do the same job? *)
107.1389 + assume Case1: "(a1,a2) \<in> r"
107.1390 + hence 1: "wo_rel.max2 r a1 a2 = a2"
107.1391 + using Well 0 by (simp add: wo_rel.max2_equals2)
107.1392 + show ?thesis
107.1393 + proof(rule wo_rel.cases_Total[of r b1 b2], clarsimp simp add: Well, simp add: 0)
107.1394 + assume Case11: "(b1,b2) \<in> r"
107.1395 + hence 2: "wo_rel.max2 r b1 b2 = b2"
107.1396 + using Well 0 by (simp add: wo_rel.max2_equals2)
107.1397 + show ?thesis
107.1398 + proof(rule wo_rel.cases_Total3[of r a2 b2], clarsimp simp add: Well, simp add: 0)
107.1399 + assume Case111: "(a2,b2) \<in> r - Id \<or> (b2,a2) \<in> r - Id"
107.1400 + thus ?thesis using 0 1 2 unfolding bsqr_def by auto
107.1401 + next
107.1402 + assume Case112: "a2 = b2"
107.1403 + show ?thesis
107.1404 + proof(rule wo_rel.cases_Total3[of r a1 b1], clarsimp simp add: Well, simp add: 0)
107.1405 + assume Case1121: "(a1,b1) \<in> r - Id \<or> (b1,a1) \<in> r - Id"
107.1406 + thus ?thesis using 0 1 2 Case112 unfolding bsqr_def by auto
107.1407 + next
107.1408 + assume Case1122: "a1 = b1"
107.1409 + thus ?thesis using Case112 by auto
107.1410 + qed
107.1411 + qed
107.1412 + next
107.1413 + assume Case12: "(b2,b1) \<in> r"
107.1414 + hence 3: "wo_rel.max2 r b1 b2 = b1" using Well 0 by (simp add: wo_rel.max2_equals1)
107.1415 + show ?thesis
107.1416 + proof(rule wo_rel.cases_Total3[of r a2 b1], clarsimp simp add: Well, simp add: 0)
107.1417 + assume Case121: "(a2,b1) \<in> r - Id \<or> (b1,a2) \<in> r - Id"
107.1418 + thus ?thesis using 0 1 3 unfolding bsqr_def by auto
107.1419 + next
107.1420 + assume Case122: "a2 = b1"
107.1421 + show ?thesis
107.1422 + proof(rule wo_rel.cases_Total3[of r a1 b1], clarsimp simp add: Well, simp add: 0)
107.1423 + assume Case1221: "(a1,b1) \<in> r - Id \<or> (b1,a1) \<in> r - Id"
107.1424 + thus ?thesis using 0 1 3 Case122 unfolding bsqr_def by auto
107.1425 + next
107.1426 + assume Case1222: "a1 = b1"
107.1427 + show ?thesis
107.1428 + proof(rule wo_rel.cases_Total3[of r a2 b2], clarsimp simp add: Well, simp add: 0)
107.1429 + assume Case12221: "(a2,b2) \<in> r - Id \<or> (b2,a2) \<in> r - Id"
107.1430 + thus ?thesis using 0 1 3 Case122 Case1222 unfolding bsqr_def by auto
107.1431 + next
107.1432 + assume Case12222: "a2 = b2"
107.1433 + thus ?thesis using Case122 Case1222 by auto
107.1434 + qed
107.1435 + qed
107.1436 + qed
107.1437 + qed
107.1438 + next
107.1439 + assume Case2: "(a2,a1) \<in> r"
107.1440 + hence 1: "wo_rel.max2 r a1 a2 = a1" using Well 0 by (simp add: wo_rel.max2_equals1)
107.1441 + show ?thesis
107.1442 + proof(rule wo_rel.cases_Total[of r b1 b2], clarsimp simp add: Well, simp add: 0)
107.1443 + assume Case21: "(b1,b2) \<in> r"
107.1444 + hence 2: "wo_rel.max2 r b1 b2 = b2" using Well 0 by (simp add: wo_rel.max2_equals2)
107.1445 + show ?thesis
107.1446 + proof(rule wo_rel.cases_Total3[of r a1 b2], clarsimp simp add: Well, simp add: 0)
107.1447 + assume Case211: "(a1,b2) \<in> r - Id \<or> (b2,a1) \<in> r - Id"
107.1448 + thus ?thesis using 0 1 2 unfolding bsqr_def by auto
107.1449 + next
107.1450 + assume Case212: "a1 = b2"
107.1451 + show ?thesis
107.1452 + proof(rule wo_rel.cases_Total3[of r a1 b1], clarsimp simp add: Well, simp add: 0)
107.1453 + assume Case2121: "(a1,b1) \<in> r - Id \<or> (b1,a1) \<in> r - Id"
107.1454 + thus ?thesis using 0 1 2 Case212 unfolding bsqr_def by auto
107.1455 + next
107.1456 + assume Case2122: "a1 = b1"
107.1457 + show ?thesis
107.1458 + proof(rule wo_rel.cases_Total3[of r a2 b2], clarsimp simp add: Well, simp add: 0)
107.1459 + assume Case21221: "(a2,b2) \<in> r - Id \<or> (b2,a2) \<in> r - Id"
107.1460 + thus ?thesis using 0 1 2 Case212 Case2122 unfolding bsqr_def by auto
107.1461 + next
107.1462 + assume Case21222: "a2 = b2"
107.1463 + thus ?thesis using Case2122 Case212 by auto
107.1464 + qed
107.1465 + qed
107.1466 + qed
107.1467 + next
107.1468 + assume Case22: "(b2,b1) \<in> r"
107.1469 + hence 3: "wo_rel.max2 r b1 b2 = b1" using Well 0 by (simp add: wo_rel.max2_equals1)
107.1470 + show ?thesis
107.1471 + proof(rule wo_rel.cases_Total3[of r a1 b1], clarsimp simp add: Well, simp add: 0)
107.1472 + assume Case221: "(a1,b1) \<in> r - Id \<or> (b1,a1) \<in> r - Id"
107.1473 + thus ?thesis using 0 1 3 unfolding bsqr_def by auto
107.1474 + next
107.1475 + assume Case222: "a1 = b1"
107.1476 + show ?thesis
107.1477 + proof(rule wo_rel.cases_Total3[of r a2 b2], clarsimp simp add: Well, simp add: 0)
107.1478 + assume Case2221: "(a2,b2) \<in> r - Id \<or> (b2,a2) \<in> r - Id"
107.1479 + thus ?thesis using 0 1 3 Case222 unfolding bsqr_def by auto
107.1480 + next
107.1481 + assume Case2222: "a2 = b2"
107.1482 + thus ?thesis using Case222 by auto
107.1483 + qed
107.1484 + qed
107.1485 + qed
107.1486 + qed
107.1487 + }
107.1488 + thus ?thesis unfolding total_on_def by fast
107.1489 +qed
107.1490 +
107.1491 +
107.1492 +lemma bsqr_Linear_order:
107.1493 +assumes "Well_order r"
107.1494 +shows "Linear_order(bsqr r)"
107.1495 +unfolding order_on_defs
107.1496 +using assms bsqr_Refl bsqr_Trans bsqr_antisym bsqr_Total by blast
107.1497 +
107.1498 +
107.1499 +lemma bsqr_Well_order:
107.1500 +assumes "Well_order r"
107.1501 +shows "Well_order(bsqr r)"
107.1502 +using assms
107.1503 +proof(simp add: bsqr_Linear_order Linear_order_Well_order_iff, intro allI impI)
107.1504 + have 0: "\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r)"
107.1505 + using assms well_order_on_def Linear_order_Well_order_iff by blast
107.1506 + fix D assume *: "D \<le> Field (bsqr r)" and **: "D \<noteq> {}"
107.1507 + hence 1: "D \<le> Field r \<times> Field r" unfolding Field_bsqr by simp
107.1508 + (* *)
107.1509 + obtain M where M_def: "M = {wo_rel.max2 r a1 a2| a1 a2. (a1,a2) \<in> D}" by blast
107.1510 + have "M \<noteq> {}" using 1 M_def ** by auto
107.1511 + moreover
107.1512 + have "M \<le> Field r" unfolding M_def
107.1513 + using 1 assms wo_rel_def[of r] wo_rel.max2_among[of r] by fastforce
107.1514 + ultimately obtain m where m_min: "m \<in> M \<and> (\<forall>a \<in> M. (m,a) \<in> r)"
107.1515 + using 0 by blast
107.1516 + (* *)
107.1517 + obtain A1 where A1_def: "A1 = {a1. \<exists>a2. (a1,a2) \<in> D \<and> wo_rel.max2 r a1 a2 = m}" by blast
107.1518 + have "A1 \<le> Field r" unfolding A1_def using 1 by auto
107.1519 + moreover have "A1 \<noteq> {}" unfolding A1_def using m_min unfolding M_def by blast
107.1520 + ultimately obtain a1 where a1_min: "a1 \<in> A1 \<and> (\<forall>a \<in> A1. (a1,a) \<in> r)"
107.1521 + using 0 by blast
107.1522 + (* *)
107.1523 + obtain A2 where A2_def: "A2 = {a2. (a1,a2) \<in> D \<and> wo_rel.max2 r a1 a2 = m}" by blast
107.1524 + have "A2 \<le> Field r" unfolding A2_def using 1 by auto
107.1525 + moreover have "A2 \<noteq> {}" unfolding A2_def
107.1526 + using m_min a1_min unfolding A1_def M_def by blast
107.1527 + ultimately obtain a2 where a2_min: "a2 \<in> A2 \<and> (\<forall>a \<in> A2. (a2,a) \<in> r)"
107.1528 + using 0 by blast
107.1529 + (* *)
107.1530 + have 2: "wo_rel.max2 r a1 a2 = m"
107.1531 + using a1_min a2_min unfolding A1_def A2_def by auto
107.1532 + have 3: "(a1,a2) \<in> D" using a2_min unfolding A2_def by auto
107.1533 + (* *)
107.1534 + moreover
107.1535 + {fix b1 b2 assume ***: "(b1,b2) \<in> D"
107.1536 + hence 4: "{a1,a2,b1,b2} \<le> Field r" using 1 3 by blast
107.1537 + have 5: "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r"
107.1538 + using *** a1_min a2_min m_min unfolding A1_def A2_def M_def by auto
107.1539 + have "((a1,a2),(b1,b2)) \<in> bsqr r"
107.1540 + proof(cases "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2")
107.1541 + assume Case1: "wo_rel.max2 r a1 a2 \<noteq> wo_rel.max2 r b1 b2"
107.1542 + thus ?thesis unfolding bsqr_def using 4 5 by auto
107.1543 + next
107.1544 + assume Case2: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2"
107.1545 + hence "b1 \<in> A1" unfolding A1_def using 2 *** by auto
107.1546 + hence 6: "(a1,b1) \<in> r" using a1_min by auto
107.1547 + show ?thesis
107.1548 + proof(cases "a1 = b1")
107.1549 + assume Case21: "a1 \<noteq> b1"
107.1550 + thus ?thesis unfolding bsqr_def using 4 Case2 6 by auto
107.1551 + next
107.1552 + assume Case22: "a1 = b1"
107.1553 + hence "b2 \<in> A2" unfolding A2_def using 2 *** Case2 by auto
107.1554 + hence 7: "(a2,b2) \<in> r" using a2_min by auto
107.1555 + thus ?thesis unfolding bsqr_def using 4 7 Case2 Case22 by auto
107.1556 + qed
107.1557 + qed
107.1558 + }
107.1559 + (* *)
107.1560 + ultimately show "\<exists>d \<in> D. \<forall>d' \<in> D. (d,d') \<in> bsqr r" by fastforce
107.1561 +qed
107.1562 +
107.1563 +
107.1564 +lemma bsqr_max2:
107.1565 +assumes WELL: "Well_order r" and LEQ: "((a1,a2),(b1,b2)) \<in> bsqr r"
107.1566 +shows "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r"
107.1567 +proof-
107.1568 + have "{(a1,a2),(b1,b2)} \<le> Field(bsqr r)"
107.1569 + using LEQ unfolding Field_def by auto
107.1570 + hence "{a1,a2,b1,b2} \<le> Field r" unfolding Field_bsqr by auto
107.1571 + hence "{wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2} \<le> Field r"
107.1572 + using WELL wo_rel_def[of r] wo_rel.max2_among[of r] by fastforce
107.1573 + moreover have "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r \<or> wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2"
107.1574 + using LEQ unfolding bsqr_def by auto
107.1575 + ultimately show ?thesis using WELL unfolding order_on_defs refl_on_def by auto
107.1576 +qed
107.1577 +
107.1578 +
107.1579 +lemma bsqr_ofilter:
107.1580 +assumes WELL: "Well_order r" and
107.1581 + OF: "wo_rel.ofilter (bsqr r) D" and SUB: "D < Field r \<times> Field r" and
107.1582 + NE: "\<not> (\<exists>a. Field r = rel.under r a)"
107.1583 +shows "\<exists>A. wo_rel.ofilter r A \<and> A < Field r \<and> D \<le> A \<times> A"
107.1584 +proof-
107.1585 + let ?r' = "bsqr r"
107.1586 + have Well: "wo_rel r" using WELL wo_rel_def by blast
107.1587 + hence Trans: "trans r" using wo_rel.TRANS by blast
107.1588 + have Well': "Well_order ?r' \<and> wo_rel ?r'"
107.1589 + using WELL bsqr_Well_order wo_rel_def by blast
107.1590 + (* *)
107.1591 + have "D < Field ?r'" unfolding Field_bsqr using SUB .
107.1592 + with OF obtain a1 and a2 where
107.1593 + "(a1,a2) \<in> Field ?r'" and 1: "D = rel.underS ?r' (a1,a2)"
107.1594 + using Well' wo_rel.ofilter_underS_Field[of ?r' D] by auto
107.1595 + hence 2: "{a1,a2} \<le> Field r" unfolding Field_bsqr by auto
107.1596 + let ?m = "wo_rel.max2 r a1 a2"
107.1597 + have "D \<le> (rel.under r ?m) \<times> (rel.under r ?m)"
107.1598 + proof(unfold 1)
107.1599 + {fix b1 b2
107.1600 + let ?n = "wo_rel.max2 r b1 b2"
107.1601 + assume "(b1,b2) \<in> rel.underS ?r' (a1,a2)"
107.1602 + hence 3: "((b1,b2),(a1,a2)) \<in> ?r'"
107.1603 + unfolding rel.underS_def by blast
107.1604 + hence "(?n,?m) \<in> r" using WELL by (simp add: bsqr_max2)
107.1605 + moreover
107.1606 + {have "(b1,b2) \<in> Field ?r'" using 3 unfolding Field_def by auto
107.1607 + hence "{b1,b2} \<le> Field r" unfolding Field_bsqr by auto
107.1608 + hence "(b1,?n) \<in> r \<and> (b2,?n) \<in> r"
107.1609 + using Well by (simp add: wo_rel.max2_greater)
107.1610 + }
107.1611 + ultimately have "(b1,?m) \<in> r \<and> (b2,?m) \<in> r"
107.1612 + using Trans trans_def[of r] by blast
107.1613 + hence "(b1,b2) \<in> (rel.under r ?m) \<times> (rel.under r ?m)" unfolding rel.under_def by simp}
107.1614 + thus "rel.underS ?r' (a1,a2) \<le> (rel.under r ?m) \<times> (rel.under r ?m)" by auto
107.1615 + qed
107.1616 + moreover have "wo_rel.ofilter r (rel.under r ?m)"
107.1617 + using Well by (simp add: wo_rel.under_ofilter)
107.1618 + moreover have "rel.under r ?m < Field r"
107.1619 + using NE rel.under_Field[of r ?m] by blast
107.1620 + ultimately show ?thesis by blast
107.1621 +qed
107.1622 +
107.1623 +
107.1624 +end
108.1 --- a/src/HOL/Cardinals/Fun_More.thy Thu Dec 05 17:52:12 2013 +0100
108.2 +++ b/src/HOL/Cardinals/Fun_More.thy Thu Dec 05 17:58:03 2013 +0100
108.3 @@ -8,7 +8,7 @@
108.4 header {* More on Injections, Bijections and Inverses *}
108.5
108.6 theory Fun_More
108.7 -imports Fun_More_Base
108.8 +imports Fun_More_FP Main
108.9 begin
108.10
108.11
108.12 @@ -132,6 +132,18 @@
108.13 subsection {* Properties involving Hilbert choice *}
108.14
108.15
108.16 +(*1*)lemma bij_betw_inv_into_LEFT:
108.17 +assumes BIJ: "bij_betw f A A'" and SUB: "B \<le> A"
108.18 +shows "(inv_into A f)`(f ` B) = B"
108.19 +using assms unfolding bij_betw_def using inv_into_image_cancel by force
108.20 +
108.21 +(*1*)lemma bij_betw_inv_into_LEFT_RIGHT:
108.22 +assumes BIJ: "bij_betw f A A'" and SUB: "B \<le> A" and
108.23 + IM: "f ` B = B'"
108.24 +shows "(inv_into A f) ` B' = B"
108.25 +using assms bij_betw_inv_into_LEFT[of f A A' B] by fast
108.26 +
108.27 +
108.28 subsection {* Other facts *}
108.29
108.30 (*3*)lemma atLeastLessThan_injective:
108.31 @@ -158,6 +170,20 @@
108.32 card_atLeastLessThan[of m] card_atLeastLessThan[of n]
108.33 bij_betw_iff_card[of "{0 ..< m}" "{0 ..< n}"] by auto
108.34
108.35 +
108.36 +(*2*)lemma atLeastLessThan_less_eq:
108.37 +"({0..<m} \<le> {0..<n}) = ((m::nat) \<le> n)"
108.38 +unfolding ivl_subset by arith
108.39 +
108.40 +
108.41 +(*2*)lemma atLeastLessThan_less_eq2:
108.42 +assumes "inj_on f {0..<(m::nat)} \<and> f ` {0..<m} \<le> {0..<n}"
108.43 +shows "m \<le> n"
108.44 +using assms
108.45 +using finite_atLeastLessThan[of m] finite_atLeastLessThan[of n]
108.46 + card_atLeastLessThan[of m] card_atLeastLessThan[of n]
108.47 + card_inj_on_le[of f "{0 ..< m}" "{0 ..< n}"] by fastforce
108.48 +
108.49 (* unused *)
108.50 (*2*)lemma atLeastLessThan_less_eq3:
108.51 "(\<exists>f. inj_on f {0..<(m::nat)} \<and> f ` {0..<m} \<le> {0..<n}) = (m \<le> n)"
109.1 --- a/src/HOL/Cardinals/Fun_More_Base.thy Thu Dec 05 17:52:12 2013 +0100
109.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
109.3 @@ -1,252 +0,0 @@
109.4 -(* Title: HOL/Cardinals/Fun_More_Base.thy
109.5 - Author: Andrei Popescu, TU Muenchen
109.6 - Copyright 2012
109.7 -
109.8 -More on injections, bijections and inverses (base).
109.9 -*)
109.10 -
109.11 -header {* More on Injections, Bijections and Inverses (Base) *}
109.12 -
109.13 -theory Fun_More_Base
109.14 -imports "~~/src/HOL/Library/Infinite_Set"
109.15 -begin
109.16 -
109.17 -
109.18 -text {* This section proves more facts (additional to those in @{text "Fun.thy"},
109.19 -@{text "Hilbert_Choice.thy"}, @{text "Finite_Set.thy"} and @{text "Infinite_Set.thy"}),
109.20 -mainly concerning injections, bijections, inverses and (numeric) cardinals of
109.21 -finite sets. *}
109.22 -
109.23 -
109.24 -subsection {* Purely functional properties *}
109.25 -
109.26 -
109.27 -(*2*)lemma bij_betw_id_iff:
109.28 -"(A = B) = (bij_betw id A B)"
109.29 -by(simp add: bij_betw_def)
109.30 -
109.31 -
109.32 -(*2*)lemma bij_betw_byWitness:
109.33 -assumes LEFT: "\<forall>a \<in> A. f'(f a) = a" and
109.34 - RIGHT: "\<forall>a' \<in> A'. f(f' a') = a'" and
109.35 - IM1: "f ` A \<le> A'" and IM2: "f' ` A' \<le> A"
109.36 -shows "bij_betw f A A'"
109.37 -using assms
109.38 -proof(unfold bij_betw_def inj_on_def, safe)
109.39 - fix a b assume *: "a \<in> A" "b \<in> A" and **: "f a = f b"
109.40 - have "a = f'(f a) \<and> b = f'(f b)" using * LEFT by simp
109.41 - with ** show "a = b" by simp
109.42 -next
109.43 - fix a' assume *: "a' \<in> A'"
109.44 - hence "f' a' \<in> A" using IM2 by blast
109.45 - moreover
109.46 - have "a' = f(f' a')" using * RIGHT by simp
109.47 - ultimately show "a' \<in> f ` A" by blast
109.48 -qed
109.49 -
109.50 -
109.51 -(*3*)corollary notIn_Un_bij_betw:
109.52 -assumes NIN: "b \<notin> A" and NIN': "f b \<notin> A'" and
109.53 - BIJ: "bij_betw f A A'"
109.54 -shows "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
109.55 -proof-
109.56 - have "bij_betw f {b} {f b}"
109.57 - unfolding bij_betw_def inj_on_def by simp
109.58 - with assms show ?thesis
109.59 - using bij_betw_combine[of f A A' "{b}" "{f b}"] by blast
109.60 -qed
109.61 -
109.62 -
109.63 -(*1*)lemma notIn_Un_bij_betw3:
109.64 -assumes NIN: "b \<notin> A" and NIN': "f b \<notin> A'"
109.65 -shows "bij_betw f A A' = bij_betw f (A \<union> {b}) (A' \<union> {f b})"
109.66 -proof
109.67 - assume "bij_betw f A A'"
109.68 - thus "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
109.69 - using assms notIn_Un_bij_betw[of b A f A'] by blast
109.70 -next
109.71 - assume *: "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
109.72 - have "f ` A = A'"
109.73 - proof(auto)
109.74 - fix a assume **: "a \<in> A"
109.75 - hence "f a \<in> A' \<union> {f b}" using * unfolding bij_betw_def by blast
109.76 - moreover
109.77 - {assume "f a = f b"
109.78 - hence "a = b" using * ** unfolding bij_betw_def inj_on_def by blast
109.79 - with NIN ** have False by blast
109.80 - }
109.81 - ultimately show "f a \<in> A'" by blast
109.82 - next
109.83 - fix a' assume **: "a' \<in> A'"
109.84 - hence "a' \<in> f`(A \<union> {b})"
109.85 - using * by (auto simp add: bij_betw_def)
109.86 - then obtain a where 1: "a \<in> A \<union> {b} \<and> f a = a'" by blast
109.87 - moreover
109.88 - {assume "a = b" with 1 ** NIN' have False by blast
109.89 - }
109.90 - ultimately have "a \<in> A" by blast
109.91 - with 1 show "a' \<in> f ` A" by blast
109.92 - qed
109.93 - thus "bij_betw f A A'" using * bij_betw_subset[of f "A \<union> {b}" _ A] by blast
109.94 -qed
109.95 -
109.96 -
109.97 -subsection {* Properties involving finite and infinite sets *}
109.98 -
109.99 -
109.100 -(*3*)lemma inj_on_finite:
109.101 -assumes "inj_on f A" "f ` A \<le> B" "finite B"
109.102 -shows "finite A"
109.103 -using assms infinite_super by (fast dest: finite_imageD)
109.104 -
109.105 -
109.106 -(*3*)lemma infinite_imp_bij_betw:
109.107 -assumes INF: "infinite A"
109.108 -shows "\<exists>h. bij_betw h A (A - {a})"
109.109 -proof(cases "a \<in> A")
109.110 - assume Case1: "a \<notin> A" hence "A - {a} = A" by blast
109.111 - thus ?thesis using bij_betw_id[of A] by auto
109.112 -next
109.113 - assume Case2: "a \<in> A"
109.114 - have "infinite (A - {a})" using INF infinite_remove by auto
109.115 - with infinite_iff_countable_subset[of "A - {a}"] obtain f::"nat \<Rightarrow> 'a"
109.116 - where 1: "inj f" and 2: "f ` UNIV \<le> A - {a}" by blast
109.117 - obtain g where g_def: "g = (\<lambda> n. if n = 0 then a else f (Suc n))" by blast
109.118 - obtain A' where A'_def: "A' = g ` UNIV" by blast
109.119 - have temp: "\<forall>y. f y \<noteq> a" using 2 by blast
109.120 - have 3: "inj_on g UNIV \<and> g ` UNIV \<le> A \<and> a \<in> g ` UNIV"
109.121 - proof(auto simp add: Case2 g_def, unfold inj_on_def, intro ballI impI,
109.122 - case_tac "x = 0", auto simp add: 2)
109.123 - fix y assume "a = (if y = 0 then a else f (Suc y))"
109.124 - thus "y = 0" using temp by (case_tac "y = 0", auto)
109.125 - next
109.126 - fix x y
109.127 - assume "f (Suc x) = (if y = 0 then a else f (Suc y))"
109.128 - thus "x = y" using 1 temp unfolding inj_on_def by (case_tac "y = 0", auto)
109.129 - next
109.130 - fix n show "f (Suc n) \<in> A" using 2 by blast
109.131 - qed
109.132 - hence 4: "bij_betw g UNIV A' \<and> a \<in> A' \<and> A' \<le> A"
109.133 - using inj_on_imp_bij_betw[of g] unfolding A'_def by auto
109.134 - hence 5: "bij_betw (inv g) A' UNIV"
109.135 - by (auto simp add: bij_betw_inv_into)
109.136 - (* *)
109.137 - obtain n where "g n = a" using 3 by auto
109.138 - hence 6: "bij_betw g (UNIV - {n}) (A' - {a})"
109.139 - using 3 4 unfolding A'_def
109.140 - by clarify (rule bij_betw_subset, auto simp: image_set_diff)
109.141 - (* *)
109.142 - obtain v where v_def: "v = (\<lambda> m. if m < n then m else Suc m)" by blast
109.143 - have 7: "bij_betw v UNIV (UNIV - {n})"
109.144 - proof(unfold bij_betw_def inj_on_def, intro conjI, clarify)
109.145 - fix m1 m2 assume "v m1 = v m2"
109.146 - thus "m1 = m2"
109.147 - by(case_tac "m1 < n", case_tac "m2 < n",
109.148 - auto simp add: inj_on_def v_def, case_tac "m2 < n", auto)
109.149 - next
109.150 - show "v ` UNIV = UNIV - {n}"
109.151 - proof(auto simp add: v_def)
109.152 - fix m assume *: "m \<noteq> n" and **: "m \<notin> Suc ` {m'. \<not> m' < n}"
109.153 - {assume "n \<le> m" with * have 71: "Suc n \<le> m" by auto
109.154 - then obtain m' where 72: "m = Suc m'" using Suc_le_D by auto
109.155 - with 71 have "n \<le> m'" by auto
109.156 - with 72 ** have False by auto
109.157 - }
109.158 - thus "m < n" by force
109.159 - qed
109.160 - qed
109.161 - (* *)
109.162 - obtain h' where h'_def: "h' = g o v o (inv g)" by blast
109.163 - hence 8: "bij_betw h' A' (A' - {a})" using 5 7 6
109.164 - by (auto simp add: bij_betw_trans)
109.165 - (* *)
109.166 - obtain h where h_def: "h = (\<lambda> b. if b \<in> A' then h' b else b)" by blast
109.167 - have "\<forall>b \<in> A'. h b = h' b" unfolding h_def by auto
109.168 - hence "bij_betw h A' (A' - {a})" using 8 bij_betw_cong[of A' h] by auto
109.169 - moreover
109.170 - {have "\<forall>b \<in> A - A'. h b = b" unfolding h_def by auto
109.171 - hence "bij_betw h (A - A') (A - A')"
109.172 - using bij_betw_cong[of "A - A'" h id] bij_betw_id[of "A - A'"] by auto
109.173 - }
109.174 - moreover
109.175 - have "(A' Int (A - A') = {} \<and> A' \<union> (A - A') = A) \<and>
109.176 - ((A' - {a}) Int (A - A') = {} \<and> (A' - {a}) \<union> (A - A') = A - {a})"
109.177 - using 4 by blast
109.178 - ultimately have "bij_betw h A (A - {a})"
109.179 - using bij_betw_combine[of h A' "A' - {a}" "A - A'" "A - A'"] by simp
109.180 - thus ?thesis by blast
109.181 -qed
109.182 -
109.183 -
109.184 -(*3*)lemma infinite_imp_bij_betw2:
109.185 -assumes INF: "infinite A"
109.186 -shows "\<exists>h. bij_betw h A (A \<union> {a})"
109.187 -proof(cases "a \<in> A")
109.188 - assume Case1: "a \<in> A" hence "A \<union> {a} = A" by blast
109.189 - thus ?thesis using bij_betw_id[of A] by auto
109.190 -next
109.191 - let ?A' = "A \<union> {a}"
109.192 - assume Case2: "a \<notin> A" hence "A = ?A' - {a}" by blast
109.193 - moreover have "infinite ?A'" using INF by auto
109.194 - ultimately obtain f where "bij_betw f ?A' A"
109.195 - using infinite_imp_bij_betw[of ?A' a] by auto
109.196 - hence "bij_betw(inv_into ?A' f) A ?A'" using bij_betw_inv_into by blast
109.197 - thus ?thesis by auto
109.198 -qed
109.199 -
109.200 -
109.201 -subsection {* Properties involving Hilbert choice *}
109.202 -
109.203 -
109.204 -(*2*)lemma bij_betw_inv_into_left:
109.205 -assumes BIJ: "bij_betw f A A'" and IN: "a \<in> A"
109.206 -shows "(inv_into A f) (f a) = a"
109.207 -using assms unfolding bij_betw_def
109.208 -by clarify (rule inv_into_f_f)
109.209 -
109.210 -(*2*)lemma bij_betw_inv_into_right:
109.211 -assumes "bij_betw f A A'" "a' \<in> A'"
109.212 -shows "f(inv_into A f a') = a'"
109.213 -using assms unfolding bij_betw_def using f_inv_into_f by force
109.214 -
109.215 -
109.216 -(*1*)lemma bij_betw_inv_into_LEFT:
109.217 -assumes BIJ: "bij_betw f A A'" and SUB: "B \<le> A"
109.218 -shows "(inv_into A f)`(f ` B) = B"
109.219 -using assms unfolding bij_betw_def using inv_into_image_cancel by force
109.220 -
109.221 -
109.222 -(*1*)lemma bij_betw_inv_into_LEFT_RIGHT:
109.223 -assumes BIJ: "bij_betw f A A'" and SUB: "B \<le> A" and
109.224 - IM: "f ` B = B'"
109.225 -shows "(inv_into A f) ` B' = B"
109.226 -using assms bij_betw_inv_into_LEFT[of f A A' B] by fast
109.227 -
109.228 -
109.229 -(*1*)lemma bij_betw_inv_into_subset:
109.230 -assumes BIJ: "bij_betw f A A'" and
109.231 - SUB: "B \<le> A" and IM: "f ` B = B'"
109.232 -shows "bij_betw (inv_into A f) B' B"
109.233 -using assms unfolding bij_betw_def
109.234 -by (auto intro: inj_on_inv_into)
109.235 -
109.236 -
109.237 -subsection {* Other facts *}
109.238 -
109.239 -
109.240 -(*2*)lemma atLeastLessThan_less_eq:
109.241 -"({0..<m} \<le> {0..<n}) = ((m::nat) \<le> n)"
109.242 -unfolding ivl_subset by arith
109.243 -
109.244 -
109.245 -(*2*)lemma atLeastLessThan_less_eq2:
109.246 -assumes "inj_on f {0..<(m::nat)} \<and> f ` {0..<m} \<le> {0..<n}"
109.247 -shows "m \<le> n"
109.248 -using assms
109.249 -using finite_atLeastLessThan[of m] finite_atLeastLessThan[of n]
109.250 - card_atLeastLessThan[of m] card_atLeastLessThan[of n]
109.251 - card_inj_on_le[of f "{0 ..< m}" "{0 ..< n}"] by auto
109.252 -
109.253 -
109.254 -
109.255 -end
110.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
110.2 +++ b/src/HOL/Cardinals/Fun_More_FP.thy Thu Dec 05 17:58:03 2013 +0100
110.3 @@ -0,0 +1,223 @@
110.4 +(* Title: HOL/Cardinals/Fun_More_FP.thy
110.5 + Author: Andrei Popescu, TU Muenchen
110.6 + Copyright 2012
110.7 +
110.8 +More on injections, bijections and inverses (FP).
110.9 +*)
110.10 +
110.11 +header {* More on Injections, Bijections and Inverses (FP) *}
110.12 +
110.13 +theory Fun_More_FP
110.14 +imports Hilbert_Choice
110.15 +begin
110.16 +
110.17 +
110.18 +text {* This section proves more facts (additional to those in @{text "Fun.thy"},
110.19 +@{text "Hilbert_Choice.thy"}, and @{text "Finite_Set.thy"}),
110.20 +mainly concerning injections, bijections, inverses and (numeric) cardinals of
110.21 +finite sets. *}
110.22 +
110.23 +
110.24 +subsection {* Purely functional properties *}
110.25 +
110.26 +
110.27 +(*2*)lemma bij_betw_id_iff:
110.28 +"(A = B) = (bij_betw id A B)"
110.29 +by(simp add: bij_betw_def)
110.30 +
110.31 +
110.32 +(*2*)lemma bij_betw_byWitness:
110.33 +assumes LEFT: "\<forall>a \<in> A. f'(f a) = a" and
110.34 + RIGHT: "\<forall>a' \<in> A'. f(f' a') = a'" and
110.35 + IM1: "f ` A \<le> A'" and IM2: "f' ` A' \<le> A"
110.36 +shows "bij_betw f A A'"
110.37 +using assms
110.38 +proof(unfold bij_betw_def inj_on_def, safe)
110.39 + fix a b assume *: "a \<in> A" "b \<in> A" and **: "f a = f b"
110.40 + have "a = f'(f a) \<and> b = f'(f b)" using * LEFT by simp
110.41 + with ** show "a = b" by simp
110.42 +next
110.43 + fix a' assume *: "a' \<in> A'"
110.44 + hence "f' a' \<in> A" using IM2 by blast
110.45 + moreover
110.46 + have "a' = f(f' a')" using * RIGHT by simp
110.47 + ultimately show "a' \<in> f ` A" by blast
110.48 +qed
110.49 +
110.50 +
110.51 +(*3*)corollary notIn_Un_bij_betw:
110.52 +assumes NIN: "b \<notin> A" and NIN': "f b \<notin> A'" and
110.53 + BIJ: "bij_betw f A A'"
110.54 +shows "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
110.55 +proof-
110.56 + have "bij_betw f {b} {f b}"
110.57 + unfolding bij_betw_def inj_on_def by simp
110.58 + with assms show ?thesis
110.59 + using bij_betw_combine[of f A A' "{b}" "{f b}"] by blast
110.60 +qed
110.61 +
110.62 +
110.63 +(*1*)lemma notIn_Un_bij_betw3:
110.64 +assumes NIN: "b \<notin> A" and NIN': "f b \<notin> A'"
110.65 +shows "bij_betw f A A' = bij_betw f (A \<union> {b}) (A' \<union> {f b})"
110.66 +proof
110.67 + assume "bij_betw f A A'"
110.68 + thus "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
110.69 + using assms notIn_Un_bij_betw[of b A f A'] by blast
110.70 +next
110.71 + assume *: "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
110.72 + have "f ` A = A'"
110.73 + proof(auto)
110.74 + fix a assume **: "a \<in> A"
110.75 + hence "f a \<in> A' \<union> {f b}" using * unfolding bij_betw_def by blast
110.76 + moreover
110.77 + {assume "f a = f b"
110.78 + hence "a = b" using * ** unfolding bij_betw_def inj_on_def by blast
110.79 + with NIN ** have False by blast
110.80 + }
110.81 + ultimately show "f a \<in> A'" by blast
110.82 + next
110.83 + fix a' assume **: "a' \<in> A'"
110.84 + hence "a' \<in> f`(A \<union> {b})"
110.85 + using * by (auto simp add: bij_betw_def)
110.86 + then obtain a where 1: "a \<in> A \<union> {b} \<and> f a = a'" by blast
110.87 + moreover
110.88 + {assume "a = b" with 1 ** NIN' have False by blast
110.89 + }
110.90 + ultimately have "a \<in> A" by blast
110.91 + with 1 show "a' \<in> f ` A" by blast
110.92 + qed
110.93 + thus "bij_betw f A A'" using * bij_betw_subset[of f "A \<union> {b}" _ A] by blast
110.94 +qed
110.95 +
110.96 +
110.97 +subsection {* Properties involving finite and infinite sets *}
110.98 +
110.99 +
110.100 +(*3*)lemma inj_on_finite:
110.101 +assumes "inj_on f A" "f ` A \<le> B" "finite B"
110.102 +shows "finite A"
110.103 +using assms by (metis finite_imageD finite_subset)
110.104 +
110.105 +
110.106 +(*3*)lemma infinite_imp_bij_betw:
110.107 +assumes INF: "\<not> finite A"
110.108 +shows "\<exists>h. bij_betw h A (A - {a})"
110.109 +proof(cases "a \<in> A")
110.110 + assume Case1: "a \<notin> A" hence "A - {a} = A" by blast
110.111 + thus ?thesis using bij_betw_id[of A] by auto
110.112 +next
110.113 + assume Case2: "a \<in> A"
110.114 +find_theorems "\<not> finite _"
110.115 + have "\<not> finite (A - {a})" using INF by auto
110.116 + with infinite_iff_countable_subset[of "A - {a}"] obtain f::"nat \<Rightarrow> 'a"
110.117 + where 1: "inj f" and 2: "f ` UNIV \<le> A - {a}" by blast
110.118 + obtain g where g_def: "g = (\<lambda> n. if n = 0 then a else f (Suc n))" by blast
110.119 + obtain A' where A'_def: "A' = g ` UNIV" by blast
110.120 + have temp: "\<forall>y. f y \<noteq> a" using 2 by blast
110.121 + have 3: "inj_on g UNIV \<and> g ` UNIV \<le> A \<and> a \<in> g ` UNIV"
110.122 + proof(auto simp add: Case2 g_def, unfold inj_on_def, intro ballI impI,
110.123 + case_tac "x = 0", auto simp add: 2)
110.124 + fix y assume "a = (if y = 0 then a else f (Suc y))"
110.125 + thus "y = 0" using temp by (case_tac "y = 0", auto)
110.126 + next
110.127 + fix x y
110.128 + assume "f (Suc x) = (if y = 0 then a else f (Suc y))"
110.129 + thus "x = y" using 1 temp unfolding inj_on_def by (case_tac "y = 0", auto)
110.130 + next
110.131 + fix n show "f (Suc n) \<in> A" using 2 by blast
110.132 + qed
110.133 + hence 4: "bij_betw g UNIV A' \<and> a \<in> A' \<and> A' \<le> A"
110.134 + using inj_on_imp_bij_betw[of g] unfolding A'_def by auto
110.135 + hence 5: "bij_betw (inv g) A' UNIV"
110.136 + by (auto simp add: bij_betw_inv_into)
110.137 + (* *)
110.138 + obtain n where "g n = a" using 3 by auto
110.139 + hence 6: "bij_betw g (UNIV - {n}) (A' - {a})"
110.140 + using 3 4 unfolding A'_def
110.141 + by clarify (rule bij_betw_subset, auto simp: image_set_diff)
110.142 + (* *)
110.143 + obtain v where v_def: "v = (\<lambda> m. if m < n then m else Suc m)" by blast
110.144 + have 7: "bij_betw v UNIV (UNIV - {n})"
110.145 + proof(unfold bij_betw_def inj_on_def, intro conjI, clarify)
110.146 + fix m1 m2 assume "v m1 = v m2"
110.147 + thus "m1 = m2"
110.148 + by(case_tac "m1 < n", case_tac "m2 < n",
110.149 + auto simp add: inj_on_def v_def, case_tac "m2 < n", auto)
110.150 + next
110.151 + show "v ` UNIV = UNIV - {n}"
110.152 + proof(auto simp add: v_def)
110.153 + fix m assume *: "m \<noteq> n" and **: "m \<notin> Suc ` {m'. \<not> m' < n}"
110.154 + {assume "n \<le> m" with * have 71: "Suc n \<le> m" by auto
110.155 + then obtain m' where 72: "m = Suc m'" using Suc_le_D by auto
110.156 + with 71 have "n \<le> m'" by auto
110.157 + with 72 ** have False by auto
110.158 + }
110.159 + thus "m < n" by force
110.160 + qed
110.161 + qed
110.162 + (* *)
110.163 + obtain h' where h'_def: "h' = g o v o (inv g)" by blast
110.164 + hence 8: "bij_betw h' A' (A' - {a})" using 5 7 6
110.165 + by (auto simp add: bij_betw_trans)
110.166 + (* *)
110.167 + obtain h where h_def: "h = (\<lambda> b. if b \<in> A' then h' b else b)" by blast
110.168 + have "\<forall>b \<in> A'. h b = h' b" unfolding h_def by auto
110.169 + hence "bij_betw h A' (A' - {a})" using 8 bij_betw_cong[of A' h] by auto
110.170 + moreover
110.171 + {have "\<forall>b \<in> A - A'. h b = b" unfolding h_def by auto
110.172 + hence "bij_betw h (A - A') (A - A')"
110.173 + using bij_betw_cong[of "A - A'" h id] bij_betw_id[of "A - A'"] by auto
110.174 + }
110.175 + moreover
110.176 + have "(A' Int (A - A') = {} \<and> A' \<union> (A - A') = A) \<and>
110.177 + ((A' - {a}) Int (A - A') = {} \<and> (A' - {a}) \<union> (A - A') = A - {a})"
110.178 + using 4 by blast
110.179 + ultimately have "bij_betw h A (A - {a})"
110.180 + using bij_betw_combine[of h A' "A' - {a}" "A - A'" "A - A'"] by simp
110.181 + thus ?thesis by blast
110.182 +qed
110.183 +
110.184 +
110.185 +(*3*)lemma infinite_imp_bij_betw2:
110.186 +assumes INF: "\<not> finite A"
110.187 +shows "\<exists>h. bij_betw h A (A \<union> {a})"
110.188 +proof(cases "a \<in> A")
110.189 + assume Case1: "a \<in> A" hence "A \<union> {a} = A" by blast
110.190 + thus ?thesis using bij_betw_id[of A] by auto
110.191 +next
110.192 + let ?A' = "A \<union> {a}"
110.193 + assume Case2: "a \<notin> A" hence "A = ?A' - {a}" by blast
110.194 + moreover have "\<not> finite ?A'" using INF by auto
110.195 + ultimately obtain f where "bij_betw f ?A' A"
110.196 + using infinite_imp_bij_betw[of ?A' a] by auto
110.197 + hence "bij_betw(inv_into ?A' f) A ?A'" using bij_betw_inv_into by blast
110.198 + thus ?thesis by auto
110.199 +qed
110.200 +
110.201 +
110.202 +subsection {* Properties involving Hilbert choice *}
110.203 +
110.204 +
110.205 +(*2*)lemma bij_betw_inv_into_left:
110.206 +assumes BIJ: "bij_betw f A A'" and IN: "a \<in> A"
110.207 +shows "(inv_into A f) (f a) = a"
110.208 +using assms unfolding bij_betw_def
110.209 +by clarify (rule inv_into_f_f)
110.210 +
110.211 +(*2*)lemma bij_betw_inv_into_right:
110.212 +assumes "bij_betw f A A'" "a' \<in> A'"
110.213 +shows "f(inv_into A f a') = a'"
110.214 +using assms unfolding bij_betw_def using f_inv_into_f by force
110.215 +
110.216 +
110.217 +(*1*)lemma bij_betw_inv_into_subset:
110.218 +assumes BIJ: "bij_betw f A A'" and
110.219 + SUB: "B \<le> A" and IM: "f ` B = B'"
110.220 +shows "bij_betw (inv_into A f) B' B"
110.221 +using assms unfolding bij_betw_def
110.222 +by (auto intro: inj_on_inv_into)
110.223 +
110.224 +
110.225 +
110.226 +end
111.1 --- a/src/HOL/Cardinals/Order_Relation_More.thy Thu Dec 05 17:52:12 2013 +0100
111.2 +++ b/src/HOL/Cardinals/Order_Relation_More.thy Thu Dec 05 17:58:03 2013 +0100
111.3 @@ -8,64 +8,70 @@
111.4 header {* Basics on Order-Like Relations *}
111.5
111.6 theory Order_Relation_More
111.7 -imports Order_Relation_More_Base
111.8 +imports Order_Relation_More_FP Main
111.9 begin
111.10
111.11
111.12 subsection {* The upper and lower bounds operators *}
111.13
111.14 -lemma (in rel) aboveS_subset_above: "aboveS a \<le> above a"
111.15 +context rel
111.16 +begin
111.17 +
111.18 +lemma aboveS_subset_above: "aboveS a \<le> above a"
111.19 by(auto simp add: aboveS_def above_def)
111.20
111.21 -lemma (in rel) AboveS_subset_Above: "AboveS A \<le> Above A"
111.22 +lemma AboveS_subset_Above: "AboveS A \<le> Above A"
111.23 by(auto simp add: AboveS_def Above_def)
111.24
111.25 -lemma (in rel) UnderS_disjoint: "A Int (UnderS A) = {}"
111.26 +lemma UnderS_disjoint: "A Int (UnderS A) = {}"
111.27 by(auto simp add: UnderS_def)
111.28
111.29 -lemma (in rel) aboveS_notIn: "a \<notin> aboveS a"
111.30 +lemma aboveS_notIn: "a \<notin> aboveS a"
111.31 by(auto simp add: aboveS_def)
111.32
111.33 -lemma (in rel) Refl_above_in: "\<lbrakk>Refl r; a \<in> Field r\<rbrakk> \<Longrightarrow> a \<in> above a"
111.34 +lemma Refl_above_in: "\<lbrakk>Refl r; a \<in> Field r\<rbrakk> \<Longrightarrow> a \<in> above a"
111.35 by(auto simp add: refl_on_def above_def)
111.36
111.37 -lemma (in rel) in_Above_under: "a \<in> Field r \<Longrightarrow> a \<in> Above (under a)"
111.38 +lemma in_Above_under: "a \<in> Field r \<Longrightarrow> a \<in> Above (under a)"
111.39 by(auto simp add: Above_def under_def)
111.40
111.41 -lemma (in rel) in_Under_above: "a \<in> Field r \<Longrightarrow> a \<in> Under (above a)"
111.42 +lemma in_Under_above: "a \<in> Field r \<Longrightarrow> a \<in> Under (above a)"
111.43 by(auto simp add: Under_def above_def)
111.44
111.45 -lemma (in rel) in_UnderS_aboveS: "a \<in> Field r \<Longrightarrow> a \<in> UnderS (aboveS a)"
111.46 +lemma in_UnderS_aboveS: "a \<in> Field r \<Longrightarrow> a \<in> UnderS (aboveS a)"
111.47 by(auto simp add: UnderS_def aboveS_def)
111.48
111.49 -lemma (in rel) subset_Above_Under: "B \<le> Field r \<Longrightarrow> B \<le> Above (Under B)"
111.50 +lemma UnderS_subset_Under: "UnderS A \<le> Under A"
111.51 +by(auto simp add: UnderS_def Under_def)
111.52 +
111.53 +lemma subset_Above_Under: "B \<le> Field r \<Longrightarrow> B \<le> Above (Under B)"
111.54 by(auto simp add: Above_def Under_def)
111.55
111.56 -lemma (in rel) subset_Under_Above: "B \<le> Field r \<Longrightarrow> B \<le> Under (Above B)"
111.57 +lemma subset_Under_Above: "B \<le> Field r \<Longrightarrow> B \<le> Under (Above B)"
111.58 by(auto simp add: Under_def Above_def)
111.59
111.60 -lemma (in rel) subset_AboveS_UnderS: "B \<le> Field r \<Longrightarrow> B \<le> AboveS (UnderS B)"
111.61 +lemma subset_AboveS_UnderS: "B \<le> Field r \<Longrightarrow> B \<le> AboveS (UnderS B)"
111.62 by(auto simp add: AboveS_def UnderS_def)
111.63
111.64 -lemma (in rel) subset_UnderS_AboveS: "B \<le> Field r \<Longrightarrow> B \<le> UnderS (AboveS B)"
111.65 +lemma subset_UnderS_AboveS: "B \<le> Field r \<Longrightarrow> B \<le> UnderS (AboveS B)"
111.66 by(auto simp add: UnderS_def AboveS_def)
111.67
111.68 -lemma (in rel) Under_Above_Galois:
111.69 +lemma Under_Above_Galois:
111.70 "\<lbrakk>B \<le> Field r; C \<le> Field r\<rbrakk> \<Longrightarrow> (B \<le> Above C) = (C \<le> Under B)"
111.71 by(unfold Above_def Under_def, blast)
111.72
111.73 -lemma (in rel) UnderS_AboveS_Galois:
111.74 +lemma UnderS_AboveS_Galois:
111.75 "\<lbrakk>B \<le> Field r; C \<le> Field r\<rbrakk> \<Longrightarrow> (B \<le> AboveS C) = (C \<le> UnderS B)"
111.76 by(unfold AboveS_def UnderS_def, blast)
111.77
111.78 -lemma (in rel) Refl_above_aboveS:
111.79 +lemma Refl_above_aboveS:
111.80 assumes REFL: "Refl r" and IN: "a \<in> Field r"
111.81 shows "above a = aboveS a \<union> {a}"
111.82 proof(unfold above_def aboveS_def, auto)
111.83 show "(a,a) \<in> r" using REFL IN refl_on_def[of _ r] by blast
111.84 qed
111.85
111.86 -lemma (in rel) Linear_order_under_aboveS_Field:
111.87 +lemma Linear_order_under_aboveS_Field:
111.88 assumes LIN: "Linear_order r" and IN: "a \<in> Field r"
111.89 shows "Field r = under a \<union> aboveS a"
111.90 proof(unfold under_def aboveS_def, auto)
111.91 @@ -88,7 +94,7 @@
111.92 using LIN order_on_defs[of "Field r" r] refl_on_def[of "Field r" r] by blast
111.93 qed
111.94
111.95 -lemma (in rel) Linear_order_underS_above_Field:
111.96 +lemma Linear_order_underS_above_Field:
111.97 assumes LIN: "Linear_order r" and IN: "a \<in> Field r"
111.98 shows "Field r = underS a \<union> above a"
111.99 proof(unfold underS_def above_def, auto)
111.100 @@ -111,19 +117,25 @@
111.101 using LIN order_on_defs[of "Field r" r] refl_on_def[of "Field r" r] by blast
111.102 qed
111.103
111.104 -lemma (in rel) under_empty: "a \<notin> Field r \<Longrightarrow> under a = {}"
111.105 +lemma under_empty: "a \<notin> Field r \<Longrightarrow> under a = {}"
111.106 unfolding Field_def under_def by auto
111.107
111.108 -lemma (in rel) above_Field: "above a \<le> Field r"
111.109 +lemma Under_Field: "Under A \<le> Field r"
111.110 +by(unfold Under_def Field_def, auto)
111.111 +
111.112 +lemma UnderS_Field: "UnderS A \<le> Field r"
111.113 +by(unfold UnderS_def Field_def, auto)
111.114 +
111.115 +lemma above_Field: "above a \<le> Field r"
111.116 by(unfold above_def Field_def, auto)
111.117
111.118 -lemma (in rel) aboveS_Field: "aboveS a \<le> Field r"
111.119 +lemma aboveS_Field: "aboveS a \<le> Field r"
111.120 by(unfold aboveS_def Field_def, auto)
111.121
111.122 -lemma (in rel) Above_Field: "Above A \<le> Field r"
111.123 +lemma Above_Field: "Above A \<le> Field r"
111.124 by(unfold Above_def Field_def, auto)
111.125
111.126 -lemma (in rel) Refl_under_Under:
111.127 +lemma Refl_under_Under:
111.128 assumes REFL: "Refl r" and NE: "A \<noteq> {}"
111.129 shows "Under A = (\<Inter> a \<in> A. under a)"
111.130 proof
111.131 @@ -147,7 +159,7 @@
111.132 qed
111.133 qed
111.134
111.135 -lemma (in rel) Refl_underS_UnderS:
111.136 +lemma Refl_underS_UnderS:
111.137 assumes REFL: "Refl r" and NE: "A \<noteq> {}"
111.138 shows "UnderS A = (\<Inter> a \<in> A. underS a)"
111.139 proof
111.140 @@ -171,7 +183,7 @@
111.141 qed
111.142 qed
111.143
111.144 -lemma (in rel) Refl_above_Above:
111.145 +lemma Refl_above_Above:
111.146 assumes REFL: "Refl r" and NE: "A \<noteq> {}"
111.147 shows "Above A = (\<Inter> a \<in> A. above a)"
111.148 proof
111.149 @@ -195,7 +207,7 @@
111.150 qed
111.151 qed
111.152
111.153 -lemma (in rel) Refl_aboveS_AboveS:
111.154 +lemma Refl_aboveS_AboveS:
111.155 assumes REFL: "Refl r" and NE: "A \<noteq> {}"
111.156 shows "AboveS A = (\<Inter> a \<in> A. aboveS a)"
111.157 proof
111.158 @@ -219,31 +231,31 @@
111.159 qed
111.160 qed
111.161
111.162 -lemma (in rel) under_Under_singl: "under a = Under {a}"
111.163 +lemma under_Under_singl: "under a = Under {a}"
111.164 by(unfold Under_def under_def, auto simp add: Field_def)
111.165
111.166 -lemma (in rel) underS_UnderS_singl: "underS a = UnderS {a}"
111.167 +lemma underS_UnderS_singl: "underS a = UnderS {a}"
111.168 by(unfold UnderS_def underS_def, auto simp add: Field_def)
111.169
111.170 -lemma (in rel) above_Above_singl: "above a = Above {a}"
111.171 +lemma above_Above_singl: "above a = Above {a}"
111.172 by(unfold Above_def above_def, auto simp add: Field_def)
111.173
111.174 -lemma (in rel) aboveS_AboveS_singl: "aboveS a = AboveS {a}"
111.175 +lemma aboveS_AboveS_singl: "aboveS a = AboveS {a}"
111.176 by(unfold AboveS_def aboveS_def, auto simp add: Field_def)
111.177
111.178 -lemma (in rel) Under_decr: "A \<le> B \<Longrightarrow> Under B \<le> Under A"
111.179 +lemma Under_decr: "A \<le> B \<Longrightarrow> Under B \<le> Under A"
111.180 by(unfold Under_def, auto)
111.181
111.182 -lemma (in rel) UnderS_decr: "A \<le> B \<Longrightarrow> UnderS B \<le> UnderS A"
111.183 +lemma UnderS_decr: "A \<le> B \<Longrightarrow> UnderS B \<le> UnderS A"
111.184 by(unfold UnderS_def, auto)
111.185
111.186 -lemma (in rel) Above_decr: "A \<le> B \<Longrightarrow> Above B \<le> Above A"
111.187 +lemma Above_decr: "A \<le> B \<Longrightarrow> Above B \<le> Above A"
111.188 by(unfold Above_def, auto)
111.189
111.190 -lemma (in rel) AboveS_decr: "A \<le> B \<Longrightarrow> AboveS B \<le> AboveS A"
111.191 +lemma AboveS_decr: "A \<le> B \<Longrightarrow> AboveS B \<le> AboveS A"
111.192 by(unfold AboveS_def, auto)
111.193
111.194 -lemma (in rel) under_incl_iff:
111.195 +lemma under_incl_iff:
111.196 assumes TRANS: "trans r" and REFL: "Refl r" and IN: "a \<in> Field r"
111.197 shows "(under a \<le> under b) = ((a,b) \<in> r)"
111.198 proof
111.199 @@ -259,7 +271,7 @@
111.200 by (auto simp add: under_def)
111.201 qed
111.202
111.203 -lemma (in rel) above_decr:
111.204 +lemma above_decr:
111.205 assumes TRANS: "trans r" and REL: "(a,b) \<in> r"
111.206 shows "above b \<le> above a"
111.207 proof(unfold above_def, auto)
111.208 @@ -268,7 +280,7 @@
111.209 show "(a,x) \<in> r" by blast
111.210 qed
111.211
111.212 -lemma (in rel) aboveS_decr:
111.213 +lemma aboveS_decr:
111.214 assumes TRANS: "trans r" and ANTISYM: "antisym r" and
111.215 REL: "(a,b) \<in> r"
111.216 shows "aboveS b \<le> aboveS a"
111.217 @@ -282,7 +294,7 @@
111.218 show "(a,x) \<in> r" by blast
111.219 qed
111.220
111.221 -lemma (in rel) under_trans:
111.222 +lemma under_trans:
111.223 assumes TRANS: "trans r" and
111.224 IN1: "a \<in> under b" and IN2: "b \<in> under c"
111.225 shows "a \<in> under c"
111.226 @@ -294,7 +306,7 @@
111.227 thus ?thesis unfolding under_def by simp
111.228 qed
111.229
111.230 -lemma (in rel) under_underS_trans:
111.231 +lemma under_underS_trans:
111.232 assumes TRANS: "trans r" and ANTISYM: "antisym r" and
111.233 IN1: "a \<in> under b" and IN2: "b \<in> underS c"
111.234 shows "a \<in> underS c"
111.235 @@ -312,7 +324,7 @@
111.236 from 1 3 show ?thesis unfolding underS_def by simp
111.237 qed
111.238
111.239 -lemma (in rel) underS_under_trans:
111.240 +lemma underS_under_trans:
111.241 assumes TRANS: "trans r" and ANTISYM: "antisym r" and
111.242 IN1: "a \<in> underS b" and IN2: "b \<in> under c"
111.243 shows "a \<in> underS c"
111.244 @@ -330,7 +342,7 @@
111.245 from 1 3 show ?thesis unfolding underS_def by simp
111.246 qed
111.247
111.248 -lemma (in rel) underS_underS_trans:
111.249 +lemma underS_underS_trans:
111.250 assumes TRANS: "trans r" and ANTISYM: "antisym r" and
111.251 IN1: "a \<in> underS b" and IN2: "b \<in> underS c"
111.252 shows "a \<in> underS c"
111.253 @@ -340,7 +352,7 @@
111.254 with assms under_underS_trans show ?thesis by auto
111.255 qed
111.256
111.257 -lemma (in rel) above_trans:
111.258 +lemma above_trans:
111.259 assumes TRANS: "trans r" and
111.260 IN1: "b \<in> above a" and IN2: "c \<in> above b"
111.261 shows "c \<in> above a"
111.262 @@ -352,7 +364,7 @@
111.263 thus ?thesis unfolding above_def by simp
111.264 qed
111.265
111.266 -lemma (in rel) above_aboveS_trans:
111.267 +lemma above_aboveS_trans:
111.268 assumes TRANS: "trans r" and ANTISYM: "antisym r" and
111.269 IN1: "b \<in> above a" and IN2: "c \<in> aboveS b"
111.270 shows "c \<in> aboveS a"
111.271 @@ -370,7 +382,7 @@
111.272 from 1 3 show ?thesis unfolding aboveS_def by simp
111.273 qed
111.274
111.275 -lemma (in rel) aboveS_above_trans:
111.276 +lemma aboveS_above_trans:
111.277 assumes TRANS: "trans r" and ANTISYM: "antisym r" and
111.278 IN1: "b \<in> aboveS a" and IN2: "c \<in> above b"
111.279 shows "c \<in> aboveS a"
111.280 @@ -388,7 +400,7 @@
111.281 from 1 3 show ?thesis unfolding aboveS_def by simp
111.282 qed
111.283
111.284 -lemma (in rel) aboveS_aboveS_trans:
111.285 +lemma aboveS_aboveS_trans:
111.286 assumes TRANS: "trans r" and ANTISYM: "antisym r" and
111.287 IN1: "b \<in> aboveS a" and IN2: "c \<in> aboveS b"
111.288 shows "c \<in> aboveS a"
111.289 @@ -398,7 +410,22 @@
111.290 with assms above_aboveS_trans show ?thesis by auto
111.291 qed
111.292
111.293 -lemma (in rel) underS_Under_trans:
111.294 +lemma under_Under_trans:
111.295 +assumes TRANS: "trans r" and
111.296 + IN1: "a \<in> under b" and IN2: "b \<in> Under C"
111.297 +shows "a \<in> Under C"
111.298 +proof-
111.299 + have "(a,b) \<in> r \<and> (\<forall>c \<in> C. (b,c) \<in> r)"
111.300 + using IN1 IN2 under_def Under_def by blast
111.301 + hence "\<forall>c \<in> C. (a,c) \<in> r"
111.302 + using TRANS trans_def[of r] by blast
111.303 + moreover
111.304 + have "a \<in> Field r" using IN1 unfolding Field_def under_def by blast
111.305 + ultimately
111.306 + show ?thesis unfolding Under_def by blast
111.307 +qed
111.308 +
111.309 +lemma underS_Under_trans:
111.310 assumes TRANS: "trans r" and ANTISYM: "antisym r" and
111.311 IN1: "a \<in> underS b" and IN2: "b \<in> Under C"
111.312 shows "a \<in> UnderS C"
111.313 @@ -426,7 +453,7 @@
111.314 using Under_def by auto
111.315 qed
111.316
111.317 -lemma (in rel) underS_UnderS_trans:
111.318 +lemma underS_UnderS_trans:
111.319 assumes TRANS: "trans r" and ANTISYM: "antisym r" and
111.320 IN1: "a \<in> underS b" and IN2: "b \<in> UnderS C"
111.321 shows "a \<in> UnderS C"
111.322 @@ -437,7 +464,7 @@
111.323 show ?thesis by auto
111.324 qed
111.325
111.326 -lemma (in rel) above_Above_trans:
111.327 +lemma above_Above_trans:
111.328 assumes TRANS: "trans r" and
111.329 IN1: "a \<in> above b" and IN2: "b \<in> Above C"
111.330 shows "a \<in> Above C"
111.331 @@ -452,7 +479,7 @@
111.332 show ?thesis unfolding Above_def by auto
111.333 qed
111.334
111.335 -lemma (in rel) aboveS_Above_trans:
111.336 +lemma aboveS_Above_trans:
111.337 assumes TRANS: "trans r" and ANTISYM: "antisym r" and
111.338 IN1: "a \<in> aboveS b" and IN2: "b \<in> Above C"
111.339 shows "a \<in> AboveS C"
111.340 @@ -480,7 +507,7 @@
111.341 using Above_def by auto
111.342 qed
111.343
111.344 -lemma (in rel) above_AboveS_trans:
111.345 +lemma above_AboveS_trans:
111.346 assumes TRANS: "trans r" and ANTISYM: "antisym r" and
111.347 IN1: "a \<in> above b" and IN2: "b \<in> AboveS C"
111.348 shows "a \<in> AboveS C"
111.349 @@ -508,7 +535,7 @@
111.350 using Above_def by auto
111.351 qed
111.352
111.353 -lemma (in rel) aboveS_AboveS_trans:
111.354 +lemma aboveS_AboveS_trans:
111.355 assumes TRANS: "trans r" and ANTISYM: "antisym r" and
111.356 IN1: "a \<in> aboveS b" and IN2: "b \<in> AboveS C"
111.357 shows "a \<in> AboveS C"
111.358 @@ -519,6 +546,35 @@
111.359 show ?thesis by auto
111.360 qed
111.361
111.362 +lemma under_UnderS_trans:
111.363 +assumes TRANS: "trans r" and ANTISYM: "antisym r" and
111.364 + IN1: "a \<in> under b" and IN2: "b \<in> UnderS C"
111.365 +shows "a \<in> UnderS C"
111.366 +proof-
111.367 + from IN2 have "b \<in> Under C"
111.368 + using UnderS_subset_Under[of C] by blast
111.369 + with assms under_Under_trans
111.370 + have "a \<in> Under C" by blast
111.371 + (* *)
111.372 + moreover
111.373 + have "a \<notin> C"
111.374 + proof
111.375 + assume *: "a \<in> C"
111.376 + have 1: "(a,b) \<in> r"
111.377 + using IN1 under_def[of b] by auto
111.378 + have "\<forall>c \<in> C. b \<noteq> c \<and> (b,c) \<in> r"
111.379 + using IN2 UnderS_def[of C] by blast
111.380 + with * have "b \<noteq> a \<and> (b,a) \<in> r" by blast
111.381 + with 1 ANTISYM antisym_def[of r]
111.382 + show False by blast
111.383 + qed
111.384 + (* *)
111.385 + ultimately
111.386 + show ?thesis unfolding UnderS_def Under_def by fast
111.387 +qed
111.388 +
111.389 +end (* context rel *)
111.390 +
111.391
111.392 subsection {* Properties depending on more than one relation *}
111.393
112.1 --- a/src/HOL/Cardinals/Order_Relation_More_Base.thy Thu Dec 05 17:52:12 2013 +0100
112.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
112.3 @@ -1,286 +0,0 @@
112.4 -(* Title: HOL/Cardinals/Order_Relation_More_Base.thy
112.5 - Author: Andrei Popescu, TU Muenchen
112.6 - Copyright 2012
112.7 -
112.8 -Basics on order-like relations (base).
112.9 -*)
112.10 -
112.11 -header {* Basics on Order-Like Relations (Base) *}
112.12 -
112.13 -theory Order_Relation_More_Base
112.14 -imports "~~/src/HOL/Library/Order_Relation"
112.15 -begin
112.16 -
112.17 -
112.18 -text{* In this section, we develop basic concepts and results pertaining
112.19 -to order-like relations, i.e., to reflexive and/or transitive and/or symmetric and/or
112.20 -total relations. The development is placed on top of the definitions
112.21 -from the theory @{text "Order_Relation"}. We also
112.22 -further define upper and lower bounds operators. *}
112.23 -
112.24 -
112.25 -locale rel = fixes r :: "'a rel"
112.26 -
112.27 -text{* The following context encompasses all this section, except
112.28 -for its last subsection. In other words, for the rest of this section except its last
112.29 -subsection, we consider a fixed relation @{text "r"}. *}
112.30 -
112.31 -context rel
112.32 -begin
112.33 -
112.34 -
112.35 -subsection {* Auxiliaries *}
112.36 -
112.37 -
112.38 -lemma refl_on_domain:
112.39 -"\<lbrakk>refl_on A r; (a,b) : r\<rbrakk> \<Longrightarrow> a \<in> A \<and> b \<in> A"
112.40 -by(auto simp add: refl_on_def)
112.41 -
112.42 -
112.43 -corollary well_order_on_domain:
112.44 -"\<lbrakk>well_order_on A r; (a,b) \<in> r\<rbrakk> \<Longrightarrow> a \<in> A \<and> b \<in> A"
112.45 -by(simp add: refl_on_domain order_on_defs)
112.46 -
112.47 -
112.48 -lemma well_order_on_Field:
112.49 -"well_order_on A r \<Longrightarrow> A = Field r"
112.50 -by(auto simp add: refl_on_def Field_def order_on_defs)
112.51 -
112.52 -
112.53 -lemma well_order_on_Well_order:
112.54 -"well_order_on A r \<Longrightarrow> A = Field r \<and> Well_order r"
112.55 -using well_order_on_Field by simp
112.56 -
112.57 -
112.58 -lemma Total_subset_Id:
112.59 -assumes TOT: "Total r" and SUB: "r \<le> Id"
112.60 -shows "r = {} \<or> (\<exists>a. r = {(a,a)})"
112.61 -proof-
112.62 - {assume "r \<noteq> {}"
112.63 - then obtain a b where 1: "(a,b) \<in> r" by fast
112.64 - hence "a = b" using SUB by blast
112.65 - hence 2: "(a,a) \<in> r" using 1 by simp
112.66 - {fix c d assume "(c,d) \<in> r"
112.67 - hence "{a,c,d} \<le> Field r" using 1 unfolding Field_def by blast
112.68 - hence "((a,c) \<in> r \<or> (c,a) \<in> r \<or> a = c) \<and>
112.69 - ((a,d) \<in> r \<or> (d,a) \<in> r \<or> a = d)"
112.70 - using TOT unfolding total_on_def by blast
112.71 - hence "a = c \<and> a = d" using SUB by blast
112.72 - }
112.73 - hence "r \<le> {(a,a)}" by auto
112.74 - with 2 have "\<exists>a. r = {(a,a)}" by blast
112.75 - }
112.76 - thus ?thesis by blast
112.77 -qed
112.78 -
112.79 -
112.80 -lemma Linear_order_in_diff_Id:
112.81 -assumes LI: "Linear_order r" and
112.82 - IN1: "a \<in> Field r" and IN2: "b \<in> Field r"
112.83 -shows "((a,b) \<in> r) = ((b,a) \<notin> r - Id)"
112.84 -using assms unfolding order_on_defs total_on_def antisym_def Id_def refl_on_def by force
112.85 -
112.86 -
112.87 -subsection {* The upper and lower bounds operators *}
112.88 -
112.89 -
112.90 -text{* Here we define upper (``above") and lower (``below") bounds operators.
112.91 -We think of @{text "r"} as a {\em non-strict} relation. The suffix ``S"
112.92 -at the names of some operators indicates that the bounds are strict -- e.g.,
112.93 -@{text "underS a"} is the set of all strict lower bounds of @{text "a"} (w.r.t. @{text "r"}).
112.94 -Capitalization of the first letter in the name reminds that the operator acts on sets, rather
112.95 -than on individual elements. *}
112.96 -
112.97 -definition under::"'a \<Rightarrow> 'a set"
112.98 -where "under a \<equiv> {b. (b,a) \<in> r}"
112.99 -
112.100 -definition underS::"'a \<Rightarrow> 'a set"
112.101 -where "underS a \<equiv> {b. b \<noteq> a \<and> (b,a) \<in> r}"
112.102 -
112.103 -definition Under::"'a set \<Rightarrow> 'a set"
112.104 -where "Under A \<equiv> {b \<in> Field r. \<forall>a \<in> A. (b,a) \<in> r}"
112.105 -
112.106 -definition UnderS::"'a set \<Rightarrow> 'a set"
112.107 -where "UnderS A \<equiv> {b \<in> Field r. \<forall>a \<in> A. b \<noteq> a \<and> (b,a) \<in> r}"
112.108 -
112.109 -definition above::"'a \<Rightarrow> 'a set"
112.110 -where "above a \<equiv> {b. (a,b) \<in> r}"
112.111 -
112.112 -definition aboveS::"'a \<Rightarrow> 'a set"
112.113 -where "aboveS a \<equiv> {b. b \<noteq> a \<and> (a,b) \<in> r}"
112.114 -
112.115 -definition Above::"'a set \<Rightarrow> 'a set"
112.116 -where "Above A \<equiv> {b \<in> Field r. \<forall>a \<in> A. (a,b) \<in> r}"
112.117 -
112.118 -definition AboveS::"'a set \<Rightarrow> 'a set"
112.119 -where "AboveS A \<equiv> {b \<in> Field r. \<forall>a \<in> A. b \<noteq> a \<and> (a,b) \<in> r}"
112.120 -(* *)
112.121 -
112.122 -text{* Note: In the definitions of @{text "Above[S]"} and @{text "Under[S]"},
112.123 - we bounded comprehension by @{text "Field r"} in order to properly cover
112.124 - the case of @{text "A"} being empty. *}
112.125 -
112.126 -
112.127 -lemma UnderS_subset_Under: "UnderS A \<le> Under A"
112.128 -by(auto simp add: UnderS_def Under_def)
112.129 -
112.130 -
112.131 -lemma underS_subset_under: "underS a \<le> under a"
112.132 -by(auto simp add: underS_def under_def)
112.133 -
112.134 -
112.135 -lemma underS_notIn: "a \<notin> underS a"
112.136 -by(simp add: underS_def)
112.137 -
112.138 -
112.139 -lemma Refl_under_in: "\<lbrakk>Refl r; a \<in> Field r\<rbrakk> \<Longrightarrow> a \<in> under a"
112.140 -by(simp add: refl_on_def under_def)
112.141 -
112.142 -
112.143 -lemma AboveS_disjoint: "A Int (AboveS A) = {}"
112.144 -by(auto simp add: AboveS_def)
112.145 -
112.146 -
112.147 -lemma in_AboveS_underS: "a \<in> Field r \<Longrightarrow> a \<in> AboveS (underS a)"
112.148 -by(auto simp add: AboveS_def underS_def)
112.149 -
112.150 -
112.151 -lemma Refl_under_underS:
112.152 -assumes "Refl r" "a \<in> Field r"
112.153 -shows "under a = underS a \<union> {a}"
112.154 -unfolding under_def underS_def
112.155 -using assms refl_on_def[of _ r] by fastforce
112.156 -
112.157 -
112.158 -lemma underS_empty: "a \<notin> Field r \<Longrightarrow> underS a = {}"
112.159 -by (auto simp: Field_def underS_def)
112.160 -
112.161 -
112.162 -lemma under_Field: "under a \<le> Field r"
112.163 -by(unfold under_def Field_def, auto)
112.164 -
112.165 -
112.166 -lemma underS_Field: "underS a \<le> Field r"
112.167 -by(unfold underS_def Field_def, auto)
112.168 -
112.169 -
112.170 -lemma underS_Field2:
112.171 -"a \<in> Field r \<Longrightarrow> underS a < Field r"
112.172 -using assms underS_notIn underS_Field by blast
112.173 -
112.174 -
112.175 -lemma underS_Field3:
112.176 -"Field r \<noteq> {} \<Longrightarrow> underS a < Field r"
112.177 -by(cases "a \<in> Field r", simp add: underS_Field2, auto simp add: underS_empty)
112.178 -
112.179 -
112.180 -lemma Under_Field: "Under A \<le> Field r"
112.181 -by(unfold Under_def Field_def, auto)
112.182 -
112.183 -
112.184 -lemma UnderS_Field: "UnderS A \<le> Field r"
112.185 -by(unfold UnderS_def Field_def, auto)
112.186 -
112.187 -
112.188 -lemma AboveS_Field: "AboveS A \<le> Field r"
112.189 -by(unfold AboveS_def Field_def, auto)
112.190 -
112.191 -
112.192 -lemma under_incr:
112.193 -assumes TRANS: "trans r" and REL: "(a,b) \<in> r"
112.194 -shows "under a \<le> under b"
112.195 -proof(unfold under_def, auto)
112.196 - fix x assume "(x,a) \<in> r"
112.197 - with REL TRANS trans_def[of r]
112.198 - show "(x,b) \<in> r" by blast
112.199 -qed
112.200 -
112.201 -
112.202 -lemma underS_incr:
112.203 -assumes TRANS: "trans r" and ANTISYM: "antisym r" and
112.204 - REL: "(a,b) \<in> r"
112.205 -shows "underS a \<le> underS b"
112.206 -proof(unfold underS_def, auto)
112.207 - assume *: "b \<noteq> a" and **: "(b,a) \<in> r"
112.208 - with ANTISYM antisym_def[of r] REL
112.209 - show False by blast
112.210 -next
112.211 - fix x assume "x \<noteq> a" "(x,a) \<in> r"
112.212 - with REL TRANS trans_def[of r]
112.213 - show "(x,b) \<in> r" by blast
112.214 -qed
112.215 -
112.216 -
112.217 -lemma underS_incl_iff:
112.218 -assumes LO: "Linear_order r" and
112.219 - INa: "a \<in> Field r" and INb: "b \<in> Field r"
112.220 -shows "(underS a \<le> underS b) = ((a,b) \<in> r)"
112.221 -proof
112.222 - assume "(a,b) \<in> r"
112.223 - thus "underS a \<le> underS b" using LO
112.224 - by (simp add: order_on_defs underS_incr)
112.225 -next
112.226 - assume *: "underS a \<le> underS b"
112.227 - {assume "a = b"
112.228 - hence "(a,b) \<in> r" using assms
112.229 - by (simp add: order_on_defs refl_on_def)
112.230 - }
112.231 - moreover
112.232 - {assume "a \<noteq> b \<and> (b,a) \<in> r"
112.233 - hence "b \<in> underS a" unfolding underS_def by blast
112.234 - hence "b \<in> underS b" using * by blast
112.235 - hence False by (simp add: underS_notIn)
112.236 - }
112.237 - ultimately
112.238 - show "(a,b) \<in> r" using assms
112.239 - order_on_defs[of "Field r" r] total_on_def[of "Field r" r] by blast
112.240 -qed
112.241 -
112.242 -
112.243 -lemma under_Under_trans:
112.244 -assumes TRANS: "trans r" and
112.245 - IN1: "a \<in> under b" and IN2: "b \<in> Under C"
112.246 -shows "a \<in> Under C"
112.247 -proof-
112.248 - have "(a,b) \<in> r \<and> (\<forall>c \<in> C. (b,c) \<in> r)"
112.249 - using IN1 IN2 under_def Under_def by blast
112.250 - hence "\<forall>c \<in> C. (a,c) \<in> r"
112.251 - using TRANS trans_def[of r] by blast
112.252 - moreover
112.253 - have "a \<in> Field r" using IN1 unfolding Field_def under_def by blast
112.254 - ultimately
112.255 - show ?thesis unfolding Under_def by blast
112.256 -qed
112.257 -
112.258 -
112.259 -lemma under_UnderS_trans:
112.260 -assumes TRANS: "trans r" and ANTISYM: "antisym r" and
112.261 - IN1: "a \<in> under b" and IN2: "b \<in> UnderS C"
112.262 -shows "a \<in> UnderS C"
112.263 -proof-
112.264 - from IN2 have "b \<in> Under C"
112.265 - using UnderS_subset_Under[of C] by blast
112.266 - with assms under_Under_trans
112.267 - have "a \<in> Under C" by blast
112.268 - (* *)
112.269 - moreover
112.270 - have "a \<notin> C"
112.271 - proof
112.272 - assume *: "a \<in> C"
112.273 - have 1: "(a,b) \<in> r"
112.274 - using IN1 under_def[of b] by auto
112.275 - have "\<forall>c \<in> C. b \<noteq> c \<and> (b,c) \<in> r"
112.276 - using IN2 UnderS_def[of C] by blast
112.277 - with * have "b \<noteq> a \<and> (b,a) \<in> r" by blast
112.278 - with 1 ANTISYM antisym_def[of r]
112.279 - show False by blast
112.280 - qed
112.281 - (* *)
112.282 - ultimately
112.283 - show ?thesis unfolding UnderS_def Under_def by fast
112.284 -qed
112.285 -
112.286 -
112.287 -end (* context rel *)
112.288 -
112.289 -end
113.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
113.2 +++ b/src/HOL/Cardinals/Order_Relation_More_FP.thy Thu Dec 05 17:58:03 2013 +0100
113.3 @@ -0,0 +1,230 @@
113.4 +(* Title: HOL/Cardinals/Order_Relation_More_FP.thy
113.5 + Author: Andrei Popescu, TU Muenchen
113.6 + Copyright 2012
113.7 +
113.8 +Basics on order-like relations (FP).
113.9 +*)
113.10 +
113.11 +header {* Basics on Order-Like Relations (FP) *}
113.12 +
113.13 +theory Order_Relation_More_FP
113.14 +imports Order_Relation
113.15 +begin
113.16 +
113.17 +
113.18 +text{* In this section, we develop basic concepts and results pertaining
113.19 +to order-like relations, i.e., to reflexive and/or transitive and/or symmetric and/or
113.20 +total relations. The development is placed on top of the definitions
113.21 +from the theory @{text "Order_Relation"}. We also
113.22 +further define upper and lower bounds operators. *}
113.23 +
113.24 +
113.25 +locale rel = fixes r :: "'a rel"
113.26 +
113.27 +text{* The following context encompasses all this section, except
113.28 +for its last subsection. In other words, for the rest of this section except its last
113.29 +subsection, we consider a fixed relation @{text "r"}. *}
113.30 +
113.31 +context rel
113.32 +begin
113.33 +
113.34 +
113.35 +subsection {* Auxiliaries *}
113.36 +
113.37 +
113.38 +lemma refl_on_domain:
113.39 +"\<lbrakk>refl_on A r; (a,b) : r\<rbrakk> \<Longrightarrow> a \<in> A \<and> b \<in> A"
113.40 +by(auto simp add: refl_on_def)
113.41 +
113.42 +
113.43 +corollary well_order_on_domain:
113.44 +"\<lbrakk>well_order_on A r; (a,b) \<in> r\<rbrakk> \<Longrightarrow> a \<in> A \<and> b \<in> A"
113.45 +by(simp add: refl_on_domain order_on_defs)
113.46 +
113.47 +
113.48 +lemma well_order_on_Field:
113.49 +"well_order_on A r \<Longrightarrow> A = Field r"
113.50 +by(auto simp add: refl_on_def Field_def order_on_defs)
113.51 +
113.52 +
113.53 +lemma well_order_on_Well_order:
113.54 +"well_order_on A r \<Longrightarrow> A = Field r \<and> Well_order r"
113.55 +using well_order_on_Field by simp
113.56 +
113.57 +
113.58 +lemma Total_subset_Id:
113.59 +assumes TOT: "Total r" and SUB: "r \<le> Id"
113.60 +shows "r = {} \<or> (\<exists>a. r = {(a,a)})"
113.61 +proof-
113.62 + {assume "r \<noteq> {}"
113.63 + then obtain a b where 1: "(a,b) \<in> r" by fast
113.64 + hence "a = b" using SUB by blast
113.65 + hence 2: "(a,a) \<in> r" using 1 by simp
113.66 + {fix c d assume "(c,d) \<in> r"
113.67 + hence "{a,c,d} \<le> Field r" using 1 unfolding Field_def by blast
113.68 + hence "((a,c) \<in> r \<or> (c,a) \<in> r \<or> a = c) \<and>
113.69 + ((a,d) \<in> r \<or> (d,a) \<in> r \<or> a = d)"
113.70 + using TOT unfolding total_on_def by blast
113.71 + hence "a = c \<and> a = d" using SUB by blast
113.72 + }
113.73 + hence "r \<le> {(a,a)}" by auto
113.74 + with 2 have "\<exists>a. r = {(a,a)}" by blast
113.75 + }
113.76 + thus ?thesis by blast
113.77 +qed
113.78 +
113.79 +
113.80 +lemma Linear_order_in_diff_Id:
113.81 +assumes LI: "Linear_order r" and
113.82 + IN1: "a \<in> Field r" and IN2: "b \<in> Field r"
113.83 +shows "((a,b) \<in> r) = ((b,a) \<notin> r - Id)"
113.84 +using assms unfolding order_on_defs total_on_def antisym_def Id_def refl_on_def by force
113.85 +
113.86 +
113.87 +subsection {* The upper and lower bounds operators *}
113.88 +
113.89 +
113.90 +text{* Here we define upper (``above") and lower (``below") bounds operators.
113.91 +We think of @{text "r"} as a {\em non-strict} relation. The suffix ``S"
113.92 +at the names of some operators indicates that the bounds are strict -- e.g.,
113.93 +@{text "underS a"} is the set of all strict lower bounds of @{text "a"} (w.r.t. @{text "r"}).
113.94 +Capitalization of the first letter in the name reminds that the operator acts on sets, rather
113.95 +than on individual elements. *}
113.96 +
113.97 +definition under::"'a \<Rightarrow> 'a set"
113.98 +where "under a \<equiv> {b. (b,a) \<in> r}"
113.99 +
113.100 +definition underS::"'a \<Rightarrow> 'a set"
113.101 +where "underS a \<equiv> {b. b \<noteq> a \<and> (b,a) \<in> r}"
113.102 +
113.103 +definition Under::"'a set \<Rightarrow> 'a set"
113.104 +where "Under A \<equiv> {b \<in> Field r. \<forall>a \<in> A. (b,a) \<in> r}"
113.105 +
113.106 +definition UnderS::"'a set \<Rightarrow> 'a set"
113.107 +where "UnderS A \<equiv> {b \<in> Field r. \<forall>a \<in> A. b \<noteq> a \<and> (b,a) \<in> r}"
113.108 +
113.109 +definition above::"'a \<Rightarrow> 'a set"
113.110 +where "above a \<equiv> {b. (a,b) \<in> r}"
113.111 +
113.112 +definition aboveS::"'a \<Rightarrow> 'a set"
113.113 +where "aboveS a \<equiv> {b. b \<noteq> a \<and> (a,b) \<in> r}"
113.114 +
113.115 +definition Above::"'a set \<Rightarrow> 'a set"
113.116 +where "Above A \<equiv> {b \<in> Field r. \<forall>a \<in> A. (a,b) \<in> r}"
113.117 +
113.118 +definition AboveS::"'a set \<Rightarrow> 'a set"
113.119 +where "AboveS A \<equiv> {b \<in> Field r. \<forall>a \<in> A. b \<noteq> a \<and> (a,b) \<in> r}"
113.120 +(* *)
113.121 +
113.122 +text{* Note: In the definitions of @{text "Above[S]"} and @{text "Under[S]"},
113.123 + we bounded comprehension by @{text "Field r"} in order to properly cover
113.124 + the case of @{text "A"} being empty. *}
113.125 +
113.126 +
113.127 +lemma underS_subset_under: "underS a \<le> under a"
113.128 +by(auto simp add: underS_def under_def)
113.129 +
113.130 +
113.131 +lemma underS_notIn: "a \<notin> underS a"
113.132 +by(simp add: underS_def)
113.133 +
113.134 +
113.135 +lemma Refl_under_in: "\<lbrakk>Refl r; a \<in> Field r\<rbrakk> \<Longrightarrow> a \<in> under a"
113.136 +by(simp add: refl_on_def under_def)
113.137 +
113.138 +
113.139 +lemma AboveS_disjoint: "A Int (AboveS A) = {}"
113.140 +by(auto simp add: AboveS_def)
113.141 +
113.142 +
113.143 +lemma in_AboveS_underS: "a \<in> Field r \<Longrightarrow> a \<in> AboveS (underS a)"
113.144 +by(auto simp add: AboveS_def underS_def)
113.145 +
113.146 +
113.147 +lemma Refl_under_underS:
113.148 +assumes "Refl r" "a \<in> Field r"
113.149 +shows "under a = underS a \<union> {a}"
113.150 +unfolding under_def underS_def
113.151 +using assms refl_on_def[of _ r] by fastforce
113.152 +
113.153 +
113.154 +lemma underS_empty: "a \<notin> Field r \<Longrightarrow> underS a = {}"
113.155 +by (auto simp: Field_def underS_def)
113.156 +
113.157 +
113.158 +lemma under_Field: "under a \<le> Field r"
113.159 +by(unfold under_def Field_def, auto)
113.160 +
113.161 +
113.162 +lemma underS_Field: "underS a \<le> Field r"
113.163 +by(unfold underS_def Field_def, auto)
113.164 +
113.165 +
113.166 +lemma underS_Field2:
113.167 +"a \<in> Field r \<Longrightarrow> underS a < Field r"
113.168 +using assms underS_notIn underS_Field by blast
113.169 +
113.170 +
113.171 +lemma underS_Field3:
113.172 +"Field r \<noteq> {} \<Longrightarrow> underS a < Field r"
113.173 +by(cases "a \<in> Field r", simp add: underS_Field2, auto simp add: underS_empty)
113.174 +
113.175 +
113.176 +lemma AboveS_Field: "AboveS A \<le> Field r"
113.177 +by(unfold AboveS_def Field_def, auto)
113.178 +
113.179 +
113.180 +lemma under_incr:
113.181 +assumes TRANS: "trans r" and REL: "(a,b) \<in> r"
113.182 +shows "under a \<le> under b"
113.183 +proof(unfold under_def, auto)
113.184 + fix x assume "(x,a) \<in> r"
113.185 + with REL TRANS trans_def[of r]
113.186 + show "(x,b) \<in> r" by blast
113.187 +qed
113.188 +
113.189 +
113.190 +lemma underS_incr:
113.191 +assumes TRANS: "trans r" and ANTISYM: "antisym r" and
113.192 + REL: "(a,b) \<in> r"
113.193 +shows "underS a \<le> underS b"
113.194 +proof(unfold underS_def, auto)
113.195 + assume *: "b \<noteq> a" and **: "(b,a) \<in> r"
113.196 + with ANTISYM antisym_def[of r] REL
113.197 + show False by blast
113.198 +next
113.199 + fix x assume "x \<noteq> a" "(x,a) \<in> r"
113.200 + with REL TRANS trans_def[of r]
113.201 + show "(x,b) \<in> r" by blast
113.202 +qed
113.203 +
113.204 +
113.205 +lemma underS_incl_iff:
113.206 +assumes LO: "Linear_order r" and
113.207 + INa: "a \<in> Field r" and INb: "b \<in> Field r"
113.208 +shows "(underS a \<le> underS b) = ((a,b) \<in> r)"
113.209 +proof
113.210 + assume "(a,b) \<in> r"
113.211 + thus "underS a \<le> underS b" using LO
113.212 + by (simp add: order_on_defs underS_incr)
113.213 +next
113.214 + assume *: "underS a \<le> underS b"
113.215 + {assume "a = b"
113.216 + hence "(a,b) \<in> r" using assms
113.217 + by (simp add: order_on_defs refl_on_def)
113.218 + }
113.219 + moreover
113.220 + {assume "a \<noteq> b \<and> (b,a) \<in> r"
113.221 + hence "b \<in> underS a" unfolding underS_def by blast
113.222 + hence "b \<in> underS b" using * by blast
113.223 + hence False by (simp add: underS_notIn)
113.224 + }
113.225 + ultimately
113.226 + show "(a,b) \<in> r" using assms
113.227 + order_on_defs[of "Field r" r] total_on_def[of "Field r" r] by blast
113.228 +qed
113.229 +
113.230 +
113.231 +end (* context rel *)
113.232 +
113.233 +end
114.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
114.2 +++ b/src/HOL/Cardinals/Order_Union.thy Thu Dec 05 17:58:03 2013 +0100
114.3 @@ -0,0 +1,370 @@
114.4 +(* Title: HOL/Cardinals/Order_Union.thy
114.5 + Author: Andrei Popescu, TU Muenchen
114.6 +
114.7 +The ordinal-like sum of two orders with disjoint fields
114.8 +*)
114.9 +
114.10 +header {* Order Union *}
114.11 +
114.12 +theory Order_Union
114.13 +imports Wellfounded_More_FP
114.14 +begin
114.15 +
114.16 +definition Osum :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" (infix "Osum" 60) where
114.17 + "r Osum r' = r \<union> r' \<union> {(a, a'). a \<in> Field r \<and> a' \<in> Field r'}"
114.18 +
114.19 +notation Osum (infix "\<union>o" 60)
114.20 +
114.21 +lemma Field_Osum: "Field (r \<union>o r') = Field r \<union> Field r'"
114.22 + unfolding Osum_def Field_def by blast
114.23 +
114.24 +lemma Osum_wf:
114.25 +assumes FLD: "Field r Int Field r' = {}" and
114.26 + WF: "wf r" and WF': "wf r'"
114.27 +shows "wf (r Osum r')"
114.28 +unfolding wf_eq_minimal2 unfolding Field_Osum
114.29 +proof(intro allI impI, elim conjE)
114.30 + fix A assume *: "A \<subseteq> Field r \<union> Field r'" and **: "A \<noteq> {}"
114.31 + obtain B where B_def: "B = A Int Field r" by blast
114.32 + show "\<exists>a\<in>A. \<forall>a'\<in>A. (a', a) \<notin> r \<union>o r'"
114.33 + proof(cases "B = {}")
114.34 + assume Case1: "B \<noteq> {}"
114.35 + hence "B \<noteq> {} \<and> B \<le> Field r" using B_def by auto
114.36 + then obtain a where 1: "a \<in> B" and 2: "\<forall>a1 \<in> B. (a1,a) \<notin> r"
114.37 + using WF unfolding wf_eq_minimal2 by metis
114.38 + hence 3: "a \<in> Field r \<and> a \<notin> Field r'" using B_def FLD by auto
114.39 + (* *)
114.40 + have "\<forall>a1 \<in> A. (a1,a) \<notin> r Osum r'"
114.41 + proof(intro ballI)
114.42 + fix a1 assume **: "a1 \<in> A"
114.43 + {assume Case11: "a1 \<in> Field r"
114.44 + hence "(a1,a) \<notin> r" using B_def ** 2 by auto
114.45 + moreover
114.46 + have "(a1,a) \<notin> r'" using 3 by (auto simp add: Field_def)
114.47 + ultimately have "(a1,a) \<notin> r Osum r'"
114.48 + using 3 unfolding Osum_def by auto
114.49 + }
114.50 + moreover
114.51 + {assume Case12: "a1 \<notin> Field r"
114.52 + hence "(a1,a) \<notin> r" unfolding Field_def by auto
114.53 + moreover
114.54 + have "(a1,a) \<notin> r'" using 3 unfolding Field_def by auto
114.55 + ultimately have "(a1,a) \<notin> r Osum r'"
114.56 + using 3 unfolding Osum_def by auto
114.57 + }
114.58 + ultimately show "(a1,a) \<notin> r Osum r'" by blast
114.59 + qed
114.60 + thus ?thesis using 1 B_def by auto
114.61 + next
114.62 + assume Case2: "B = {}"
114.63 + hence 1: "A \<noteq> {} \<and> A \<le> Field r'" using * ** B_def by auto
114.64 + then obtain a' where 2: "a' \<in> A" and 3: "\<forall>a1' \<in> A. (a1',a') \<notin> r'"
114.65 + using WF' unfolding wf_eq_minimal2 by metis
114.66 + hence 4: "a' \<in> Field r' \<and> a' \<notin> Field r" using 1 FLD by blast
114.67 + (* *)
114.68 + have "\<forall>a1' \<in> A. (a1',a') \<notin> r Osum r'"
114.69 + proof(unfold Osum_def, auto simp add: 3)
114.70 + fix a1' assume "(a1', a') \<in> r"
114.71 + thus False using 4 unfolding Field_def by blast
114.72 + next
114.73 + fix a1' assume "a1' \<in> A" and "a1' \<in> Field r"
114.74 + thus False using Case2 B_def by auto
114.75 + qed
114.76 + thus ?thesis using 2 by blast
114.77 + qed
114.78 +qed
114.79 +
114.80 +lemma Osum_Refl:
114.81 +assumes FLD: "Field r Int Field r' = {}" and
114.82 + REFL: "Refl r" and REFL': "Refl r'"
114.83 +shows "Refl (r Osum r')"
114.84 +using assms
114.85 +unfolding refl_on_def Field_Osum unfolding Osum_def by blast
114.86 +
114.87 +lemma Osum_trans:
114.88 +assumes FLD: "Field r Int Field r' = {}" and
114.89 + TRANS: "trans r" and TRANS': "trans r'"
114.90 +shows "trans (r Osum r')"
114.91 +proof(unfold trans_def, auto)
114.92 + fix x y z assume *: "(x, y) \<in> r \<union>o r'" and **: "(y, z) \<in> r \<union>o r'"
114.93 + show "(x, z) \<in> r \<union>o r'"
114.94 + proof-
114.95 + {assume Case1: "(x,y) \<in> r"
114.96 + hence 1: "x \<in> Field r \<and> y \<in> Field r" unfolding Field_def by auto
114.97 + have ?thesis
114.98 + proof-
114.99 + {assume Case11: "(y,z) \<in> r"
114.100 + hence "(x,z) \<in> r" using Case1 TRANS trans_def[of r] by blast
114.101 + hence ?thesis unfolding Osum_def by auto
114.102 + }
114.103 + moreover
114.104 + {assume Case12: "(y,z) \<in> r'"
114.105 + hence "y \<in> Field r'" unfolding Field_def by auto
114.106 + hence False using FLD 1 by auto
114.107 + }
114.108 + moreover
114.109 + {assume Case13: "z \<in> Field r'"
114.110 + hence ?thesis using 1 unfolding Osum_def by auto
114.111 + }
114.112 + ultimately show ?thesis using ** unfolding Osum_def by blast
114.113 + qed
114.114 + }
114.115 + moreover
114.116 + {assume Case2: "(x,y) \<in> r'"
114.117 + hence 2: "x \<in> Field r' \<and> y \<in> Field r'" unfolding Field_def by auto
114.118 + have ?thesis
114.119 + proof-
114.120 + {assume Case21: "(y,z) \<in> r"
114.121 + hence "y \<in> Field r" unfolding Field_def by auto
114.122 + hence False using FLD 2 by auto
114.123 + }
114.124 + moreover
114.125 + {assume Case22: "(y,z) \<in> r'"
114.126 + hence "(x,z) \<in> r'" using Case2 TRANS' trans_def[of r'] by blast
114.127 + hence ?thesis unfolding Osum_def by auto
114.128 + }
114.129 + moreover
114.130 + {assume Case23: "y \<in> Field r"
114.131 + hence False using FLD 2 by auto
114.132 + }
114.133 + ultimately show ?thesis using ** unfolding Osum_def by blast
114.134 + qed
114.135 + }
114.136 + moreover
114.137 + {assume Case3: "x \<in> Field r \<and> y \<in> Field r'"
114.138 + have ?thesis
114.139 + proof-
114.140 + {assume Case31: "(y,z) \<in> r"
114.141 + hence "y \<in> Field r" unfolding Field_def by auto
114.142 + hence False using FLD Case3 by auto
114.143 + }
114.144 + moreover
114.145 + {assume Case32: "(y,z) \<in> r'"
114.146 + hence "z \<in> Field r'" unfolding Field_def by blast
114.147 + hence ?thesis unfolding Osum_def using Case3 by auto
114.148 + }
114.149 + moreover
114.150 + {assume Case33: "y \<in> Field r"
114.151 + hence False using FLD Case3 by auto
114.152 + }
114.153 + ultimately show ?thesis using ** unfolding Osum_def by blast
114.154 + qed
114.155 + }
114.156 + ultimately show ?thesis using * unfolding Osum_def by blast
114.157 + qed
114.158 +qed
114.159 +
114.160 +lemma Osum_Preorder:
114.161 +"\<lbrakk>Field r Int Field r' = {}; Preorder r; Preorder r'\<rbrakk> \<Longrightarrow> Preorder (r Osum r')"
114.162 +unfolding preorder_on_def using Osum_Refl Osum_trans by blast
114.163 +
114.164 +lemma Osum_antisym:
114.165 +assumes FLD: "Field r Int Field r' = {}" and
114.166 + AN: "antisym r" and AN': "antisym r'"
114.167 +shows "antisym (r Osum r')"
114.168 +proof(unfold antisym_def, auto)
114.169 + fix x y assume *: "(x, y) \<in> r \<union>o r'" and **: "(y, x) \<in> r \<union>o r'"
114.170 + show "x = y"
114.171 + proof-
114.172 + {assume Case1: "(x,y) \<in> r"
114.173 + hence 1: "x \<in> Field r \<and> y \<in> Field r" unfolding Field_def by auto
114.174 + have ?thesis
114.175 + proof-
114.176 + have "(y,x) \<in> r \<Longrightarrow> ?thesis"
114.177 + using Case1 AN antisym_def[of r] by blast
114.178 + moreover
114.179 + {assume "(y,x) \<in> r'"
114.180 + hence "y \<in> Field r'" unfolding Field_def by auto
114.181 + hence False using FLD 1 by auto
114.182 + }
114.183 + moreover
114.184 + have "x \<in> Field r' \<Longrightarrow> False" using FLD 1 by auto
114.185 + ultimately show ?thesis using ** unfolding Osum_def by blast
114.186 + qed
114.187 + }
114.188 + moreover
114.189 + {assume Case2: "(x,y) \<in> r'"
114.190 + hence 2: "x \<in> Field r' \<and> y \<in> Field r'" unfolding Field_def by auto
114.191 + have ?thesis
114.192 + proof-
114.193 + {assume "(y,x) \<in> r"
114.194 + hence "y \<in> Field r" unfolding Field_def by auto
114.195 + hence False using FLD 2 by auto
114.196 + }
114.197 + moreover
114.198 + have "(y,x) \<in> r' \<Longrightarrow> ?thesis"
114.199 + using Case2 AN' antisym_def[of r'] by blast
114.200 + moreover
114.201 + {assume "y \<in> Field r"
114.202 + hence False using FLD 2 by auto
114.203 + }
114.204 + ultimately show ?thesis using ** unfolding Osum_def by blast
114.205 + qed
114.206 + }
114.207 + moreover
114.208 + {assume Case3: "x \<in> Field r \<and> y \<in> Field r'"
114.209 + have ?thesis
114.210 + proof-
114.211 + {assume "(y,x) \<in> r"
114.212 + hence "y \<in> Field r" unfolding Field_def by auto
114.213 + hence False using FLD Case3 by auto
114.214 + }
114.215 + moreover
114.216 + {assume Case32: "(y,x) \<in> r'"
114.217 + hence "x \<in> Field r'" unfolding Field_def by blast
114.218 + hence False using FLD Case3 by auto
114.219 + }
114.220 + moreover
114.221 + have "\<not> y \<in> Field r" using FLD Case3 by auto
114.222 + ultimately show ?thesis using ** unfolding Osum_def by blast
114.223 + qed
114.224 + }
114.225 + ultimately show ?thesis using * unfolding Osum_def by blast
114.226 + qed
114.227 +qed
114.228 +
114.229 +lemma Osum_Partial_order:
114.230 +"\<lbrakk>Field r Int Field r' = {}; Partial_order r; Partial_order r'\<rbrakk> \<Longrightarrow>
114.231 + Partial_order (r Osum r')"
114.232 +unfolding partial_order_on_def using Osum_Preorder Osum_antisym by blast
114.233 +
114.234 +lemma Osum_Total:
114.235 +assumes FLD: "Field r Int Field r' = {}" and
114.236 + TOT: "Total r" and TOT': "Total r'"
114.237 +shows "Total (r Osum r')"
114.238 +using assms
114.239 +unfolding total_on_def Field_Osum unfolding Osum_def by blast
114.240 +
114.241 +lemma Osum_Linear_order:
114.242 +"\<lbrakk>Field r Int Field r' = {}; Linear_order r; Linear_order r'\<rbrakk> \<Longrightarrow>
114.243 + Linear_order (r Osum r')"
114.244 +unfolding linear_order_on_def using Osum_Partial_order Osum_Total by blast
114.245 +
114.246 +lemma Osum_minus_Id1:
114.247 +assumes "r \<le> Id"
114.248 +shows "(r Osum r') - Id \<le> (r' - Id) \<union> (Field r \<times> Field r')"
114.249 +proof-
114.250 + let ?Left = "(r Osum r') - Id"
114.251 + let ?Right = "(r' - Id) \<union> (Field r \<times> Field r')"
114.252 + {fix a::'a and b assume *: "(a,b) \<notin> Id"
114.253 + {assume "(a,b) \<in> r"
114.254 + with * have False using assms by auto
114.255 + }
114.256 + moreover
114.257 + {assume "(a,b) \<in> r'"
114.258 + with * have "(a,b) \<in> r' - Id" by auto
114.259 + }
114.260 + ultimately
114.261 + have "(a,b) \<in> ?Left \<Longrightarrow> (a,b) \<in> ?Right"
114.262 + unfolding Osum_def by auto
114.263 + }
114.264 + thus ?thesis by auto
114.265 +qed
114.266 +
114.267 +lemma Osum_minus_Id2:
114.268 +assumes "r' \<le> Id"
114.269 +shows "(r Osum r') - Id \<le> (r - Id) \<union> (Field r \<times> Field r')"
114.270 +proof-
114.271 + let ?Left = "(r Osum r') - Id"
114.272 + let ?Right = "(r - Id) \<union> (Field r \<times> Field r')"
114.273 + {fix a::'a and b assume *: "(a,b) \<notin> Id"
114.274 + {assume "(a,b) \<in> r'"
114.275 + with * have False using assms by auto
114.276 + }
114.277 + moreover
114.278 + {assume "(a,b) \<in> r"
114.279 + with * have "(a,b) \<in> r - Id" by auto
114.280 + }
114.281 + ultimately
114.282 + have "(a,b) \<in> ?Left \<Longrightarrow> (a,b) \<in> ?Right"
114.283 + unfolding Osum_def by auto
114.284 + }
114.285 + thus ?thesis by auto
114.286 +qed
114.287 +
114.288 +lemma Osum_minus_Id:
114.289 +assumes TOT: "Total r" and TOT': "Total r'" and
114.290 + NID: "\<not> (r \<le> Id)" and NID': "\<not> (r' \<le> Id)"
114.291 +shows "(r Osum r') - Id \<le> (r - Id) Osum (r' - Id)"
114.292 +proof-
114.293 + {fix a a' assume *: "(a,a') \<in> (r Osum r')" and **: "a \<noteq> a'"
114.294 + have "(a,a') \<in> (r - Id) Osum (r' - Id)"
114.295 + proof-
114.296 + {assume "(a,a') \<in> r \<or> (a,a') \<in> r'"
114.297 + with ** have ?thesis unfolding Osum_def by auto
114.298 + }
114.299 + moreover
114.300 + {assume "a \<in> Field r \<and> a' \<in> Field r'"
114.301 + hence "a \<in> Field(r - Id) \<and> a' \<in> Field (r' - Id)"
114.302 + using assms Total_Id_Field by blast
114.303 + hence ?thesis unfolding Osum_def by auto
114.304 + }
114.305 + ultimately show ?thesis using * unfolding Osum_def by fast
114.306 + qed
114.307 + }
114.308 + thus ?thesis by(auto simp add: Osum_def)
114.309 +qed
114.310 +
114.311 +lemma wf_Int_Times:
114.312 +assumes "A Int B = {}"
114.313 +shows "wf(A \<times> B)"
114.314 +unfolding wf_def using assms by blast
114.315 +
114.316 +lemma Osum_wf_Id:
114.317 +assumes TOT: "Total r" and TOT': "Total r'" and
114.318 + FLD: "Field r Int Field r' = {}" and
114.319 + WF: "wf(r - Id)" and WF': "wf(r' - Id)"
114.320 +shows "wf ((r Osum r') - Id)"
114.321 +proof(cases "r \<le> Id \<or> r' \<le> Id")
114.322 + assume Case1: "\<not>(r \<le> Id \<or> r' \<le> Id)"
114.323 + have "Field(r - Id) Int Field(r' - Id) = {}"
114.324 + using FLD mono_Field[of "r - Id" r] mono_Field[of "r' - Id" r']
114.325 + Diff_subset[of r Id] Diff_subset[of r' Id] by blast
114.326 + thus ?thesis
114.327 + using Case1 Osum_minus_Id[of r r'] assms Osum_wf[of "r - Id" "r' - Id"]
114.328 + wf_subset[of "(r - Id) \<union>o (r' - Id)" "(r Osum r') - Id"] by auto
114.329 +next
114.330 + have 1: "wf(Field r \<times> Field r')"
114.331 + using FLD by (auto simp add: wf_Int_Times)
114.332 + assume Case2: "r \<le> Id \<or> r' \<le> Id"
114.333 + moreover
114.334 + {assume Case21: "r \<le> Id"
114.335 + hence "(r Osum r') - Id \<le> (r' - Id) \<union> (Field r \<times> Field r')"
114.336 + using Osum_minus_Id1[of r r'] by simp
114.337 + moreover
114.338 + {have "Domain(Field r \<times> Field r') Int Range(r' - Id) = {}"
114.339 + using FLD unfolding Field_def by blast
114.340 + hence "wf((r' - Id) \<union> (Field r \<times> Field r'))"
114.341 + using 1 WF' wf_Un[of "Field r \<times> Field r'" "r' - Id"]
114.342 + by (auto simp add: Un_commute)
114.343 + }
114.344 + ultimately have ?thesis by (metis wf_subset)
114.345 + }
114.346 + moreover
114.347 + {assume Case22: "r' \<le> Id"
114.348 + hence "(r Osum r') - Id \<le> (r - Id) \<union> (Field r \<times> Field r')"
114.349 + using Osum_minus_Id2[of r' r] by simp
114.350 + moreover
114.351 + {have "Range(Field r \<times> Field r') Int Domain(r - Id) = {}"
114.352 + using FLD unfolding Field_def by blast
114.353 + hence "wf((r - Id) \<union> (Field r \<times> Field r'))"
114.354 + using 1 WF wf_Un[of "r - Id" "Field r \<times> Field r'"]
114.355 + by (auto simp add: Un_commute)
114.356 + }
114.357 + ultimately have ?thesis by (metis wf_subset)
114.358 + }
114.359 + ultimately show ?thesis by blast
114.360 +qed
114.361 +
114.362 +lemma Osum_Well_order:
114.363 +assumes FLD: "Field r Int Field r' = {}" and
114.364 + WELL: "Well_order r" and WELL': "Well_order r'"
114.365 +shows "Well_order (r Osum r')"
114.366 +proof-
114.367 + have "Total r \<and> Total r'" using WELL WELL'
114.368 + by (auto simp add: order_on_defs)
114.369 + thus ?thesis using assms unfolding well_order_on_def
114.370 + using Osum_Linear_order Osum_wf_Id by blast
114.371 +qed
114.372 +
114.373 +end
115.1 --- a/src/HOL/Cardinals/README.txt Thu Dec 05 17:52:12 2013 +0100
115.2 +++ b/src/HOL/Cardinals/README.txt Thu Dec 05 17:58:03 2013 +0100
115.3 @@ -89,15 +89,16 @@
115.4 Minor technicalities and naming issues:
115.5 ---------------------------------------
115.6
115.7 -1. Most of the definitions and theorems are proved in files suffixed with
115.8 -"_Base". Bootstrapping considerations (for the (co)datatype package) made this
115.9 -division desirable.
115.10 +1. Most of the definitions and theorems are proved in files suffixed with "_FP".
115.11 +Bootstrapping considerations (for the (co)datatype package) made this division
115.12 +desirable.
115.13
115.14
115.15 -2. Even though we would have preferred to use "initial segment" instead of
115.16 -"order filter", we chose the latter to avoid terminological clash with
115.17 -the operator "init_seg_of" from Zorn.thy. The latter expresses a related, but different
115.18 -concept -- it considers a relation, rather than a set, as initial segment of a relation.
115.19 +2. Even though we would have preferred to use "initial segment" instead of
115.20 +"order filter", we chose the latter to avoid terminological clash with the
115.21 +operator "init_seg_of" from Zorn.thy. The latter expresses a related, but
115.22 +different concept -- it considers a relation, rather than a set, as initial
115.23 +segment of a relation.
115.24
115.25
115.26 3. We prefer to define the upper-bound operations under, underS,
115.27 @@ -148,7 +149,7 @@
115.28 Notes for anyone who would like to enrich these theories in the future
115.29 --------------------------------------------------------------------------------------
115.30
115.31 -Theory Fun_More (and Fun_More_Base):
115.32 +Theory Fun_More (and Fun_More_FP):
115.33 - Careful: "inj" is an abbreviation for "inj_on UNIV", while
115.34 "bij" is not an abreviation for "bij_betw UNIV UNIV", but
115.35 a defined constant; there is no "surj_betw", but only "surj".
115.36 @@ -166,7 +167,7 @@
115.37 - In subsection "Other facts":
115.38 -- Does the lemma "atLeastLessThan_injective" already exist anywhere?
115.39
115.40 -Theory Order_Relation_More (and Order_Relation_More_Base):
115.41 +Theory Order_Relation_More (and Order_Relation_More_FP):
115.42 - In subsection "Auxiliaries":
115.43 -- Recall the lemmas "order_on_defs", "Field_def", "Domain_def", "Range_def", "converse_def".
115.44 -- Recall that "refl_on r A" forces r to not be defined outside A.
115.45 @@ -181,16 +182,16 @@
115.46 abbreviation "Linear_order r ≡ linear_order_on (Field r) r"
115.47 abbreviation "Well_order r ≡ well_order_on (Field r) r"
115.48
115.49 -Theory Wellorder_Relation (and Wellorder_Relation_Base):
115.50 +Theory Wellorder_Relation (and Wellorder_Relation_FP):
115.51 - In subsection "Auxiliaries": recall lemmas "order_on_defs"
115.52 - In subsection "The notions of maximum, minimum, supremum, successor and order filter":
115.53 Should we define all constants from "wo_rel" in "rel" instead,
115.54 so that their outside definition not be conditional in "wo_rel r"?
115.55
115.56 -Theory Wellfounded_More (and Wellfounded_More_Base):
115.57 +Theory Wellfounded_More (and Wellfounded_More_FP):
115.58 Recall the lemmas "wfrec" and "wf_induct".
115.59
115.60 -Theory Wellorder_Embedding (and Wellorder_Embedding_Base):
115.61 +Theory Wellorder_Embedding (and Wellorder_Embedding_FP):
115.62 - Recall "inj_on_def" and "bij_betw_def".
115.63 - Line 5 in the proof of lemma embed_in_Field: we have to figure out for this and many other
115.64 situations: Why did it work without annotations to Refl_under_in?
115.65 @@ -200,7 +201,7 @@
115.66 making impossible to debug theorem instantiations.
115.67 - At lemma "embed_unique": If we add the attribute "rule format" at lemma, we get an error at qed.
115.68
115.69 -Theory Constructions_on_Wellorders (and Constructions_on_Wellorders_Base):
115.70 +Theory Constructions_on_Wellorders (and Constructions_on_Wellorders_FP):
115.71 - Some of the lemmas in this section are about more general kinds of relations than
115.72 well-orders, but it is not clear whether they are useful in such more general contexts.
115.73 - Recall that "equiv" does not have the "equiv_on" and "Equiv" versions,
115.74 @@ -208,7 +209,7 @@
115.75 - The lemmas "ord_trans" are not clearly useful together, as their employment within blast or auto
115.76 tends to diverge.
115.77
115.78 -Theory Cardinal_Order_Relation (and Cardinal_Order_Relation_Base):
115.79 +Theory Cardinal_Order_Relation (and Cardinal_Order_Relation_FP):
115.80 - Careful: if "|..|" meets an outer parehthesis, an extra space needs to be inserted, as in
115.81 "( |A| )".
115.82 - At lemma like ordLeq_Sigma_mono1: Not worth stating something like ordLeq_Sigma_mono2 --
116.1 --- a/src/HOL/Cardinals/Wellfounded_More.thy Thu Dec 05 17:52:12 2013 +0100
116.2 +++ b/src/HOL/Cardinals/Wellfounded_More.thy Thu Dec 05 17:58:03 2013 +0100
116.3 @@ -8,7 +8,7 @@
116.4 header {* More on Well-Founded Relations *}
116.5
116.6 theory Wellfounded_More
116.7 -imports Wellfounded_More_Base Order_Relation_More
116.8 +imports Wellfounded_More_FP Order_Relation_More
116.9 begin
116.10
116.11
117.1 --- a/src/HOL/Cardinals/Wellfounded_More_Base.thy Thu Dec 05 17:52:12 2013 +0100
117.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
117.3 @@ -1,194 +0,0 @@
117.4 -(* Title: HOL/Cardinals/Wellfounded_More_Base.thy
117.5 - Author: Andrei Popescu, TU Muenchen
117.6 - Copyright 2012
117.7 -
117.8 -More on well-founded relations (base).
117.9 -*)
117.10 -
117.11 -header {* More on Well-Founded Relations (Base) *}
117.12 -
117.13 -theory Wellfounded_More_Base
117.14 -imports Wellfounded Order_Relation_More_Base "~~/src/HOL/Library/Wfrec"
117.15 -begin
117.16 -
117.17 -
117.18 -text {* This section contains some variations of results in the theory
117.19 -@{text "Wellfounded.thy"}:
117.20 -\begin{itemize}
117.21 -\item means for slightly more direct definitions by well-founded recursion;
117.22 -\item variations of well-founded induction;
117.23 -\item means for proving a linear order to be a well-order.
117.24 -\end{itemize} *}
117.25 -
117.26 -
117.27 -subsection {* Well-founded recursion via genuine fixpoints *}
117.28 -
117.29 -
117.30 -(*2*)lemma wfrec_fixpoint:
117.31 -fixes r :: "('a * 'a) set" and
117.32 - H :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
117.33 -assumes WF: "wf r" and ADM: "adm_wf r H"
117.34 -shows "wfrec r H = H (wfrec r H)"
117.35 -proof(rule ext)
117.36 - fix x
117.37 - have "wfrec r H x = H (cut (wfrec r H) r x) x"
117.38 - using wfrec[of r H] WF by simp
117.39 - also
117.40 - {have "\<And> y. (y,x) : r \<Longrightarrow> (cut (wfrec r H) r x) y = (wfrec r H) y"
117.41 - by (auto simp add: cut_apply)
117.42 - hence "H (cut (wfrec r H) r x) x = H (wfrec r H) x"
117.43 - using ADM adm_wf_def[of r H] by auto
117.44 - }
117.45 - finally show "wfrec r H x = H (wfrec r H) x" .
117.46 -qed
117.47 -
117.48 -
117.49 -
117.50 -subsection {* Characterizations of well-founded-ness *}
117.51 -
117.52 -
117.53 -text {* A transitive relation is well-founded iff it is ``locally" well-founded,
117.54 -i.e., iff its restriction to the lower bounds of of any element is well-founded. *}
117.55 -
117.56 -(*3*)lemma trans_wf_iff:
117.57 -assumes "trans r"
117.58 -shows "wf r = (\<forall>a. wf(r Int (r^-1``{a} \<times> r^-1``{a})))"
117.59 -proof-
117.60 - obtain R where R_def: "R = (\<lambda> a. r Int (r^-1``{a} \<times> r^-1``{a}))" by blast
117.61 - {assume *: "wf r"
117.62 - {fix a
117.63 - have "wf(R a)"
117.64 - using * R_def wf_subset[of r "R a"] by auto
117.65 - }
117.66 - }
117.67 - (* *)
117.68 - moreover
117.69 - {assume *: "\<forall>a. wf(R a)"
117.70 - have "wf r"
117.71 - proof(unfold wf_def, clarify)
117.72 - fix phi a
117.73 - assume **: "\<forall>a. (\<forall>b. (b,a) \<in> r \<longrightarrow> phi b) \<longrightarrow> phi a"
117.74 - obtain chi where chi_def: "chi = (\<lambda>b. (b,a) \<in> r \<longrightarrow> phi b)" by blast
117.75 - with * have "wf (R a)" by auto
117.76 - hence "(\<forall>b. (\<forall>c. (c,b) \<in> R a \<longrightarrow> chi c) \<longrightarrow> chi b) \<longrightarrow> (\<forall>b. chi b)"
117.77 - unfolding wf_def by blast
117.78 - moreover
117.79 - have "\<forall>b. (\<forall>c. (c,b) \<in> R a \<longrightarrow> chi c) \<longrightarrow> chi b"
117.80 - proof(auto simp add: chi_def R_def)
117.81 - fix b
117.82 - assume 1: "(b,a) \<in> r" and 2: "\<forall>c. (c, b) \<in> r \<and> (c, a) \<in> r \<longrightarrow> phi c"
117.83 - hence "\<forall>c. (c, b) \<in> r \<longrightarrow> phi c"
117.84 - using assms trans_def[of r] by blast
117.85 - thus "phi b" using ** by blast
117.86 - qed
117.87 - ultimately have "\<forall>b. chi b" by (rule mp)
117.88 - with ** chi_def show "phi a" by blast
117.89 - qed
117.90 - }
117.91 - ultimately show ?thesis using R_def by blast
117.92 -qed
117.93 -
117.94 -
117.95 -text {* The next lemma is a variation of @{text "wf_eq_minimal"} from Wellfounded,
117.96 -allowing one to assume the set included in the field. *}
117.97 -
117.98 -(*2*)lemma wf_eq_minimal2:
117.99 -"wf r = (\<forall>A. A <= Field r \<and> A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. \<not> (a',a) \<in> r))"
117.100 -proof-
117.101 - let ?phi = "\<lambda> A. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. \<not> (a',a) \<in> r)"
117.102 - have "wf r = (\<forall>A. ?phi A)"
117.103 - by (auto simp: ex_in_conv [THEN sym], erule wfE_min, assumption, blast)
117.104 - (rule wfI_min, metis)
117.105 - (* *)
117.106 - also have "(\<forall>A. ?phi A) = (\<forall>B \<le> Field r. ?phi B)"
117.107 - proof
117.108 - assume "\<forall>A. ?phi A"
117.109 - thus "\<forall>B \<le> Field r. ?phi B" by simp
117.110 - next
117.111 - assume *: "\<forall>B \<le> Field r. ?phi B"
117.112 - show "\<forall>A. ?phi A"
117.113 - proof(clarify)
117.114 - fix A::"'a set" assume **: "A \<noteq> {}"
117.115 - obtain B where B_def: "B = A Int (Field r)" by blast
117.116 - show "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r"
117.117 - proof(cases "B = {}")
117.118 - assume Case1: "B = {}"
117.119 - obtain a where 1: "a \<in> A \<and> a \<notin> Field r"
117.120 - using ** Case1 unfolding B_def by blast
117.121 - hence "\<forall>a' \<in> A. (a',a) \<notin> r" using 1 unfolding Field_def by blast
117.122 - thus ?thesis using 1 by blast
117.123 - next
117.124 - assume Case2: "B \<noteq> {}" have 1: "B \<le> Field r" unfolding B_def by blast
117.125 - obtain a where 2: "a \<in> B \<and> (\<forall>a' \<in> B. (a',a) \<notin> r)"
117.126 - using Case2 1 * by blast
117.127 - have "\<forall>a' \<in> A. (a',a) \<notin> r"
117.128 - proof(clarify)
117.129 - fix a' assume "a' \<in> A" and **: "(a',a) \<in> r"
117.130 - hence "a' \<in> B" unfolding B_def Field_def by blast
117.131 - thus False using 2 ** by blast
117.132 - qed
117.133 - thus ?thesis using 2 unfolding B_def by blast
117.134 - qed
117.135 - qed
117.136 - qed
117.137 - finally show ?thesis by blast
117.138 -qed
117.139 -
117.140 -subsection {* Characterizations of well-founded-ness *}
117.141 -
117.142 -text {* The next lemma and its corollary enable one to prove that
117.143 -a linear order is a well-order in a way which is more standard than
117.144 -via well-founded-ness of the strict version of the relation. *}
117.145 -
117.146 -(*3*)
117.147 -lemma Linear_order_wf_diff_Id:
117.148 -assumes LI: "Linear_order r"
117.149 -shows "wf(r - Id) = (\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r))"
117.150 -proof(cases "r \<le> Id")
117.151 - assume Case1: "r \<le> Id"
117.152 - hence temp: "r - Id = {}" by blast
117.153 - hence "wf(r - Id)" by (simp add: temp)
117.154 - moreover
117.155 - {fix A assume *: "A \<le> Field r" and **: "A \<noteq> {}"
117.156 - obtain a where 1: "r = {} \<or> r = {(a,a)}" using LI
117.157 - unfolding order_on_defs using Case1 rel.Total_subset_Id by metis
117.158 - hence "A = {a} \<and> r = {(a,a)}" using * ** unfolding Field_def by blast
117.159 - hence "\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r" using 1 by blast
117.160 - }
117.161 - ultimately show ?thesis by blast
117.162 -next
117.163 - assume Case2: "\<not> r \<le> Id"
117.164 - hence 1: "Field r = Field(r - Id)" using Total_Id_Field LI
117.165 - unfolding order_on_defs by blast
117.166 - show ?thesis
117.167 - proof
117.168 - assume *: "wf(r - Id)"
117.169 - show "\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r)"
117.170 - proof(clarify)
117.171 - fix A assume **: "A \<le> Field r" and ***: "A \<noteq> {}"
117.172 - hence "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r - Id"
117.173 - using 1 * unfolding wf_eq_minimal2 by simp
117.174 - moreover have "\<forall>a \<in> A. \<forall>a' \<in> A. ((a,a') \<in> r) = ((a',a) \<notin> r - Id)"
117.175 - using rel.Linear_order_in_diff_Id[of r] ** LI by blast
117.176 - ultimately show "\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r" by blast
117.177 - qed
117.178 - next
117.179 - assume *: "\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r)"
117.180 - show "wf(r - Id)"
117.181 - proof(unfold wf_eq_minimal2, clarify)
117.182 - fix A assume **: "A \<le> Field(r - Id)" and ***: "A \<noteq> {}"
117.183 - hence "\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r"
117.184 - using 1 * by simp
117.185 - moreover have "\<forall>a \<in> A. \<forall>a' \<in> A. ((a,a') \<in> r) = ((a',a) \<notin> r - Id)"
117.186 - using rel.Linear_order_in_diff_Id[of r] ** LI mono_Field[of "r - Id" r] by blast
117.187 - ultimately show "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r - Id" by blast
117.188 - qed
117.189 - qed
117.190 -qed
117.191 -
117.192 -(*3*)corollary Linear_order_Well_order_iff:
117.193 -assumes "Linear_order r"
117.194 -shows "Well_order r = (\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r))"
117.195 -using assms unfolding well_order_on_def using Linear_order_wf_diff_Id[of r] by blast
117.196 -
117.197 -end
118.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
118.2 +++ b/src/HOL/Cardinals/Wellfounded_More_FP.thy Thu Dec 05 17:58:03 2013 +0100
118.3 @@ -0,0 +1,194 @@
118.4 +(* Title: HOL/Cardinals/Wellfounded_More_FP.thy
118.5 + Author: Andrei Popescu, TU Muenchen
118.6 + Copyright 2012
118.7 +
118.8 +More on well-founded relations (FP).
118.9 +*)
118.10 +
118.11 +header {* More on Well-Founded Relations (FP) *}
118.12 +
118.13 +theory Wellfounded_More_FP
118.14 +imports Order_Relation_More_FP "~~/src/HOL/Library/Wfrec"
118.15 +begin
118.16 +
118.17 +
118.18 +text {* This section contains some variations of results in the theory
118.19 +@{text "Wellfounded.thy"}:
118.20 +\begin{itemize}
118.21 +\item means for slightly more direct definitions by well-founded recursion;
118.22 +\item variations of well-founded induction;
118.23 +\item means for proving a linear order to be a well-order.
118.24 +\end{itemize} *}
118.25 +
118.26 +
118.27 +subsection {* Well-founded recursion via genuine fixpoints *}
118.28 +
118.29 +
118.30 +(*2*)lemma wfrec_fixpoint:
118.31 +fixes r :: "('a * 'a) set" and
118.32 + H :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
118.33 +assumes WF: "wf r" and ADM: "adm_wf r H"
118.34 +shows "wfrec r H = H (wfrec r H)"
118.35 +proof(rule ext)
118.36 + fix x
118.37 + have "wfrec r H x = H (cut (wfrec r H) r x) x"
118.38 + using wfrec[of r H] WF by simp
118.39 + also
118.40 + {have "\<And> y. (y,x) : r \<Longrightarrow> (cut (wfrec r H) r x) y = (wfrec r H) y"
118.41 + by (auto simp add: cut_apply)
118.42 + hence "H (cut (wfrec r H) r x) x = H (wfrec r H) x"
118.43 + using ADM adm_wf_def[of r H] by auto
118.44 + }
118.45 + finally show "wfrec r H x = H (wfrec r H) x" .
118.46 +qed
118.47 +
118.48 +
118.49 +
118.50 +subsection {* Characterizations of well-founded-ness *}
118.51 +
118.52 +
118.53 +text {* A transitive relation is well-founded iff it is ``locally" well-founded,
118.54 +i.e., iff its restriction to the lower bounds of of any element is well-founded. *}
118.55 +
118.56 +(*3*)lemma trans_wf_iff:
118.57 +assumes "trans r"
118.58 +shows "wf r = (\<forall>a. wf(r Int (r^-1``{a} \<times> r^-1``{a})))"
118.59 +proof-
118.60 + obtain R where R_def: "R = (\<lambda> a. r Int (r^-1``{a} \<times> r^-1``{a}))" by blast
118.61 + {assume *: "wf r"
118.62 + {fix a
118.63 + have "wf(R a)"
118.64 + using * R_def wf_subset[of r "R a"] by auto
118.65 + }
118.66 + }
118.67 + (* *)
118.68 + moreover
118.69 + {assume *: "\<forall>a. wf(R a)"
118.70 + have "wf r"
118.71 + proof(unfold wf_def, clarify)
118.72 + fix phi a
118.73 + assume **: "\<forall>a. (\<forall>b. (b,a) \<in> r \<longrightarrow> phi b) \<longrightarrow> phi a"
118.74 + obtain chi where chi_def: "chi = (\<lambda>b. (b,a) \<in> r \<longrightarrow> phi b)" by blast
118.75 + with * have "wf (R a)" by auto
118.76 + hence "(\<forall>b. (\<forall>c. (c,b) \<in> R a \<longrightarrow> chi c) \<longrightarrow> chi b) \<longrightarrow> (\<forall>b. chi b)"
118.77 + unfolding wf_def by blast
118.78 + moreover
118.79 + have "\<forall>b. (\<forall>c. (c,b) \<in> R a \<longrightarrow> chi c) \<longrightarrow> chi b"
118.80 + proof(auto simp add: chi_def R_def)
118.81 + fix b
118.82 + assume 1: "(b,a) \<in> r" and 2: "\<forall>c. (c, b) \<in> r \<and> (c, a) \<in> r \<longrightarrow> phi c"
118.83 + hence "\<forall>c. (c, b) \<in> r \<longrightarrow> phi c"
118.84 + using assms trans_def[of r] by blast
118.85 + thus "phi b" using ** by blast
118.86 + qed
118.87 + ultimately have "\<forall>b. chi b" by (rule mp)
118.88 + with ** chi_def show "phi a" by blast
118.89 + qed
118.90 + }
118.91 + ultimately show ?thesis using R_def by blast
118.92 +qed
118.93 +
118.94 +
118.95 +text {* The next lemma is a variation of @{text "wf_eq_minimal"} from Wellfounded,
118.96 +allowing one to assume the set included in the field. *}
118.97 +
118.98 +(*2*)lemma wf_eq_minimal2:
118.99 +"wf r = (\<forall>A. A <= Field r \<and> A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. \<not> (a',a) \<in> r))"
118.100 +proof-
118.101 + let ?phi = "\<lambda> A. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. \<not> (a',a) \<in> r)"
118.102 + have "wf r = (\<forall>A. ?phi A)"
118.103 + by (auto simp: ex_in_conv [THEN sym], erule wfE_min, assumption, blast)
118.104 + (rule wfI_min, metis)
118.105 + (* *)
118.106 + also have "(\<forall>A. ?phi A) = (\<forall>B \<le> Field r. ?phi B)"
118.107 + proof
118.108 + assume "\<forall>A. ?phi A"
118.109 + thus "\<forall>B \<le> Field r. ?phi B" by simp
118.110 + next
118.111 + assume *: "\<forall>B \<le> Field r. ?phi B"
118.112 + show "\<forall>A. ?phi A"
118.113 + proof(clarify)
118.114 + fix A::"'a set" assume **: "A \<noteq> {}"
118.115 + obtain B where B_def: "B = A Int (Field r)" by blast
118.116 + show "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r"
118.117 + proof(cases "B = {}")
118.118 + assume Case1: "B = {}"
118.119 + obtain a where 1: "a \<in> A \<and> a \<notin> Field r"
118.120 + using ** Case1 unfolding B_def by blast
118.121 + hence "\<forall>a' \<in> A. (a',a) \<notin> r" using 1 unfolding Field_def by blast
118.122 + thus ?thesis using 1 by blast
118.123 + next
118.124 + assume Case2: "B \<noteq> {}" have 1: "B \<le> Field r" unfolding B_def by blast
118.125 + obtain a where 2: "a \<in> B \<and> (\<forall>a' \<in> B. (a',a) \<notin> r)"
118.126 + using Case2 1 * by blast
118.127 + have "\<forall>a' \<in> A. (a',a) \<notin> r"
118.128 + proof(clarify)
118.129 + fix a' assume "a' \<in> A" and **: "(a',a) \<in> r"
118.130 + hence "a' \<in> B" unfolding B_def Field_def by blast
118.131 + thus False using 2 ** by blast
118.132 + qed
118.133 + thus ?thesis using 2 unfolding B_def by blast
118.134 + qed
118.135 + qed
118.136 + qed
118.137 + finally show ?thesis by blast
118.138 +qed
118.139 +
118.140 +subsection {* Characterizations of well-founded-ness *}
118.141 +
118.142 +text {* The next lemma and its corollary enable one to prove that
118.143 +a linear order is a well-order in a way which is more standard than
118.144 +via well-founded-ness of the strict version of the relation. *}
118.145 +
118.146 +(*3*)
118.147 +lemma Linear_order_wf_diff_Id:
118.148 +assumes LI: "Linear_order r"
118.149 +shows "wf(r - Id) = (\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r))"
118.150 +proof(cases "r \<le> Id")
118.151 + assume Case1: "r \<le> Id"
118.152 + hence temp: "r - Id = {}" by blast
118.153 + hence "wf(r - Id)" by (simp add: temp)
118.154 + moreover
118.155 + {fix A assume *: "A \<le> Field r" and **: "A \<noteq> {}"
118.156 + obtain a where 1: "r = {} \<or> r = {(a,a)}" using LI
118.157 + unfolding order_on_defs using Case1 rel.Total_subset_Id by metis
118.158 + hence "A = {a} \<and> r = {(a,a)}" using * ** unfolding Field_def by blast
118.159 + hence "\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r" using 1 by blast
118.160 + }
118.161 + ultimately show ?thesis by blast
118.162 +next
118.163 + assume Case2: "\<not> r \<le> Id"
118.164 + hence 1: "Field r = Field(r - Id)" using Total_Id_Field LI
118.165 + unfolding order_on_defs by blast
118.166 + show ?thesis
118.167 + proof
118.168 + assume *: "wf(r - Id)"
118.169 + show "\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r)"
118.170 + proof(clarify)
118.171 + fix A assume **: "A \<le> Field r" and ***: "A \<noteq> {}"
118.172 + hence "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r - Id"
118.173 + using 1 * unfolding wf_eq_minimal2 by simp
118.174 + moreover have "\<forall>a \<in> A. \<forall>a' \<in> A. ((a,a') \<in> r) = ((a',a) \<notin> r - Id)"
118.175 + using rel.Linear_order_in_diff_Id[of r] ** LI by blast
118.176 + ultimately show "\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r" by blast
118.177 + qed
118.178 + next
118.179 + assume *: "\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r)"
118.180 + show "wf(r - Id)"
118.181 + proof(unfold wf_eq_minimal2, clarify)
118.182 + fix A assume **: "A \<le> Field(r - Id)" and ***: "A \<noteq> {}"
118.183 + hence "\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r"
118.184 + using 1 * by simp
118.185 + moreover have "\<forall>a \<in> A. \<forall>a' \<in> A. ((a,a') \<in> r) = ((a',a) \<notin> r - Id)"
118.186 + using rel.Linear_order_in_diff_Id[of r] ** LI mono_Field[of "r - Id" r] by blast
118.187 + ultimately show "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r - Id" by blast
118.188 + qed
118.189 + qed
118.190 +qed
118.191 +
118.192 +(*3*)corollary Linear_order_Well_order_iff:
118.193 +assumes "Linear_order r"
118.194 +shows "Well_order r = (\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r))"
118.195 +using assms unfolding well_order_on_def using Linear_order_wf_diff_Id[of r] by blast
118.196 +
118.197 +end
119.1 --- a/src/HOL/Cardinals/Wellorder_Embedding.thy Thu Dec 05 17:52:12 2013 +0100
119.2 +++ b/src/HOL/Cardinals/Wellorder_Embedding.thy Thu Dec 05 17:58:03 2013 +0100
119.3 @@ -8,7 +8,7 @@
119.4 header {* Well-Order Embeddings *}
119.5
119.6 theory Wellorder_Embedding
119.7 -imports Wellorder_Embedding_Base Fun_More Wellorder_Relation
119.8 +imports Wellorder_Embedding_FP Fun_More Wellorder_Relation
119.9 begin
119.10
119.11
120.1 --- a/src/HOL/Cardinals/Wellorder_Embedding_Base.thy Thu Dec 05 17:52:12 2013 +0100
120.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
120.3 @@ -1,1146 +0,0 @@
120.4 -(* Title: HOL/Cardinals/Wellorder_Embedding_Base.thy
120.5 - Author: Andrei Popescu, TU Muenchen
120.6 - Copyright 2012
120.7 -
120.8 -Well-order embeddings (base).
120.9 -*)
120.10 -
120.11 -header {* Well-Order Embeddings (Base) *}
120.12 -
120.13 -theory Wellorder_Embedding_Base
120.14 -imports "~~/src/HOL/Library/Zorn" Fun_More_Base Wellorder_Relation_Base
120.15 -begin
120.16 -
120.17 -
120.18 -text{* In this section, we introduce well-order {\em embeddings} and {\em isomorphisms} and
120.19 -prove their basic properties. The notion of embedding is considered from the point
120.20 -of view of the theory of ordinals, and therefore requires the source to be injected
120.21 -as an {\em initial segment} (i.e., {\em order filter}) of the target. A main result
120.22 -of this section is the existence of embeddings (in one direction or another) between
120.23 -any two well-orders, having as a consequence the fact that, given any two sets on
120.24 -any two types, one is smaller than (i.e., can be injected into) the other. *}
120.25 -
120.26 -
120.27 -subsection {* Auxiliaries *}
120.28 -
120.29 -lemma UNION_inj_on_ofilter:
120.30 -assumes WELL: "Well_order r" and
120.31 - OF: "\<And> i. i \<in> I \<Longrightarrow> wo_rel.ofilter r (A i)" and
120.32 - INJ: "\<And> i. i \<in> I \<Longrightarrow> inj_on f (A i)"
120.33 -shows "inj_on f (\<Union> i \<in> I. A i)"
120.34 -proof-
120.35 - have "wo_rel r" using WELL by (simp add: wo_rel_def)
120.36 - hence "\<And> i j. \<lbrakk>i \<in> I; j \<in> I\<rbrakk> \<Longrightarrow> A i <= A j \<or> A j <= A i"
120.37 - using wo_rel.ofilter_linord[of r] OF by blast
120.38 - with WELL INJ show ?thesis
120.39 - by (auto simp add: inj_on_UNION_chain)
120.40 -qed
120.41 -
120.42 -
120.43 -lemma under_underS_bij_betw:
120.44 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and
120.45 - IN: "a \<in> Field r" and IN': "f a \<in> Field r'" and
120.46 - BIJ: "bij_betw f (rel.underS r a) (rel.underS r' (f a))"
120.47 -shows "bij_betw f (rel.under r a) (rel.under r' (f a))"
120.48 -proof-
120.49 - have "a \<notin> rel.underS r a \<and> f a \<notin> rel.underS r' (f a)"
120.50 - unfolding rel.underS_def by auto
120.51 - moreover
120.52 - {have "Refl r \<and> Refl r'" using WELL WELL'
120.53 - by (auto simp add: order_on_defs)
120.54 - hence "rel.under r a = rel.underS r a \<union> {a} \<and>
120.55 - rel.under r' (f a) = rel.underS r' (f a) \<union> {f a}"
120.56 - using IN IN' by(auto simp add: rel.Refl_under_underS)
120.57 - }
120.58 - ultimately show ?thesis
120.59 - using BIJ notIn_Un_bij_betw[of a "rel.underS r a" f "rel.underS r' (f a)"] by auto
120.60 -qed
120.61 -
120.62 -
120.63 -
120.64 -subsection {* (Well-order) embeddings, strict embeddings, isomorphisms and order-compatible
120.65 -functions *}
120.66 -
120.67 -
120.68 -text{* Standardly, a function is an embedding of a well-order in another if it injectively and
120.69 -order-compatibly maps the former into an order filter of the latter.
120.70 -Here we opt for a more succinct definition (operator @{text "embed"}),
120.71 -asking that, for any element in the source, the function should be a bijection
120.72 -between the set of strict lower bounds of that element
120.73 -and the set of strict lower bounds of its image. (Later we prove equivalence with
120.74 -the standard definition -- lemma @{text "embed_iff_compat_inj_on_ofilter"}.)
120.75 -A {\em strict embedding} (operator @{text "embedS"}) is a non-bijective embedding
120.76 -and an isomorphism (operator @{text "iso"}) is a bijective embedding. *}
120.77 -
120.78 -
120.79 -definition embed :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> bool"
120.80 -where
120.81 -"embed r r' f \<equiv> \<forall>a \<in> Field r. bij_betw f (rel.under r a) (rel.under r' (f a))"
120.82 -
120.83 -
120.84 -lemmas embed_defs = embed_def embed_def[abs_def]
120.85 -
120.86 -
120.87 -text {* Strict embeddings: *}
120.88 -
120.89 -definition embedS :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> bool"
120.90 -where
120.91 -"embedS r r' f \<equiv> embed r r' f \<and> \<not> bij_betw f (Field r) (Field r')"
120.92 -
120.93 -
120.94 -lemmas embedS_defs = embedS_def embedS_def[abs_def]
120.95 -
120.96 -
120.97 -definition iso :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> bool"
120.98 -where
120.99 -"iso r r' f \<equiv> embed r r' f \<and> bij_betw f (Field r) (Field r')"
120.100 -
120.101 -
120.102 -lemmas iso_defs = iso_def iso_def[abs_def]
120.103 -
120.104 -
120.105 -definition compat :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> bool"
120.106 -where
120.107 -"compat r r' f \<equiv> \<forall>a b. (a,b) \<in> r \<longrightarrow> (f a, f b) \<in> r'"
120.108 -
120.109 -
120.110 -lemma compat_wf:
120.111 -assumes CMP: "compat r r' f" and WF: "wf r'"
120.112 -shows "wf r"
120.113 -proof-
120.114 - have "r \<le> inv_image r' f"
120.115 - unfolding inv_image_def using CMP
120.116 - by (auto simp add: compat_def)
120.117 - with WF show ?thesis
120.118 - using wf_inv_image[of r' f] wf_subset[of "inv_image r' f"] by auto
120.119 -qed
120.120 -
120.121 -
120.122 -lemma id_embed: "embed r r id"
120.123 -by(auto simp add: id_def embed_def bij_betw_def)
120.124 -
120.125 -
120.126 -lemma id_iso: "iso r r id"
120.127 -by(auto simp add: id_def embed_def iso_def bij_betw_def)
120.128 -
120.129 -
120.130 -lemma embed_in_Field:
120.131 -assumes WELL: "Well_order r" and
120.132 - EMB: "embed r r' f" and IN: "a \<in> Field r"
120.133 -shows "f a \<in> Field r'"
120.134 -proof-
120.135 - have Well: "wo_rel r"
120.136 - using WELL by (auto simp add: wo_rel_def)
120.137 - hence 1: "Refl r"
120.138 - by (auto simp add: wo_rel.REFL)
120.139 - hence "a \<in> rel.under r a" using IN rel.Refl_under_in by fastforce
120.140 - hence "f a \<in> rel.under r' (f a)"
120.141 - using EMB IN by (auto simp add: embed_def bij_betw_def)
120.142 - thus ?thesis unfolding Field_def
120.143 - by (auto simp: rel.under_def)
120.144 -qed
120.145 -
120.146 -
120.147 -lemma comp_embed:
120.148 -assumes WELL: "Well_order r" and
120.149 - EMB: "embed r r' f" and EMB': "embed r' r'' f'"
120.150 -shows "embed r r'' (f' o f)"
120.151 -proof(unfold embed_def, auto)
120.152 - fix a assume *: "a \<in> Field r"
120.153 - hence "bij_betw f (rel.under r a) (rel.under r' (f a))"
120.154 - using embed_def[of r] EMB by auto
120.155 - moreover
120.156 - {have "f a \<in> Field r'"
120.157 - using EMB WELL * by (auto simp add: embed_in_Field)
120.158 - hence "bij_betw f' (rel.under r' (f a)) (rel.under r'' (f' (f a)))"
120.159 - using embed_def[of r'] EMB' by auto
120.160 - }
120.161 - ultimately
120.162 - show "bij_betw (f' \<circ> f) (rel.under r a) (rel.under r'' (f'(f a)))"
120.163 - by(auto simp add: bij_betw_trans)
120.164 -qed
120.165 -
120.166 -
120.167 -lemma comp_iso:
120.168 -assumes WELL: "Well_order r" and
120.169 - EMB: "iso r r' f" and EMB': "iso r' r'' f'"
120.170 -shows "iso r r'' (f' o f)"
120.171 -using assms unfolding iso_def
120.172 -by (auto simp add: comp_embed bij_betw_trans)
120.173 -
120.174 -
120.175 -text{* That @{text "embedS"} is also preserved by function composition shall be proved only later. *}
120.176 -
120.177 -
120.178 -lemma embed_Field:
120.179 -"\<lbrakk>Well_order r; embed r r' f\<rbrakk> \<Longrightarrow> f`(Field r) \<le> Field r'"
120.180 -by (auto simp add: embed_in_Field)
120.181 -
120.182 -
120.183 -lemma embed_preserves_ofilter:
120.184 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and
120.185 - EMB: "embed r r' f" and OF: "wo_rel.ofilter r A"
120.186 -shows "wo_rel.ofilter r' (f`A)"
120.187 -proof-
120.188 - (* Preliminary facts *)
120.189 - from WELL have Well: "wo_rel r" unfolding wo_rel_def .
120.190 - from WELL' have Well': "wo_rel r'" unfolding wo_rel_def .
120.191 - from OF have 0: "A \<le> Field r" by(auto simp add: Well wo_rel.ofilter_def)
120.192 - (* Main proof *)
120.193 - show ?thesis using Well' WELL EMB 0 embed_Field[of r r' f]
120.194 - proof(unfold wo_rel.ofilter_def, auto simp add: image_def)
120.195 - fix a b'
120.196 - assume *: "a \<in> A" and **: "b' \<in> rel.under r' (f a)"
120.197 - hence "a \<in> Field r" using 0 by auto
120.198 - hence "bij_betw f (rel.under r a) (rel.under r' (f a))"
120.199 - using * EMB by (auto simp add: embed_def)
120.200 - hence "f`(rel.under r a) = rel.under r' (f a)"
120.201 - by (simp add: bij_betw_def)
120.202 - with ** image_def[of f "rel.under r a"] obtain b where
120.203 - 1: "b \<in> rel.under r a \<and> b' = f b" by blast
120.204 - hence "b \<in> A" using Well * OF
120.205 - by (auto simp add: wo_rel.ofilter_def)
120.206 - with 1 show "\<exists>b \<in> A. b' = f b" by blast
120.207 - qed
120.208 -qed
120.209 -
120.210 -
120.211 -lemma embed_Field_ofilter:
120.212 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and
120.213 - EMB: "embed r r' f"
120.214 -shows "wo_rel.ofilter r' (f`(Field r))"
120.215 -proof-
120.216 - have "wo_rel.ofilter r (Field r)"
120.217 - using WELL by (auto simp add: wo_rel_def wo_rel.Field_ofilter)
120.218 - with WELL WELL' EMB
120.219 - show ?thesis by (auto simp add: embed_preserves_ofilter)
120.220 -qed
120.221 -
120.222 -
120.223 -lemma embed_compat:
120.224 -assumes EMB: "embed r r' f"
120.225 -shows "compat r r' f"
120.226 -proof(unfold compat_def, clarify)
120.227 - fix a b
120.228 - assume *: "(a,b) \<in> r"
120.229 - hence 1: "b \<in> Field r" using Field_def[of r] by blast
120.230 - have "a \<in> rel.under r b"
120.231 - using * rel.under_def[of r] by simp
120.232 - hence "f a \<in> rel.under r' (f b)"
120.233 - using EMB embed_def[of r r' f]
120.234 - bij_betw_def[of f "rel.under r b" "rel.under r' (f b)"]
120.235 - image_def[of f "rel.under r b"] 1 by auto
120.236 - thus "(f a, f b) \<in> r'"
120.237 - by (auto simp add: rel.under_def)
120.238 -qed
120.239 -
120.240 -
120.241 -lemma embed_inj_on:
120.242 -assumes WELL: "Well_order r" and EMB: "embed r r' f"
120.243 -shows "inj_on f (Field r)"
120.244 -proof(unfold inj_on_def, clarify)
120.245 - (* Preliminary facts *)
120.246 - from WELL have Well: "wo_rel r" unfolding wo_rel_def .
120.247 - with wo_rel.TOTAL[of r]
120.248 - have Total: "Total r" by simp
120.249 - from Well wo_rel.REFL[of r]
120.250 - have Refl: "Refl r" by simp
120.251 - (* Main proof *)
120.252 - fix a b
120.253 - assume *: "a \<in> Field r" and **: "b \<in> Field r" and
120.254 - ***: "f a = f b"
120.255 - hence 1: "a \<in> Field r \<and> b \<in> Field r"
120.256 - unfolding Field_def by auto
120.257 - {assume "(a,b) \<in> r"
120.258 - hence "a \<in> rel.under r b \<and> b \<in> rel.under r b"
120.259 - using Refl by(auto simp add: rel.under_def refl_on_def)
120.260 - hence "a = b"
120.261 - using EMB 1 ***
120.262 - by (auto simp add: embed_def bij_betw_def inj_on_def)
120.263 - }
120.264 - moreover
120.265 - {assume "(b,a) \<in> r"
120.266 - hence "a \<in> rel.under r a \<and> b \<in> rel.under r a"
120.267 - using Refl by(auto simp add: rel.under_def refl_on_def)
120.268 - hence "a = b"
120.269 - using EMB 1 ***
120.270 - by (auto simp add: embed_def bij_betw_def inj_on_def)
120.271 - }
120.272 - ultimately
120.273 - show "a = b" using Total 1
120.274 - by (auto simp add: total_on_def)
120.275 -qed
120.276 -
120.277 -
120.278 -lemma embed_underS:
120.279 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and
120.280 - EMB: "embed r r' f" and IN: "a \<in> Field r"
120.281 -shows "bij_betw f (rel.underS r a) (rel.underS r' (f a))"
120.282 -proof-
120.283 - have "bij_betw f (rel.under r a) (rel.under r' (f a))"
120.284 - using assms by (auto simp add: embed_def)
120.285 - moreover
120.286 - {have "f a \<in> Field r'" using assms embed_Field[of r r' f] by auto
120.287 - hence "rel.under r a = rel.underS r a \<union> {a} \<and>
120.288 - rel.under r' (f a) = rel.underS r' (f a) \<union> {f a}"
120.289 - using assms by (auto simp add: order_on_defs rel.Refl_under_underS)
120.290 - }
120.291 - moreover
120.292 - {have "a \<notin> rel.underS r a \<and> f a \<notin> rel.underS r' (f a)"
120.293 - unfolding rel.underS_def by blast
120.294 - }
120.295 - ultimately show ?thesis
120.296 - by (auto simp add: notIn_Un_bij_betw3)
120.297 -qed
120.298 -
120.299 -
120.300 -lemma embed_iff_compat_inj_on_ofilter:
120.301 -assumes WELL: "Well_order r" and WELL': "Well_order r'"
120.302 -shows "embed r r' f = (compat r r' f \<and> inj_on f (Field r) \<and> wo_rel.ofilter r' (f`(Field r)))"
120.303 -using assms
120.304 -proof(auto simp add: embed_compat embed_inj_on embed_Field_ofilter,
120.305 - unfold embed_def, auto) (* get rid of one implication *)
120.306 - fix a
120.307 - assume *: "inj_on f (Field r)" and
120.308 - **: "compat r r' f" and
120.309 - ***: "wo_rel.ofilter r' (f`(Field r))" and
120.310 - ****: "a \<in> Field r"
120.311 - (* Preliminary facts *)
120.312 - have Well: "wo_rel r"
120.313 - using WELL wo_rel_def[of r] by simp
120.314 - hence Refl: "Refl r"
120.315 - using wo_rel.REFL[of r] by simp
120.316 - have Total: "Total r"
120.317 - using Well wo_rel.TOTAL[of r] by simp
120.318 - have Well': "wo_rel r'"
120.319 - using WELL' wo_rel_def[of r'] by simp
120.320 - hence Antisym': "antisym r'"
120.321 - using wo_rel.ANTISYM[of r'] by simp
120.322 - have "(a,a) \<in> r"
120.323 - using **** Well wo_rel.REFL[of r]
120.324 - refl_on_def[of _ r] by auto
120.325 - hence "(f a, f a) \<in> r'"
120.326 - using ** by(auto simp add: compat_def)
120.327 - hence 0: "f a \<in> Field r'"
120.328 - unfolding Field_def by auto
120.329 - have "f a \<in> f`(Field r)"
120.330 - using **** by auto
120.331 - hence 2: "rel.under r' (f a) \<le> f`(Field r)"
120.332 - using Well' *** wo_rel.ofilter_def[of r' "f`(Field r)"] by fastforce
120.333 - (* Main proof *)
120.334 - show "bij_betw f (rel.under r a) (rel.under r' (f a))"
120.335 - proof(unfold bij_betw_def, auto)
120.336 - show "inj_on f (rel.under r a)"
120.337 - using *
120.338 - by (auto simp add: rel.under_Field subset_inj_on)
120.339 - next
120.340 - fix b assume "b \<in> rel.under r a"
120.341 - thus "f b \<in> rel.under r' (f a)"
120.342 - unfolding rel.under_def using **
120.343 - by (auto simp add: compat_def)
120.344 - next
120.345 - fix b' assume *****: "b' \<in> rel.under r' (f a)"
120.346 - hence "b' \<in> f`(Field r)"
120.347 - using 2 by auto
120.348 - with Field_def[of r] obtain b where
120.349 - 3: "b \<in> Field r" and 4: "b' = f b" by auto
120.350 - have "(b,a): r"
120.351 - proof-
120.352 - {assume "(a,b) \<in> r"
120.353 - with ** 4 have "(f a, b'): r'"
120.354 - by (auto simp add: compat_def)
120.355 - with ***** Antisym' have "f a = b'"
120.356 - by(auto simp add: rel.under_def antisym_def)
120.357 - with 3 **** 4 * have "a = b"
120.358 - by(auto simp add: inj_on_def)
120.359 - }
120.360 - moreover
120.361 - {assume "a = b"
120.362 - hence "(b,a) \<in> r" using Refl **** 3
120.363 - by (auto simp add: refl_on_def)
120.364 - }
120.365 - ultimately
120.366 - show ?thesis using Total **** 3 by (fastforce simp add: total_on_def)
120.367 - qed
120.368 - with 4 show "b' \<in> f`(rel.under r a)"
120.369 - unfolding rel.under_def by auto
120.370 - qed
120.371 -qed
120.372 -
120.373 -
120.374 -lemma inv_into_ofilter_embed:
120.375 -assumes WELL: "Well_order r" and OF: "wo_rel.ofilter r A" and
120.376 - BIJ: "\<forall>b \<in> A. bij_betw f (rel.under r b) (rel.under r' (f b))" and
120.377 - IMAGE: "f ` A = Field r'"
120.378 -shows "embed r' r (inv_into A f)"
120.379 -proof-
120.380 - (* Preliminary facts *)
120.381 - have Well: "wo_rel r"
120.382 - using WELL wo_rel_def[of r] by simp
120.383 - have Refl: "Refl r"
120.384 - using Well wo_rel.REFL[of r] by simp
120.385 - have Total: "Total r"
120.386 - using Well wo_rel.TOTAL[of r] by simp
120.387 - (* Main proof *)
120.388 - have 1: "bij_betw f A (Field r')"
120.389 - proof(unfold bij_betw_def inj_on_def, auto simp add: IMAGE)
120.390 - fix b1 b2
120.391 - assume *: "b1 \<in> A" and **: "b2 \<in> A" and
120.392 - ***: "f b1 = f b2"
120.393 - have 11: "b1 \<in> Field r \<and> b2 \<in> Field r"
120.394 - using * ** Well OF by (auto simp add: wo_rel.ofilter_def)
120.395 - moreover
120.396 - {assume "(b1,b2) \<in> r"
120.397 - hence "b1 \<in> rel.under r b2 \<and> b2 \<in> rel.under r b2"
120.398 - unfolding rel.under_def using 11 Refl
120.399 - by (auto simp add: refl_on_def)
120.400 - hence "b1 = b2" using BIJ * ** ***
120.401 - by (auto simp add: bij_betw_def inj_on_def)
120.402 - }
120.403 - moreover
120.404 - {assume "(b2,b1) \<in> r"
120.405 - hence "b1 \<in> rel.under r b1 \<and> b2 \<in> rel.under r b1"
120.406 - unfolding rel.under_def using 11 Refl
120.407 - by (auto simp add: refl_on_def)
120.408 - hence "b1 = b2" using BIJ * ** ***
120.409 - by (auto simp add: bij_betw_def inj_on_def)
120.410 - }
120.411 - ultimately
120.412 - show "b1 = b2"
120.413 - using Total by (auto simp add: total_on_def)
120.414 - qed
120.415 - (* *)
120.416 - let ?f' = "(inv_into A f)"
120.417 - (* *)
120.418 - have 2: "\<forall>b \<in> A. bij_betw ?f' (rel.under r' (f b)) (rel.under r b)"
120.419 - proof(clarify)
120.420 - fix b assume *: "b \<in> A"
120.421 - hence "rel.under r b \<le> A"
120.422 - using Well OF by(auto simp add: wo_rel.ofilter_def)
120.423 - moreover
120.424 - have "f ` (rel.under r b) = rel.under r' (f b)"
120.425 - using * BIJ by (auto simp add: bij_betw_def)
120.426 - ultimately
120.427 - show "bij_betw ?f' (rel.under r' (f b)) (rel.under r b)"
120.428 - using 1 by (auto simp add: bij_betw_inv_into_subset)
120.429 - qed
120.430 - (* *)
120.431 - have 3: "\<forall>b' \<in> Field r'. bij_betw ?f' (rel.under r' b') (rel.under r (?f' b'))"
120.432 - proof(clarify)
120.433 - fix b' assume *: "b' \<in> Field r'"
120.434 - have "b' = f (?f' b')" using * 1
120.435 - by (auto simp add: bij_betw_inv_into_right)
120.436 - moreover
120.437 - {obtain b where 31: "b \<in> A" and "f b = b'" using IMAGE * by force
120.438 - hence "?f' b' = b" using 1 by (auto simp add: bij_betw_inv_into_left)
120.439 - with 31 have "?f' b' \<in> A" by auto
120.440 - }
120.441 - ultimately
120.442 - show "bij_betw ?f' (rel.under r' b') (rel.under r (?f' b'))"
120.443 - using 2 by auto
120.444 - qed
120.445 - (* *)
120.446 - thus ?thesis unfolding embed_def .
120.447 -qed
120.448 -
120.449 -
120.450 -lemma inv_into_underS_embed:
120.451 -assumes WELL: "Well_order r" and
120.452 - BIJ: "\<forall>b \<in> rel.underS r a. bij_betw f (rel.under r b) (rel.under r' (f b))" and
120.453 - IN: "a \<in> Field r" and
120.454 - IMAGE: "f ` (rel.underS r a) = Field r'"
120.455 -shows "embed r' r (inv_into (rel.underS r a) f)"
120.456 -using assms
120.457 -by(auto simp add: wo_rel_def wo_rel.underS_ofilter inv_into_ofilter_embed)
120.458 -
120.459 -
120.460 -lemma inv_into_Field_embed:
120.461 -assumes WELL: "Well_order r" and EMB: "embed r r' f" and
120.462 - IMAGE: "Field r' \<le> f ` (Field r)"
120.463 -shows "embed r' r (inv_into (Field r) f)"
120.464 -proof-
120.465 - have "(\<forall>b \<in> Field r. bij_betw f (rel.under r b) (rel.under r' (f b)))"
120.466 - using EMB by (auto simp add: embed_def)
120.467 - moreover
120.468 - have "f ` (Field r) \<le> Field r'"
120.469 - using EMB WELL by (auto simp add: embed_Field)
120.470 - ultimately
120.471 - show ?thesis using assms
120.472 - by(auto simp add: wo_rel_def wo_rel.Field_ofilter inv_into_ofilter_embed)
120.473 -qed
120.474 -
120.475 -
120.476 -lemma inv_into_Field_embed_bij_betw:
120.477 -assumes WELL: "Well_order r" and
120.478 - EMB: "embed r r' f" and BIJ: "bij_betw f (Field r) (Field r')"
120.479 -shows "embed r' r (inv_into (Field r) f)"
120.480 -proof-
120.481 - have "Field r' \<le> f ` (Field r)"
120.482 - using BIJ by (auto simp add: bij_betw_def)
120.483 - thus ?thesis using assms
120.484 - by(auto simp add: inv_into_Field_embed)
120.485 -qed
120.486 -
120.487 -
120.488 -
120.489 -
120.490 -
120.491 -subsection {* Given any two well-orders, one can be embedded in the other *}
120.492 -
120.493 -
120.494 -text{* Here is an overview of the proof of of this fact, stated in theorem
120.495 -@{text "wellorders_totally_ordered"}:
120.496 -
120.497 - Fix the well-orders @{text "r::'a rel"} and @{text "r'::'a' rel"}.
120.498 - Attempt to define an embedding @{text "f::'a \<Rightarrow> 'a'"} from @{text "r"} to @{text "r'"} in the
120.499 - natural way by well-order recursion ("hoping" that @{text "Field r"} turns out to be smaller
120.500 - than @{text "Field r'"}), but also record, at the recursive step, in a function
120.501 - @{text "g::'a \<Rightarrow> bool"}, the extra information of whether @{text "Field r'"}
120.502 - gets exhausted or not.
120.503 -
120.504 - If @{text "Field r'"} does not get exhausted, then @{text "Field r"} is indeed smaller
120.505 - and @{text "f"} is the desired embedding from @{text "r"} to @{text "r'"}
120.506 - (lemma @{text "wellorders_totally_ordered_aux"}).
120.507 -
120.508 - Otherwise, it means that @{text "Field r'"} is the smaller one, and the inverse of
120.509 - (the "good" segment of) @{text "f"} is the desired embedding from @{text "r'"} to @{text "r"}
120.510 - (lemma @{text "wellorders_totally_ordered_aux2"}).
120.511 -*}
120.512 -
120.513 -
120.514 -lemma wellorders_totally_ordered_aux:
120.515 -fixes r ::"'a rel" and r'::"'a' rel" and
120.516 - f :: "'a \<Rightarrow> 'a'" and a::'a
120.517 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and IN: "a \<in> Field r" and
120.518 - IH: "\<forall>b \<in> rel.underS r a. bij_betw f (rel.under r b) (rel.under r' (f b))" and
120.519 - NOT: "f ` (rel.underS r a) \<noteq> Field r'" and SUC: "f a = wo_rel.suc r' (f`(rel.underS r a))"
120.520 -shows "bij_betw f (rel.under r a) (rel.under r' (f a))"
120.521 -proof-
120.522 - (* Preliminary facts *)
120.523 - have Well: "wo_rel r" using WELL unfolding wo_rel_def .
120.524 - hence Refl: "Refl r" using wo_rel.REFL[of r] by auto
120.525 - have Trans: "trans r" using Well wo_rel.TRANS[of r] by auto
120.526 - have Well': "wo_rel r'" using WELL' unfolding wo_rel_def .
120.527 - have OF: "wo_rel.ofilter r (rel.underS r a)"
120.528 - by (auto simp add: Well wo_rel.underS_ofilter)
120.529 - hence UN: "rel.underS r a = (\<Union> b \<in> rel.underS r a. rel.under r b)"
120.530 - using Well wo_rel.ofilter_under_UNION[of r "rel.underS r a"] by blast
120.531 - (* Gather facts about elements of rel.underS r a *)
120.532 - {fix b assume *: "b \<in> rel.underS r a"
120.533 - hence t0: "(b,a) \<in> r \<and> b \<noteq> a" unfolding rel.underS_def by auto
120.534 - have t1: "b \<in> Field r"
120.535 - using * rel.underS_Field[of r a] by auto
120.536 - have t2: "f`(rel.under r b) = rel.under r' (f b)"
120.537 - using IH * by (auto simp add: bij_betw_def)
120.538 - hence t3: "wo_rel.ofilter r' (f`(rel.under r b))"
120.539 - using Well' by (auto simp add: wo_rel.under_ofilter)
120.540 - have "f`(rel.under r b) \<le> Field r'"
120.541 - using t2 by (auto simp add: rel.under_Field)
120.542 - moreover
120.543 - have "b \<in> rel.under r b"
120.544 - using t1 by(auto simp add: Refl rel.Refl_under_in)
120.545 - ultimately
120.546 - have t4: "f b \<in> Field r'" by auto
120.547 - have "f`(rel.under r b) = rel.under r' (f b) \<and>
120.548 - wo_rel.ofilter r' (f`(rel.under r b)) \<and>
120.549 - f b \<in> Field r'"
120.550 - using t2 t3 t4 by auto
120.551 - }
120.552 - hence bFact:
120.553 - "\<forall>b \<in> rel.underS r a. f`(rel.under r b) = rel.under r' (f b) \<and>
120.554 - wo_rel.ofilter r' (f`(rel.under r b)) \<and>
120.555 - f b \<in> Field r'" by blast
120.556 - (* *)
120.557 - have subField: "f`(rel.underS r a) \<le> Field r'"
120.558 - using bFact by blast
120.559 - (* *)
120.560 - have OF': "wo_rel.ofilter r' (f`(rel.underS r a))"
120.561 - proof-
120.562 - have "f`(rel.underS r a) = f`(\<Union> b \<in> rel.underS r a. rel.under r b)"
120.563 - using UN by auto
120.564 - also have "\<dots> = (\<Union> b \<in> rel.underS r a. f`(rel.under r b))" by blast
120.565 - also have "\<dots> = (\<Union> b \<in> rel.underS r a. (rel.under r' (f b)))"
120.566 - using bFact by auto
120.567 - finally
120.568 - have "f`(rel.underS r a) = (\<Union> b \<in> rel.underS r a. (rel.under r' (f b)))" .
120.569 - thus ?thesis
120.570 - using Well' bFact
120.571 - wo_rel.ofilter_UNION[of r' "rel.underS r a" "\<lambda> b. rel.under r' (f b)"] by fastforce
120.572 - qed
120.573 - (* *)
120.574 - have "f`(rel.underS r a) \<union> rel.AboveS r' (f`(rel.underS r a)) = Field r'"
120.575 - using Well' OF' by (auto simp add: wo_rel.ofilter_AboveS_Field)
120.576 - hence NE: "rel.AboveS r' (f`(rel.underS r a)) \<noteq> {}"
120.577 - using subField NOT by blast
120.578 - (* Main proof *)
120.579 - have INCL1: "f`(rel.underS r a) \<le> rel.underS r' (f a) "
120.580 - proof(auto)
120.581 - fix b assume *: "b \<in> rel.underS r a"
120.582 - have "f b \<noteq> f a \<and> (f b, f a) \<in> r'"
120.583 - using subField Well' SUC NE *
120.584 - wo_rel.suc_greater[of r' "f`(rel.underS r a)" "f b"] by auto
120.585 - thus "f b \<in> rel.underS r' (f a)"
120.586 - unfolding rel.underS_def by simp
120.587 - qed
120.588 - (* *)
120.589 - have INCL2: "rel.underS r' (f a) \<le> f`(rel.underS r a)"
120.590 - proof
120.591 - fix b' assume "b' \<in> rel.underS r' (f a)"
120.592 - hence "b' \<noteq> f a \<and> (b', f a) \<in> r'"
120.593 - unfolding rel.underS_def by simp
120.594 - thus "b' \<in> f`(rel.underS r a)"
120.595 - using Well' SUC NE OF'
120.596 - wo_rel.suc_ofilter_in[of r' "f ` rel.underS r a" b'] by auto
120.597 - qed
120.598 - (* *)
120.599 - have INJ: "inj_on f (rel.underS r a)"
120.600 - proof-
120.601 - have "\<forall>b \<in> rel.underS r a. inj_on f (rel.under r b)"
120.602 - using IH by (auto simp add: bij_betw_def)
120.603 - moreover
120.604 - have "\<forall>b. wo_rel.ofilter r (rel.under r b)"
120.605 - using Well by (auto simp add: wo_rel.under_ofilter)
120.606 - ultimately show ?thesis
120.607 - using WELL bFact UN
120.608 - UNION_inj_on_ofilter[of r "rel.underS r a" "\<lambda>b. rel.under r b" f]
120.609 - by auto
120.610 - qed
120.611 - (* *)
120.612 - have BIJ: "bij_betw f (rel.underS r a) (rel.underS r' (f a))"
120.613 - unfolding bij_betw_def
120.614 - using INJ INCL1 INCL2 by auto
120.615 - (* *)
120.616 - have "f a \<in> Field r'"
120.617 - using Well' subField NE SUC
120.618 - by (auto simp add: wo_rel.suc_inField)
120.619 - thus ?thesis
120.620 - using WELL WELL' IN BIJ under_underS_bij_betw[of r r' a f] by auto
120.621 -qed
120.622 -
120.623 -
120.624 -lemma wellorders_totally_ordered_aux2:
120.625 -fixes r ::"'a rel" and r'::"'a' rel" and
120.626 - f :: "'a \<Rightarrow> 'a'" and g :: "'a \<Rightarrow> bool" and a::'a
120.627 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and
120.628 -MAIN1:
120.629 - "\<And> a. (False \<notin> g`(rel.underS r a) \<and> f`(rel.underS r a) \<noteq> Field r'
120.630 - \<longrightarrow> f a = wo_rel.suc r' (f`(rel.underS r a)) \<and> g a = True)
120.631 - \<and>
120.632 - (\<not>(False \<notin> (g`(rel.underS r a)) \<and> f`(rel.underS r a) \<noteq> Field r')
120.633 - \<longrightarrow> g a = False)" and
120.634 -MAIN2: "\<And> a. a \<in> Field r \<and> False \<notin> g`(rel.under r a) \<longrightarrow>
120.635 - bij_betw f (rel.under r a) (rel.under r' (f a))" and
120.636 -Case: "a \<in> Field r \<and> False \<in> g`(rel.under r a)"
120.637 -shows "\<exists>f'. embed r' r f'"
120.638 -proof-
120.639 - have Well: "wo_rel r" using WELL unfolding wo_rel_def .
120.640 - hence Refl: "Refl r" using wo_rel.REFL[of r] by auto
120.641 - have Trans: "trans r" using Well wo_rel.TRANS[of r] by auto
120.642 - have Antisym: "antisym r" using Well wo_rel.ANTISYM[of r] by auto
120.643 - have Well': "wo_rel r'" using WELL' unfolding wo_rel_def .
120.644 - (* *)
120.645 - have 0: "rel.under r a = rel.underS r a \<union> {a}"
120.646 - using Refl Case by(auto simp add: rel.Refl_under_underS)
120.647 - (* *)
120.648 - have 1: "g a = False"
120.649 - proof-
120.650 - {assume "g a \<noteq> False"
120.651 - with 0 Case have "False \<in> g`(rel.underS r a)" by blast
120.652 - with MAIN1 have "g a = False" by blast}
120.653 - thus ?thesis by blast
120.654 - qed
120.655 - let ?A = "{a \<in> Field r. g a = False}"
120.656 - let ?a = "(wo_rel.minim r ?A)"
120.657 - (* *)
120.658 - have 2: "?A \<noteq> {} \<and> ?A \<le> Field r" using Case 1 by blast
120.659 - (* *)
120.660 - have 3: "False \<notin> g`(rel.underS r ?a)"
120.661 - proof
120.662 - assume "False \<in> g`(rel.underS r ?a)"
120.663 - then obtain b where "b \<in> rel.underS r ?a" and 31: "g b = False" by auto
120.664 - hence 32: "(b,?a) \<in> r \<and> b \<noteq> ?a"
120.665 - by (auto simp add: rel.underS_def)
120.666 - hence "b \<in> Field r" unfolding Field_def by auto
120.667 - with 31 have "b \<in> ?A" by auto
120.668 - hence "(?a,b) \<in> r" using wo_rel.minim_least 2 Well by fastforce
120.669 - (* again: why worked without type annotations? *)
120.670 - with 32 Antisym show False
120.671 - by (auto simp add: antisym_def)
120.672 - qed
120.673 - have temp: "?a \<in> ?A"
120.674 - using Well 2 wo_rel.minim_in[of r ?A] by auto
120.675 - hence 4: "?a \<in> Field r" by auto
120.676 - (* *)
120.677 - have 5: "g ?a = False" using temp by blast
120.678 - (* *)
120.679 - have 6: "f`(rel.underS r ?a) = Field r'"
120.680 - using MAIN1[of ?a] 3 5 by blast
120.681 - (* *)
120.682 - have 7: "\<forall>b \<in> rel.underS r ?a. bij_betw f (rel.under r b) (rel.under r' (f b))"
120.683 - proof
120.684 - fix b assume as: "b \<in> rel.underS r ?a"
120.685 - moreover
120.686 - have "wo_rel.ofilter r (rel.underS r ?a)"
120.687 - using Well by (auto simp add: wo_rel.underS_ofilter)
120.688 - ultimately
120.689 - have "False \<notin> g`(rel.under r b)" using 3 Well by (subst (asm) wo_rel.ofilter_def) fast+
120.690 - moreover have "b \<in> Field r"
120.691 - unfolding Field_def using as by (auto simp add: rel.underS_def)
120.692 - ultimately
120.693 - show "bij_betw f (rel.under r b) (rel.under r' (f b))"
120.694 - using MAIN2 by auto
120.695 - qed
120.696 - (* *)
120.697 - have "embed r' r (inv_into (rel.underS r ?a) f)"
120.698 - using WELL WELL' 7 4 6 inv_into_underS_embed[of r ?a f r'] by auto
120.699 - thus ?thesis
120.700 - unfolding embed_def by blast
120.701 -qed
120.702 -
120.703 -
120.704 -theorem wellorders_totally_ordered:
120.705 -fixes r ::"'a rel" and r'::"'a' rel"
120.706 -assumes WELL: "Well_order r" and WELL': "Well_order r'"
120.707 -shows "(\<exists>f. embed r r' f) \<or> (\<exists>f'. embed r' r f')"
120.708 -proof-
120.709 - (* Preliminary facts *)
120.710 - have Well: "wo_rel r" using WELL unfolding wo_rel_def .
120.711 - hence Refl: "Refl r" using wo_rel.REFL[of r] by auto
120.712 - have Trans: "trans r" using Well wo_rel.TRANS[of r] by auto
120.713 - have Well': "wo_rel r'" using WELL' unfolding wo_rel_def .
120.714 - (* Main proof *)
120.715 - obtain H where H_def: "H =
120.716 - (\<lambda>h a. if False \<notin> (snd o h)`(rel.underS r a) \<and> (fst o h)`(rel.underS r a) \<noteq> Field r'
120.717 - then (wo_rel.suc r' ((fst o h)`(rel.underS r a)), True)
120.718 - else (undefined, False))" by blast
120.719 - have Adm: "wo_rel.adm_wo r H"
120.720 - using Well
120.721 - proof(unfold wo_rel.adm_wo_def, clarify)
120.722 - fix h1::"'a \<Rightarrow> 'a' * bool" and h2::"'a \<Rightarrow> 'a' * bool" and x
120.723 - assume "\<forall>y\<in>rel.underS r x. h1 y = h2 y"
120.724 - hence "\<forall>y\<in>rel.underS r x. (fst o h1) y = (fst o h2) y \<and>
120.725 - (snd o h1) y = (snd o h2) y" by auto
120.726 - hence "(fst o h1)`(rel.underS r x) = (fst o h2)`(rel.underS r x) \<and>
120.727 - (snd o h1)`(rel.underS r x) = (snd o h2)`(rel.underS r x)"
120.728 - by (auto simp add: image_def)
120.729 - thus "H h1 x = H h2 x" by (simp add: H_def del: not_False_in_image_Ball)
120.730 - qed
120.731 - (* More constant definitions: *)
120.732 - obtain h::"'a \<Rightarrow> 'a' * bool" and f::"'a \<Rightarrow> 'a'" and g::"'a \<Rightarrow> bool"
120.733 - where h_def: "h = wo_rel.worec r H" and
120.734 - f_def: "f = fst o h" and g_def: "g = snd o h" by blast
120.735 - obtain test where test_def:
120.736 - "test = (\<lambda> a. False \<notin> (g`(rel.underS r a)) \<and> f`(rel.underS r a) \<noteq> Field r')" by blast
120.737 - (* *)
120.738 - have *: "\<And> a. h a = H h a"
120.739 - using Adm Well wo_rel.worec_fixpoint[of r H] by (simp add: h_def)
120.740 - have Main1:
120.741 - "\<And> a. (test a \<longrightarrow> f a = wo_rel.suc r' (f`(rel.underS r a)) \<and> g a = True) \<and>
120.742 - (\<not>(test a) \<longrightarrow> g a = False)"
120.743 - proof- (* How can I prove this withou fixing a? *)
120.744 - fix a show "(test a \<longrightarrow> f a = wo_rel.suc r' (f`(rel.underS r a)) \<and> g a = True) \<and>
120.745 - (\<not>(test a) \<longrightarrow> g a = False)"
120.746 - using *[of a] test_def f_def g_def H_def by auto
120.747 - qed
120.748 - (* *)
120.749 - let ?phi = "\<lambda> a. a \<in> Field r \<and> False \<notin> g`(rel.under r a) \<longrightarrow>
120.750 - bij_betw f (rel.under r a) (rel.under r' (f a))"
120.751 - have Main2: "\<And> a. ?phi a"
120.752 - proof-
120.753 - fix a show "?phi a"
120.754 - proof(rule wo_rel.well_order_induct[of r ?phi],
120.755 - simp only: Well, clarify)
120.756 - fix a
120.757 - assume IH: "\<forall>b. b \<noteq> a \<and> (b,a) \<in> r \<longrightarrow> ?phi b" and
120.758 - *: "a \<in> Field r" and
120.759 - **: "False \<notin> g`(rel.under r a)"
120.760 - have 1: "\<forall>b \<in> rel.underS r a. bij_betw f (rel.under r b) (rel.under r' (f b))"
120.761 - proof(clarify)
120.762 - fix b assume ***: "b \<in> rel.underS r a"
120.763 - hence 0: "(b,a) \<in> r \<and> b \<noteq> a" unfolding rel.underS_def by auto
120.764 - moreover have "b \<in> Field r"
120.765 - using *** rel.underS_Field[of r a] by auto
120.766 - moreover have "False \<notin> g`(rel.under r b)"
120.767 - using 0 ** Trans rel.under_incr[of r b a] by auto
120.768 - ultimately show "bij_betw f (rel.under r b) (rel.under r' (f b))"
120.769 - using IH by auto
120.770 - qed
120.771 - (* *)
120.772 - have 21: "False \<notin> g`(rel.underS r a)"
120.773 - using ** rel.underS_subset_under[of r a] by auto
120.774 - have 22: "g`(rel.under r a) \<le> {True}" using ** by auto
120.775 - moreover have 23: "a \<in> rel.under r a"
120.776 - using Refl * by (auto simp add: rel.Refl_under_in)
120.777 - ultimately have 24: "g a = True" by blast
120.778 - have 2: "f`(rel.underS r a) \<noteq> Field r'"
120.779 - proof
120.780 - assume "f`(rel.underS r a) = Field r'"
120.781 - hence "g a = False" using Main1 test_def by blast
120.782 - with 24 show False using ** by blast
120.783 - qed
120.784 - (* *)
120.785 - have 3: "f a = wo_rel.suc r' (f`(rel.underS r a))"
120.786 - using 21 2 Main1 test_def by blast
120.787 - (* *)
120.788 - show "bij_betw f (rel.under r a) (rel.under r' (f a))"
120.789 - using WELL WELL' 1 2 3 *
120.790 - wellorders_totally_ordered_aux[of r r' a f] by auto
120.791 - qed
120.792 - qed
120.793 - (* *)
120.794 - let ?chi = "(\<lambda> a. a \<in> Field r \<and> False \<in> g`(rel.under r a))"
120.795 - show ?thesis
120.796 - proof(cases "\<exists>a. ?chi a")
120.797 - assume "\<not> (\<exists>a. ?chi a)"
120.798 - hence "\<forall>a \<in> Field r. bij_betw f (rel.under r a) (rel.under r' (f a))"
120.799 - using Main2 by blast
120.800 - thus ?thesis unfolding embed_def by blast
120.801 - next
120.802 - assume "\<exists>a. ?chi a"
120.803 - then obtain a where "?chi a" by blast
120.804 - hence "\<exists>f'. embed r' r f'"
120.805 - using wellorders_totally_ordered_aux2[of r r' g f a]
120.806 - WELL WELL' Main1 Main2 test_def by blast
120.807 - thus ?thesis by blast
120.808 - qed
120.809 -qed
120.810 -
120.811 -
120.812 -subsection {* Uniqueness of embeddings *}
120.813 -
120.814 -
120.815 -text{* Here we show a fact complementary to the one from the previous subsection -- namely,
120.816 -that between any two well-orders there is {\em at most} one embedding, and is the one
120.817 -definable by the expected well-order recursive equation. As a consequence, any two
120.818 -embeddings of opposite directions are mutually inverse. *}
120.819 -
120.820 -
120.821 -lemma embed_determined:
120.822 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and
120.823 - EMB: "embed r r' f" and IN: "a \<in> Field r"
120.824 -shows "f a = wo_rel.suc r' (f`(rel.underS r a))"
120.825 -proof-
120.826 - have "bij_betw f (rel.underS r a) (rel.underS r' (f a))"
120.827 - using assms by (auto simp add: embed_underS)
120.828 - hence "f`(rel.underS r a) = rel.underS r' (f a)"
120.829 - by (auto simp add: bij_betw_def)
120.830 - moreover
120.831 - {have "f a \<in> Field r'" using IN
120.832 - using EMB WELL embed_Field[of r r' f] by auto
120.833 - hence "f a = wo_rel.suc r' (rel.underS r' (f a))"
120.834 - using WELL' by (auto simp add: wo_rel_def wo_rel.suc_underS)
120.835 - }
120.836 - ultimately show ?thesis by simp
120.837 -qed
120.838 -
120.839 -
120.840 -lemma embed_unique:
120.841 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and
120.842 - EMBf: "embed r r' f" and EMBg: "embed r r' g"
120.843 -shows "a \<in> Field r \<longrightarrow> f a = g a"
120.844 -proof(rule wo_rel.well_order_induct[of r], auto simp add: WELL wo_rel_def)
120.845 - fix a
120.846 - assume IH: "\<forall>b. b \<noteq> a \<and> (b,a): r \<longrightarrow> b \<in> Field r \<longrightarrow> f b = g b" and
120.847 - *: "a \<in> Field r"
120.848 - hence "\<forall>b \<in> rel.underS r a. f b = g b"
120.849 - unfolding rel.underS_def by (auto simp add: Field_def)
120.850 - hence "f`(rel.underS r a) = g`(rel.underS r a)" by force
120.851 - thus "f a = g a"
120.852 - using assms * embed_determined[of r r' f a] embed_determined[of r r' g a] by auto
120.853 -qed
120.854 -
120.855 -
120.856 -lemma embed_bothWays_inverse:
120.857 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and
120.858 - EMB: "embed r r' f" and EMB': "embed r' r f'"
120.859 -shows "(\<forall>a \<in> Field r. f'(f a) = a) \<and> (\<forall>a' \<in> Field r'. f(f' a') = a')"
120.860 -proof-
120.861 - have "embed r r (f' o f)" using assms
120.862 - by(auto simp add: comp_embed)
120.863 - moreover have "embed r r id" using assms
120.864 - by (auto simp add: id_embed)
120.865 - ultimately have "\<forall>a \<in> Field r. f'(f a) = a"
120.866 - using assms embed_unique[of r r "f' o f" id] id_def by auto
120.867 - moreover
120.868 - {have "embed r' r' (f o f')" using assms
120.869 - by(auto simp add: comp_embed)
120.870 - moreover have "embed r' r' id" using assms
120.871 - by (auto simp add: id_embed)
120.872 - ultimately have "\<forall>a' \<in> Field r'. f(f' a') = a'"
120.873 - using assms embed_unique[of r' r' "f o f'" id] id_def by auto
120.874 - }
120.875 - ultimately show ?thesis by blast
120.876 -qed
120.877 -
120.878 -
120.879 -lemma embed_bothWays_bij_betw:
120.880 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and
120.881 - EMB: "embed r r' f" and EMB': "embed r' r g"
120.882 -shows "bij_betw f (Field r) (Field r')"
120.883 -proof-
120.884 - let ?A = "Field r" let ?A' = "Field r'"
120.885 - have "embed r r (g o f) \<and> embed r' r' (f o g)"
120.886 - using assms by (auto simp add: comp_embed)
120.887 - hence 1: "(\<forall>a \<in> ?A. g(f a) = a) \<and> (\<forall>a' \<in> ?A'. f(g a') = a')"
120.888 - using WELL id_embed[of r] embed_unique[of r r "g o f" id]
120.889 - WELL' id_embed[of r'] embed_unique[of r' r' "f o g" id]
120.890 - id_def by auto
120.891 - have 2: "(\<forall>a \<in> ?A. f a \<in> ?A') \<and> (\<forall>a' \<in> ?A'. g a' \<in> ?A)"
120.892 - using assms embed_Field[of r r' f] embed_Field[of r' r g] by blast
120.893 - (* *)
120.894 - show ?thesis
120.895 - proof(unfold bij_betw_def inj_on_def, auto simp add: 2)
120.896 - fix a b assume *: "a \<in> ?A" "b \<in> ?A" and **: "f a = f b"
120.897 - have "a = g(f a) \<and> b = g(f b)" using * 1 by auto
120.898 - with ** show "a = b" by auto
120.899 - next
120.900 - fix a' assume *: "a' \<in> ?A'"
120.901 - hence "g a' \<in> ?A \<and> f(g a') = a'" using 1 2 by auto
120.902 - thus "a' \<in> f ` ?A" by force
120.903 - qed
120.904 -qed
120.905 -
120.906 -
120.907 -lemma embed_bothWays_iso:
120.908 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and
120.909 - EMB: "embed r r' f" and EMB': "embed r' r g"
120.910 -shows "iso r r' f"
120.911 -unfolding iso_def using assms by (auto simp add: embed_bothWays_bij_betw)
120.912 -
120.913 -
120.914 -subsection {* More properties of embeddings, strict embeddings and isomorphisms *}
120.915 -
120.916 -
120.917 -lemma embed_bothWays_Field_bij_betw:
120.918 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and
120.919 - EMB: "embed r r' f" and EMB': "embed r' r f'"
120.920 -shows "bij_betw f (Field r) (Field r')"
120.921 -proof-
120.922 - have "(\<forall>a \<in> Field r. f'(f a) = a) \<and> (\<forall>a' \<in> Field r'. f(f' a') = a')"
120.923 - using assms by (auto simp add: embed_bothWays_inverse)
120.924 - moreover
120.925 - have "f`(Field r) \<le> Field r' \<and> f' ` (Field r') \<le> Field r"
120.926 - using assms by (auto simp add: embed_Field)
120.927 - ultimately
120.928 - show ?thesis using bij_betw_byWitness[of "Field r" f' f "Field r'"] by auto
120.929 -qed
120.930 -
120.931 -
120.932 -lemma embedS_comp_embed:
120.933 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
120.934 - and EMB: "embedS r r' f" and EMB': "embed r' r'' f'"
120.935 -shows "embedS r r'' (f' o f)"
120.936 -proof-
120.937 - let ?g = "(f' o f)" let ?h = "inv_into (Field r) ?g"
120.938 - have 1: "embed r r' f \<and> \<not> (bij_betw f (Field r) (Field r'))"
120.939 - using EMB by (auto simp add: embedS_def)
120.940 - hence 2: "embed r r'' ?g"
120.941 - using WELL EMB' comp_embed[of r r' f r'' f'] by auto
120.942 - moreover
120.943 - {assume "bij_betw ?g (Field r) (Field r'')"
120.944 - hence "embed r'' r ?h" using 2 WELL
120.945 - by (auto simp add: inv_into_Field_embed_bij_betw)
120.946 - hence "embed r' r (?h o f')" using WELL' EMB'
120.947 - by (auto simp add: comp_embed)
120.948 - hence "bij_betw f (Field r) (Field r')" using WELL WELL' 1
120.949 - by (auto simp add: embed_bothWays_Field_bij_betw)
120.950 - with 1 have False by blast
120.951 - }
120.952 - ultimately show ?thesis unfolding embedS_def by auto
120.953 -qed
120.954 -
120.955 -
120.956 -lemma embed_comp_embedS:
120.957 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
120.958 - and EMB: "embed r r' f" and EMB': "embedS r' r'' f'"
120.959 -shows "embedS r r'' (f' o f)"
120.960 -proof-
120.961 - let ?g = "(f' o f)" let ?h = "inv_into (Field r) ?g"
120.962 - have 1: "embed r' r'' f' \<and> \<not> (bij_betw f' (Field r') (Field r''))"
120.963 - using EMB' by (auto simp add: embedS_def)
120.964 - hence 2: "embed r r'' ?g"
120.965 - using WELL EMB comp_embed[of r r' f r'' f'] by auto
120.966 - moreover
120.967 - {assume "bij_betw ?g (Field r) (Field r'')"
120.968 - hence "embed r'' r ?h" using 2 WELL
120.969 - by (auto simp add: inv_into_Field_embed_bij_betw)
120.970 - hence "embed r'' r' (f o ?h)" using WELL'' EMB
120.971 - by (auto simp add: comp_embed)
120.972 - hence "bij_betw f' (Field r') (Field r'')" using WELL' WELL'' 1
120.973 - by (auto simp add: embed_bothWays_Field_bij_betw)
120.974 - with 1 have False by blast
120.975 - }
120.976 - ultimately show ?thesis unfolding embedS_def by auto
120.977 -qed
120.978 -
120.979 -
120.980 -lemma embed_comp_iso:
120.981 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
120.982 - and EMB: "embed r r' f" and EMB': "iso r' r'' f'"
120.983 -shows "embed r r'' (f' o f)"
120.984 -using assms unfolding iso_def
120.985 -by (auto simp add: comp_embed)
120.986 -
120.987 -
120.988 -lemma iso_comp_embed:
120.989 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
120.990 - and EMB: "iso r r' f" and EMB': "embed r' r'' f'"
120.991 -shows "embed r r'' (f' o f)"
120.992 -using assms unfolding iso_def
120.993 -by (auto simp add: comp_embed)
120.994 -
120.995 -
120.996 -lemma embedS_comp_iso:
120.997 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
120.998 - and EMB: "embedS r r' f" and EMB': "iso r' r'' f'"
120.999 -shows "embedS r r'' (f' o f)"
120.1000 -using assms unfolding iso_def
120.1001 -by (auto simp add: embedS_comp_embed)
120.1002 -
120.1003 -
120.1004 -lemma iso_comp_embedS:
120.1005 -assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
120.1006 - and EMB: "iso r r' f" and EMB': "embedS r' r'' f'"
120.1007 -shows "embedS r r'' (f' o f)"
120.1008 -using assms unfolding iso_def using embed_comp_embedS
120.1009 -by (auto simp add: embed_comp_embedS)
120.1010 -
120.1011 -
120.1012 -lemma embedS_Field:
120.1013 -assumes WELL: "Well_order r" and EMB: "embedS r r' f"
120.1014 -shows "f ` (Field r) < Field r'"
120.1015 -proof-
120.1016 - have "f`(Field r) \<le> Field r'" using assms
120.1017 - by (auto simp add: embed_Field embedS_def)
120.1018 - moreover
120.1019 - {have "inj_on f (Field r)" using assms
120.1020 - by (auto simp add: embedS_def embed_inj_on)
120.1021 - hence "f`(Field r) \<noteq> Field r'" using EMB
120.1022 - by (auto simp add: embedS_def bij_betw_def)
120.1023 - }
120.1024 - ultimately show ?thesis by blast
120.1025 -qed
120.1026 -
120.1027 -
120.1028 -lemma embedS_iff:
120.1029 -assumes WELL: "Well_order r" and ISO: "embed r r' f"
120.1030 -shows "embedS r r' f = (f ` (Field r) < Field r')"
120.1031 -proof
120.1032 - assume "embedS r r' f"
120.1033 - thus "f ` Field r \<subset> Field r'"
120.1034 - using WELL by (auto simp add: embedS_Field)
120.1035 -next
120.1036 - assume "f ` Field r \<subset> Field r'"
120.1037 - hence "\<not> bij_betw f (Field r) (Field r')"
120.1038 - unfolding bij_betw_def by blast
120.1039 - thus "embedS r r' f" unfolding embedS_def
120.1040 - using ISO by auto
120.1041 -qed
120.1042 -
120.1043 -
120.1044 -lemma iso_Field:
120.1045 -"iso r r' f \<Longrightarrow> f ` (Field r) = Field r'"
120.1046 -using assms by (auto simp add: iso_def bij_betw_def)
120.1047 -
120.1048 -
120.1049 -lemma iso_iff:
120.1050 -assumes "Well_order r"
120.1051 -shows "iso r r' f = (embed r r' f \<and> f ` (Field r) = Field r')"
120.1052 -proof
120.1053 - assume "iso r r' f"
120.1054 - thus "embed r r' f \<and> f ` (Field r) = Field r'"
120.1055 - by (auto simp add: iso_Field iso_def)
120.1056 -next
120.1057 - assume *: "embed r r' f \<and> f ` Field r = Field r'"
120.1058 - hence "inj_on f (Field r)" using assms by (auto simp add: embed_inj_on)
120.1059 - with * have "bij_betw f (Field r) (Field r')"
120.1060 - unfolding bij_betw_def by simp
120.1061 - with * show "iso r r' f" unfolding iso_def by auto
120.1062 -qed
120.1063 -
120.1064 -
120.1065 -lemma iso_iff2:
120.1066 -assumes "Well_order r"
120.1067 -shows "iso r r' f = (bij_betw f (Field r) (Field r') \<and>
120.1068 - (\<forall>a \<in> Field r. \<forall>b \<in> Field r.
120.1069 - (((a,b) \<in> r) = ((f a, f b) \<in> r'))))"
120.1070 -using assms
120.1071 -proof(auto simp add: iso_def)
120.1072 - fix a b
120.1073 - assume "embed r r' f"
120.1074 - hence "compat r r' f" using embed_compat[of r] by auto
120.1075 - moreover assume "(a,b) \<in> r"
120.1076 - ultimately show "(f a, f b) \<in> r'" using compat_def[of r] by auto
120.1077 -next
120.1078 - let ?f' = "inv_into (Field r) f"
120.1079 - assume "embed r r' f" and 1: "bij_betw f (Field r) (Field r')"
120.1080 - hence "embed r' r ?f'" using assms
120.1081 - by (auto simp add: inv_into_Field_embed_bij_betw)
120.1082 - hence 2: "compat r' r ?f'" using embed_compat[of r'] by auto
120.1083 - fix a b assume *: "a \<in> Field r" "b \<in> Field r" and **: "(f a,f b) \<in> r'"
120.1084 - hence "?f'(f a) = a \<and> ?f'(f b) = b" using 1
120.1085 - by (auto simp add: bij_betw_inv_into_left)
120.1086 - thus "(a,b) \<in> r" using ** 2 compat_def[of r' r ?f'] by fastforce
120.1087 -next
120.1088 - assume *: "bij_betw f (Field r) (Field r')" and
120.1089 - **: "\<forall>a\<in>Field r. \<forall>b\<in>Field r. ((a, b) \<in> r) = ((f a, f b) \<in> r')"
120.1090 - have 1: "\<And> a. rel.under r a \<le> Field r \<and> rel.under r' (f a) \<le> Field r'"
120.1091 - by (auto simp add: rel.under_Field)
120.1092 - have 2: "inj_on f (Field r)" using * by (auto simp add: bij_betw_def)
120.1093 - {fix a assume ***: "a \<in> Field r"
120.1094 - have "bij_betw f (rel.under r a) (rel.under r' (f a))"
120.1095 - proof(unfold bij_betw_def, auto)
120.1096 - show "inj_on f (rel.under r a)"
120.1097 - using 1 2 by (auto simp add: subset_inj_on)
120.1098 - next
120.1099 - fix b assume "b \<in> rel.under r a"
120.1100 - hence "a \<in> Field r \<and> b \<in> Field r \<and> (b,a) \<in> r"
120.1101 - unfolding rel.under_def by (auto simp add: Field_def Range_def Domain_def)
120.1102 - with 1 ** show "f b \<in> rel.under r' (f a)"
120.1103 - unfolding rel.under_def by auto
120.1104 - next
120.1105 - fix b' assume "b' \<in> rel.under r' (f a)"
120.1106 - hence 3: "(b',f a) \<in> r'" unfolding rel.under_def by simp
120.1107 - hence "b' \<in> Field r'" unfolding Field_def by auto
120.1108 - with * obtain b where "b \<in> Field r \<and> f b = b'"
120.1109 - unfolding bij_betw_def by force
120.1110 - with 3 ** ***
120.1111 - show "b' \<in> f ` (rel.under r a)" unfolding rel.under_def by blast
120.1112 - qed
120.1113 - }
120.1114 - thus "embed r r' f" unfolding embed_def using * by auto
120.1115 -qed
120.1116 -
120.1117 -
120.1118 -lemma iso_iff3:
120.1119 -assumes WELL: "Well_order r" and WELL': "Well_order r'"
120.1120 -shows "iso r r' f = (bij_betw f (Field r) (Field r') \<and> compat r r' f)"
120.1121 -proof
120.1122 - assume "iso r r' f"
120.1123 - thus "bij_betw f (Field r) (Field r') \<and> compat r r' f"
120.1124 - unfolding compat_def using WELL by (auto simp add: iso_iff2 Field_def)
120.1125 -next
120.1126 - have Well: "wo_rel r \<and> wo_rel r'" using WELL WELL'
120.1127 - by (auto simp add: wo_rel_def)
120.1128 - assume *: "bij_betw f (Field r) (Field r') \<and> compat r r' f"
120.1129 - thus "iso r r' f"
120.1130 - unfolding "compat_def" using assms
120.1131 - proof(auto simp add: iso_iff2)
120.1132 - fix a b assume **: "a \<in> Field r" "b \<in> Field r" and
120.1133 - ***: "(f a, f b) \<in> r'"
120.1134 - {assume "(b,a) \<in> r \<or> b = a"
120.1135 - hence "(b,a): r"using Well ** wo_rel.REFL[of r] refl_on_def[of _ r] by blast
120.1136 - hence "(f b, f a) \<in> r'" using * unfolding compat_def by auto
120.1137 - hence "f a = f b"
120.1138 - using Well *** wo_rel.ANTISYM[of r'] antisym_def[of r'] by blast
120.1139 - hence "a = b" using * ** unfolding bij_betw_def inj_on_def by auto
120.1140 - hence "(a,b) \<in> r" using Well ** wo_rel.REFL[of r] refl_on_def[of _ r] by blast
120.1141 - }
120.1142 - thus "(a,b) \<in> r"
120.1143 - using Well ** wo_rel.TOTAL[of r] total_on_def[of _ r] by blast
120.1144 - qed
120.1145 -qed
120.1146 -
120.1147 -
120.1148 -
120.1149 -end
121.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
121.2 +++ b/src/HOL/Cardinals/Wellorder_Embedding_FP.thy Thu Dec 05 17:58:03 2013 +0100
121.3 @@ -0,0 +1,1145 @@
121.4 +(* Title: HOL/Cardinals/Wellorder_Embedding_FP.thy
121.5 + Author: Andrei Popescu, TU Muenchen
121.6 + Copyright 2012
121.7 +
121.8 +Well-order embeddings (FP).
121.9 +*)
121.10 +
121.11 +header {* Well-Order Embeddings (FP) *}
121.12 +
121.13 +theory Wellorder_Embedding_FP
121.14 +imports "~~/src/HOL/Library/Zorn" Fun_More_FP Wellorder_Relation_FP
121.15 +begin
121.16 +
121.17 +
121.18 +text{* In this section, we introduce well-order {\em embeddings} and {\em isomorphisms} and
121.19 +prove their basic properties. The notion of embedding is considered from the point
121.20 +of view of the theory of ordinals, and therefore requires the source to be injected
121.21 +as an {\em initial segment} (i.e., {\em order filter}) of the target. A main result
121.22 +of this section is the existence of embeddings (in one direction or another) between
121.23 +any two well-orders, having as a consequence the fact that, given any two sets on
121.24 +any two types, one is smaller than (i.e., can be injected into) the other. *}
121.25 +
121.26 +
121.27 +subsection {* Auxiliaries *}
121.28 +
121.29 +lemma UNION_inj_on_ofilter:
121.30 +assumes WELL: "Well_order r" and
121.31 + OF: "\<And> i. i \<in> I \<Longrightarrow> wo_rel.ofilter r (A i)" and
121.32 + INJ: "\<And> i. i \<in> I \<Longrightarrow> inj_on f (A i)"
121.33 +shows "inj_on f (\<Union> i \<in> I. A i)"
121.34 +proof-
121.35 + have "wo_rel r" using WELL by (simp add: wo_rel_def)
121.36 + hence "\<And> i j. \<lbrakk>i \<in> I; j \<in> I\<rbrakk> \<Longrightarrow> A i <= A j \<or> A j <= A i"
121.37 + using wo_rel.ofilter_linord[of r] OF by blast
121.38 + with WELL INJ show ?thesis
121.39 + by (auto simp add: inj_on_UNION_chain)
121.40 +qed
121.41 +
121.42 +
121.43 +lemma under_underS_bij_betw:
121.44 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and
121.45 + IN: "a \<in> Field r" and IN': "f a \<in> Field r'" and
121.46 + BIJ: "bij_betw f (rel.underS r a) (rel.underS r' (f a))"
121.47 +shows "bij_betw f (rel.under r a) (rel.under r' (f a))"
121.48 +proof-
121.49 + have "a \<notin> rel.underS r a \<and> f a \<notin> rel.underS r' (f a)"
121.50 + unfolding rel.underS_def by auto
121.51 + moreover
121.52 + {have "Refl r \<and> Refl r'" using WELL WELL'
121.53 + by (auto simp add: order_on_defs)
121.54 + hence "rel.under r a = rel.underS r a \<union> {a} \<and>
121.55 + rel.under r' (f a) = rel.underS r' (f a) \<union> {f a}"
121.56 + using IN IN' by(auto simp add: rel.Refl_under_underS)
121.57 + }
121.58 + ultimately show ?thesis
121.59 + using BIJ notIn_Un_bij_betw[of a "rel.underS r a" f "rel.underS r' (f a)"] by auto
121.60 +qed
121.61 +
121.62 +
121.63 +
121.64 +subsection {* (Well-order) embeddings, strict embeddings, isomorphisms and order-compatible
121.65 +functions *}
121.66 +
121.67 +
121.68 +text{* Standardly, a function is an embedding of a well-order in another if it injectively and
121.69 +order-compatibly maps the former into an order filter of the latter.
121.70 +Here we opt for a more succinct definition (operator @{text "embed"}),
121.71 +asking that, for any element in the source, the function should be a bijection
121.72 +between the set of strict lower bounds of that element
121.73 +and the set of strict lower bounds of its image. (Later we prove equivalence with
121.74 +the standard definition -- lemma @{text "embed_iff_compat_inj_on_ofilter"}.)
121.75 +A {\em strict embedding} (operator @{text "embedS"}) is a non-bijective embedding
121.76 +and an isomorphism (operator @{text "iso"}) is a bijective embedding. *}
121.77 +
121.78 +
121.79 +definition embed :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> bool"
121.80 +where
121.81 +"embed r r' f \<equiv> \<forall>a \<in> Field r. bij_betw f (rel.under r a) (rel.under r' (f a))"
121.82 +
121.83 +
121.84 +lemmas embed_defs = embed_def embed_def[abs_def]
121.85 +
121.86 +
121.87 +text {* Strict embeddings: *}
121.88 +
121.89 +definition embedS :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> bool"
121.90 +where
121.91 +"embedS r r' f \<equiv> embed r r' f \<and> \<not> bij_betw f (Field r) (Field r')"
121.92 +
121.93 +
121.94 +lemmas embedS_defs = embedS_def embedS_def[abs_def]
121.95 +
121.96 +
121.97 +definition iso :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> bool"
121.98 +where
121.99 +"iso r r' f \<equiv> embed r r' f \<and> bij_betw f (Field r) (Field r')"
121.100 +
121.101 +
121.102 +lemmas iso_defs = iso_def iso_def[abs_def]
121.103 +
121.104 +
121.105 +definition compat :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> bool"
121.106 +where
121.107 +"compat r r' f \<equiv> \<forall>a b. (a,b) \<in> r \<longrightarrow> (f a, f b) \<in> r'"
121.108 +
121.109 +
121.110 +lemma compat_wf:
121.111 +assumes CMP: "compat r r' f" and WF: "wf r'"
121.112 +shows "wf r"
121.113 +proof-
121.114 + have "r \<le> inv_image r' f"
121.115 + unfolding inv_image_def using CMP
121.116 + by (auto simp add: compat_def)
121.117 + with WF show ?thesis
121.118 + using wf_inv_image[of r' f] wf_subset[of "inv_image r' f"] by auto
121.119 +qed
121.120 +
121.121 +
121.122 +lemma id_embed: "embed r r id"
121.123 +by(auto simp add: id_def embed_def bij_betw_def)
121.124 +
121.125 +
121.126 +lemma id_iso: "iso r r id"
121.127 +by(auto simp add: id_def embed_def iso_def bij_betw_def)
121.128 +
121.129 +
121.130 +lemma embed_in_Field:
121.131 +assumes WELL: "Well_order r" and
121.132 + EMB: "embed r r' f" and IN: "a \<in> Field r"
121.133 +shows "f a \<in> Field r'"
121.134 +proof-
121.135 + have Well: "wo_rel r"
121.136 + using WELL by (auto simp add: wo_rel_def)
121.137 + hence 1: "Refl r"
121.138 + by (auto simp add: wo_rel.REFL)
121.139 + hence "a \<in> rel.under r a" using IN rel.Refl_under_in by fastforce
121.140 + hence "f a \<in> rel.under r' (f a)"
121.141 + using EMB IN by (auto simp add: embed_def bij_betw_def)
121.142 + thus ?thesis unfolding Field_def
121.143 + by (auto simp: rel.under_def)
121.144 +qed
121.145 +
121.146 +
121.147 +lemma comp_embed:
121.148 +assumes WELL: "Well_order r" and
121.149 + EMB: "embed r r' f" and EMB': "embed r' r'' f'"
121.150 +shows "embed r r'' (f' o f)"
121.151 +proof(unfold embed_def, auto)
121.152 + fix a assume *: "a \<in> Field r"
121.153 + hence "bij_betw f (rel.under r a) (rel.under r' (f a))"
121.154 + using embed_def[of r] EMB by auto
121.155 + moreover
121.156 + {have "f a \<in> Field r'"
121.157 + using EMB WELL * by (auto simp add: embed_in_Field)
121.158 + hence "bij_betw f' (rel.under r' (f a)) (rel.under r'' (f' (f a)))"
121.159 + using embed_def[of r'] EMB' by auto
121.160 + }
121.161 + ultimately
121.162 + show "bij_betw (f' \<circ> f) (rel.under r a) (rel.under r'' (f'(f a)))"
121.163 + by(auto simp add: bij_betw_trans)
121.164 +qed
121.165 +
121.166 +
121.167 +lemma comp_iso:
121.168 +assumes WELL: "Well_order r" and
121.169 + EMB: "iso r r' f" and EMB': "iso r' r'' f'"
121.170 +shows "iso r r'' (f' o f)"
121.171 +using assms unfolding iso_def
121.172 +by (auto simp add: comp_embed bij_betw_trans)
121.173 +
121.174 +
121.175 +text{* That @{text "embedS"} is also preserved by function composition shall be proved only later. *}
121.176 +
121.177 +
121.178 +lemma embed_Field:
121.179 +"\<lbrakk>Well_order r; embed r r' f\<rbrakk> \<Longrightarrow> f`(Field r) \<le> Field r'"
121.180 +by (auto simp add: embed_in_Field)
121.181 +
121.182 +
121.183 +lemma embed_preserves_ofilter:
121.184 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and
121.185 + EMB: "embed r r' f" and OF: "wo_rel.ofilter r A"
121.186 +shows "wo_rel.ofilter r' (f`A)"
121.187 +proof-
121.188 + (* Preliminary facts *)
121.189 + from WELL have Well: "wo_rel r" unfolding wo_rel_def .
121.190 + from WELL' have Well': "wo_rel r'" unfolding wo_rel_def .
121.191 + from OF have 0: "A \<le> Field r" by(auto simp add: Well wo_rel.ofilter_def)
121.192 + (* Main proof *)
121.193 + show ?thesis using Well' WELL EMB 0 embed_Field[of r r' f]
121.194 + proof(unfold wo_rel.ofilter_def, auto simp add: image_def)
121.195 + fix a b'
121.196 + assume *: "a \<in> A" and **: "b' \<in> rel.under r' (f a)"
121.197 + hence "a \<in> Field r" using 0 by auto
121.198 + hence "bij_betw f (rel.under r a) (rel.under r' (f a))"
121.199 + using * EMB by (auto simp add: embed_def)
121.200 + hence "f`(rel.under r a) = rel.under r' (f a)"
121.201 + by (simp add: bij_betw_def)
121.202 + with ** image_def[of f "rel.under r a"] obtain b where
121.203 + 1: "b \<in> rel.under r a \<and> b' = f b" by blast
121.204 + hence "b \<in> A" using Well * OF
121.205 + by (auto simp add: wo_rel.ofilter_def)
121.206 + with 1 show "\<exists>b \<in> A. b' = f b" by blast
121.207 + qed
121.208 +qed
121.209 +
121.210 +
121.211 +lemma embed_Field_ofilter:
121.212 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and
121.213 + EMB: "embed r r' f"
121.214 +shows "wo_rel.ofilter r' (f`(Field r))"
121.215 +proof-
121.216 + have "wo_rel.ofilter r (Field r)"
121.217 + using WELL by (auto simp add: wo_rel_def wo_rel.Field_ofilter)
121.218 + with WELL WELL' EMB
121.219 + show ?thesis by (auto simp add: embed_preserves_ofilter)
121.220 +qed
121.221 +
121.222 +
121.223 +lemma embed_compat:
121.224 +assumes EMB: "embed r r' f"
121.225 +shows "compat r r' f"
121.226 +proof(unfold compat_def, clarify)
121.227 + fix a b
121.228 + assume *: "(a,b) \<in> r"
121.229 + hence 1: "b \<in> Field r" using Field_def[of r] by blast
121.230 + have "a \<in> rel.under r b"
121.231 + using * rel.under_def[of r] by simp
121.232 + hence "f a \<in> rel.under r' (f b)"
121.233 + using EMB embed_def[of r r' f]
121.234 + bij_betw_def[of f "rel.under r b" "rel.under r' (f b)"]
121.235 + image_def[of f "rel.under r b"] 1 by auto
121.236 + thus "(f a, f b) \<in> r'"
121.237 + by (auto simp add: rel.under_def)
121.238 +qed
121.239 +
121.240 +
121.241 +lemma embed_inj_on:
121.242 +assumes WELL: "Well_order r" and EMB: "embed r r' f"
121.243 +shows "inj_on f (Field r)"
121.244 +proof(unfold inj_on_def, clarify)
121.245 + (* Preliminary facts *)
121.246 + from WELL have Well: "wo_rel r" unfolding wo_rel_def .
121.247 + with wo_rel.TOTAL[of r]
121.248 + have Total: "Total r" by simp
121.249 + from Well wo_rel.REFL[of r]
121.250 + have Refl: "Refl r" by simp
121.251 + (* Main proof *)
121.252 + fix a b
121.253 + assume *: "a \<in> Field r" and **: "b \<in> Field r" and
121.254 + ***: "f a = f b"
121.255 + hence 1: "a \<in> Field r \<and> b \<in> Field r"
121.256 + unfolding Field_def by auto
121.257 + {assume "(a,b) \<in> r"
121.258 + hence "a \<in> rel.under r b \<and> b \<in> rel.under r b"
121.259 + using Refl by(auto simp add: rel.under_def refl_on_def)
121.260 + hence "a = b"
121.261 + using EMB 1 ***
121.262 + by (auto simp add: embed_def bij_betw_def inj_on_def)
121.263 + }
121.264 + moreover
121.265 + {assume "(b,a) \<in> r"
121.266 + hence "a \<in> rel.under r a \<and> b \<in> rel.under r a"
121.267 + using Refl by(auto simp add: rel.under_def refl_on_def)
121.268 + hence "a = b"
121.269 + using EMB 1 ***
121.270 + by (auto simp add: embed_def bij_betw_def inj_on_def)
121.271 + }
121.272 + ultimately
121.273 + show "a = b" using Total 1
121.274 + by (auto simp add: total_on_def)
121.275 +qed
121.276 +
121.277 +
121.278 +lemma embed_underS:
121.279 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and
121.280 + EMB: "embed r r' f" and IN: "a \<in> Field r"
121.281 +shows "bij_betw f (rel.underS r a) (rel.underS r' (f a))"
121.282 +proof-
121.283 + have "bij_betw f (rel.under r a) (rel.under r' (f a))"
121.284 + using assms by (auto simp add: embed_def)
121.285 + moreover
121.286 + {have "f a \<in> Field r'" using assms embed_Field[of r r' f] by auto
121.287 + hence "rel.under r a = rel.underS r a \<union> {a} \<and>
121.288 + rel.under r' (f a) = rel.underS r' (f a) \<union> {f a}"
121.289 + using assms by (auto simp add: order_on_defs rel.Refl_under_underS)
121.290 + }
121.291 + moreover
121.292 + {have "a \<notin> rel.underS r a \<and> f a \<notin> rel.underS r' (f a)"
121.293 + unfolding rel.underS_def by blast
121.294 + }
121.295 + ultimately show ?thesis
121.296 + by (auto simp add: notIn_Un_bij_betw3)
121.297 +qed
121.298 +
121.299 +
121.300 +lemma embed_iff_compat_inj_on_ofilter:
121.301 +assumes WELL: "Well_order r" and WELL': "Well_order r'"
121.302 +shows "embed r r' f = (compat r r' f \<and> inj_on f (Field r) \<and> wo_rel.ofilter r' (f`(Field r)))"
121.303 +using assms
121.304 +proof(auto simp add: embed_compat embed_inj_on embed_Field_ofilter,
121.305 + unfold embed_def, auto) (* get rid of one implication *)
121.306 + fix a
121.307 + assume *: "inj_on f (Field r)" and
121.308 + **: "compat r r' f" and
121.309 + ***: "wo_rel.ofilter r' (f`(Field r))" and
121.310 + ****: "a \<in> Field r"
121.311 + (* Preliminary facts *)
121.312 + have Well: "wo_rel r"
121.313 + using WELL wo_rel_def[of r] by simp
121.314 + hence Refl: "Refl r"
121.315 + using wo_rel.REFL[of r] by simp
121.316 + have Total: "Total r"
121.317 + using Well wo_rel.TOTAL[of r] by simp
121.318 + have Well': "wo_rel r'"
121.319 + using WELL' wo_rel_def[of r'] by simp
121.320 + hence Antisym': "antisym r'"
121.321 + using wo_rel.ANTISYM[of r'] by simp
121.322 + have "(a,a) \<in> r"
121.323 + using **** Well wo_rel.REFL[of r]
121.324 + refl_on_def[of _ r] by auto
121.325 + hence "(f a, f a) \<in> r'"
121.326 + using ** by(auto simp add: compat_def)
121.327 + hence 0: "f a \<in> Field r'"
121.328 + unfolding Field_def by auto
121.329 + have "f a \<in> f`(Field r)"
121.330 + using **** by auto
121.331 + hence 2: "rel.under r' (f a) \<le> f`(Field r)"
121.332 + using Well' *** wo_rel.ofilter_def[of r' "f`(Field r)"] by fastforce
121.333 + (* Main proof *)
121.334 + show "bij_betw f (rel.under r a) (rel.under r' (f a))"
121.335 + proof(unfold bij_betw_def, auto)
121.336 + show "inj_on f (rel.under r a)"
121.337 + using * by (metis (no_types) rel.under_Field subset_inj_on)
121.338 + next
121.339 + fix b assume "b \<in> rel.under r a"
121.340 + thus "f b \<in> rel.under r' (f a)"
121.341 + unfolding rel.under_def using **
121.342 + by (auto simp add: compat_def)
121.343 + next
121.344 + fix b' assume *****: "b' \<in> rel.under r' (f a)"
121.345 + hence "b' \<in> f`(Field r)"
121.346 + using 2 by auto
121.347 + with Field_def[of r] obtain b where
121.348 + 3: "b \<in> Field r" and 4: "b' = f b" by auto
121.349 + have "(b,a): r"
121.350 + proof-
121.351 + {assume "(a,b) \<in> r"
121.352 + with ** 4 have "(f a, b'): r'"
121.353 + by (auto simp add: compat_def)
121.354 + with ***** Antisym' have "f a = b'"
121.355 + by(auto simp add: rel.under_def antisym_def)
121.356 + with 3 **** 4 * have "a = b"
121.357 + by(auto simp add: inj_on_def)
121.358 + }
121.359 + moreover
121.360 + {assume "a = b"
121.361 + hence "(b,a) \<in> r" using Refl **** 3
121.362 + by (auto simp add: refl_on_def)
121.363 + }
121.364 + ultimately
121.365 + show ?thesis using Total **** 3 by (fastforce simp add: total_on_def)
121.366 + qed
121.367 + with 4 show "b' \<in> f`(rel.under r a)"
121.368 + unfolding rel.under_def by auto
121.369 + qed
121.370 +qed
121.371 +
121.372 +
121.373 +lemma inv_into_ofilter_embed:
121.374 +assumes WELL: "Well_order r" and OF: "wo_rel.ofilter r A" and
121.375 + BIJ: "\<forall>b \<in> A. bij_betw f (rel.under r b) (rel.under r' (f b))" and
121.376 + IMAGE: "f ` A = Field r'"
121.377 +shows "embed r' r (inv_into A f)"
121.378 +proof-
121.379 + (* Preliminary facts *)
121.380 + have Well: "wo_rel r"
121.381 + using WELL wo_rel_def[of r] by simp
121.382 + have Refl: "Refl r"
121.383 + using Well wo_rel.REFL[of r] by simp
121.384 + have Total: "Total r"
121.385 + using Well wo_rel.TOTAL[of r] by simp
121.386 + (* Main proof *)
121.387 + have 1: "bij_betw f A (Field r')"
121.388 + proof(unfold bij_betw_def inj_on_def, auto simp add: IMAGE)
121.389 + fix b1 b2
121.390 + assume *: "b1 \<in> A" and **: "b2 \<in> A" and
121.391 + ***: "f b1 = f b2"
121.392 + have 11: "b1 \<in> Field r \<and> b2 \<in> Field r"
121.393 + using * ** Well OF by (auto simp add: wo_rel.ofilter_def)
121.394 + moreover
121.395 + {assume "(b1,b2) \<in> r"
121.396 + hence "b1 \<in> rel.under r b2 \<and> b2 \<in> rel.under r b2"
121.397 + unfolding rel.under_def using 11 Refl
121.398 + by (auto simp add: refl_on_def)
121.399 + hence "b1 = b2" using BIJ * ** ***
121.400 + by (simp add: bij_betw_def inj_on_def)
121.401 + }
121.402 + moreover
121.403 + {assume "(b2,b1) \<in> r"
121.404 + hence "b1 \<in> rel.under r b1 \<and> b2 \<in> rel.under r b1"
121.405 + unfolding rel.under_def using 11 Refl
121.406 + by (auto simp add: refl_on_def)
121.407 + hence "b1 = b2" using BIJ * ** ***
121.408 + by (simp add: bij_betw_def inj_on_def)
121.409 + }
121.410 + ultimately
121.411 + show "b1 = b2"
121.412 + using Total by (auto simp add: total_on_def)
121.413 + qed
121.414 + (* *)
121.415 + let ?f' = "(inv_into A f)"
121.416 + (* *)
121.417 + have 2: "\<forall>b \<in> A. bij_betw ?f' (rel.under r' (f b)) (rel.under r b)"
121.418 + proof(clarify)
121.419 + fix b assume *: "b \<in> A"
121.420 + hence "rel.under r b \<le> A"
121.421 + using Well OF by(auto simp add: wo_rel.ofilter_def)
121.422 + moreover
121.423 + have "f ` (rel.under r b) = rel.under r' (f b)"
121.424 + using * BIJ by (auto simp add: bij_betw_def)
121.425 + ultimately
121.426 + show "bij_betw ?f' (rel.under r' (f b)) (rel.under r b)"
121.427 + using 1 by (auto simp add: bij_betw_inv_into_subset)
121.428 + qed
121.429 + (* *)
121.430 + have 3: "\<forall>b' \<in> Field r'. bij_betw ?f' (rel.under r' b') (rel.under r (?f' b'))"
121.431 + proof(clarify)
121.432 + fix b' assume *: "b' \<in> Field r'"
121.433 + have "b' = f (?f' b')" using * 1
121.434 + by (auto simp add: bij_betw_inv_into_right)
121.435 + moreover
121.436 + {obtain b where 31: "b \<in> A" and "f b = b'" using IMAGE * by force
121.437 + hence "?f' b' = b" using 1 by (auto simp add: bij_betw_inv_into_left)
121.438 + with 31 have "?f' b' \<in> A" by auto
121.439 + }
121.440 + ultimately
121.441 + show "bij_betw ?f' (rel.under r' b') (rel.under r (?f' b'))"
121.442 + using 2 by auto
121.443 + qed
121.444 + (* *)
121.445 + thus ?thesis unfolding embed_def .
121.446 +qed
121.447 +
121.448 +
121.449 +lemma inv_into_underS_embed:
121.450 +assumes WELL: "Well_order r" and
121.451 + BIJ: "\<forall>b \<in> rel.underS r a. bij_betw f (rel.under r b) (rel.under r' (f b))" and
121.452 + IN: "a \<in> Field r" and
121.453 + IMAGE: "f ` (rel.underS r a) = Field r'"
121.454 +shows "embed r' r (inv_into (rel.underS r a) f)"
121.455 +using assms
121.456 +by(auto simp add: wo_rel_def wo_rel.underS_ofilter inv_into_ofilter_embed)
121.457 +
121.458 +
121.459 +lemma inv_into_Field_embed:
121.460 +assumes WELL: "Well_order r" and EMB: "embed r r' f" and
121.461 + IMAGE: "Field r' \<le> f ` (Field r)"
121.462 +shows "embed r' r (inv_into (Field r) f)"
121.463 +proof-
121.464 + have "(\<forall>b \<in> Field r. bij_betw f (rel.under r b) (rel.under r' (f b)))"
121.465 + using EMB by (auto simp add: embed_def)
121.466 + moreover
121.467 + have "f ` (Field r) \<le> Field r'"
121.468 + using EMB WELL by (auto simp add: embed_Field)
121.469 + ultimately
121.470 + show ?thesis using assms
121.471 + by(auto simp add: wo_rel_def wo_rel.Field_ofilter inv_into_ofilter_embed)
121.472 +qed
121.473 +
121.474 +
121.475 +lemma inv_into_Field_embed_bij_betw:
121.476 +assumes WELL: "Well_order r" and
121.477 + EMB: "embed r r' f" and BIJ: "bij_betw f (Field r) (Field r')"
121.478 +shows "embed r' r (inv_into (Field r) f)"
121.479 +proof-
121.480 + have "Field r' \<le> f ` (Field r)"
121.481 + using BIJ by (auto simp add: bij_betw_def)
121.482 + thus ?thesis using assms
121.483 + by(auto simp add: inv_into_Field_embed)
121.484 +qed
121.485 +
121.486 +
121.487 +
121.488 +
121.489 +
121.490 +subsection {* Given any two well-orders, one can be embedded in the other *}
121.491 +
121.492 +
121.493 +text{* Here is an overview of the proof of of this fact, stated in theorem
121.494 +@{text "wellorders_totally_ordered"}:
121.495 +
121.496 + Fix the well-orders @{text "r::'a rel"} and @{text "r'::'a' rel"}.
121.497 + Attempt to define an embedding @{text "f::'a \<Rightarrow> 'a'"} from @{text "r"} to @{text "r'"} in the
121.498 + natural way by well-order recursion ("hoping" that @{text "Field r"} turns out to be smaller
121.499 + than @{text "Field r'"}), but also record, at the recursive step, in a function
121.500 + @{text "g::'a \<Rightarrow> bool"}, the extra information of whether @{text "Field r'"}
121.501 + gets exhausted or not.
121.502 +
121.503 + If @{text "Field r'"} does not get exhausted, then @{text "Field r"} is indeed smaller
121.504 + and @{text "f"} is the desired embedding from @{text "r"} to @{text "r'"}
121.505 + (lemma @{text "wellorders_totally_ordered_aux"}).
121.506 +
121.507 + Otherwise, it means that @{text "Field r'"} is the smaller one, and the inverse of
121.508 + (the "good" segment of) @{text "f"} is the desired embedding from @{text "r'"} to @{text "r"}
121.509 + (lemma @{text "wellorders_totally_ordered_aux2"}).
121.510 +*}
121.511 +
121.512 +
121.513 +lemma wellorders_totally_ordered_aux:
121.514 +fixes r ::"'a rel" and r'::"'a' rel" and
121.515 + f :: "'a \<Rightarrow> 'a'" and a::'a
121.516 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and IN: "a \<in> Field r" and
121.517 + IH: "\<forall>b \<in> rel.underS r a. bij_betw f (rel.under r b) (rel.under r' (f b))" and
121.518 + NOT: "f ` (rel.underS r a) \<noteq> Field r'" and SUC: "f a = wo_rel.suc r' (f`(rel.underS r a))"
121.519 +shows "bij_betw f (rel.under r a) (rel.under r' (f a))"
121.520 +proof-
121.521 + (* Preliminary facts *)
121.522 + have Well: "wo_rel r" using WELL unfolding wo_rel_def .
121.523 + hence Refl: "Refl r" using wo_rel.REFL[of r] by auto
121.524 + have Trans: "trans r" using Well wo_rel.TRANS[of r] by auto
121.525 + have Well': "wo_rel r'" using WELL' unfolding wo_rel_def .
121.526 + have OF: "wo_rel.ofilter r (rel.underS r a)"
121.527 + by (auto simp add: Well wo_rel.underS_ofilter)
121.528 + hence UN: "rel.underS r a = (\<Union> b \<in> rel.underS r a. rel.under r b)"
121.529 + using Well wo_rel.ofilter_under_UNION[of r "rel.underS r a"] by blast
121.530 + (* Gather facts about elements of rel.underS r a *)
121.531 + {fix b assume *: "b \<in> rel.underS r a"
121.532 + hence t0: "(b,a) \<in> r \<and> b \<noteq> a" unfolding rel.underS_def by auto
121.533 + have t1: "b \<in> Field r"
121.534 + using * rel.underS_Field[of r a] by auto
121.535 + have t2: "f`(rel.under r b) = rel.under r' (f b)"
121.536 + using IH * by (auto simp add: bij_betw_def)
121.537 + hence t3: "wo_rel.ofilter r' (f`(rel.under r b))"
121.538 + using Well' by (auto simp add: wo_rel.under_ofilter)
121.539 + have "f`(rel.under r b) \<le> Field r'"
121.540 + using t2 by (auto simp add: rel.under_Field)
121.541 + moreover
121.542 + have "b \<in> rel.under r b"
121.543 + using t1 by(auto simp add: Refl rel.Refl_under_in)
121.544 + ultimately
121.545 + have t4: "f b \<in> Field r'" by auto
121.546 + have "f`(rel.under r b) = rel.under r' (f b) \<and>
121.547 + wo_rel.ofilter r' (f`(rel.under r b)) \<and>
121.548 + f b \<in> Field r'"
121.549 + using t2 t3 t4 by auto
121.550 + }
121.551 + hence bFact:
121.552 + "\<forall>b \<in> rel.underS r a. f`(rel.under r b) = rel.under r' (f b) \<and>
121.553 + wo_rel.ofilter r' (f`(rel.under r b)) \<and>
121.554 + f b \<in> Field r'" by blast
121.555 + (* *)
121.556 + have subField: "f`(rel.underS r a) \<le> Field r'"
121.557 + using bFact by blast
121.558 + (* *)
121.559 + have OF': "wo_rel.ofilter r' (f`(rel.underS r a))"
121.560 + proof-
121.561 + have "f`(rel.underS r a) = f`(\<Union> b \<in> rel.underS r a. rel.under r b)"
121.562 + using UN by auto
121.563 + also have "\<dots> = (\<Union> b \<in> rel.underS r a. f`(rel.under r b))" by blast
121.564 + also have "\<dots> = (\<Union> b \<in> rel.underS r a. (rel.under r' (f b)))"
121.565 + using bFact by auto
121.566 + finally
121.567 + have "f`(rel.underS r a) = (\<Union> b \<in> rel.underS r a. (rel.under r' (f b)))" .
121.568 + thus ?thesis
121.569 + using Well' bFact
121.570 + wo_rel.ofilter_UNION[of r' "rel.underS r a" "\<lambda> b. rel.under r' (f b)"] by fastforce
121.571 + qed
121.572 + (* *)
121.573 + have "f`(rel.underS r a) \<union> rel.AboveS r' (f`(rel.underS r a)) = Field r'"
121.574 + using Well' OF' by (auto simp add: wo_rel.ofilter_AboveS_Field)
121.575 + hence NE: "rel.AboveS r' (f`(rel.underS r a)) \<noteq> {}"
121.576 + using subField NOT by blast
121.577 + (* Main proof *)
121.578 + have INCL1: "f`(rel.underS r a) \<le> rel.underS r' (f a) "
121.579 + proof(auto)
121.580 + fix b assume *: "b \<in> rel.underS r a"
121.581 + have "f b \<noteq> f a \<and> (f b, f a) \<in> r'"
121.582 + using subField Well' SUC NE *
121.583 + wo_rel.suc_greater[of r' "f`(rel.underS r a)" "f b"] by force
121.584 + thus "f b \<in> rel.underS r' (f a)"
121.585 + unfolding rel.underS_def by simp
121.586 + qed
121.587 + (* *)
121.588 + have INCL2: "rel.underS r' (f a) \<le> f`(rel.underS r a)"
121.589 + proof
121.590 + fix b' assume "b' \<in> rel.underS r' (f a)"
121.591 + hence "b' \<noteq> f a \<and> (b', f a) \<in> r'"
121.592 + unfolding rel.underS_def by simp
121.593 + thus "b' \<in> f`(rel.underS r a)"
121.594 + using Well' SUC NE OF'
121.595 + wo_rel.suc_ofilter_in[of r' "f ` rel.underS r a" b'] by auto
121.596 + qed
121.597 + (* *)
121.598 + have INJ: "inj_on f (rel.underS r a)"
121.599 + proof-
121.600 + have "\<forall>b \<in> rel.underS r a. inj_on f (rel.under r b)"
121.601 + using IH by (auto simp add: bij_betw_def)
121.602 + moreover
121.603 + have "\<forall>b. wo_rel.ofilter r (rel.under r b)"
121.604 + using Well by (auto simp add: wo_rel.under_ofilter)
121.605 + ultimately show ?thesis
121.606 + using WELL bFact UN
121.607 + UNION_inj_on_ofilter[of r "rel.underS r a" "\<lambda>b. rel.under r b" f]
121.608 + by auto
121.609 + qed
121.610 + (* *)
121.611 + have BIJ: "bij_betw f (rel.underS r a) (rel.underS r' (f a))"
121.612 + unfolding bij_betw_def
121.613 + using INJ INCL1 INCL2 by auto
121.614 + (* *)
121.615 + have "f a \<in> Field r'"
121.616 + using Well' subField NE SUC
121.617 + by (auto simp add: wo_rel.suc_inField)
121.618 + thus ?thesis
121.619 + using WELL WELL' IN BIJ under_underS_bij_betw[of r r' a f] by auto
121.620 +qed
121.621 +
121.622 +
121.623 +lemma wellorders_totally_ordered_aux2:
121.624 +fixes r ::"'a rel" and r'::"'a' rel" and
121.625 + f :: "'a \<Rightarrow> 'a'" and g :: "'a \<Rightarrow> bool" and a::'a
121.626 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and
121.627 +MAIN1:
121.628 + "\<And> a. (False \<notin> g`(rel.underS r a) \<and> f`(rel.underS r a) \<noteq> Field r'
121.629 + \<longrightarrow> f a = wo_rel.suc r' (f`(rel.underS r a)) \<and> g a = True)
121.630 + \<and>
121.631 + (\<not>(False \<notin> (g`(rel.underS r a)) \<and> f`(rel.underS r a) \<noteq> Field r')
121.632 + \<longrightarrow> g a = False)" and
121.633 +MAIN2: "\<And> a. a \<in> Field r \<and> False \<notin> g`(rel.under r a) \<longrightarrow>
121.634 + bij_betw f (rel.under r a) (rel.under r' (f a))" and
121.635 +Case: "a \<in> Field r \<and> False \<in> g`(rel.under r a)"
121.636 +shows "\<exists>f'. embed r' r f'"
121.637 +proof-
121.638 + have Well: "wo_rel r" using WELL unfolding wo_rel_def .
121.639 + hence Refl: "Refl r" using wo_rel.REFL[of r] by auto
121.640 + have Trans: "trans r" using Well wo_rel.TRANS[of r] by auto
121.641 + have Antisym: "antisym r" using Well wo_rel.ANTISYM[of r] by auto
121.642 + have Well': "wo_rel r'" using WELL' unfolding wo_rel_def .
121.643 + (* *)
121.644 + have 0: "rel.under r a = rel.underS r a \<union> {a}"
121.645 + using Refl Case by(auto simp add: rel.Refl_under_underS)
121.646 + (* *)
121.647 + have 1: "g a = False"
121.648 + proof-
121.649 + {assume "g a \<noteq> False"
121.650 + with 0 Case have "False \<in> g`(rel.underS r a)" by blast
121.651 + with MAIN1 have "g a = False" by blast}
121.652 + thus ?thesis by blast
121.653 + qed
121.654 + let ?A = "{a \<in> Field r. g a = False}"
121.655 + let ?a = "(wo_rel.minim r ?A)"
121.656 + (* *)
121.657 + have 2: "?A \<noteq> {} \<and> ?A \<le> Field r" using Case 1 by blast
121.658 + (* *)
121.659 + have 3: "False \<notin> g`(rel.underS r ?a)"
121.660 + proof
121.661 + assume "False \<in> g`(rel.underS r ?a)"
121.662 + then obtain b where "b \<in> rel.underS r ?a" and 31: "g b = False" by auto
121.663 + hence 32: "(b,?a) \<in> r \<and> b \<noteq> ?a"
121.664 + by (auto simp add: rel.underS_def)
121.665 + hence "b \<in> Field r" unfolding Field_def by auto
121.666 + with 31 have "b \<in> ?A" by auto
121.667 + hence "(?a,b) \<in> r" using wo_rel.minim_least 2 Well by fastforce
121.668 + (* again: why worked without type annotations? *)
121.669 + with 32 Antisym show False
121.670 + by (auto simp add: antisym_def)
121.671 + qed
121.672 + have temp: "?a \<in> ?A"
121.673 + using Well 2 wo_rel.minim_in[of r ?A] by auto
121.674 + hence 4: "?a \<in> Field r" by auto
121.675 + (* *)
121.676 + have 5: "g ?a = False" using temp by blast
121.677 + (* *)
121.678 + have 6: "f`(rel.underS r ?a) = Field r'"
121.679 + using MAIN1[of ?a] 3 5 by blast
121.680 + (* *)
121.681 + have 7: "\<forall>b \<in> rel.underS r ?a. bij_betw f (rel.under r b) (rel.under r' (f b))"
121.682 + proof
121.683 + fix b assume as: "b \<in> rel.underS r ?a"
121.684 + moreover
121.685 + have "wo_rel.ofilter r (rel.underS r ?a)"
121.686 + using Well by (auto simp add: wo_rel.underS_ofilter)
121.687 + ultimately
121.688 + have "False \<notin> g`(rel.under r b)" using 3 Well by (subst (asm) wo_rel.ofilter_def) fast+
121.689 + moreover have "b \<in> Field r"
121.690 + unfolding Field_def using as by (auto simp add: rel.underS_def)
121.691 + ultimately
121.692 + show "bij_betw f (rel.under r b) (rel.under r' (f b))"
121.693 + using MAIN2 by auto
121.694 + qed
121.695 + (* *)
121.696 + have "embed r' r (inv_into (rel.underS r ?a) f)"
121.697 + using WELL WELL' 7 4 6 inv_into_underS_embed[of r ?a f r'] by auto
121.698 + thus ?thesis
121.699 + unfolding embed_def by blast
121.700 +qed
121.701 +
121.702 +
121.703 +theorem wellorders_totally_ordered:
121.704 +fixes r ::"'a rel" and r'::"'a' rel"
121.705 +assumes WELL: "Well_order r" and WELL': "Well_order r'"
121.706 +shows "(\<exists>f. embed r r' f) \<or> (\<exists>f'. embed r' r f')"
121.707 +proof-
121.708 + (* Preliminary facts *)
121.709 + have Well: "wo_rel r" using WELL unfolding wo_rel_def .
121.710 + hence Refl: "Refl r" using wo_rel.REFL[of r] by auto
121.711 + have Trans: "trans r" using Well wo_rel.TRANS[of r] by auto
121.712 + have Well': "wo_rel r'" using WELL' unfolding wo_rel_def .
121.713 + (* Main proof *)
121.714 + obtain H where H_def: "H =
121.715 + (\<lambda>h a. if False \<notin> (snd o h)`(rel.underS r a) \<and> (fst o h)`(rel.underS r a) \<noteq> Field r'
121.716 + then (wo_rel.suc r' ((fst o h)`(rel.underS r a)), True)
121.717 + else (undefined, False))" by blast
121.718 + have Adm: "wo_rel.adm_wo r H"
121.719 + using Well
121.720 + proof(unfold wo_rel.adm_wo_def, clarify)
121.721 + fix h1::"'a \<Rightarrow> 'a' * bool" and h2::"'a \<Rightarrow> 'a' * bool" and x
121.722 + assume "\<forall>y\<in>rel.underS r x. h1 y = h2 y"
121.723 + hence "\<forall>y\<in>rel.underS r x. (fst o h1) y = (fst o h2) y \<and>
121.724 + (snd o h1) y = (snd o h2) y" by auto
121.725 + hence "(fst o h1)`(rel.underS r x) = (fst o h2)`(rel.underS r x) \<and>
121.726 + (snd o h1)`(rel.underS r x) = (snd o h2)`(rel.underS r x)"
121.727 + by (auto simp add: image_def)
121.728 + thus "H h1 x = H h2 x" by (simp add: H_def del: not_False_in_image_Ball)
121.729 + qed
121.730 + (* More constant definitions: *)
121.731 + obtain h::"'a \<Rightarrow> 'a' * bool" and f::"'a \<Rightarrow> 'a'" and g::"'a \<Rightarrow> bool"
121.732 + where h_def: "h = wo_rel.worec r H" and
121.733 + f_def: "f = fst o h" and g_def: "g = snd o h" by blast
121.734 + obtain test where test_def:
121.735 + "test = (\<lambda> a. False \<notin> (g`(rel.underS r a)) \<and> f`(rel.underS r a) \<noteq> Field r')" by blast
121.736 + (* *)
121.737 + have *: "\<And> a. h a = H h a"
121.738 + using Adm Well wo_rel.worec_fixpoint[of r H] by (simp add: h_def)
121.739 + have Main1:
121.740 + "\<And> a. (test a \<longrightarrow> f a = wo_rel.suc r' (f`(rel.underS r a)) \<and> g a = True) \<and>
121.741 + (\<not>(test a) \<longrightarrow> g a = False)"
121.742 + proof- (* How can I prove this withou fixing a? *)
121.743 + fix a show "(test a \<longrightarrow> f a = wo_rel.suc r' (f`(rel.underS r a)) \<and> g a = True) \<and>
121.744 + (\<not>(test a) \<longrightarrow> g a = False)"
121.745 + using *[of a] test_def f_def g_def H_def by auto
121.746 + qed
121.747 + (* *)
121.748 + let ?phi = "\<lambda> a. a \<in> Field r \<and> False \<notin> g`(rel.under r a) \<longrightarrow>
121.749 + bij_betw f (rel.under r a) (rel.under r' (f a))"
121.750 + have Main2: "\<And> a. ?phi a"
121.751 + proof-
121.752 + fix a show "?phi a"
121.753 + proof(rule wo_rel.well_order_induct[of r ?phi],
121.754 + simp only: Well, clarify)
121.755 + fix a
121.756 + assume IH: "\<forall>b. b \<noteq> a \<and> (b,a) \<in> r \<longrightarrow> ?phi b" and
121.757 + *: "a \<in> Field r" and
121.758 + **: "False \<notin> g`(rel.under r a)"
121.759 + have 1: "\<forall>b \<in> rel.underS r a. bij_betw f (rel.under r b) (rel.under r' (f b))"
121.760 + proof(clarify)
121.761 + fix b assume ***: "b \<in> rel.underS r a"
121.762 + hence 0: "(b,a) \<in> r \<and> b \<noteq> a" unfolding rel.underS_def by auto
121.763 + moreover have "b \<in> Field r"
121.764 + using *** rel.underS_Field[of r a] by auto
121.765 + moreover have "False \<notin> g`(rel.under r b)"
121.766 + using 0 ** Trans rel.under_incr[of r b a] by auto
121.767 + ultimately show "bij_betw f (rel.under r b) (rel.under r' (f b))"
121.768 + using IH by auto
121.769 + qed
121.770 + (* *)
121.771 + have 21: "False \<notin> g`(rel.underS r a)"
121.772 + using ** rel.underS_subset_under[of r a] by auto
121.773 + have 22: "g`(rel.under r a) \<le> {True}" using ** by auto
121.774 + moreover have 23: "a \<in> rel.under r a"
121.775 + using Refl * by (auto simp add: rel.Refl_under_in)
121.776 + ultimately have 24: "g a = True" by blast
121.777 + have 2: "f`(rel.underS r a) \<noteq> Field r'"
121.778 + proof
121.779 + assume "f`(rel.underS r a) = Field r'"
121.780 + hence "g a = False" using Main1 test_def by blast
121.781 + with 24 show False using ** by blast
121.782 + qed
121.783 + (* *)
121.784 + have 3: "f a = wo_rel.suc r' (f`(rel.underS r a))"
121.785 + using 21 2 Main1 test_def by blast
121.786 + (* *)
121.787 + show "bij_betw f (rel.under r a) (rel.under r' (f a))"
121.788 + using WELL WELL' 1 2 3 *
121.789 + wellorders_totally_ordered_aux[of r r' a f] by auto
121.790 + qed
121.791 + qed
121.792 + (* *)
121.793 + let ?chi = "(\<lambda> a. a \<in> Field r \<and> False \<in> g`(rel.under r a))"
121.794 + show ?thesis
121.795 + proof(cases "\<exists>a. ?chi a")
121.796 + assume "\<not> (\<exists>a. ?chi a)"
121.797 + hence "\<forall>a \<in> Field r. bij_betw f (rel.under r a) (rel.under r' (f a))"
121.798 + using Main2 by blast
121.799 + thus ?thesis unfolding embed_def by blast
121.800 + next
121.801 + assume "\<exists>a. ?chi a"
121.802 + then obtain a where "?chi a" by blast
121.803 + hence "\<exists>f'. embed r' r f'"
121.804 + using wellorders_totally_ordered_aux2[of r r' g f a]
121.805 + WELL WELL' Main1 Main2 test_def by fast
121.806 + thus ?thesis by blast
121.807 + qed
121.808 +qed
121.809 +
121.810 +
121.811 +subsection {* Uniqueness of embeddings *}
121.812 +
121.813 +
121.814 +text{* Here we show a fact complementary to the one from the previous subsection -- namely,
121.815 +that between any two well-orders there is {\em at most} one embedding, and is the one
121.816 +definable by the expected well-order recursive equation. As a consequence, any two
121.817 +embeddings of opposite directions are mutually inverse. *}
121.818 +
121.819 +
121.820 +lemma embed_determined:
121.821 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and
121.822 + EMB: "embed r r' f" and IN: "a \<in> Field r"
121.823 +shows "f a = wo_rel.suc r' (f`(rel.underS r a))"
121.824 +proof-
121.825 + have "bij_betw f (rel.underS r a) (rel.underS r' (f a))"
121.826 + using assms by (auto simp add: embed_underS)
121.827 + hence "f`(rel.underS r a) = rel.underS r' (f a)"
121.828 + by (auto simp add: bij_betw_def)
121.829 + moreover
121.830 + {have "f a \<in> Field r'" using IN
121.831 + using EMB WELL embed_Field[of r r' f] by auto
121.832 + hence "f a = wo_rel.suc r' (rel.underS r' (f a))"
121.833 + using WELL' by (auto simp add: wo_rel_def wo_rel.suc_underS)
121.834 + }
121.835 + ultimately show ?thesis by simp
121.836 +qed
121.837 +
121.838 +
121.839 +lemma embed_unique:
121.840 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and
121.841 + EMBf: "embed r r' f" and EMBg: "embed r r' g"
121.842 +shows "a \<in> Field r \<longrightarrow> f a = g a"
121.843 +proof(rule wo_rel.well_order_induct[of r], auto simp add: WELL wo_rel_def)
121.844 + fix a
121.845 + assume IH: "\<forall>b. b \<noteq> a \<and> (b,a): r \<longrightarrow> b \<in> Field r \<longrightarrow> f b = g b" and
121.846 + *: "a \<in> Field r"
121.847 + hence "\<forall>b \<in> rel.underS r a. f b = g b"
121.848 + unfolding rel.underS_def by (auto simp add: Field_def)
121.849 + hence "f`(rel.underS r a) = g`(rel.underS r a)" by force
121.850 + thus "f a = g a"
121.851 + using assms * embed_determined[of r r' f a] embed_determined[of r r' g a] by auto
121.852 +qed
121.853 +
121.854 +
121.855 +lemma embed_bothWays_inverse:
121.856 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and
121.857 + EMB: "embed r r' f" and EMB': "embed r' r f'"
121.858 +shows "(\<forall>a \<in> Field r. f'(f a) = a) \<and> (\<forall>a' \<in> Field r'. f(f' a') = a')"
121.859 +proof-
121.860 + have "embed r r (f' o f)" using assms
121.861 + by(auto simp add: comp_embed)
121.862 + moreover have "embed r r id" using assms
121.863 + by (auto simp add: id_embed)
121.864 + ultimately have "\<forall>a \<in> Field r. f'(f a) = a"
121.865 + using assms embed_unique[of r r "f' o f" id] id_def by auto
121.866 + moreover
121.867 + {have "embed r' r' (f o f')" using assms
121.868 + by(auto simp add: comp_embed)
121.869 + moreover have "embed r' r' id" using assms
121.870 + by (auto simp add: id_embed)
121.871 + ultimately have "\<forall>a' \<in> Field r'. f(f' a') = a'"
121.872 + using assms embed_unique[of r' r' "f o f'" id] id_def by auto
121.873 + }
121.874 + ultimately show ?thesis by blast
121.875 +qed
121.876 +
121.877 +
121.878 +lemma embed_bothWays_bij_betw:
121.879 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and
121.880 + EMB: "embed r r' f" and EMB': "embed r' r g"
121.881 +shows "bij_betw f (Field r) (Field r')"
121.882 +proof-
121.883 + let ?A = "Field r" let ?A' = "Field r'"
121.884 + have "embed r r (g o f) \<and> embed r' r' (f o g)"
121.885 + using assms by (auto simp add: comp_embed)
121.886 + hence 1: "(\<forall>a \<in> ?A. g(f a) = a) \<and> (\<forall>a' \<in> ?A'. f(g a') = a')"
121.887 + using WELL id_embed[of r] embed_unique[of r r "g o f" id]
121.888 + WELL' id_embed[of r'] embed_unique[of r' r' "f o g" id]
121.889 + id_def by auto
121.890 + have 2: "(\<forall>a \<in> ?A. f a \<in> ?A') \<and> (\<forall>a' \<in> ?A'. g a' \<in> ?A)"
121.891 + using assms embed_Field[of r r' f] embed_Field[of r' r g] by blast
121.892 + (* *)
121.893 + show ?thesis
121.894 + proof(unfold bij_betw_def inj_on_def, auto simp add: 2)
121.895 + fix a b assume *: "a \<in> ?A" "b \<in> ?A" and **: "f a = f b"
121.896 + have "a = g(f a) \<and> b = g(f b)" using * 1 by auto
121.897 + with ** show "a = b" by auto
121.898 + next
121.899 + fix a' assume *: "a' \<in> ?A'"
121.900 + hence "g a' \<in> ?A \<and> f(g a') = a'" using 1 2 by auto
121.901 + thus "a' \<in> f ` ?A" by force
121.902 + qed
121.903 +qed
121.904 +
121.905 +
121.906 +lemma embed_bothWays_iso:
121.907 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and
121.908 + EMB: "embed r r' f" and EMB': "embed r' r g"
121.909 +shows "iso r r' f"
121.910 +unfolding iso_def using assms by (auto simp add: embed_bothWays_bij_betw)
121.911 +
121.912 +
121.913 +subsection {* More properties of embeddings, strict embeddings and isomorphisms *}
121.914 +
121.915 +
121.916 +lemma embed_bothWays_Field_bij_betw:
121.917 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and
121.918 + EMB: "embed r r' f" and EMB': "embed r' r f'"
121.919 +shows "bij_betw f (Field r) (Field r')"
121.920 +proof-
121.921 + have "(\<forall>a \<in> Field r. f'(f a) = a) \<and> (\<forall>a' \<in> Field r'. f(f' a') = a')"
121.922 + using assms by (auto simp add: embed_bothWays_inverse)
121.923 + moreover
121.924 + have "f`(Field r) \<le> Field r' \<and> f' ` (Field r') \<le> Field r"
121.925 + using assms by (auto simp add: embed_Field)
121.926 + ultimately
121.927 + show ?thesis using bij_betw_byWitness[of "Field r" f' f "Field r'"] by auto
121.928 +qed
121.929 +
121.930 +
121.931 +lemma embedS_comp_embed:
121.932 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
121.933 + and EMB: "embedS r r' f" and EMB': "embed r' r'' f'"
121.934 +shows "embedS r r'' (f' o f)"
121.935 +proof-
121.936 + let ?g = "(f' o f)" let ?h = "inv_into (Field r) ?g"
121.937 + have 1: "embed r r' f \<and> \<not> (bij_betw f (Field r) (Field r'))"
121.938 + using EMB by (auto simp add: embedS_def)
121.939 + hence 2: "embed r r'' ?g"
121.940 + using WELL EMB' comp_embed[of r r' f r'' f'] by auto
121.941 + moreover
121.942 + {assume "bij_betw ?g (Field r) (Field r'')"
121.943 + hence "embed r'' r ?h" using 2 WELL
121.944 + by (auto simp add: inv_into_Field_embed_bij_betw)
121.945 + hence "embed r' r (?h o f')" using WELL' EMB'
121.946 + by (auto simp add: comp_embed)
121.947 + hence "bij_betw f (Field r) (Field r')" using WELL WELL' 1
121.948 + by (auto simp add: embed_bothWays_Field_bij_betw)
121.949 + with 1 have False by blast
121.950 + }
121.951 + ultimately show ?thesis unfolding embedS_def by auto
121.952 +qed
121.953 +
121.954 +
121.955 +lemma embed_comp_embedS:
121.956 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
121.957 + and EMB: "embed r r' f" and EMB': "embedS r' r'' f'"
121.958 +shows "embedS r r'' (f' o f)"
121.959 +proof-
121.960 + let ?g = "(f' o f)" let ?h = "inv_into (Field r) ?g"
121.961 + have 1: "embed r' r'' f' \<and> \<not> (bij_betw f' (Field r') (Field r''))"
121.962 + using EMB' by (auto simp add: embedS_def)
121.963 + hence 2: "embed r r'' ?g"
121.964 + using WELL EMB comp_embed[of r r' f r'' f'] by auto
121.965 + moreover
121.966 + {assume "bij_betw ?g (Field r) (Field r'')"
121.967 + hence "embed r'' r ?h" using 2 WELL
121.968 + by (auto simp add: inv_into_Field_embed_bij_betw)
121.969 + hence "embed r'' r' (f o ?h)" using WELL'' EMB
121.970 + by (auto simp add: comp_embed)
121.971 + hence "bij_betw f' (Field r') (Field r'')" using WELL' WELL'' 1
121.972 + by (auto simp add: embed_bothWays_Field_bij_betw)
121.973 + with 1 have False by blast
121.974 + }
121.975 + ultimately show ?thesis unfolding embedS_def by auto
121.976 +qed
121.977 +
121.978 +
121.979 +lemma embed_comp_iso:
121.980 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
121.981 + and EMB: "embed r r' f" and EMB': "iso r' r'' f'"
121.982 +shows "embed r r'' (f' o f)"
121.983 +using assms unfolding iso_def
121.984 +by (auto simp add: comp_embed)
121.985 +
121.986 +
121.987 +lemma iso_comp_embed:
121.988 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
121.989 + and EMB: "iso r r' f" and EMB': "embed r' r'' f'"
121.990 +shows "embed r r'' (f' o f)"
121.991 +using assms unfolding iso_def
121.992 +by (auto simp add: comp_embed)
121.993 +
121.994 +
121.995 +lemma embedS_comp_iso:
121.996 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
121.997 + and EMB: "embedS r r' f" and EMB': "iso r' r'' f'"
121.998 +shows "embedS r r'' (f' o f)"
121.999 +using assms unfolding iso_def
121.1000 +by (auto simp add: embedS_comp_embed)
121.1001 +
121.1002 +
121.1003 +lemma iso_comp_embedS:
121.1004 +assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
121.1005 + and EMB: "iso r r' f" and EMB': "embedS r' r'' f'"
121.1006 +shows "embedS r r'' (f' o f)"
121.1007 +using assms unfolding iso_def using embed_comp_embedS
121.1008 +by (auto simp add: embed_comp_embedS)
121.1009 +
121.1010 +
121.1011 +lemma embedS_Field:
121.1012 +assumes WELL: "Well_order r" and EMB: "embedS r r' f"
121.1013 +shows "f ` (Field r) < Field r'"
121.1014 +proof-
121.1015 + have "f`(Field r) \<le> Field r'" using assms
121.1016 + by (auto simp add: embed_Field embedS_def)
121.1017 + moreover
121.1018 + {have "inj_on f (Field r)" using assms
121.1019 + by (auto simp add: embedS_def embed_inj_on)
121.1020 + hence "f`(Field r) \<noteq> Field r'" using EMB
121.1021 + by (auto simp add: embedS_def bij_betw_def)
121.1022 + }
121.1023 + ultimately show ?thesis by blast
121.1024 +qed
121.1025 +
121.1026 +
121.1027 +lemma embedS_iff:
121.1028 +assumes WELL: "Well_order r" and ISO: "embed r r' f"
121.1029 +shows "embedS r r' f = (f ` (Field r) < Field r')"
121.1030 +proof
121.1031 + assume "embedS r r' f"
121.1032 + thus "f ` Field r \<subset> Field r'"
121.1033 + using WELL by (auto simp add: embedS_Field)
121.1034 +next
121.1035 + assume "f ` Field r \<subset> Field r'"
121.1036 + hence "\<not> bij_betw f (Field r) (Field r')"
121.1037 + unfolding bij_betw_def by blast
121.1038 + thus "embedS r r' f" unfolding embedS_def
121.1039 + using ISO by auto
121.1040 +qed
121.1041 +
121.1042 +
121.1043 +lemma iso_Field:
121.1044 +"iso r r' f \<Longrightarrow> f ` (Field r) = Field r'"
121.1045 +using assms by (auto simp add: iso_def bij_betw_def)
121.1046 +
121.1047 +
121.1048 +lemma iso_iff:
121.1049 +assumes "Well_order r"
121.1050 +shows "iso r r' f = (embed r r' f \<and> f ` (Field r) = Field r')"
121.1051 +proof
121.1052 + assume "iso r r' f"
121.1053 + thus "embed r r' f \<and> f ` (Field r) = Field r'"
121.1054 + by (auto simp add: iso_Field iso_def)
121.1055 +next
121.1056 + assume *: "embed r r' f \<and> f ` Field r = Field r'"
121.1057 + hence "inj_on f (Field r)" using assms by (auto simp add: embed_inj_on)
121.1058 + with * have "bij_betw f (Field r) (Field r')"
121.1059 + unfolding bij_betw_def by simp
121.1060 + with * show "iso r r' f" unfolding iso_def by auto
121.1061 +qed
121.1062 +
121.1063 +
121.1064 +lemma iso_iff2:
121.1065 +assumes "Well_order r"
121.1066 +shows "iso r r' f = (bij_betw f (Field r) (Field r') \<and>
121.1067 + (\<forall>a \<in> Field r. \<forall>b \<in> Field r.
121.1068 + (((a,b) \<in> r) = ((f a, f b) \<in> r'))))"
121.1069 +using assms
121.1070 +proof(auto simp add: iso_def)
121.1071 + fix a b
121.1072 + assume "embed r r' f"
121.1073 + hence "compat r r' f" using embed_compat[of r] by auto
121.1074 + moreover assume "(a,b) \<in> r"
121.1075 + ultimately show "(f a, f b) \<in> r'" using compat_def[of r] by auto
121.1076 +next
121.1077 + let ?f' = "inv_into (Field r) f"
121.1078 + assume "embed r r' f" and 1: "bij_betw f (Field r) (Field r')"
121.1079 + hence "embed r' r ?f'" using assms
121.1080 + by (auto simp add: inv_into_Field_embed_bij_betw)
121.1081 + hence 2: "compat r' r ?f'" using embed_compat[of r'] by auto
121.1082 + fix a b assume *: "a \<in> Field r" "b \<in> Field r" and **: "(f a,f b) \<in> r'"
121.1083 + hence "?f'(f a) = a \<and> ?f'(f b) = b" using 1
121.1084 + by (auto simp add: bij_betw_inv_into_left)
121.1085 + thus "(a,b) \<in> r" using ** 2 compat_def[of r' r ?f'] by fastforce
121.1086 +next
121.1087 + assume *: "bij_betw f (Field r) (Field r')" and
121.1088 + **: "\<forall>a\<in>Field r. \<forall>b\<in>Field r. ((a, b) \<in> r) = ((f a, f b) \<in> r')"
121.1089 + have 1: "\<And> a. rel.under r a \<le> Field r \<and> rel.under r' (f a) \<le> Field r'"
121.1090 + by (auto simp add: rel.under_Field)
121.1091 + have 2: "inj_on f (Field r)" using * by (auto simp add: bij_betw_def)
121.1092 + {fix a assume ***: "a \<in> Field r"
121.1093 + have "bij_betw f (rel.under r a) (rel.under r' (f a))"
121.1094 + proof(unfold bij_betw_def, auto)
121.1095 + show "inj_on f (rel.under r a)"
121.1096 + using 1 2 by (metis subset_inj_on)
121.1097 + next
121.1098 + fix b assume "b \<in> rel.under r a"
121.1099 + hence "a \<in> Field r \<and> b \<in> Field r \<and> (b,a) \<in> r"
121.1100 + unfolding rel.under_def by (auto simp add: Field_def Range_def Domain_def)
121.1101 + with 1 ** show "f b \<in> rel.under r' (f a)"
121.1102 + unfolding rel.under_def by auto
121.1103 + next
121.1104 + fix b' assume "b' \<in> rel.under r' (f a)"
121.1105 + hence 3: "(b',f a) \<in> r'" unfolding rel.under_def by simp
121.1106 + hence "b' \<in> Field r'" unfolding Field_def by auto
121.1107 + with * obtain b where "b \<in> Field r \<and> f b = b'"
121.1108 + unfolding bij_betw_def by force
121.1109 + with 3 ** ***
121.1110 + show "b' \<in> f ` (rel.under r a)" unfolding rel.under_def by blast
121.1111 + qed
121.1112 + }
121.1113 + thus "embed r r' f" unfolding embed_def using * by auto
121.1114 +qed
121.1115 +
121.1116 +
121.1117 +lemma iso_iff3:
121.1118 +assumes WELL: "Well_order r" and WELL': "Well_order r'"
121.1119 +shows "iso r r' f = (bij_betw f (Field r) (Field r') \<and> compat r r' f)"
121.1120 +proof
121.1121 + assume "iso r r' f"
121.1122 + thus "bij_betw f (Field r) (Field r') \<and> compat r r' f"
121.1123 + unfolding compat_def using WELL by (auto simp add: iso_iff2 Field_def)
121.1124 +next
121.1125 + have Well: "wo_rel r \<and> wo_rel r'" using WELL WELL'
121.1126 + by (auto simp add: wo_rel_def)
121.1127 + assume *: "bij_betw f (Field r) (Field r') \<and> compat r r' f"
121.1128 + thus "iso r r' f"
121.1129 + unfolding "compat_def" using assms
121.1130 + proof(auto simp add: iso_iff2)
121.1131 + fix a b assume **: "a \<in> Field r" "b \<in> Field r" and
121.1132 + ***: "(f a, f b) \<in> r'"
121.1133 + {assume "(b,a) \<in> r \<or> b = a"
121.1134 + hence "(b,a): r"using Well ** wo_rel.REFL[of r] refl_on_def[of _ r] by blast
121.1135 + hence "(f b, f a) \<in> r'" using * unfolding compat_def by auto
121.1136 + hence "f a = f b"
121.1137 + using Well *** wo_rel.ANTISYM[of r'] antisym_def[of r'] by blast
121.1138 + hence "a = b" using * ** unfolding bij_betw_def inj_on_def by auto
121.1139 + hence "(a,b) \<in> r" using Well ** wo_rel.REFL[of r] refl_on_def[of _ r] by blast
121.1140 + }
121.1141 + thus "(a,b) \<in> r"
121.1142 + using Well ** wo_rel.TOTAL[of r] total_on_def[of _ r] by blast
121.1143 + qed
121.1144 +qed
121.1145 +
121.1146 +
121.1147 +
121.1148 +end
122.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
122.2 +++ b/src/HOL/Cardinals/Wellorder_Extension.thy Thu Dec 05 17:58:03 2013 +0100
122.3 @@ -0,0 +1,213 @@
122.4 +(* Title: HOL/Cardinals/Wellorder_Extension.thy
122.5 + Author: Christian Sternagel, JAIST
122.6 +*)
122.7 +
122.8 +header {* Extending Well-founded Relations to Wellorders *}
122.9 +
122.10 +theory Wellorder_Extension
122.11 +imports "~~/src/HOL/Library/Zorn" Order_Union
122.12 +begin
122.13 +
122.14 +subsection {* Extending Well-founded Relations to Wellorders *}
122.15 +
122.16 +text {*A \emph{downset} (also lower set, decreasing set, initial segment, or
122.17 +downward closed set) is closed w.r.t.\ smaller elements.*}
122.18 +definition downset_on where
122.19 + "downset_on A r = (\<forall>x y. (x, y) \<in> r \<and> y \<in> A \<longrightarrow> x \<in> A)"
122.20 +
122.21 +(*
122.22 +text {*Connection to order filters of the @{theory Cardinals} theory.*}
122.23 +lemma (in wo_rel) ofilter_downset_on_conv:
122.24 + "ofilter A \<longleftrightarrow> downset_on A r \<and> A \<subseteq> Field r"
122.25 + by (auto simp: downset_on_def ofilter_def under_def)
122.26 +*)
122.27 +
122.28 +lemma downset_onI:
122.29 + "(\<And>x y. (x, y) \<in> r \<Longrightarrow> y \<in> A \<Longrightarrow> x \<in> A) \<Longrightarrow> downset_on A r"
122.30 + by (auto simp: downset_on_def)
122.31 +
122.32 +lemma downset_onD:
122.33 + "downset_on A r \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> y \<in> A \<Longrightarrow> x \<in> A"
122.34 + unfolding downset_on_def by blast
122.35 +
122.36 +text {*Extensions of relations w.r.t.\ a given set.*}
122.37 +definition extension_on where
122.38 + "extension_on A r s = (\<forall>x\<in>A. \<forall>y\<in>A. (x, y) \<in> s \<longrightarrow> (x, y) \<in> r)"
122.39 +
122.40 +lemma extension_onI:
122.41 + "(\<And>x y. \<lbrakk>x \<in> A; y \<in> A; (x, y) \<in> s\<rbrakk> \<Longrightarrow> (x, y) \<in> r) \<Longrightarrow> extension_on A r s"
122.42 + by (auto simp: extension_on_def)
122.43 +
122.44 +lemma extension_onD:
122.45 + "extension_on A r s \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> (x, y) \<in> s \<Longrightarrow> (x, y) \<in> r"
122.46 + by (auto simp: extension_on_def)
122.47 +
122.48 +lemma downset_on_Union:
122.49 + assumes "\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p"
122.50 + shows "downset_on (Field (\<Union>R)) p"
122.51 + using assms by (auto intro: downset_onI dest: downset_onD)
122.52 +
122.53 +lemma chain_subset_extension_on_Union:
122.54 + assumes "chain\<^sub>\<subseteq> R" and "\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p"
122.55 + shows "extension_on (Field (\<Union>R)) (\<Union>R) p"
122.56 + using assms
122.57 + by (simp add: chain_subset_def extension_on_def)
122.58 + (metis (no_types) mono_Field set_mp)
122.59 +
122.60 +lemma downset_on_empty [simp]: "downset_on {} p"
122.61 + by (auto simp: downset_on_def)
122.62 +
122.63 +lemma extension_on_empty [simp]: "extension_on {} p q"
122.64 + by (auto simp: extension_on_def)
122.65 +
122.66 +text {*Every well-founded relation can be extended to a wellorder.*}
122.67 +theorem well_order_extension:
122.68 + assumes "wf p"
122.69 + shows "\<exists>w. p \<subseteq> w \<and> Well_order w"
122.70 +proof -
122.71 + let ?K = "{r. Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p}"
122.72 + def I \<equiv> "init_seg_of \<inter> ?K \<times> ?K"
122.73 + have I_init: "I \<subseteq> init_seg_of" by (simp add: I_def)
122.74 + then have subch: "\<And>R. R \<in> Chains I \<Longrightarrow> chain\<^sub>\<subseteq> R"
122.75 + by (auto simp: init_seg_of_def chain_subset_def Chains_def)
122.76 + have Chains_wo: "\<And>R r. R \<in> Chains I \<Longrightarrow> r \<in> R \<Longrightarrow>
122.77 + Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p"
122.78 + by (simp add: Chains_def I_def) blast
122.79 + have FI: "Field I = ?K" by (auto simp: I_def init_seg_of_def Field_def)
122.80 + then have 0: "Partial_order I"
122.81 + by (auto simp: partial_order_on_def preorder_on_def antisym_def antisym_init_seg_of refl_on_def
122.82 + trans_def I_def elim: trans_init_seg_of)
122.83 + { fix R assume "R \<in> Chains I"
122.84 + then have Ris: "R \<in> Chains init_seg_of" using mono_Chains [OF I_init] by blast
122.85 + have subch: "chain\<^sub>\<subseteq> R" using `R \<in> Chains I` I_init
122.86 + by (auto simp: init_seg_of_def chain_subset_def Chains_def)
122.87 + have "\<forall>r\<in>R. Refl r" and "\<forall>r\<in>R. trans r" and "\<forall>r\<in>R. antisym r" and
122.88 + "\<forall>r\<in>R. Total r" and "\<forall>r\<in>R. wf (r - Id)" and
122.89 + "\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p" and
122.90 + "\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p"
122.91 + using Chains_wo [OF `R \<in> Chains I`] by (simp_all add: order_on_defs)
122.92 + have "Refl (\<Union>R)" using `\<forall>r\<in>R. Refl r` unfolding refl_on_def by fastforce
122.93 + moreover have "trans (\<Union>R)"
122.94 + by (rule chain_subset_trans_Union [OF subch `\<forall>r\<in>R. trans r`])
122.95 + moreover have "antisym (\<Union>R)"
122.96 + by (rule chain_subset_antisym_Union [OF subch `\<forall>r\<in>R. antisym r`])
122.97 + moreover have "Total (\<Union>R)"
122.98 + by (rule chain_subset_Total_Union [OF subch `\<forall>r\<in>R. Total r`])
122.99 + moreover have "wf ((\<Union>R) - Id)"
122.100 + proof -
122.101 + have "(\<Union>R) - Id = \<Union>{r - Id | r. r \<in> R}" by blast
122.102 + with `\<forall>r\<in>R. wf (r - Id)` wf_Union_wf_init_segs [OF Chains_inits_DiffI [OF Ris]]
122.103 + show ?thesis by fastforce
122.104 + qed
122.105 + ultimately have "Well_order (\<Union>R)" by (simp add: order_on_defs)
122.106 + moreover have "\<forall>r\<in>R. r initial_segment_of \<Union>R" using Ris
122.107 + by (simp add: Chains_init_seg_of_Union)
122.108 + moreover have "downset_on (Field (\<Union>R)) p"
122.109 + by (rule downset_on_Union [OF `\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p`])
122.110 + moreover have "extension_on (Field (\<Union>R)) (\<Union>R) p"
122.111 + by (rule chain_subset_extension_on_Union [OF subch `\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p`])
122.112 + ultimately have "\<Union>R \<in> ?K \<and> (\<forall>r\<in>R. (r,\<Union>R) \<in> I)"
122.113 + using mono_Chains [OF I_init] and `R \<in> Chains I`
122.114 + by (simp (no_asm) add: I_def del: Field_Union) (metis Chains_wo)
122.115 + }
122.116 + then have 1: "\<forall>R\<in>Chains I. \<exists>u\<in>Field I. \<forall>r\<in>R. (r, u) \<in> I" by (subst FI) blast
122.117 + txt {*Zorn's Lemma yields a maximal wellorder m.*}
122.118 + from Zorns_po_lemma [OF 0 1] obtain m :: "('a \<times> 'a) set"
122.119 + where "Well_order m" and "downset_on (Field m) p" and "extension_on (Field m) m p" and
122.120 + max: "\<forall>r. Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p \<and>
122.121 + (m, r) \<in> I \<longrightarrow> r = m"
122.122 + by (auto simp: FI)
122.123 + have "Field p \<subseteq> Field m"
122.124 + proof (rule ccontr)
122.125 + let ?Q = "Field p - Field m"
122.126 + assume "\<not> (Field p \<subseteq> Field m)"
122.127 + with assms [unfolded wf_eq_minimal, THEN spec, of ?Q]
122.128 + obtain x where "x \<in> Field p" and "x \<notin> Field m" and
122.129 + min: "\<forall>y. (y, x) \<in> p \<longrightarrow> y \<notin> ?Q" by blast
122.130 + txt {*Add @{term x} as topmost element to @{term m}.*}
122.131 + let ?s = "{(y, x) | y. y \<in> Field m}"
122.132 + let ?m = "insert (x, x) m \<union> ?s"
122.133 + have Fm: "Field ?m = insert x (Field m)" by (auto simp: Field_def)
122.134 + have "Refl m" and "trans m" and "antisym m" and "Total m" and "wf (m - Id)"
122.135 + using `Well_order m` by (simp_all add: order_on_defs)
122.136 + txt {*We show that the extension is a wellorder.*}
122.137 + have "Refl ?m" using `Refl m` Fm by (auto simp: refl_on_def)
122.138 + moreover have "trans ?m" using `trans m` `x \<notin> Field m`
122.139 + unfolding trans_def Field_def Domain_unfold Domain_converse [symmetric] by blast
122.140 + moreover have "antisym ?m" using `antisym m` `x \<notin> Field m`
122.141 + unfolding antisym_def Field_def Domain_unfold Domain_converse [symmetric] by blast
122.142 + moreover have "Total ?m" using `Total m` Fm by (auto simp: Relation.total_on_def)
122.143 + moreover have "wf (?m - Id)"
122.144 + proof -
122.145 + have "wf ?s" using `x \<notin> Field m`
122.146 + by (simp add: wf_eq_minimal Field_def Domain_unfold Domain_converse [symmetric]) metis
122.147 + thus ?thesis using `wf (m - Id)` `x \<notin> Field m`
122.148 + wf_subset [OF `wf ?s` Diff_subset]
122.149 + by (fastforce intro!: wf_Un simp add: Un_Diff Field_def)
122.150 + qed
122.151 + ultimately have "Well_order ?m" by (simp add: order_on_defs)
122.152 + moreover have "extension_on (Field ?m) ?m p"
122.153 + using `extension_on (Field m) m p` `downset_on (Field m) p`
122.154 + by (subst Fm) (auto simp: extension_on_def dest: downset_onD)
122.155 + moreover have "downset_on (Field ?m) p"
122.156 + apply (subst Fm)
122.157 + using `downset_on (Field m) p` and min
122.158 + unfolding downset_on_def Field_def by blast
122.159 + moreover have "(m, ?m) \<in> I"
122.160 + using `Well_order m` and `Well_order ?m` and
122.161 + `downset_on (Field m) p` and `downset_on (Field ?m) p` and
122.162 + `extension_on (Field m) m p` and `extension_on (Field ?m) ?m p` and
122.163 + `Refl m` and `x \<notin> Field m`
122.164 + by (auto simp: I_def init_seg_of_def refl_on_def)
122.165 + ultimately
122.166 + --{*This contradicts maximality of m:*}
122.167 + show False using max and `x \<notin> Field m` unfolding Field_def by blast
122.168 + qed
122.169 + have "p \<subseteq> m"
122.170 + using `Field p \<subseteq> Field m` and `extension_on (Field m) m p`
122.171 + unfolding Field_def extension_on_def by auto fast
122.172 + with `Well_order m` show ?thesis by blast
122.173 +qed
122.174 +
122.175 +text {*Every well-founded relation can be extended to a total wellorder.*}
122.176 +corollary total_well_order_extension:
122.177 + assumes "wf p"
122.178 + shows "\<exists>w. p \<subseteq> w \<and> Well_order w \<and> Field w = UNIV"
122.179 +proof -
122.180 + from well_order_extension [OF assms] obtain w
122.181 + where "p \<subseteq> w" and wo: "Well_order w" by blast
122.182 + let ?A = "UNIV - Field w"
122.183 + from well_order_on [of ?A] obtain w' where wo': "well_order_on ?A w'" ..
122.184 + have [simp]: "Field w' = ?A" using rel.well_order_on_Well_order [OF wo'] by simp
122.185 + have *: "Field w \<inter> Field w' = {}" by simp
122.186 + let ?w = "w \<union>o w'"
122.187 + have "p \<subseteq> ?w" using `p \<subseteq> w` by (auto simp: Osum_def)
122.188 + moreover have "Well_order ?w" using Osum_Well_order [OF * wo] and wo' by simp
122.189 + moreover have "Field ?w = UNIV" by (simp add: Field_Osum)
122.190 + ultimately show ?thesis by blast
122.191 +qed
122.192 +
122.193 +corollary well_order_on_extension:
122.194 + assumes "wf p" and "Field p \<subseteq> A"
122.195 + shows "\<exists>w. p \<subseteq> w \<and> well_order_on A w"
122.196 +proof -
122.197 + from total_well_order_extension [OF `wf p`] obtain r
122.198 + where "p \<subseteq> r" and wo: "Well_order r" and univ: "Field r = UNIV" by blast
122.199 + let ?r = "{(x, y). x \<in> A \<and> y \<in> A \<and> (x, y) \<in> r}"
122.200 + from `p \<subseteq> r` have "p \<subseteq> ?r" using `Field p \<subseteq> A` by (auto simp: Field_def)
122.201 + have 1: "Field ?r = A" using wo univ
122.202 + by (fastforce simp: Field_def order_on_defs refl_on_def)
122.203 + have "Refl r" "trans r" "antisym r" "Total r" "wf (r - Id)"
122.204 + using `Well_order r` by (simp_all add: order_on_defs)
122.205 + have "refl_on A ?r" using `Refl r` by (auto simp: refl_on_def univ)
122.206 + moreover have "trans ?r" using `trans r`
122.207 + unfolding trans_def by blast
122.208 + moreover have "antisym ?r" using `antisym r`
122.209 + unfolding antisym_def by blast
122.210 + moreover have "total_on A ?r" using `Total r` by (simp add: total_on_def univ)
122.211 + moreover have "wf (?r - Id)" by (rule wf_subset [OF `wf(r - Id)`]) blast
122.212 + ultimately have "well_order_on A ?r" by (simp add: order_on_defs)
122.213 + with `p \<subseteq> ?r` show ?thesis by blast
122.214 +qed
122.215 +
122.216 +end
123.1 --- a/src/HOL/Cardinals/Wellorder_Relation.thy Thu Dec 05 17:52:12 2013 +0100
123.2 +++ b/src/HOL/Cardinals/Wellorder_Relation.thy Thu Dec 05 17:58:03 2013 +0100
123.3 @@ -8,7 +8,7 @@
123.4 header {* Well-Order Relations *}
123.5
123.6 theory Wellorder_Relation
123.7 -imports Wellorder_Relation_Base Wellfounded_More
123.8 +imports Wellorder_Relation_FP Wellfounded_More
123.9 begin
123.10
123.11 context wo_rel
123.12 @@ -64,17 +64,7 @@
123.13
123.14 lemma minim_Under:
123.15 "\<lbrakk>B \<le> Field r; B \<noteq> {}\<rbrakk> \<Longrightarrow> minim B \<in> Under B"
123.16 -by(auto simp add: Under_def
123.17 -minim_in
123.18 -minim_inField
123.19 -minim_least
123.20 -under_ofilter
123.21 -underS_ofilter
123.22 -Field_ofilter
123.23 -ofilter_Under
123.24 -ofilter_UnderS
123.25 -ofilter_Un
123.26 -)
123.27 +by(auto simp add: Under_def minim_inField minim_least)
123.28
123.29 lemma equals_minim_Under:
123.30 "\<lbrakk>B \<le> Field r; a \<in> B; a \<in> Under B\<rbrakk>
123.31 @@ -410,7 +400,41 @@
123.32 qed
123.33
123.34
123.35 -subsubsection {* Properties of order filters *}
123.36 +subsubsection {* Properties of order filters *}
123.37 +
123.38 +lemma ofilter_Under[simp]:
123.39 +assumes "A \<le> Field r"
123.40 +shows "ofilter(Under A)"
123.41 +proof(unfold ofilter_def, auto)
123.42 + fix x assume "x \<in> Under A"
123.43 + thus "x \<in> Field r"
123.44 + using Under_Field assms by auto
123.45 +next
123.46 + fix a x
123.47 + assume "a \<in> Under A" and "x \<in> under a"
123.48 + thus "x \<in> Under A"
123.49 + using TRANS under_Under_trans by auto
123.50 +qed
123.51 +
123.52 +lemma ofilter_UnderS[simp]:
123.53 +assumes "A \<le> Field r"
123.54 +shows "ofilter(UnderS A)"
123.55 +proof(unfold ofilter_def, auto)
123.56 + fix x assume "x \<in> UnderS A"
123.57 + thus "x \<in> Field r"
123.58 + using UnderS_Field assms by auto
123.59 +next
123.60 + fix a x
123.61 + assume "a \<in> UnderS A" and "x \<in> under a"
123.62 + thus "x \<in> UnderS A"
123.63 + using TRANS ANTISYM under_UnderS_trans by auto
123.64 +qed
123.65 +
123.66 +lemma ofilter_Int[simp]: "\<lbrakk>ofilter A; ofilter B\<rbrakk> \<Longrightarrow> ofilter(A Int B)"
123.67 +unfolding ofilter_def by blast
123.68 +
123.69 +lemma ofilter_Un[simp]: "\<lbrakk>ofilter A; ofilter B\<rbrakk> \<Longrightarrow> ofilter(A \<union> B)"
123.70 +unfolding ofilter_def by blast
123.71
123.72 lemma ofilter_INTER:
123.73 "\<lbrakk>I \<noteq> {}; \<And> i. i \<in> I \<Longrightarrow> ofilter(A i)\<rbrakk> \<Longrightarrow> ofilter (\<Inter> i \<in> I. A i)"
123.74 @@ -496,10 +520,6 @@
123.75 under_ofilter[simp]
123.76 underS_ofilter[simp]
123.77 Field_ofilter[simp]
123.78 - ofilter_Under[simp]
123.79 - ofilter_UnderS[simp]
123.80 - ofilter_Int[simp]
123.81 - ofilter_Un[simp]
123.82
123.83 end
123.84
124.1 --- a/src/HOL/Cardinals/Wellorder_Relation_Base.thy Thu Dec 05 17:52:12 2013 +0100
124.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
124.3 @@ -1,669 +0,0 @@
124.4 -(* Title: HOL/Cardinals/Wellorder_Relation_Base.thy
124.5 - Author: Andrei Popescu, TU Muenchen
124.6 - Copyright 2012
124.7 -
124.8 -Well-order relations (base).
124.9 -*)
124.10 -
124.11 -header {* Well-Order Relations (Base) *}
124.12 -
124.13 -theory Wellorder_Relation_Base
124.14 -imports Wellfounded_More_Base
124.15 -begin
124.16 -
124.17 -
124.18 -text{* In this section, we develop basic concepts and results pertaining
124.19 -to well-order relations. Note that we consider well-order relations
124.20 -as {\em non-strict relations},
124.21 -i.e., as containing the diagonals of their fields. *}
124.22 -
124.23 -
124.24 -locale wo_rel = rel + assumes WELL: "Well_order r"
124.25 -begin
124.26 -
124.27 -text{* The following context encompasses all this section. In other words,
124.28 -for the whole section, we consider a fixed well-order relation @{term "r"}. *}
124.29 -
124.30 -(* context wo_rel *)
124.31 -
124.32 -
124.33 -subsection {* Auxiliaries *}
124.34 -
124.35 -
124.36 -lemma REFL: "Refl r"
124.37 -using WELL order_on_defs[of _ r] by auto
124.38 -
124.39 -
124.40 -lemma TRANS: "trans r"
124.41 -using WELL order_on_defs[of _ r] by auto
124.42 -
124.43 -
124.44 -lemma ANTISYM: "antisym r"
124.45 -using WELL order_on_defs[of _ r] by auto
124.46 -
124.47 -
124.48 -lemma TOTAL: "Total r"
124.49 -using WELL order_on_defs[of _ r] by auto
124.50 -
124.51 -
124.52 -lemma TOTALS: "\<forall>a \<in> Field r. \<forall>b \<in> Field r. (a,b) \<in> r \<or> (b,a) \<in> r"
124.53 -using REFL TOTAL refl_on_def[of _ r] total_on_def[of _ r] by force
124.54 -
124.55 -
124.56 -lemma LIN: "Linear_order r"
124.57 -using WELL well_order_on_def[of _ r] by auto
124.58 -
124.59 -
124.60 -lemma WF: "wf (r - Id)"
124.61 -using WELL well_order_on_def[of _ r] by auto
124.62 -
124.63 -
124.64 -lemma cases_Total:
124.65 -"\<And> phi a b. \<lbrakk>{a,b} <= Field r; ((a,b) \<in> r \<Longrightarrow> phi a b); ((b,a) \<in> r \<Longrightarrow> phi a b)\<rbrakk>
124.66 - \<Longrightarrow> phi a b"
124.67 -using TOTALS by auto
124.68 -
124.69 -
124.70 -lemma cases_Total3:
124.71 -"\<And> phi a b. \<lbrakk>{a,b} \<le> Field r; ((a,b) \<in> r - Id \<or> (b,a) \<in> r - Id \<Longrightarrow> phi a b);
124.72 - (a = b \<Longrightarrow> phi a b)\<rbrakk> \<Longrightarrow> phi a b"
124.73 -using TOTALS by auto
124.74 -
124.75 -
124.76 -subsection {* Well-founded induction and recursion adapted to non-strict well-order relations *}
124.77 -
124.78 -
124.79 -text{* Here we provide induction and recursion principles specific to {\em non-strict}
124.80 -well-order relations.
124.81 -Although minor variations of those for well-founded relations, they will be useful
124.82 -for doing away with the tediousness of
124.83 -having to take out the diagonal each time in order to switch to a well-founded relation. *}
124.84 -
124.85 -
124.86 -lemma well_order_induct:
124.87 -assumes IND: "\<And>x. \<forall>y. y \<noteq> x \<and> (y, x) \<in> r \<longrightarrow> P y \<Longrightarrow> P x"
124.88 -shows "P a"
124.89 -proof-
124.90 - have "\<And>x. \<forall>y. (y, x) \<in> r - Id \<longrightarrow> P y \<Longrightarrow> P x"
124.91 - using IND by blast
124.92 - thus "P a" using WF wf_induct[of "r - Id" P a] by blast
124.93 -qed
124.94 -
124.95 -
124.96 -definition
124.97 -worec :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
124.98 -where
124.99 -"worec F \<equiv> wfrec (r - Id) F"
124.100 -
124.101 -
124.102 -definition
124.103 -adm_wo :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> bool"
124.104 -where
124.105 -"adm_wo H \<equiv> \<forall>f g x. (\<forall>y \<in> underS x. f y = g y) \<longrightarrow> H f x = H g x"
124.106 -
124.107 -
124.108 -lemma worec_fixpoint:
124.109 -assumes ADM: "adm_wo H"
124.110 -shows "worec H = H (worec H)"
124.111 -proof-
124.112 - let ?rS = "r - Id"
124.113 - have "adm_wf (r - Id) H"
124.114 - unfolding adm_wf_def
124.115 - using ADM adm_wo_def[of H] underS_def by auto
124.116 - hence "wfrec ?rS H = H (wfrec ?rS H)"
124.117 - using WF wfrec_fixpoint[of ?rS H] by simp
124.118 - thus ?thesis unfolding worec_def .
124.119 -qed
124.120 -
124.121 -
124.122 -subsection {* The notions of maximum, minimum, supremum, successor and order filter *}
124.123 -
124.124 -
124.125 -text{*
124.126 -We define the successor {\em of a set}, and not of an element (the latter is of course
124.127 -a particular case). Also, we define the maximum {\em of two elements}, @{text "max2"},
124.128 -and the minimum {\em of a set}, @{text "minim"} -- we chose these variants since we
124.129 -consider them the most useful for well-orders. The minimum is defined in terms of the
124.130 -auxiliary relational operator @{text "isMinim"}. Then, supremum and successor are
124.131 -defined in terms of minimum as expected.
124.132 -The minimum is only meaningful for non-empty sets, and the successor is only
124.133 -meaningful for sets for which strict upper bounds exist.
124.134 -Order filters for well-orders are also known as ``initial segments". *}
124.135 -
124.136 -
124.137 -definition max2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
124.138 -where "max2 a b \<equiv> if (a,b) \<in> r then b else a"
124.139 -
124.140 -
124.141 -definition isMinim :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
124.142 -where "isMinim A b \<equiv> b \<in> A \<and> (\<forall>a \<in> A. (b,a) \<in> r)"
124.143 -
124.144 -definition minim :: "'a set \<Rightarrow> 'a"
124.145 -where "minim A \<equiv> THE b. isMinim A b"
124.146 -
124.147 -
124.148 -definition supr :: "'a set \<Rightarrow> 'a"
124.149 -where "supr A \<equiv> minim (Above A)"
124.150 -
124.151 -definition suc :: "'a set \<Rightarrow> 'a"
124.152 -where "suc A \<equiv> minim (AboveS A)"
124.153 -
124.154 -definition ofilter :: "'a set \<Rightarrow> bool"
124.155 -where
124.156 -"ofilter A \<equiv> (A \<le> Field r) \<and> (\<forall>a \<in> A. under a \<le> A)"
124.157 -
124.158 -
124.159 -subsubsection {* Properties of max2 *}
124.160 -
124.161 -
124.162 -lemma max2_greater_among:
124.163 -assumes "a \<in> Field r" and "b \<in> Field r"
124.164 -shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r \<and> max2 a b \<in> {a,b}"
124.165 -proof-
124.166 - {assume "(a,b) \<in> r"
124.167 - hence ?thesis using max2_def assms REFL refl_on_def
124.168 - by (auto simp add: refl_on_def)
124.169 - }
124.170 - moreover
124.171 - {assume "a = b"
124.172 - hence "(a,b) \<in> r" using REFL assms
124.173 - by (auto simp add: refl_on_def)
124.174 - }
124.175 - moreover
124.176 - {assume *: "a \<noteq> b \<and> (b,a) \<in> r"
124.177 - hence "(a,b) \<notin> r" using ANTISYM
124.178 - by (auto simp add: antisym_def)
124.179 - hence ?thesis using * max2_def assms REFL refl_on_def
124.180 - by (auto simp add: refl_on_def)
124.181 - }
124.182 - ultimately show ?thesis using assms TOTAL
124.183 - total_on_def[of "Field r" r] by blast
124.184 -qed
124.185 -
124.186 -
124.187 -lemma max2_greater:
124.188 -assumes "a \<in> Field r" and "b \<in> Field r"
124.189 -shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r"
124.190 -using assms by (auto simp add: max2_greater_among)
124.191 -
124.192 -
124.193 -lemma max2_among:
124.194 -assumes "a \<in> Field r" and "b \<in> Field r"
124.195 -shows "max2 a b \<in> {a, b}"
124.196 -using assms max2_greater_among[of a b] by simp
124.197 -
124.198 -
124.199 -lemma max2_equals1:
124.200 -assumes "a \<in> Field r" and "b \<in> Field r"
124.201 -shows "(max2 a b = a) = ((b,a) \<in> r)"
124.202 -using assms ANTISYM unfolding antisym_def using TOTALS
124.203 -by(auto simp add: max2_def max2_among)
124.204 -
124.205 -
124.206 -lemma max2_equals2:
124.207 -assumes "a \<in> Field r" and "b \<in> Field r"
124.208 -shows "(max2 a b = b) = ((a,b) \<in> r)"
124.209 -using assms ANTISYM unfolding antisym_def using TOTALS
124.210 -unfolding max2_def by auto
124.211 -
124.212 -
124.213 -subsubsection {* Existence and uniqueness for isMinim and well-definedness of minim *}
124.214 -
124.215 -
124.216 -lemma isMinim_unique:
124.217 -assumes MINIM: "isMinim B a" and MINIM': "isMinim B a'"
124.218 -shows "a = a'"
124.219 -proof-
124.220 - {have "a \<in> B"
124.221 - using MINIM isMinim_def by simp
124.222 - hence "(a',a) \<in> r"
124.223 - using MINIM' isMinim_def by simp
124.224 - }
124.225 - moreover
124.226 - {have "a' \<in> B"
124.227 - using MINIM' isMinim_def by simp
124.228 - hence "(a,a') \<in> r"
124.229 - using MINIM isMinim_def by simp
124.230 - }
124.231 - ultimately
124.232 - show ?thesis using ANTISYM antisym_def[of r] by blast
124.233 -qed
124.234 -
124.235 -
124.236 -lemma Well_order_isMinim_exists:
124.237 -assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
124.238 -shows "\<exists>b. isMinim B b"
124.239 -proof-
124.240 - from spec[OF WF[unfolded wf_eq_minimal[of "r - Id"]], of B] NE obtain b where
124.241 - *: "b \<in> B \<and> (\<forall>b'. b' \<noteq> b \<and> (b',b) \<in> r \<longrightarrow> b' \<notin> B)" by auto
124.242 - show ?thesis
124.243 - proof(simp add: isMinim_def, rule exI[of _ b], auto)
124.244 - show "b \<in> B" using * by simp
124.245 - next
124.246 - fix b' assume As: "b' \<in> B"
124.247 - hence **: "b \<in> Field r \<and> b' \<in> Field r" using As SUB * by auto
124.248 - (* *)
124.249 - from As * have "b' = b \<or> (b',b) \<notin> r" by auto
124.250 - moreover
124.251 - {assume "b' = b"
124.252 - hence "(b,b') \<in> r"
124.253 - using ** REFL by (auto simp add: refl_on_def)
124.254 - }
124.255 - moreover
124.256 - {assume "b' \<noteq> b \<and> (b',b) \<notin> r"
124.257 - hence "(b,b') \<in> r"
124.258 - using ** TOTAL by (auto simp add: total_on_def)
124.259 - }
124.260 - ultimately show "(b,b') \<in> r" by blast
124.261 - qed
124.262 -qed
124.263 -
124.264 -
124.265 -lemma minim_isMinim:
124.266 -assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
124.267 -shows "isMinim B (minim B)"
124.268 -proof-
124.269 - let ?phi = "(\<lambda> b. isMinim B b)"
124.270 - from assms Well_order_isMinim_exists
124.271 - obtain b where *: "?phi b" by blast
124.272 - moreover
124.273 - have "\<And> b'. ?phi b' \<Longrightarrow> b' = b"
124.274 - using isMinim_unique * by auto
124.275 - ultimately show ?thesis
124.276 - unfolding minim_def using theI[of ?phi b] by blast
124.277 -qed
124.278 -
124.279 -
124.280 -subsubsection{* Properties of minim *}
124.281 -
124.282 -
124.283 -lemma minim_in:
124.284 -assumes "B \<le> Field r" and "B \<noteq> {}"
124.285 -shows "minim B \<in> B"
124.286 -proof-
124.287 - from minim_isMinim[of B] assms
124.288 - have "isMinim B (minim B)" by simp
124.289 - thus ?thesis by (simp add: isMinim_def)
124.290 -qed
124.291 -
124.292 -
124.293 -lemma minim_inField:
124.294 -assumes "B \<le> Field r" and "B \<noteq> {}"
124.295 -shows "minim B \<in> Field r"
124.296 -proof-
124.297 - have "minim B \<in> B" using assms by (simp add: minim_in)
124.298 - thus ?thesis using assms by blast
124.299 -qed
124.300 -
124.301 -
124.302 -lemma minim_least:
124.303 -assumes SUB: "B \<le> Field r" and IN: "b \<in> B"
124.304 -shows "(minim B, b) \<in> r"
124.305 -proof-
124.306 - from minim_isMinim[of B] assms
124.307 - have "isMinim B (minim B)" by auto
124.308 - thus ?thesis by (auto simp add: isMinim_def IN)
124.309 -qed
124.310 -
124.311 -
124.312 -lemma equals_minim:
124.313 -assumes SUB: "B \<le> Field r" and IN: "a \<in> B" and
124.314 - LEAST: "\<And> b. b \<in> B \<Longrightarrow> (a,b) \<in> r"
124.315 -shows "a = minim B"
124.316 -proof-
124.317 - from minim_isMinim[of B] assms
124.318 - have "isMinim B (minim B)" by auto
124.319 - moreover have "isMinim B a" using IN LEAST isMinim_def by auto
124.320 - ultimately show ?thesis
124.321 - using isMinim_unique by auto
124.322 -qed
124.323 -
124.324 -
124.325 -subsubsection{* Properties of successor *}
124.326 -
124.327 -
124.328 -lemma suc_AboveS:
124.329 -assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}"
124.330 -shows "suc B \<in> AboveS B"
124.331 -proof(unfold suc_def)
124.332 - have "AboveS B \<le> Field r"
124.333 - using AboveS_Field by auto
124.334 - thus "minim (AboveS B) \<in> AboveS B"
124.335 - using assms by (simp add: minim_in)
124.336 -qed
124.337 -
124.338 -
124.339 -lemma suc_greater:
124.340 -assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}" and
124.341 - IN: "b \<in> B"
124.342 -shows "suc B \<noteq> b \<and> (b,suc B) \<in> r"
124.343 -proof-
124.344 - from assms suc_AboveS
124.345 - have "suc B \<in> AboveS B" by simp
124.346 - with IN AboveS_def show ?thesis by simp
124.347 -qed
124.348 -
124.349 -
124.350 -lemma suc_least_AboveS:
124.351 -assumes ABOVES: "a \<in> AboveS B"
124.352 -shows "(suc B,a) \<in> r"
124.353 -proof(unfold suc_def)
124.354 - have "AboveS B \<le> Field r"
124.355 - using AboveS_Field by auto
124.356 - thus "(minim (AboveS B),a) \<in> r"
124.357 - using assms minim_least by simp
124.358 -qed
124.359 -
124.360 -
124.361 -lemma suc_inField:
124.362 -assumes "B \<le> Field r" and "AboveS B \<noteq> {}"
124.363 -shows "suc B \<in> Field r"
124.364 -proof-
124.365 - have "suc B \<in> AboveS B" using suc_AboveS assms by simp
124.366 - thus ?thesis
124.367 - using assms AboveS_Field by auto
124.368 -qed
124.369 -
124.370 -
124.371 -lemma equals_suc_AboveS:
124.372 -assumes SUB: "B \<le> Field r" and ABV: "a \<in> AboveS B" and
124.373 - MINIM: "\<And> a'. a' \<in> AboveS B \<Longrightarrow> (a,a') \<in> r"
124.374 -shows "a = suc B"
124.375 -proof(unfold suc_def)
124.376 - have "AboveS B \<le> Field r"
124.377 - using AboveS_Field[of B] by auto
124.378 - thus "a = minim (AboveS B)"
124.379 - using assms equals_minim
124.380 - by simp
124.381 -qed
124.382 -
124.383 -
124.384 -lemma suc_underS:
124.385 -assumes IN: "a \<in> Field r"
124.386 -shows "a = suc (underS a)"
124.387 -proof-
124.388 - have "underS a \<le> Field r"
124.389 - using underS_Field by auto
124.390 - moreover
124.391 - have "a \<in> AboveS (underS a)"
124.392 - using in_AboveS_underS IN by auto
124.393 - moreover
124.394 - have "\<forall>a' \<in> AboveS (underS a). (a,a') \<in> r"
124.395 - proof(clarify)
124.396 - fix a'
124.397 - assume *: "a' \<in> AboveS (underS a)"
124.398 - hence **: "a' \<in> Field r"
124.399 - using AboveS_Field by auto
124.400 - {assume "(a,a') \<notin> r"
124.401 - hence "a' = a \<or> (a',a) \<in> r"
124.402 - using TOTAL IN ** by (auto simp add: total_on_def)
124.403 - moreover
124.404 - {assume "a' = a"
124.405 - hence "(a,a') \<in> r"
124.406 - using REFL IN ** by (auto simp add: refl_on_def)
124.407 - }
124.408 - moreover
124.409 - {assume "a' \<noteq> a \<and> (a',a) \<in> r"
124.410 - hence "a' \<in> underS a"
124.411 - unfolding underS_def by simp
124.412 - hence "a' \<notin> AboveS (underS a)"
124.413 - using AboveS_disjoint by blast
124.414 - with * have False by simp
124.415 - }
124.416 - ultimately have "(a,a') \<in> r" by blast
124.417 - }
124.418 - thus "(a, a') \<in> r" by blast
124.419 - qed
124.420 - ultimately show ?thesis
124.421 - using equals_suc_AboveS by auto
124.422 -qed
124.423 -
124.424 -
124.425 -subsubsection {* Properties of order filters *}
124.426 -
124.427 -
124.428 -lemma under_ofilter:
124.429 -"ofilter (under a)"
124.430 -proof(unfold ofilter_def under_def, auto simp add: Field_def)
124.431 - fix aa x
124.432 - assume "(aa,a) \<in> r" "(x,aa) \<in> r"
124.433 - thus "(x,a) \<in> r"
124.434 - using TRANS trans_def[of r] by blast
124.435 -qed
124.436 -
124.437 -
124.438 -lemma underS_ofilter:
124.439 -"ofilter (underS a)"
124.440 -proof(unfold ofilter_def underS_def under_def, auto simp add: Field_def)
124.441 - fix aa assume "(a, aa) \<in> r" "(aa, a) \<in> r" and DIFF: "aa \<noteq> a"
124.442 - thus False
124.443 - using ANTISYM antisym_def[of r] by blast
124.444 -next
124.445 - fix aa x
124.446 - assume "(aa,a) \<in> r" "aa \<noteq> a" "(x,aa) \<in> r"
124.447 - thus "(x,a) \<in> r"
124.448 - using TRANS trans_def[of r] by blast
124.449 -qed
124.450 -
124.451 -
124.452 -lemma Field_ofilter:
124.453 -"ofilter (Field r)"
124.454 -by(unfold ofilter_def under_def, auto simp add: Field_def)
124.455 -
124.456 -
124.457 -lemma ofilter_underS_Field:
124.458 -"ofilter A = ((\<exists>a \<in> Field r. A = underS a) \<or> (A = Field r))"
124.459 -proof
124.460 - assume "(\<exists>a\<in>Field r. A = underS a) \<or> A = Field r"
124.461 - thus "ofilter A"
124.462 - by (auto simp: underS_ofilter Field_ofilter)
124.463 -next
124.464 - assume *: "ofilter A"
124.465 - let ?One = "(\<exists>a\<in>Field r. A = underS a)"
124.466 - let ?Two = "(A = Field r)"
124.467 - show "?One \<or> ?Two"
124.468 - proof(cases ?Two, simp)
124.469 - let ?B = "(Field r) - A"
124.470 - let ?a = "minim ?B"
124.471 - assume "A \<noteq> Field r"
124.472 - moreover have "A \<le> Field r" using * ofilter_def by simp
124.473 - ultimately have 1: "?B \<noteq> {}" by blast
124.474 - hence 2: "?a \<in> Field r" using minim_inField[of ?B] by blast
124.475 - have 3: "?a \<in> ?B" using minim_in[of ?B] 1 by blast
124.476 - hence 4: "?a \<notin> A" by blast
124.477 - have 5: "A \<le> Field r" using * ofilter_def[of A] by auto
124.478 - (* *)
124.479 - moreover
124.480 - have "A = underS ?a"
124.481 - proof
124.482 - show "A \<le> underS ?a"
124.483 - proof(unfold underS_def, auto simp add: 4)
124.484 - fix x assume **: "x \<in> A"
124.485 - hence 11: "x \<in> Field r" using 5 by auto
124.486 - have 12: "x \<noteq> ?a" using 4 ** by auto
124.487 - have 13: "under x \<le> A" using * ofilter_def ** by auto
124.488 - {assume "(x,?a) \<notin> r"
124.489 - hence "(?a,x) \<in> r"
124.490 - using TOTAL total_on_def[of "Field r" r]
124.491 - 2 4 11 12 by auto
124.492 - hence "?a \<in> under x" using under_def by auto
124.493 - hence "?a \<in> A" using ** 13 by blast
124.494 - with 4 have False by simp
124.495 - }
124.496 - thus "(x,?a) \<in> r" by blast
124.497 - qed
124.498 - next
124.499 - show "underS ?a \<le> A"
124.500 - proof(unfold underS_def, auto)
124.501 - fix x
124.502 - assume **: "x \<noteq> ?a" and ***: "(x,?a) \<in> r"
124.503 - hence 11: "x \<in> Field r" using Field_def by fastforce
124.504 - {assume "x \<notin> A"
124.505 - hence "x \<in> ?B" using 11 by auto
124.506 - hence "(?a,x) \<in> r" using 3 minim_least[of ?B x] by blast
124.507 - hence False
124.508 - using ANTISYM antisym_def[of r] ** *** by auto
124.509 - }
124.510 - thus "x \<in> A" by blast
124.511 - qed
124.512 - qed
124.513 - ultimately have ?One using 2 by blast
124.514 - thus ?thesis by simp
124.515 - qed
124.516 -qed
124.517 -
124.518 -
124.519 -lemma ofilter_Under:
124.520 -assumes "A \<le> Field r"
124.521 -shows "ofilter(Under A)"
124.522 -proof(unfold ofilter_def, auto)
124.523 - fix x assume "x \<in> Under A"
124.524 - thus "x \<in> Field r"
124.525 - using Under_Field assms by auto
124.526 -next
124.527 - fix a x
124.528 - assume "a \<in> Under A" and "x \<in> under a"
124.529 - thus "x \<in> Under A"
124.530 - using TRANS under_Under_trans by auto
124.531 -qed
124.532 -
124.533 -
124.534 -lemma ofilter_UnderS:
124.535 -assumes "A \<le> Field r"
124.536 -shows "ofilter(UnderS A)"
124.537 -proof(unfold ofilter_def, auto)
124.538 - fix x assume "x \<in> UnderS A"
124.539 - thus "x \<in> Field r"
124.540 - using UnderS_Field assms by auto
124.541 -next
124.542 - fix a x
124.543 - assume "a \<in> UnderS A" and "x \<in> under a"
124.544 - thus "x \<in> UnderS A"
124.545 - using TRANS ANTISYM under_UnderS_trans by auto
124.546 -qed
124.547 -
124.548 -
124.549 -lemma ofilter_Int: "\<lbrakk>ofilter A; ofilter B\<rbrakk> \<Longrightarrow> ofilter(A Int B)"
124.550 -unfolding ofilter_def by blast
124.551 -
124.552 -
124.553 -lemma ofilter_Un: "\<lbrakk>ofilter A; ofilter B\<rbrakk> \<Longrightarrow> ofilter(A \<union> B)"
124.554 -unfolding ofilter_def by blast
124.555 -
124.556 -
124.557 -lemma ofilter_UNION:
124.558 -"(\<And> i. i \<in> I \<Longrightarrow> ofilter(A i)) \<Longrightarrow> ofilter (\<Union> i \<in> I. A i)"
124.559 -unfolding ofilter_def by blast
124.560 -
124.561 -
124.562 -lemma ofilter_under_UNION:
124.563 -assumes "ofilter A"
124.564 -shows "A = (\<Union> a \<in> A. under a)"
124.565 -proof
124.566 - have "\<forall>a \<in> A. under a \<le> A"
124.567 - using assms ofilter_def by auto
124.568 - thus "(\<Union> a \<in> A. under a) \<le> A" by blast
124.569 -next
124.570 - have "\<forall>a \<in> A. a \<in> under a"
124.571 - using REFL Refl_under_in assms ofilter_def by blast
124.572 - thus "A \<le> (\<Union> a \<in> A. under a)" by blast
124.573 -qed
124.574 -
124.575 -
124.576 -subsubsection{* Other properties *}
124.577 -
124.578 -
124.579 -lemma ofilter_linord:
124.580 -assumes OF1: "ofilter A" and OF2: "ofilter B"
124.581 -shows "A \<le> B \<or> B \<le> A"
124.582 -proof(cases "A = Field r")
124.583 - assume Case1: "A = Field r"
124.584 - hence "B \<le> A" using OF2 ofilter_def by auto
124.585 - thus ?thesis by simp
124.586 -next
124.587 - assume Case2: "A \<noteq> Field r"
124.588 - with ofilter_underS_Field OF1 obtain a where
124.589 - 1: "a \<in> Field r \<and> A = underS a" by auto
124.590 - show ?thesis
124.591 - proof(cases "B = Field r")
124.592 - assume Case21: "B = Field r"
124.593 - hence "A \<le> B" using OF1 ofilter_def by auto
124.594 - thus ?thesis by simp
124.595 - next
124.596 - assume Case22: "B \<noteq> Field r"
124.597 - with ofilter_underS_Field OF2 obtain b where
124.598 - 2: "b \<in> Field r \<and> B = underS b" by auto
124.599 - have "a = b \<or> (a,b) \<in> r \<or> (b,a) \<in> r"
124.600 - using 1 2 TOTAL total_on_def[of _ r] by auto
124.601 - moreover
124.602 - {assume "a = b" with 1 2 have ?thesis by auto
124.603 - }
124.604 - moreover
124.605 - {assume "(a,b) \<in> r"
124.606 - with underS_incr TRANS ANTISYM 1 2
124.607 - have "A \<le> B" by auto
124.608 - hence ?thesis by auto
124.609 - }
124.610 - moreover
124.611 - {assume "(b,a) \<in> r"
124.612 - with underS_incr TRANS ANTISYM 1 2
124.613 - have "B \<le> A" by auto
124.614 - hence ?thesis by auto
124.615 - }
124.616 - ultimately show ?thesis by blast
124.617 - qed
124.618 -qed
124.619 -
124.620 -
124.621 -lemma ofilter_AboveS_Field:
124.622 -assumes "ofilter A"
124.623 -shows "A \<union> (AboveS A) = Field r"
124.624 -proof
124.625 - show "A \<union> (AboveS A) \<le> Field r"
124.626 - using assms ofilter_def AboveS_Field by auto
124.627 -next
124.628 - {fix x assume *: "x \<in> Field r" and **: "x \<notin> A"
124.629 - {fix y assume ***: "y \<in> A"
124.630 - with ** have 1: "y \<noteq> x" by auto
124.631 - {assume "(y,x) \<notin> r"
124.632 - moreover
124.633 - have "y \<in> Field r" using assms ofilter_def *** by auto
124.634 - ultimately have "(x,y) \<in> r"
124.635 - using 1 * TOTAL total_on_def[of _ r] by auto
124.636 - with *** assms ofilter_def under_def have "x \<in> A" by auto
124.637 - with ** have False by contradiction
124.638 - }
124.639 - hence "(y,x) \<in> r" by blast
124.640 - with 1 have "y \<noteq> x \<and> (y,x) \<in> r" by auto
124.641 - }
124.642 - with * have "x \<in> AboveS A" unfolding AboveS_def by auto
124.643 - }
124.644 - thus "Field r \<le> A \<union> (AboveS A)" by blast
124.645 -qed
124.646 -
124.647 -
124.648 -lemma suc_ofilter_in:
124.649 -assumes OF: "ofilter A" and ABOVE_NE: "AboveS A \<noteq> {}" and
124.650 - REL: "(b,suc A) \<in> r" and DIFF: "b \<noteq> suc A"
124.651 -shows "b \<in> A"
124.652 -proof-
124.653 - have *: "suc A \<in> Field r \<and> b \<in> Field r"
124.654 - using WELL REL well_order_on_domain by auto
124.655 - {assume **: "b \<notin> A"
124.656 - hence "b \<in> AboveS A"
124.657 - using OF * ofilter_AboveS_Field by auto
124.658 - hence "(suc A, b) \<in> r"
124.659 - using suc_least_AboveS by auto
124.660 - hence False using REL DIFF ANTISYM *
124.661 - by (auto simp add: antisym_def)
124.662 - }
124.663 - thus ?thesis by blast
124.664 -qed
124.665 -
124.666 -
124.667 -
124.668 -end (* context wo_rel *)
124.669 -
124.670 -
124.671 -
124.672 -end
125.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
125.2 +++ b/src/HOL/Cardinals/Wellorder_Relation_FP.thy Thu Dec 05 17:58:03 2013 +0100
125.3 @@ -0,0 +1,631 @@
125.4 +(* Title: HOL/Cardinals/Wellorder_Relation_FP.thy
125.5 + Author: Andrei Popescu, TU Muenchen
125.6 + Copyright 2012
125.7 +
125.8 +Well-order relations (FP).
125.9 +*)
125.10 +
125.11 +header {* Well-Order Relations (FP) *}
125.12 +
125.13 +theory Wellorder_Relation_FP
125.14 +imports Wellfounded_More_FP
125.15 +begin
125.16 +
125.17 +
125.18 +text{* In this section, we develop basic concepts and results pertaining
125.19 +to well-order relations. Note that we consider well-order relations
125.20 +as {\em non-strict relations},
125.21 +i.e., as containing the diagonals of their fields. *}
125.22 +
125.23 +
125.24 +locale wo_rel = rel + assumes WELL: "Well_order r"
125.25 +begin
125.26 +
125.27 +text{* The following context encompasses all this section. In other words,
125.28 +for the whole section, we consider a fixed well-order relation @{term "r"}. *}
125.29 +
125.30 +(* context wo_rel *)
125.31 +
125.32 +
125.33 +subsection {* Auxiliaries *}
125.34 +
125.35 +
125.36 +lemma REFL: "Refl r"
125.37 +using WELL order_on_defs[of _ r] by auto
125.38 +
125.39 +
125.40 +lemma TRANS: "trans r"
125.41 +using WELL order_on_defs[of _ r] by auto
125.42 +
125.43 +
125.44 +lemma ANTISYM: "antisym r"
125.45 +using WELL order_on_defs[of _ r] by auto
125.46 +
125.47 +
125.48 +lemma TOTAL: "Total r"
125.49 +using WELL order_on_defs[of _ r] by auto
125.50 +
125.51 +
125.52 +lemma TOTALS: "\<forall>a \<in> Field r. \<forall>b \<in> Field r. (a,b) \<in> r \<or> (b,a) \<in> r"
125.53 +using REFL TOTAL refl_on_def[of _ r] total_on_def[of _ r] by force
125.54 +
125.55 +
125.56 +lemma LIN: "Linear_order r"
125.57 +using WELL well_order_on_def[of _ r] by auto
125.58 +
125.59 +
125.60 +lemma WF: "wf (r - Id)"
125.61 +using WELL well_order_on_def[of _ r] by auto
125.62 +
125.63 +
125.64 +lemma cases_Total:
125.65 +"\<And> phi a b. \<lbrakk>{a,b} <= Field r; ((a,b) \<in> r \<Longrightarrow> phi a b); ((b,a) \<in> r \<Longrightarrow> phi a b)\<rbrakk>
125.66 + \<Longrightarrow> phi a b"
125.67 +using TOTALS by auto
125.68 +
125.69 +
125.70 +lemma cases_Total3:
125.71 +"\<And> phi a b. \<lbrakk>{a,b} \<le> Field r; ((a,b) \<in> r - Id \<or> (b,a) \<in> r - Id \<Longrightarrow> phi a b);
125.72 + (a = b \<Longrightarrow> phi a b)\<rbrakk> \<Longrightarrow> phi a b"
125.73 +using TOTALS by auto
125.74 +
125.75 +
125.76 +subsection {* Well-founded induction and recursion adapted to non-strict well-order relations *}
125.77 +
125.78 +
125.79 +text{* Here we provide induction and recursion principles specific to {\em non-strict}
125.80 +well-order relations.
125.81 +Although minor variations of those for well-founded relations, they will be useful
125.82 +for doing away with the tediousness of
125.83 +having to take out the diagonal each time in order to switch to a well-founded relation. *}
125.84 +
125.85 +
125.86 +lemma well_order_induct:
125.87 +assumes IND: "\<And>x. \<forall>y. y \<noteq> x \<and> (y, x) \<in> r \<longrightarrow> P y \<Longrightarrow> P x"
125.88 +shows "P a"
125.89 +proof-
125.90 + have "\<And>x. \<forall>y. (y, x) \<in> r - Id \<longrightarrow> P y \<Longrightarrow> P x"
125.91 + using IND by blast
125.92 + thus "P a" using WF wf_induct[of "r - Id" P a] by blast
125.93 +qed
125.94 +
125.95 +
125.96 +definition
125.97 +worec :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
125.98 +where
125.99 +"worec F \<equiv> wfrec (r - Id) F"
125.100 +
125.101 +
125.102 +definition
125.103 +adm_wo :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> bool"
125.104 +where
125.105 +"adm_wo H \<equiv> \<forall>f g x. (\<forall>y \<in> underS x. f y = g y) \<longrightarrow> H f x = H g x"
125.106 +
125.107 +
125.108 +lemma worec_fixpoint:
125.109 +assumes ADM: "adm_wo H"
125.110 +shows "worec H = H (worec H)"
125.111 +proof-
125.112 + let ?rS = "r - Id"
125.113 + have "adm_wf (r - Id) H"
125.114 + unfolding adm_wf_def
125.115 + using ADM adm_wo_def[of H] underS_def by auto
125.116 + hence "wfrec ?rS H = H (wfrec ?rS H)"
125.117 + using WF wfrec_fixpoint[of ?rS H] by simp
125.118 + thus ?thesis unfolding worec_def .
125.119 +qed
125.120 +
125.121 +
125.122 +subsection {* The notions of maximum, minimum, supremum, successor and order filter *}
125.123 +
125.124 +
125.125 +text{*
125.126 +We define the successor {\em of a set}, and not of an element (the latter is of course
125.127 +a particular case). Also, we define the maximum {\em of two elements}, @{text "max2"},
125.128 +and the minimum {\em of a set}, @{text "minim"} -- we chose these variants since we
125.129 +consider them the most useful for well-orders. The minimum is defined in terms of the
125.130 +auxiliary relational operator @{text "isMinim"}. Then, supremum and successor are
125.131 +defined in terms of minimum as expected.
125.132 +The minimum is only meaningful for non-empty sets, and the successor is only
125.133 +meaningful for sets for which strict upper bounds exist.
125.134 +Order filters for well-orders are also known as ``initial segments". *}
125.135 +
125.136 +
125.137 +definition max2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
125.138 +where "max2 a b \<equiv> if (a,b) \<in> r then b else a"
125.139 +
125.140 +
125.141 +definition isMinim :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
125.142 +where "isMinim A b \<equiv> b \<in> A \<and> (\<forall>a \<in> A. (b,a) \<in> r)"
125.143 +
125.144 +definition minim :: "'a set \<Rightarrow> 'a"
125.145 +where "minim A \<equiv> THE b. isMinim A b"
125.146 +
125.147 +
125.148 +definition supr :: "'a set \<Rightarrow> 'a"
125.149 +where "supr A \<equiv> minim (Above A)"
125.150 +
125.151 +definition suc :: "'a set \<Rightarrow> 'a"
125.152 +where "suc A \<equiv> minim (AboveS A)"
125.153 +
125.154 +definition ofilter :: "'a set \<Rightarrow> bool"
125.155 +where
125.156 +"ofilter A \<equiv> (A \<le> Field r) \<and> (\<forall>a \<in> A. under a \<le> A)"
125.157 +
125.158 +
125.159 +subsubsection {* Properties of max2 *}
125.160 +
125.161 +
125.162 +lemma max2_greater_among:
125.163 +assumes "a \<in> Field r" and "b \<in> Field r"
125.164 +shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r \<and> max2 a b \<in> {a,b}"
125.165 +proof-
125.166 + {assume "(a,b) \<in> r"
125.167 + hence ?thesis using max2_def assms REFL refl_on_def
125.168 + by (auto simp add: refl_on_def)
125.169 + }
125.170 + moreover
125.171 + {assume "a = b"
125.172 + hence "(a,b) \<in> r" using REFL assms
125.173 + by (auto simp add: refl_on_def)
125.174 + }
125.175 + moreover
125.176 + {assume *: "a \<noteq> b \<and> (b,a) \<in> r"
125.177 + hence "(a,b) \<notin> r" using ANTISYM
125.178 + by (auto simp add: antisym_def)
125.179 + hence ?thesis using * max2_def assms REFL refl_on_def
125.180 + by (auto simp add: refl_on_def)
125.181 + }
125.182 + ultimately show ?thesis using assms TOTAL
125.183 + total_on_def[of "Field r" r] by blast
125.184 +qed
125.185 +
125.186 +
125.187 +lemma max2_greater:
125.188 +assumes "a \<in> Field r" and "b \<in> Field r"
125.189 +shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r"
125.190 +using assms by (auto simp add: max2_greater_among)
125.191 +
125.192 +
125.193 +lemma max2_among:
125.194 +assumes "a \<in> Field r" and "b \<in> Field r"
125.195 +shows "max2 a b \<in> {a, b}"
125.196 +using assms max2_greater_among[of a b] by simp
125.197 +
125.198 +
125.199 +lemma max2_equals1:
125.200 +assumes "a \<in> Field r" and "b \<in> Field r"
125.201 +shows "(max2 a b = a) = ((b,a) \<in> r)"
125.202 +using assms ANTISYM unfolding antisym_def using TOTALS
125.203 +by(auto simp add: max2_def max2_among)
125.204 +
125.205 +
125.206 +lemma max2_equals2:
125.207 +assumes "a \<in> Field r" and "b \<in> Field r"
125.208 +shows "(max2 a b = b) = ((a,b) \<in> r)"
125.209 +using assms ANTISYM unfolding antisym_def using TOTALS
125.210 +unfolding max2_def by auto
125.211 +
125.212 +
125.213 +subsubsection {* Existence and uniqueness for isMinim and well-definedness of minim *}
125.214 +
125.215 +
125.216 +lemma isMinim_unique:
125.217 +assumes MINIM: "isMinim B a" and MINIM': "isMinim B a'"
125.218 +shows "a = a'"
125.219 +proof-
125.220 + {have "a \<in> B"
125.221 + using MINIM isMinim_def by simp
125.222 + hence "(a',a) \<in> r"
125.223 + using MINIM' isMinim_def by simp
125.224 + }
125.225 + moreover
125.226 + {have "a' \<in> B"
125.227 + using MINIM' isMinim_def by simp
125.228 + hence "(a,a') \<in> r"
125.229 + using MINIM isMinim_def by simp
125.230 + }
125.231 + ultimately
125.232 + show ?thesis using ANTISYM antisym_def[of r] by blast
125.233 +qed
125.234 +
125.235 +
125.236 +lemma Well_order_isMinim_exists:
125.237 +assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
125.238 +shows "\<exists>b. isMinim B b"
125.239 +proof-
125.240 + from spec[OF WF[unfolded wf_eq_minimal[of "r - Id"]], of B] NE obtain b where
125.241 + *: "b \<in> B \<and> (\<forall>b'. b' \<noteq> b \<and> (b',b) \<in> r \<longrightarrow> b' \<notin> B)" by auto
125.242 + show ?thesis
125.243 + proof(simp add: isMinim_def, rule exI[of _ b], auto)
125.244 + show "b \<in> B" using * by simp
125.245 + next
125.246 + fix b' assume As: "b' \<in> B"
125.247 + hence **: "b \<in> Field r \<and> b' \<in> Field r" using As SUB * by auto
125.248 + (* *)
125.249 + from As * have "b' = b \<or> (b',b) \<notin> r" by auto
125.250 + moreover
125.251 + {assume "b' = b"
125.252 + hence "(b,b') \<in> r"
125.253 + using ** REFL by (auto simp add: refl_on_def)
125.254 + }
125.255 + moreover
125.256 + {assume "b' \<noteq> b \<and> (b',b) \<notin> r"
125.257 + hence "(b,b') \<in> r"
125.258 + using ** TOTAL by (auto simp add: total_on_def)
125.259 + }
125.260 + ultimately show "(b,b') \<in> r" by blast
125.261 + qed
125.262 +qed
125.263 +
125.264 +
125.265 +lemma minim_isMinim:
125.266 +assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
125.267 +shows "isMinim B (minim B)"
125.268 +proof-
125.269 + let ?phi = "(\<lambda> b. isMinim B b)"
125.270 + from assms Well_order_isMinim_exists
125.271 + obtain b where *: "?phi b" by blast
125.272 + moreover
125.273 + have "\<And> b'. ?phi b' \<Longrightarrow> b' = b"
125.274 + using isMinim_unique * by auto
125.275 + ultimately show ?thesis
125.276 + unfolding minim_def using theI[of ?phi b] by blast
125.277 +qed
125.278 +
125.279 +
125.280 +subsubsection{* Properties of minim *}
125.281 +
125.282 +
125.283 +lemma minim_in:
125.284 +assumes "B \<le> Field r" and "B \<noteq> {}"
125.285 +shows "minim B \<in> B"
125.286 +proof-
125.287 + from minim_isMinim[of B] assms
125.288 + have "isMinim B (minim B)" by simp
125.289 + thus ?thesis by (simp add: isMinim_def)
125.290 +qed
125.291 +
125.292 +
125.293 +lemma minim_inField:
125.294 +assumes "B \<le> Field r" and "B \<noteq> {}"
125.295 +shows "minim B \<in> Field r"
125.296 +proof-
125.297 + have "minim B \<in> B" using assms by (simp add: minim_in)
125.298 + thus ?thesis using assms by blast
125.299 +qed
125.300 +
125.301 +
125.302 +lemma minim_least:
125.303 +assumes SUB: "B \<le> Field r" and IN: "b \<in> B"
125.304 +shows "(minim B, b) \<in> r"
125.305 +proof-
125.306 + from minim_isMinim[of B] assms
125.307 + have "isMinim B (minim B)" by auto
125.308 + thus ?thesis by (auto simp add: isMinim_def IN)
125.309 +qed
125.310 +
125.311 +
125.312 +lemma equals_minim:
125.313 +assumes SUB: "B \<le> Field r" and IN: "a \<in> B" and
125.314 + LEAST: "\<And> b. b \<in> B \<Longrightarrow> (a,b) \<in> r"
125.315 +shows "a = minim B"
125.316 +proof-
125.317 + from minim_isMinim[of B] assms
125.318 + have "isMinim B (minim B)" by auto
125.319 + moreover have "isMinim B a" using IN LEAST isMinim_def by auto
125.320 + ultimately show ?thesis
125.321 + using isMinim_unique by auto
125.322 +qed
125.323 +
125.324 +
125.325 +subsubsection{* Properties of successor *}
125.326 +
125.327 +
125.328 +lemma suc_AboveS:
125.329 +assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}"
125.330 +shows "suc B \<in> AboveS B"
125.331 +proof(unfold suc_def)
125.332 + have "AboveS B \<le> Field r"
125.333 + using AboveS_Field by auto
125.334 + thus "minim (AboveS B) \<in> AboveS B"
125.335 + using assms by (simp add: minim_in)
125.336 +qed
125.337 +
125.338 +
125.339 +lemma suc_greater:
125.340 +assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}" and
125.341 + IN: "b \<in> B"
125.342 +shows "suc B \<noteq> b \<and> (b,suc B) \<in> r"
125.343 +proof-
125.344 + from assms suc_AboveS
125.345 + have "suc B \<in> AboveS B" by simp
125.346 + with IN AboveS_def show ?thesis by simp
125.347 +qed
125.348 +
125.349 +
125.350 +lemma suc_least_AboveS:
125.351 +assumes ABOVES: "a \<in> AboveS B"
125.352 +shows "(suc B,a) \<in> r"
125.353 +proof(unfold suc_def)
125.354 + have "AboveS B \<le> Field r"
125.355 + using AboveS_Field by auto
125.356 + thus "(minim (AboveS B),a) \<in> r"
125.357 + using assms minim_least by simp
125.358 +qed
125.359 +
125.360 +
125.361 +lemma suc_inField:
125.362 +assumes "B \<le> Field r" and "AboveS B \<noteq> {}"
125.363 +shows "suc B \<in> Field r"
125.364 +proof-
125.365 + have "suc B \<in> AboveS B" using suc_AboveS assms by simp
125.366 + thus ?thesis
125.367 + using assms AboveS_Field by auto
125.368 +qed
125.369 +
125.370 +
125.371 +lemma equals_suc_AboveS:
125.372 +assumes SUB: "B \<le> Field r" and ABV: "a \<in> AboveS B" and
125.373 + MINIM: "\<And> a'. a' \<in> AboveS B \<Longrightarrow> (a,a') \<in> r"
125.374 +shows "a = suc B"
125.375 +proof(unfold suc_def)
125.376 + have "AboveS B \<le> Field r"
125.377 + using AboveS_Field[of B] by auto
125.378 + thus "a = minim (AboveS B)"
125.379 + using assms equals_minim
125.380 + by simp
125.381 +qed
125.382 +
125.383 +
125.384 +lemma suc_underS:
125.385 +assumes IN: "a \<in> Field r"
125.386 +shows "a = suc (underS a)"
125.387 +proof-
125.388 + have "underS a \<le> Field r"
125.389 + using underS_Field by auto
125.390 + moreover
125.391 + have "a \<in> AboveS (underS a)"
125.392 + using in_AboveS_underS IN by auto
125.393 + moreover
125.394 + have "\<forall>a' \<in> AboveS (underS a). (a,a') \<in> r"
125.395 + proof(clarify)
125.396 + fix a'
125.397 + assume *: "a' \<in> AboveS (underS a)"
125.398 + hence **: "a' \<in> Field r"
125.399 + using AboveS_Field by auto
125.400 + {assume "(a,a') \<notin> r"
125.401 + hence "a' = a \<or> (a',a) \<in> r"
125.402 + using TOTAL IN ** by (auto simp add: total_on_def)
125.403 + moreover
125.404 + {assume "a' = a"
125.405 + hence "(a,a') \<in> r"
125.406 + using REFL IN ** by (auto simp add: refl_on_def)
125.407 + }
125.408 + moreover
125.409 + {assume "a' \<noteq> a \<and> (a',a) \<in> r"
125.410 + hence "a' \<in> underS a"
125.411 + unfolding underS_def by simp
125.412 + hence "a' \<notin> AboveS (underS a)"
125.413 + using AboveS_disjoint by blast
125.414 + with * have False by simp
125.415 + }
125.416 + ultimately have "(a,a') \<in> r" by blast
125.417 + }
125.418 + thus "(a, a') \<in> r" by blast
125.419 + qed
125.420 + ultimately show ?thesis
125.421 + using equals_suc_AboveS by auto
125.422 +qed
125.423 +
125.424 +
125.425 +subsubsection {* Properties of order filters *}
125.426 +
125.427 +
125.428 +lemma under_ofilter:
125.429 +"ofilter (under a)"
125.430 +proof(unfold ofilter_def under_def, auto simp add: Field_def)
125.431 + fix aa x
125.432 + assume "(aa,a) \<in> r" "(x,aa) \<in> r"
125.433 + thus "(x,a) \<in> r"
125.434 + using TRANS trans_def[of r] by blast
125.435 +qed
125.436 +
125.437 +
125.438 +lemma underS_ofilter:
125.439 +"ofilter (underS a)"
125.440 +proof(unfold ofilter_def underS_def under_def, auto simp add: Field_def)
125.441 + fix aa assume "(a, aa) \<in> r" "(aa, a) \<in> r" and DIFF: "aa \<noteq> a"
125.442 + thus False
125.443 + using ANTISYM antisym_def[of r] by blast
125.444 +next
125.445 + fix aa x
125.446 + assume "(aa,a) \<in> r" "aa \<noteq> a" "(x,aa) \<in> r"
125.447 + thus "(x,a) \<in> r"
125.448 + using TRANS trans_def[of r] by blast
125.449 +qed
125.450 +
125.451 +
125.452 +lemma Field_ofilter:
125.453 +"ofilter (Field r)"
125.454 +by(unfold ofilter_def under_def, auto simp add: Field_def)
125.455 +
125.456 +
125.457 +lemma ofilter_underS_Field:
125.458 +"ofilter A = ((\<exists>a \<in> Field r. A = underS a) \<or> (A = Field r))"
125.459 +proof
125.460 + assume "(\<exists>a\<in>Field r. A = underS a) \<or> A = Field r"
125.461 + thus "ofilter A"
125.462 + by (auto simp: underS_ofilter Field_ofilter)
125.463 +next
125.464 + assume *: "ofilter A"
125.465 + let ?One = "(\<exists>a\<in>Field r. A = underS a)"
125.466 + let ?Two = "(A = Field r)"
125.467 + show "?One \<or> ?Two"
125.468 + proof(cases ?Two, simp)
125.469 + let ?B = "(Field r) - A"
125.470 + let ?a = "minim ?B"
125.471 + assume "A \<noteq> Field r"
125.472 + moreover have "A \<le> Field r" using * ofilter_def by simp
125.473 + ultimately have 1: "?B \<noteq> {}" by blast
125.474 + hence 2: "?a \<in> Field r" using minim_inField[of ?B] by blast
125.475 + have 3: "?a \<in> ?B" using minim_in[of ?B] 1 by blast
125.476 + hence 4: "?a \<notin> A" by blast
125.477 + have 5: "A \<le> Field r" using * ofilter_def[of A] by auto
125.478 + (* *)
125.479 + moreover
125.480 + have "A = underS ?a"
125.481 + proof
125.482 + show "A \<le> underS ?a"
125.483 + proof(unfold underS_def, auto simp add: 4)
125.484 + fix x assume **: "x \<in> A"
125.485 + hence 11: "x \<in> Field r" using 5 by auto
125.486 + have 12: "x \<noteq> ?a" using 4 ** by auto
125.487 + have 13: "under x \<le> A" using * ofilter_def ** by auto
125.488 + {assume "(x,?a) \<notin> r"
125.489 + hence "(?a,x) \<in> r"
125.490 + using TOTAL total_on_def[of "Field r" r]
125.491 + 2 4 11 12 by auto
125.492 + hence "?a \<in> under x" using under_def by auto
125.493 + hence "?a \<in> A" using ** 13 by blast
125.494 + with 4 have False by simp
125.495 + }
125.496 + thus "(x,?a) \<in> r" by blast
125.497 + qed
125.498 + next
125.499 + show "underS ?a \<le> A"
125.500 + proof(unfold underS_def, auto)
125.501 + fix x
125.502 + assume **: "x \<noteq> ?a" and ***: "(x,?a) \<in> r"
125.503 + hence 11: "x \<in> Field r" using Field_def by fastforce
125.504 + {assume "x \<notin> A"
125.505 + hence "x \<in> ?B" using 11 by auto
125.506 + hence "(?a,x) \<in> r" using 3 minim_least[of ?B x] by blast
125.507 + hence False
125.508 + using ANTISYM antisym_def[of r] ** *** by auto
125.509 + }
125.510 + thus "x \<in> A" by blast
125.511 + qed
125.512 + qed
125.513 + ultimately have ?One using 2 by blast
125.514 + thus ?thesis by simp
125.515 + qed
125.516 +qed
125.517 +
125.518 +
125.519 +lemma ofilter_UNION:
125.520 +"(\<And> i. i \<in> I \<Longrightarrow> ofilter(A i)) \<Longrightarrow> ofilter (\<Union> i \<in> I. A i)"
125.521 +unfolding ofilter_def by blast
125.522 +
125.523 +
125.524 +lemma ofilter_under_UNION:
125.525 +assumes "ofilter A"
125.526 +shows "A = (\<Union> a \<in> A. under a)"
125.527 +proof
125.528 + have "\<forall>a \<in> A. under a \<le> A"
125.529 + using assms ofilter_def by auto
125.530 + thus "(\<Union> a \<in> A. under a) \<le> A" by blast
125.531 +next
125.532 + have "\<forall>a \<in> A. a \<in> under a"
125.533 + using REFL Refl_under_in assms ofilter_def by blast
125.534 + thus "A \<le> (\<Union> a \<in> A. under a)" by blast
125.535 +qed
125.536 +
125.537 +
125.538 +subsubsection{* Other properties *}
125.539 +
125.540 +
125.541 +lemma ofilter_linord:
125.542 +assumes OF1: "ofilter A" and OF2: "ofilter B"
125.543 +shows "A \<le> B \<or> B \<le> A"
125.544 +proof(cases "A = Field r")
125.545 + assume Case1: "A = Field r"
125.546 + hence "B \<le> A" using OF2 ofilter_def by auto
125.547 + thus ?thesis by simp
125.548 +next
125.549 + assume Case2: "A \<noteq> Field r"
125.550 + with ofilter_underS_Field OF1 obtain a where
125.551 + 1: "a \<in> Field r \<and> A = underS a" by auto
125.552 + show ?thesis
125.553 + proof(cases "B = Field r")
125.554 + assume Case21: "B = Field r"
125.555 + hence "A \<le> B" using OF1 ofilter_def by auto
125.556 + thus ?thesis by simp
125.557 + next
125.558 + assume Case22: "B \<noteq> Field r"
125.559 + with ofilter_underS_Field OF2 obtain b where
125.560 + 2: "b \<in> Field r \<and> B = underS b" by auto
125.561 + have "a = b \<or> (a,b) \<in> r \<or> (b,a) \<in> r"
125.562 + using 1 2 TOTAL total_on_def[of _ r] by auto
125.563 + moreover
125.564 + {assume "a = b" with 1 2 have ?thesis by auto
125.565 + }
125.566 + moreover
125.567 + {assume "(a,b) \<in> r"
125.568 + with underS_incr TRANS ANTISYM 1 2
125.569 + have "A \<le> B" by auto
125.570 + hence ?thesis by auto
125.571 + }
125.572 + moreover
125.573 + {assume "(b,a) \<in> r"
125.574 + with underS_incr TRANS ANTISYM 1 2
125.575 + have "B \<le> A" by auto
125.576 + hence ?thesis by auto
125.577 + }
125.578 + ultimately show ?thesis by blast
125.579 + qed
125.580 +qed
125.581 +
125.582 +
125.583 +lemma ofilter_AboveS_Field:
125.584 +assumes "ofilter A"
125.585 +shows "A \<union> (AboveS A) = Field r"
125.586 +proof
125.587 + show "A \<union> (AboveS A) \<le> Field r"
125.588 + using assms ofilter_def AboveS_Field by auto
125.589 +next
125.590 + {fix x assume *: "x \<in> Field r" and **: "x \<notin> A"
125.591 + {fix y assume ***: "y \<in> A"
125.592 + with ** have 1: "y \<noteq> x" by auto
125.593 + {assume "(y,x) \<notin> r"
125.594 + moreover
125.595 + have "y \<in> Field r" using assms ofilter_def *** by auto
125.596 + ultimately have "(x,y) \<in> r"
125.597 + using 1 * TOTAL total_on_def[of _ r] by auto
125.598 + with *** assms ofilter_def under_def have "x \<in> A" by auto
125.599 + with ** have False by contradiction
125.600 + }
125.601 + hence "(y,x) \<in> r" by blast
125.602 + with 1 have "y \<noteq> x \<and> (y,x) \<in> r" by auto
125.603 + }
125.604 + with * have "x \<in> AboveS A" unfolding AboveS_def by auto
125.605 + }
125.606 + thus "Field r \<le> A \<union> (AboveS A)" by blast
125.607 +qed
125.608 +
125.609 +
125.610 +lemma suc_ofilter_in:
125.611 +assumes OF: "ofilter A" and ABOVE_NE: "AboveS A \<noteq> {}" and
125.612 + REL: "(b,suc A) \<in> r" and DIFF: "b \<noteq> suc A"
125.613 +shows "b \<in> A"
125.614 +proof-
125.615 + have *: "suc A \<in> Field r \<and> b \<in> Field r"
125.616 + using WELL REL well_order_on_domain by auto
125.617 + {assume **: "b \<notin> A"
125.618 + hence "b \<in> AboveS A"
125.619 + using OF * ofilter_AboveS_Field by auto
125.620 + hence "(suc A, b) \<in> r"
125.621 + using suc_least_AboveS by auto
125.622 + hence False using REL DIFF ANTISYM *
125.623 + by (auto simp add: antisym_def)
125.624 + }
125.625 + thus ?thesis by blast
125.626 +qed
125.627 +
125.628 +
125.629 +
125.630 +end (* context wo_rel *)
125.631 +
125.632 +
125.633 +
125.634 +end
126.1 --- a/src/HOL/Code_Numeral.thy Thu Dec 05 17:52:12 2013 +0100
126.2 +++ b/src/HOL/Code_Numeral.thy Thu Dec 05 17:58:03 2013 +0100
126.3 @@ -96,10 +96,6 @@
126.4 qed
126.5
126.6 lemma [transfer_rule]:
126.7 - "fun_rel HOL.eq pcr_integer (neg_numeral :: num \<Rightarrow> int) (neg_numeral :: num \<Rightarrow> integer)"
126.8 - by (unfold neg_numeral_def [abs_def]) transfer_prover
126.9 -
126.10 -lemma [transfer_rule]:
126.11 "fun_rel HOL.eq (fun_rel HOL.eq pcr_integer) (Num.sub :: _ \<Rightarrow> _ \<Rightarrow> int) (Num.sub :: _ \<Rightarrow> _ \<Rightarrow> integer)"
126.12 by (unfold Num.sub_def [abs_def]) transfer_prover
126.13
126.14 @@ -147,10 +143,6 @@
126.15 "int_of_integer (numeral k) = numeral k"
126.16 by transfer rule
126.17
126.18 -lemma int_of_integer_neg_numeral [simp]:
126.19 - "int_of_integer (neg_numeral k) = neg_numeral k"
126.20 - by transfer rule
126.21 -
126.22 lemma int_of_integer_sub [simp]:
126.23 "int_of_integer (Num.sub k l) = Num.sub k l"
126.24 by transfer rule
126.25 @@ -253,11 +245,11 @@
126.26
126.27 definition Neg :: "num \<Rightarrow> integer"
126.28 where
126.29 - [simp, code_abbrev]: "Neg = neg_numeral"
126.30 + [simp, code_abbrev]: "Neg n = - Pos n"
126.31
126.32 lemma [transfer_rule]:
126.33 - "fun_rel HOL.eq pcr_integer neg_numeral Neg"
126.34 - by simp transfer_prover
126.35 + "fun_rel HOL.eq pcr_integer (\<lambda>n. - numeral n) Neg"
126.36 + by (simp add: Neg_def [abs_def]) transfer_prover
126.37
126.38 code_datatype "0::integer" Pos Neg
126.39
126.40 @@ -272,7 +264,7 @@
126.41 "dup 0 = 0"
126.42 "dup (Pos n) = Pos (Num.Bit0 n)"
126.43 "dup (Neg n) = Neg (Num.Bit0 n)"
126.44 - by (transfer, simp only: neg_numeral_def numeral_Bit0 minus_add_distrib)+
126.45 + by (transfer, simp only: numeral_Bit0 minus_add_distrib)+
126.46
126.47 lift_definition sub :: "num \<Rightarrow> num \<Rightarrow> integer"
126.48 is "\<lambda>m n. numeral m - numeral n :: int"
127.1 --- a/src/HOL/Codegenerator_Test/Generate_Binary_Nat.thy Thu Dec 05 17:52:12 2013 +0100
127.2 +++ b/src/HOL/Codegenerator_Test/Generate_Binary_Nat.thy Thu Dec 05 17:58:03 2013 +0100
127.3 @@ -16,6 +16,20 @@
127.4 by a corresponding @{text export_code} command.
127.5 *}
127.6
127.7 -export_code _ checking SML OCaml? Haskell? Scala
127.8 +text {* Formal joining of hierarchy of implicit definitions in Scala *}
127.9 +
127.10 +class semiring_numeral_even_odd = semiring_numeral_div + even_odd
127.11 +
127.12 +instance nat :: semiring_numeral_even_odd ..
127.13 +
127.14 +definition semiring_numeral_even_odd :: "'a itself \<Rightarrow> 'a::semiring_numeral_even_odd"
127.15 +where
127.16 + "semiring_numeral_even_odd TYPE('a) = undefined"
127.17 +
127.18 +definition semiring_numeral_even_odd_nat :: "nat itself \<Rightarrow> nat"
127.19 +where
127.20 + "semiring_numeral_even_odd_nat = semiring_numeral_even_odd"
127.21 +
127.22 +export_code _ checking SML OCaml? Haskell? Scala
127.23
127.24 end
128.1 --- a/src/HOL/Codegenerator_Test/Generate_Efficient_Datastructures.thy Thu Dec 05 17:52:12 2013 +0100
128.2 +++ b/src/HOL/Codegenerator_Test/Generate_Efficient_Datastructures.thy Thu Dec 05 17:58:03 2013 +0100
128.3 @@ -26,7 +26,7 @@
128.4 "pred_of_set = pred_of_set" ..
128.5
128.6 lemma [code, code del]:
128.7 - "acc = acc" ..
128.8 + "Wellfounded.acc = Wellfounded.acc" ..
128.9
128.10 lemma [code, code del]:
128.11 "Cardinality.card' = Cardinality.card'" ..
128.12 @@ -40,6 +40,18 @@
128.13 lemma [code, code del]:
128.14 "Cardinality.eq_set = Cardinality.eq_set" ..
128.15
128.16 +lemma [code, code del]:
128.17 + "(Gcd :: nat set \<Rightarrow> nat) = Gcd" ..
128.18 +
128.19 +lemma [code, code del]:
128.20 + "(Lcm :: nat set \<Rightarrow> nat) = Lcm" ..
128.21 +
128.22 +lemma [code, code del]:
128.23 + "(Gcd :: int set \<Rightarrow> int) = Gcd" ..
128.24 +
128.25 +lemma [code, code del]:
128.26 + "(Lcm :: int set \<Rightarrow> int) = Lcm" ..
128.27 +
128.28 (*
128.29 If the code generation ends with an exception with the following message:
128.30 '"List.set" is not a constructor, on left hand side of equation: ...',
129.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
129.2 +++ b/src/HOL/Coinduction.thy Thu Dec 05 17:58:03 2013 +0100
129.3 @@ -0,0 +1,19 @@
129.4 +(* Title: HOL/Coinduction.thy
129.5 + Author: Johannes Hölzl, TU Muenchen
129.6 + Author: Dmitriy Traytel, TU Muenchen
129.7 + Copyright 2013
129.8 +
129.9 +Coinduction method that avoids some boilerplate compared to coinduct.
129.10 +*)
129.11 +
129.12 +header {* Coinduction Method *}
129.13 +
129.14 +theory Coinduction
129.15 +imports Ctr_Sugar
129.16 +begin
129.17 +
129.18 +ML_file "Tools/coinduction.ML"
129.19 +
129.20 +setup Coinduction.setup
129.21 +
129.22 +end
130.1 --- a/src/HOL/Complete_Lattices.thy Thu Dec 05 17:52:12 2013 +0100
130.2 +++ b/src/HOL/Complete_Lattices.thy Thu Dec 05 17:58:03 2013 +0100
130.3 @@ -15,10 +15,66 @@
130.4
130.5 class Inf =
130.6 fixes Inf :: "'a set \<Rightarrow> 'a" ("\<Sqinter>_" [900] 900)
130.7 +begin
130.8 +
130.9 +definition INFI :: "'b set \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a" where
130.10 + INF_def: "INFI A f = \<Sqinter>(f ` A)"
130.11 +
130.12 +lemma INF_image [simp]: "INFI (f`A) g = INFI A (\<lambda>x. g (f x))"
130.13 + by (simp add: INF_def image_image)
130.14 +
130.15 +lemma INF_cong: "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> C x = D x) \<Longrightarrow> INFI A C = INFI B D"
130.16 + by (simp add: INF_def image_def)
130.17 +
130.18 +end
130.19
130.20 class Sup =
130.21 fixes Sup :: "'a set \<Rightarrow> 'a" ("\<Squnion>_" [900] 900)
130.22 +begin
130.23
130.24 +definition SUPR :: "'b set \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a" where
130.25 + SUP_def: "SUPR A f = \<Squnion>(f ` A)"
130.26 +
130.27 +lemma SUP_image [simp]: "SUPR (f`A) g = SUPR A (%x. g (f x))"
130.28 + by (simp add: SUP_def image_image)
130.29 +
130.30 +lemma SUP_cong: "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> C x = D x) \<Longrightarrow> SUPR A C = SUPR B D"
130.31 + by (simp add: SUP_def image_def)
130.32 +
130.33 +end
130.34 +
130.35 +text {*
130.36 + Note: must use names @{const INFI} and @{const SUPR} here instead of
130.37 + @{text INF} and @{text SUP} to allow the following syntax coexist
130.38 + with the plain constant names.
130.39 +*}
130.40 +
130.41 +syntax
130.42 + "_INF1" :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b" ("(3INF _./ _)" [0, 10] 10)
130.43 + "_INF" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b" ("(3INF _:_./ _)" [0, 0, 10] 10)
130.44 + "_SUP1" :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b" ("(3SUP _./ _)" [0, 10] 10)
130.45 + "_SUP" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b" ("(3SUP _:_./ _)" [0, 0, 10] 10)
130.46 +
130.47 +syntax (xsymbols)
130.48 + "_INF1" :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b" ("(3\<Sqinter>_./ _)" [0, 10] 10)
130.49 + "_INF" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b" ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
130.50 + "_SUP1" :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b" ("(3\<Squnion>_./ _)" [0, 10] 10)
130.51 + "_SUP" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b" ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
130.52 +
130.53 +translations
130.54 + "INF x y. B" == "INF x. INF y. B"
130.55 + "INF x. B" == "CONST INFI CONST UNIV (%x. B)"
130.56 + "INF x. B" == "INF x:CONST UNIV. B"
130.57 + "INF x:A. B" == "CONST INFI A (%x. B)"
130.58 + "SUP x y. B" == "SUP x. SUP y. B"
130.59 + "SUP x. B" == "CONST SUPR CONST UNIV (%x. B)"
130.60 + "SUP x. B" == "SUP x:CONST UNIV. B"
130.61 + "SUP x:A. B" == "CONST SUPR A (%x. B)"
130.62 +
130.63 +print_translation {*
130.64 + [Syntax_Trans.preserve_binder_abs2_tr' @{const_syntax INFI} @{syntax_const "_INF"},
130.65 + Syntax_Trans.preserve_binder_abs2_tr' @{const_syntax SUPR} @{syntax_const "_SUP"}]
130.66 +*} -- {* to avoid eta-contraction of body *}
130.67
130.68 subsection {* Abstract complete lattices *}
130.69
130.70 @@ -49,59 +105,17 @@
130.71 (unfold_locales, (fact Inf_empty Sup_empty
130.72 Sup_upper Sup_least Inf_lower Inf_greatest)+)
130.73
130.74 -definition INFI :: "'b set \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a" where
130.75 - INF_def: "INFI A f = \<Sqinter>(f ` A)"
130.76 -
130.77 -definition SUPR :: "'b set \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a" where
130.78 - SUP_def: "SUPR A f = \<Squnion>(f ` A)"
130.79 -
130.80 -text {*
130.81 - Note: must use names @{const INFI} and @{const SUPR} here instead of
130.82 - @{text INF} and @{text SUP} to allow the following syntax coexist
130.83 - with the plain constant names.
130.84 -*}
130.85 -
130.86 end
130.87
130.88 -syntax
130.89 - "_INF1" :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b" ("(3INF _./ _)" [0, 10] 10)
130.90 - "_INF" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b" ("(3INF _:_./ _)" [0, 0, 10] 10)
130.91 - "_SUP1" :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b" ("(3SUP _./ _)" [0, 10] 10)
130.92 - "_SUP" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b" ("(3SUP _:_./ _)" [0, 0, 10] 10)
130.93 -
130.94 -syntax (xsymbols)
130.95 - "_INF1" :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b" ("(3\<Sqinter>_./ _)" [0, 10] 10)
130.96 - "_INF" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b" ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
130.97 - "_SUP1" :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b" ("(3\<Squnion>_./ _)" [0, 10] 10)
130.98 - "_SUP" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b" ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
130.99 -
130.100 -translations
130.101 - "INF x y. B" == "INF x. INF y. B"
130.102 - "INF x. B" == "CONST INFI CONST UNIV (%x. B)"
130.103 - "INF x. B" == "INF x:CONST UNIV. B"
130.104 - "INF x:A. B" == "CONST INFI A (%x. B)"
130.105 - "SUP x y. B" == "SUP x. SUP y. B"
130.106 - "SUP x. B" == "CONST SUPR CONST UNIV (%x. B)"
130.107 - "SUP x. B" == "SUP x:CONST UNIV. B"
130.108 - "SUP x:A. B" == "CONST SUPR A (%x. B)"
130.109 -
130.110 -print_translation {*
130.111 - [Syntax_Trans.preserve_binder_abs2_tr' @{const_syntax INFI} @{syntax_const "_INF"},
130.112 - Syntax_Trans.preserve_binder_abs2_tr' @{const_syntax SUPR} @{syntax_const "_SUP"}]
130.113 -*} -- {* to avoid eta-contraction of body *}
130.114 -
130.115 context complete_lattice
130.116 begin
130.117
130.118 -lemma INF_foundation_dual [no_atp]:
130.119 - "complete_lattice.SUPR Inf = INFI"
130.120 - by (simp add: fun_eq_iff INF_def
130.121 - complete_lattice.SUP_def [OF dual_complete_lattice])
130.122 +lemma INF_foundation_dual:
130.123 + "Sup.SUPR Inf = INFI"
130.124 + by (simp add: fun_eq_iff INF_def Sup.SUP_def)
130.125
130.126 -lemma SUP_foundation_dual [no_atp]:
130.127 - "complete_lattice.INFI Sup = SUPR"
130.128 - by (simp add: fun_eq_iff SUP_def
130.129 - complete_lattice.INF_def [OF dual_complete_lattice])
130.130 +lemma SUP_foundation_dual:
130.131 + "Inf.INFI Sup = SUPR" by (simp add: fun_eq_iff SUP_def Inf.INF_def)
130.132
130.133 lemma Sup_eqI:
130.134 "(\<And>y. y \<in> A \<Longrightarrow> y \<le> x) \<Longrightarrow> (\<And>y. (\<And>z. z \<in> A \<Longrightarrow> z \<le> y) \<Longrightarrow> x \<le> y) \<Longrightarrow> \<Squnion>A = x"
130.135 @@ -181,12 +195,6 @@
130.136 "\<Squnion>UNIV = \<top>"
130.137 by (auto intro!: antisym Sup_upper)
130.138
130.139 -lemma INF_image [simp]: "(\<Sqinter>x\<in>f`A. g x) = (\<Sqinter>x\<in>A. g (f x))"
130.140 - by (simp add: INF_def image_image)
130.141 -
130.142 -lemma SUP_image [simp]: "(\<Squnion>x\<in>f`A. g x) = (\<Squnion>x\<in>A. g (f x))"
130.143 - by (simp add: SUP_def image_image)
130.144 -
130.145 lemma Inf_Sup: "\<Sqinter>A = \<Squnion>{b. \<forall>a \<in> A. b \<sqsubseteq> a}"
130.146 by (auto intro: antisym Inf_lower Inf_greatest Sup_upper Sup_least)
130.147
130.148 @@ -199,14 +207,6 @@
130.149 lemma Sup_subset_mono: "A \<subseteq> B \<Longrightarrow> \<Squnion>A \<sqsubseteq> \<Squnion>B"
130.150 by (auto intro: Sup_least Sup_upper)
130.151
130.152 -lemma INF_cong:
130.153 - "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> C x = D x) \<Longrightarrow> (\<Sqinter>x\<in>A. C x) = (\<Sqinter>x\<in>B. D x)"
130.154 - by (simp add: INF_def image_def)
130.155 -
130.156 -lemma SUP_cong:
130.157 - "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> C x = D x) \<Longrightarrow> (\<Squnion>x\<in>A. C x) = (\<Squnion>x\<in>B. D x)"
130.158 - by (simp add: SUP_def image_def)
130.159 -
130.160 lemma Inf_mono:
130.161 assumes "\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. a \<sqsubseteq> b"
130.162 shows "\<Sqinter>A \<sqsubseteq> \<Sqinter>B"
130.163 @@ -306,7 +306,7 @@
130.164 show "?R \<le> ?L" by (rule SUP_least) (auto intro: le_supI1 le_supI2 SUP_upper)
130.165 qed
130.166
130.167 -lemma Inf_top_conv [simp, no_atp]:
130.168 +lemma Inf_top_conv [simp]:
130.169 "\<Sqinter>A = \<top> \<longleftrightarrow> (\<forall>x\<in>A. x = \<top>)"
130.170 "\<top> = \<Sqinter>A \<longleftrightarrow> (\<forall>x\<in>A. x = \<top>)"
130.171 proof -
130.172 @@ -333,7 +333,7 @@
130.173 "\<top> = (\<Sqinter>x\<in>A. B x) \<longleftrightarrow> (\<forall>x\<in>A. B x = \<top>)"
130.174 by (auto simp add: INF_def)
130.175
130.176 -lemma Sup_bot_conv [simp, no_atp]:
130.177 +lemma Sup_bot_conv [simp]:
130.178 "\<Squnion>A = \<bottom> \<longleftrightarrow> (\<forall>x\<in>A. x = \<bottom>)" (is ?P)
130.179 "\<bottom> = \<Squnion>A \<longleftrightarrow> (\<forall>x\<in>A. x = \<bottom>)" (is ?Q)
130.180 using dual_complete_lattice
130.181 @@ -418,6 +418,22 @@
130.182 lemma INF_le_SUP: "A \<noteq> {} \<Longrightarrow> INFI A f \<le> SUPR A f"
130.183 unfolding INF_def SUP_def by (rule Inf_le_Sup) auto
130.184
130.185 +lemma SUP_eq_const:
130.186 + "I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> f i = x) \<Longrightarrow> SUPR I f = x"
130.187 + by (auto intro: SUP_eqI)
130.188 +
130.189 +lemma INF_eq_const:
130.190 + "I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> f i = x) \<Longrightarrow> INFI I f = x"
130.191 + by (auto intro: INF_eqI)
130.192 +
130.193 +lemma SUP_eq_iff:
130.194 + "I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> c \<le> f i) \<Longrightarrow> (SUPR I f = c) \<longleftrightarrow> (\<forall>i\<in>I. f i = c)"
130.195 + using SUP_eq_const[of I f c] SUP_upper[of _ I f] by (auto intro: antisym)
130.196 +
130.197 +lemma INF_eq_iff:
130.198 + "I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> f i \<le> c) \<Longrightarrow> (INFI I f = c) \<longleftrightarrow> (\<forall>i\<in>I. f i = c)"
130.199 + using INF_eq_const[of I f c] INF_lower[of _ I f] by (auto intro: antisym)
130.200 +
130.201 end
130.202
130.203 class complete_distrib_lattice = complete_lattice +
130.204 @@ -769,7 +785,7 @@
130.205 by (simp add: Inf_set_def image_def)
130.206 qed
130.207
130.208 -lemma Inter_iff [simp,no_atp]: "A \<in> \<Inter>C \<longleftrightarrow> (\<forall>X\<in>C. A \<in> X)"
130.209 +lemma Inter_iff [simp]: "A \<in> \<Inter>C \<longleftrightarrow> (\<forall>X\<in>C. A \<in> X)"
130.210 by (unfold Inter_eq) blast
130.211
130.212 lemma InterI [intro!]: "(\<And>X. X \<in> C \<Longrightarrow> A \<in> X) \<Longrightarrow> A \<in> \<Inter>C"
130.213 @@ -814,7 +830,7 @@
130.214 lemma Inter_Un_distrib: "\<Inter>(A \<union> B) = \<Inter>A \<inter> \<Inter>B"
130.215 by (fact Inf_union_distrib)
130.216
130.217 -lemma Inter_UNIV_conv [simp, no_atp]:
130.218 +lemma Inter_UNIV_conv [simp]:
130.219 "\<Inter>A = UNIV \<longleftrightarrow> (\<forall>x\<in>A. x = UNIV)"
130.220 "UNIV = \<Inter>A \<longleftrightarrow> (\<forall>x\<in>A. x = UNIV)"
130.221 by (fact Inf_top_conv)+
130.222 @@ -952,7 +968,7 @@
130.223 by (simp add: Sup_set_def image_def)
130.224 qed
130.225
130.226 -lemma Union_iff [simp, no_atp]:
130.227 +lemma Union_iff [simp]:
130.228 "A \<in> \<Union>C \<longleftrightarrow> (\<exists>X\<in>C. A\<in>X)"
130.229 by (unfold Union_eq) blast
130.230
130.231 @@ -987,10 +1003,10 @@
130.232 lemma Union_Int_subset: "\<Union>(A \<inter> B) \<subseteq> \<Union>A \<inter> \<Union>B"
130.233 by (fact Sup_inter_less_eq)
130.234
130.235 -lemma Union_empty_conv [no_atp]: "(\<Union>A = {}) \<longleftrightarrow> (\<forall>x\<in>A. x = {})"
130.236 +lemma Union_empty_conv: "(\<Union>A = {}) \<longleftrightarrow> (\<forall>x\<in>A. x = {})"
130.237 by (fact Sup_bot_conv) (* already simp *)
130.238
130.239 -lemma empty_Union_conv [no_atp]: "({} = \<Union>A) \<longleftrightarrow> (\<forall>x\<in>A. x = {})"
130.240 +lemma empty_Union_conv: "({} = \<Union>A) \<longleftrightarrow> (\<forall>x\<in>A. x = {})"
130.241 by (fact Sup_bot_conv) (* already simp *)
130.242
130.243 lemma subset_Pow_Union: "A \<subseteq> Pow (\<Union>A)"
130.244 @@ -1044,7 +1060,7 @@
130.245 [Syntax_Trans.preserve_binder_abs2_tr' @{const_syntax UNION} @{syntax_const "_UNION"}]
130.246 *} -- {* to avoid eta-contraction of body *}
130.247
130.248 -lemma UNION_eq [no_atp]:
130.249 +lemma UNION_eq:
130.250 "(\<Union>x\<in>A. B x) = {y. \<exists>x\<in>A. y \<in> B x}"
130.251 by (auto simp add: SUP_def)
130.252
130.253 @@ -1088,13 +1104,13 @@
130.254 lemma UN_least: "(\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> C) \<Longrightarrow> (\<Union>x\<in>A. B x) \<subseteq> C"
130.255 by (fact SUP_least)
130.256
130.257 -lemma Collect_bex_eq [no_atp]: "{x. \<exists>y\<in>A. P x y} = (\<Union>y\<in>A. {x. P x y})"
130.258 +lemma Collect_bex_eq: "{x. \<exists>y\<in>A. P x y} = (\<Union>y\<in>A. {x. P x y})"
130.259 by blast
130.260
130.261 lemma UN_insert_distrib: "u \<in> A \<Longrightarrow> (\<Union>x\<in>A. insert a (B x)) = insert a (\<Union>x\<in>A. B x)"
130.262 by blast
130.263
130.264 -lemma UN_empty [no_atp]: "(\<Union>x\<in>{}. B x) = {}"
130.265 +lemma UN_empty: "(\<Union>x\<in>{}. B x) = {}"
130.266 by (fact SUP_empty)
130.267
130.268 lemma UN_empty2: "(\<Union>x\<in>A. {}) = {}"
130.269 @@ -1126,7 +1142,7 @@
130.270 "(\<Union>x\<in>A. B x) = {} \<longleftrightarrow> (\<forall>x\<in>A. B x = {})"
130.271 by (fact SUP_bot_conv)+ (* already simp *)
130.272
130.273 -lemma Collect_ex_eq [no_atp]: "{x. \<exists>y. P x y} = (\<Union>y. {x. P x y})"
130.274 +lemma Collect_ex_eq: "{x. \<exists>y. P x y} = (\<Union>y. {x. P x y})"
130.275 by blast
130.276
130.277 lemma ball_UN: "(\<forall>z \<in> UNION A B. P z) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>z \<in> B x. P z)"
130.278 @@ -1248,7 +1264,7 @@
130.279 "\<And>A B f. (\<Inter>x\<in>f`A. B x) = (\<Inter>a\<in>A. B (f a))"
130.280 by auto
130.281
130.282 -lemma UN_ball_bex_simps [simp, no_atp]:
130.283 +lemma UN_ball_bex_simps [simp]:
130.284 "\<And>A P. (\<forall>x\<in>\<Union>A. P x) \<longleftrightarrow> (\<forall>y\<in>A. \<forall>x\<in>y. P x)"
130.285 "\<And>A B P. (\<forall>x\<in>UNION A B. P x) = (\<forall>a\<in>A. \<forall>x\<in> B a. P x)"
130.286 "\<And>A P. (\<exists>x\<in>\<Union>A. P x) \<longleftrightarrow> (\<exists>y\<in>A. \<exists>x\<in>y. P x)"
131.1 --- a/src/HOL/Complete_Partial_Order.thy Thu Dec 05 17:52:12 2013 +0100
131.2 +++ b/src/HOL/Complete_Partial_Order.thy Thu Dec 05 17:58:03 2013 +0100
131.3 @@ -50,6 +50,9 @@
131.4 obtains "ord x y" | "ord y x"
131.5 using assms unfolding chain_def by fast
131.6
131.7 +lemma chain_empty: "chain ord {}"
131.8 +by(simp add: chain_def)
131.9 +
131.10 subsection {* Chain-complete partial orders *}
131.11
131.12 text {*
131.13 @@ -119,6 +122,9 @@
131.14 qed
131.15 qed
131.16
131.17 +lemma bot_in_iterates: "Sup {} \<in> iterates f"
131.18 +by(auto intro: iterates.Sup simp add: chain_empty)
131.19 +
131.20 subsection {* Fixpoint combinator *}
131.21
131.22 definition
131.23 @@ -162,16 +168,17 @@
131.24 setup {* Sign.map_naming (Name_Space.mandatory_path "ccpo") *}
131.25
131.26 definition admissible :: "('a set \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
131.27 -where "admissible lub ord P = (\<forall>A. chain ord A \<longrightarrow> (\<forall>x\<in>A. P x) \<longrightarrow> P (lub A))"
131.28 +where "admissible lub ord P = (\<forall>A. chain ord A \<longrightarrow> (A \<noteq> {}) \<longrightarrow> (\<forall>x\<in>A. P x) \<longrightarrow> P (lub A))"
131.29
131.30 lemma admissibleI:
131.31 - assumes "\<And>A. chain ord A \<Longrightarrow> \<forall>x\<in>A. P x \<Longrightarrow> P (lub A)"
131.32 + assumes "\<And>A. chain ord A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> \<forall>x\<in>A. P x \<Longrightarrow> P (lub A)"
131.33 shows "ccpo.admissible lub ord P"
131.34 using assms unfolding ccpo.admissible_def by fast
131.35
131.36 lemma admissibleD:
131.37 assumes "ccpo.admissible lub ord P"
131.38 assumes "chain ord A"
131.39 + assumes "A \<noteq> {}"
131.40 assumes "\<And>x. x \<in> A \<Longrightarrow> P x"
131.41 shows "P (lub A)"
131.42 using assms by (auto simp: ccpo.admissible_def)
131.43 @@ -181,24 +188,26 @@
131.44 lemma (in ccpo) fixp_induct:
131.45 assumes adm: "ccpo.admissible Sup (op \<le>) P"
131.46 assumes mono: "monotone (op \<le>) (op \<le>) f"
131.47 + assumes bot: "P (Sup {})"
131.48 assumes step: "\<And>x. P x \<Longrightarrow> P (f x)"
131.49 shows "P (fixp f)"
131.50 unfolding fixp_def using adm chain_iterates[OF mono]
131.51 proof (rule ccpo.admissibleD)
131.52 + show "iterates f \<noteq> {}" using bot_in_iterates by auto
131.53 fix x assume "x \<in> iterates f"
131.54 thus "P x"
131.55 by (induct rule: iterates.induct)
131.56 - (auto intro: step ccpo.admissibleD adm)
131.57 + (case_tac "M = {}", auto intro: step bot ccpo.admissibleD adm)
131.58 qed
131.59
131.60 lemma admissible_True: "ccpo.admissible lub ord (\<lambda>x. True)"
131.61 unfolding ccpo.admissible_def by simp
131.62
131.63 -lemma admissible_False: "\<not> ccpo.admissible lub ord (\<lambda>x. False)"
131.64 +(*lemma admissible_False: "\<not> ccpo.admissible lub ord (\<lambda>x. False)"
131.65 unfolding ccpo.admissible_def chain_def by simp
131.66 -
131.67 -lemma admissible_const: "ccpo.admissible lub ord (\<lambda>x. t) = t"
131.68 -by (cases t, simp_all add: admissible_True admissible_False)
131.69 +*)
131.70 +lemma admissible_const: "ccpo.admissible lub ord (\<lambda>x. t)"
131.71 +by(auto intro: ccpo.admissibleI)
131.72
131.73 lemma admissible_conj:
131.74 assumes "ccpo.admissible lub ord (\<lambda>x. P x)"
131.75 @@ -248,15 +257,16 @@
131.76 shows "ccpo.admissible Sup (op \<le>) (\<lambda>x. P x \<or> Q x)"
131.77 proof (rule ccpo.admissibleI)
131.78 fix A :: "'a set" assume A: "chain (op \<le>) A"
131.79 - assume "\<forall>x\<in>A. P x \<or> Q x"
131.80 - hence "(\<forall>x\<in>A. \<exists>y\<in>A. x \<le> y \<and> P y) \<or> (\<forall>x\<in>A. \<exists>y\<in>A. x \<le> y \<and> Q y)"
131.81 + assume "A \<noteq> {}"
131.82 + and "\<forall>x\<in>A. P x \<or> Q x"
131.83 + hence "(\<exists>x\<in>A. P x) \<and> (\<forall>x\<in>A. \<exists>y\<in>A. x \<le> y \<and> P y) \<or> (\<exists>x\<in>A. Q x) \<and> (\<forall>x\<in>A. \<exists>y\<in>A. x \<le> y \<and> Q y)"
131.84 using chainD[OF A] by blast
131.85 - hence "Sup A = Sup {x \<in> A. P x} \<or> Sup A = Sup {x \<in> A. Q x}"
131.86 - using admissible_disj_lemma [OF A] by fast
131.87 + hence "(\<exists>x. x \<in> A \<and> P x) \<and> Sup A = Sup {x \<in> A. P x} \<or> (\<exists>x. x \<in> A \<and> Q x) \<and> Sup A = Sup {x \<in> A. Q x}"
131.88 + using admissible_disj_lemma [OF A] by blast
131.89 thus "P (Sup A) \<or> Q (Sup A)"
131.90 apply (rule disjE, simp_all)
131.91 - apply (rule disjI1, rule ccpo.admissibleD [OF P chain_compr [OF A]], simp)
131.92 - apply (rule disjI2, rule ccpo.admissibleD [OF Q chain_compr [OF A]], simp)
131.93 + apply (rule disjI1, rule ccpo.admissibleD [OF P chain_compr [OF A]], simp, simp)
131.94 + apply (rule disjI2, rule ccpo.admissibleD [OF Q chain_compr [OF A]], simp, simp)
131.95 done
131.96 qed
131.97
132.1 --- a/src/HOL/Complex.thy Thu Dec 05 17:52:12 2013 +0100
132.2 +++ b/src/HOL/Complex.thy Thu Dec 05 17:58:03 2013 +0100
132.3 @@ -108,7 +108,12 @@
132.4 definition complex_divide_def:
132.5 "x / (y\<Colon>complex) = x * inverse y"
132.6
132.7 -lemma Complex_eq_1 [simp]: "(Complex a b = 1) = (a = 1 \<and> b = 0)"
132.8 +lemma Complex_eq_1 [simp]:
132.9 + "Complex a b = 1 \<longleftrightarrow> a = 1 \<and> b = 0"
132.10 + by (simp add: complex_one_def)
132.11 +
132.12 +lemma Complex_eq_neg_1 [simp]:
132.13 + "Complex a b = - 1 \<longleftrightarrow> a = - 1 \<and> b = 0"
132.14 by (simp add: complex_one_def)
132.15
132.16 lemma complex_Re_one [simp]: "Re 1 = 1"
132.17 @@ -166,21 +171,21 @@
132.18 lemma complex_Re_numeral [simp]: "Re (numeral v) = numeral v"
132.19 using complex_Re_of_int [of "numeral v"] by simp
132.20
132.21 -lemma complex_Re_neg_numeral [simp]: "Re (neg_numeral v) = neg_numeral v"
132.22 - using complex_Re_of_int [of "neg_numeral v"] by simp
132.23 +lemma complex_Re_neg_numeral [simp]: "Re (- numeral v) = - numeral v"
132.24 + using complex_Re_of_int [of "- numeral v"] by simp
132.25
132.26 lemma complex_Im_numeral [simp]: "Im (numeral v) = 0"
132.27 using complex_Im_of_int [of "numeral v"] by simp
132.28
132.29 -lemma complex_Im_neg_numeral [simp]: "Im (neg_numeral v) = 0"
132.30 - using complex_Im_of_int [of "neg_numeral v"] by simp
132.31 +lemma complex_Im_neg_numeral [simp]: "Im (- numeral v) = 0"
132.32 + using complex_Im_of_int [of "- numeral v"] by simp
132.33
132.34 lemma Complex_eq_numeral [simp]:
132.35 - "(Complex a b = numeral w) = (a = numeral w \<and> b = 0)"
132.36 + "Complex a b = numeral w \<longleftrightarrow> a = numeral w \<and> b = 0"
132.37 by (simp add: complex_eq_iff)
132.38
132.39 lemma Complex_eq_neg_numeral [simp]:
132.40 - "(Complex a b = neg_numeral w) = (a = neg_numeral w \<and> b = 0)"
132.41 + "Complex a b = - numeral w \<longleftrightarrow> a = - numeral w \<and> b = 0"
132.42 by (simp add: complex_eq_iff)
132.43
132.44
132.45 @@ -421,7 +426,7 @@
132.46 lemma complex_i_not_numeral [simp]: "ii \<noteq> numeral w"
132.47 by (simp add: complex_eq_iff)
132.48
132.49 -lemma complex_i_not_neg_numeral [simp]: "ii \<noteq> neg_numeral w"
132.50 +lemma complex_i_not_neg_numeral [simp]: "ii \<noteq> - numeral w"
132.51 by (simp add: complex_eq_iff)
132.52
132.53 lemma i_mult_Complex [simp]: "ii * Complex a b = Complex (- b) a"
132.54 @@ -508,7 +513,7 @@
132.55 lemma complex_cnj_numeral [simp]: "cnj (numeral w) = numeral w"
132.56 by (simp add: complex_eq_iff)
132.57
132.58 -lemma complex_cnj_neg_numeral [simp]: "cnj (neg_numeral w) = neg_numeral w"
132.59 +lemma complex_cnj_neg_numeral [simp]: "cnj (- numeral w) = - numeral w"
132.60 by (simp add: complex_eq_iff)
132.61
132.62 lemma complex_cnj_scaleR: "cnj (scaleR r x) = scaleR r (cnj x)"
132.63 @@ -587,7 +592,7 @@
132.64 by (simp add: cis_def)
132.65
132.66 lemma cis_divide: "cis a / cis b = cis (a - b)"
132.67 - by (simp add: complex_divide_def cis_mult diff_minus)
132.68 + by (simp add: complex_divide_def cis_mult)
132.69
132.70 lemma cos_n_Re_cis_pow_n: "cos (real n * a) = Re(cis a ^ n)"
132.71 by (auto simp add: DeMoivre)
133.1 --- a/src/HOL/Conditionally_Complete_Lattices.thy Thu Dec 05 17:52:12 2013 +0100
133.2 +++ b/src/HOL/Conditionally_Complete_Lattices.thy Thu Dec 05 17:58:03 2013 +0100
133.3 @@ -1,20 +1,161 @@
133.4 (* Title: HOL/Conditionally_Complete_Lattices.thy
133.5 Author: Amine Chaieb and L C Paulson, University of Cambridge
133.6 Author: Johannes Hölzl, TU München
133.7 + Author: Luke S. Serafin, Carnegie Mellon University
133.8 *)
133.9
133.10 header {* Conditionally-complete Lattices *}
133.11
133.12 theory Conditionally_Complete_Lattices
133.13 -imports Main Lubs
133.14 +imports Main
133.15 begin
133.16
133.17 -lemma Sup_fin_eq_Max: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup_fin X = Max X"
133.18 +lemma (in linorder) Sup_fin_eq_Max: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup_fin X = Max X"
133.19 by (induct X rule: finite_ne_induct) (simp_all add: sup_max)
133.20
133.21 -lemma Inf_fin_eq_Min: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf_fin X = Min X"
133.22 +lemma (in linorder) Inf_fin_eq_Min: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf_fin X = Min X"
133.23 by (induct X rule: finite_ne_induct) (simp_all add: inf_min)
133.24
133.25 +context preorder
133.26 +begin
133.27 +
133.28 +definition "bdd_above A \<longleftrightarrow> (\<exists>M. \<forall>x \<in> A. x \<le> M)"
133.29 +definition "bdd_below A \<longleftrightarrow> (\<exists>m. \<forall>x \<in> A. m \<le> x)"
133.30 +
133.31 +lemma bdd_aboveI[intro]: "(\<And>x. x \<in> A \<Longrightarrow> x \<le> M) \<Longrightarrow> bdd_above A"
133.32 + by (auto simp: bdd_above_def)
133.33 +
133.34 +lemma bdd_belowI[intro]: "(\<And>x. x \<in> A \<Longrightarrow> m \<le> x) \<Longrightarrow> bdd_below A"
133.35 + by (auto simp: bdd_below_def)
133.36 +
133.37 +lemma bdd_aboveI2: "(\<And>x. x \<in> A \<Longrightarrow> f x \<le> M) \<Longrightarrow> bdd_above (f`A)"
133.38 + by force
133.39 +
133.40 +lemma bdd_belowI2: "(\<And>x. x \<in> A \<Longrightarrow> m \<le> f x) \<Longrightarrow> bdd_below (f`A)"
133.41 + by force
133.42 +
133.43 +lemma bdd_above_empty [simp, intro]: "bdd_above {}"
133.44 + unfolding bdd_above_def by auto
133.45 +
133.46 +lemma bdd_below_empty [simp, intro]: "bdd_below {}"
133.47 + unfolding bdd_below_def by auto
133.48 +
133.49 +lemma bdd_above_mono: "bdd_above B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> bdd_above A"
133.50 + by (metis (full_types) bdd_above_def order_class.le_neq_trans psubsetD)
133.51 +
133.52 +lemma bdd_below_mono: "bdd_below B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> bdd_below A"
133.53 + by (metis bdd_below_def order_class.le_neq_trans psubsetD)
133.54 +
133.55 +lemma bdd_above_Int1 [simp]: "bdd_above A \<Longrightarrow> bdd_above (A \<inter> B)"
133.56 + using bdd_above_mono by auto
133.57 +
133.58 +lemma bdd_above_Int2 [simp]: "bdd_above B \<Longrightarrow> bdd_above (A \<inter> B)"
133.59 + using bdd_above_mono by auto
133.60 +
133.61 +lemma bdd_below_Int1 [simp]: "bdd_below A \<Longrightarrow> bdd_below (A \<inter> B)"
133.62 + using bdd_below_mono by auto
133.63 +
133.64 +lemma bdd_below_Int2 [simp]: "bdd_below B \<Longrightarrow> bdd_below (A \<inter> B)"
133.65 + using bdd_below_mono by auto
133.66 +
133.67 +lemma bdd_above_Ioo [simp, intro]: "bdd_above {a <..< b}"
133.68 + by (auto simp add: bdd_above_def intro!: exI[of _ b] less_imp_le)
133.69 +
133.70 +lemma bdd_above_Ico [simp, intro]: "bdd_above {a ..< b}"
133.71 + by (auto simp add: bdd_above_def intro!: exI[of _ b] less_imp_le)
133.72 +
133.73 +lemma bdd_above_Iio [simp, intro]: "bdd_above {..< b}"
133.74 + by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)
133.75 +
133.76 +lemma bdd_above_Ioc [simp, intro]: "bdd_above {a <.. b}"
133.77 + by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)
133.78 +
133.79 +lemma bdd_above_Icc [simp, intro]: "bdd_above {a .. b}"
133.80 + by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)
133.81 +
133.82 +lemma bdd_above_Iic [simp, intro]: "bdd_above {.. b}"
133.83 + by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)
133.84 +
133.85 +lemma bdd_below_Ioo [simp, intro]: "bdd_below {a <..< b}"
133.86 + by (auto simp add: bdd_below_def intro!: exI[of _ a] less_imp_le)
133.87 +
133.88 +lemma bdd_below_Ioc [simp, intro]: "bdd_below {a <.. b}"
133.89 + by (auto simp add: bdd_below_def intro!: exI[of _ a] less_imp_le)
133.90 +
133.91 +lemma bdd_below_Ioi [simp, intro]: "bdd_below {a <..}"
133.92 + by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)
133.93 +
133.94 +lemma bdd_below_Ico [simp, intro]: "bdd_below {a ..< b}"
133.95 + by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)
133.96 +
133.97 +lemma bdd_below_Icc [simp, intro]: "bdd_below {a .. b}"
133.98 + by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)
133.99 +
133.100 +lemma bdd_below_Ici [simp, intro]: "bdd_below {a ..}"
133.101 + by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)
133.102 +
133.103 +end
133.104 +
133.105 +lemma (in order_top) bdd_above_top[simp, intro!]: "bdd_above A"
133.106 + by (rule bdd_aboveI[of _ top]) simp
133.107 +
133.108 +lemma (in order_bot) bdd_above_bot[simp, intro!]: "bdd_below A"
133.109 + by (rule bdd_belowI[of _ bot]) simp
133.110 +
133.111 +lemma bdd_above_uminus[simp]:
133.112 + fixes X :: "'a::ordered_ab_group_add set"
133.113 + shows "bdd_above (uminus ` X) \<longleftrightarrow> bdd_below X"
133.114 + by (auto simp: bdd_above_def bdd_below_def intro: le_imp_neg_le) (metis le_imp_neg_le minus_minus)
133.115 +
133.116 +lemma bdd_below_uminus[simp]:
133.117 + fixes X :: "'a::ordered_ab_group_add set"
133.118 + shows"bdd_below (uminus ` X) \<longleftrightarrow> bdd_above X"
133.119 + by (auto simp: bdd_above_def bdd_below_def intro: le_imp_neg_le) (metis le_imp_neg_le minus_minus)
133.120 +
133.121 +context lattice
133.122 +begin
133.123 +
133.124 +lemma bdd_above_insert [simp]: "bdd_above (insert a A) = bdd_above A"
133.125 + by (auto simp: bdd_above_def intro: le_supI2 sup_ge1)
133.126 +
133.127 +lemma bdd_below_insert [simp]: "bdd_below (insert a A) = bdd_below A"
133.128 + by (auto simp: bdd_below_def intro: le_infI2 inf_le1)
133.129 +
133.130 +lemma bdd_finite [simp]:
133.131 + assumes "finite A" shows bdd_above_finite: "bdd_above A" and bdd_below_finite: "bdd_below A"
133.132 + using assms by (induct rule: finite_induct, auto)
133.133 +
133.134 +lemma bdd_above_Un [simp]: "bdd_above (A \<union> B) = (bdd_above A \<and> bdd_above B)"
133.135 +proof
133.136 + assume "bdd_above (A \<union> B)"
133.137 + thus "bdd_above A \<and> bdd_above B" unfolding bdd_above_def by auto
133.138 +next
133.139 + assume "bdd_above A \<and> bdd_above B"
133.140 + then obtain a b where "\<forall>x\<in>A. x \<le> a" "\<forall>x\<in>B. x \<le> b" unfolding bdd_above_def by auto
133.141 + hence "\<forall>x \<in> A \<union> B. x \<le> sup a b" by (auto intro: Un_iff le_supI1 le_supI2)
133.142 + thus "bdd_above (A \<union> B)" unfolding bdd_above_def ..
133.143 +qed
133.144 +
133.145 +lemma bdd_below_Un [simp]: "bdd_below (A \<union> B) = (bdd_below A \<and> bdd_below B)"
133.146 +proof
133.147 + assume "bdd_below (A \<union> B)"
133.148 + thus "bdd_below A \<and> bdd_below B" unfolding bdd_below_def by auto
133.149 +next
133.150 + assume "bdd_below A \<and> bdd_below B"
133.151 + then obtain a b where "\<forall>x\<in>A. a \<le> x" "\<forall>x\<in>B. b \<le> x" unfolding bdd_below_def by auto
133.152 + hence "\<forall>x \<in> A \<union> B. inf a b \<le> x" by (auto intro: Un_iff le_infI1 le_infI2)
133.153 + thus "bdd_below (A \<union> B)" unfolding bdd_below_def ..
133.154 +qed
133.155 +
133.156 +lemma bdd_above_sup[simp]: "bdd_above ((\<lambda>x. sup (f x) (g x)) ` A) \<longleftrightarrow> bdd_above (f`A) \<and> bdd_above (g`A)"
133.157 + by (auto simp: bdd_above_def intro: le_supI1 le_supI2)
133.158 +
133.159 +lemma bdd_below_inf[simp]: "bdd_below ((\<lambda>x. inf (f x) (g x)) ` A) \<longleftrightarrow> bdd_below (f`A) \<and> bdd_below (g`A)"
133.160 + by (auto simp: bdd_below_def intro: le_infI1 le_infI2)
133.161 +
133.162 +end
133.163 +
133.164 +
133.165 text {*
133.166
133.167 To avoid name classes with the @{class complete_lattice}-class we prefix @{const Sup} and
133.168 @@ -23,46 +164,42 @@
133.169 *}
133.170
133.171 class conditionally_complete_lattice = lattice + Sup + Inf +
133.172 - assumes cInf_lower: "x \<in> X \<Longrightarrow> (\<And>a. a \<in> X \<Longrightarrow> z \<le> a) \<Longrightarrow> Inf X \<le> x"
133.173 + assumes cInf_lower: "x \<in> X \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X \<le> x"
133.174 and cInf_greatest: "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> Inf X"
133.175 - assumes cSup_upper: "x \<in> X \<Longrightarrow> (\<And>a. a \<in> X \<Longrightarrow> a \<le> z) \<Longrightarrow> x \<le> Sup X"
133.176 + assumes cSup_upper: "x \<in> X \<Longrightarrow> bdd_above X \<Longrightarrow> x \<le> Sup X"
133.177 and cSup_least: "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X \<le> z"
133.178 begin
133.179
133.180 -lemma cSup_eq_maximum: (*REAL_SUP_MAX in HOL4*)
133.181 - "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X = z"
133.182 - by (blast intro: antisym cSup_upper cSup_least)
133.183 +lemma cSup_upper2: "x \<in> X \<Longrightarrow> y \<le> x \<Longrightarrow> bdd_above X \<Longrightarrow> y \<le> Sup X"
133.184 + by (metis cSup_upper order_trans)
133.185
133.186 -lemma cInf_eq_minimum: (*REAL_INF_MIN in HOL4*)
133.187 - "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf X = z"
133.188 - by (intro antisym cInf_lower[of z X z] cInf_greatest[of X z]) auto
133.189 +lemma cInf_lower2: "x \<in> X \<Longrightarrow> x \<le> y \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X \<le> y"
133.190 + by (metis cInf_lower order_trans)
133.191
133.192 -lemma cSup_le_iff: "S \<noteq> {} \<Longrightarrow> (\<And>a. a \<in> S \<Longrightarrow> a \<le> z) \<Longrightarrow> Sup S \<le> a \<longleftrightarrow> (\<forall>x\<in>S. x \<le> a)"
133.193 +lemma cSup_mono: "B \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> (\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. b \<le> a) \<Longrightarrow> Sup B \<le> Sup A"
133.194 + by (metis cSup_least cSup_upper2)
133.195 +
133.196 +lemma cInf_mono: "B \<noteq> {} \<Longrightarrow> bdd_below A \<Longrightarrow> (\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. a \<le> b) \<Longrightarrow> Inf A \<le> Inf B"
133.197 + by (metis cInf_greatest cInf_lower2)
133.198 +
133.199 +lemma cSup_subset_mono: "A \<noteq> {} \<Longrightarrow> bdd_above B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Sup A \<le> Sup B"
133.200 + by (metis cSup_least cSup_upper subsetD)
133.201 +
133.202 +lemma cInf_superset_mono: "A \<noteq> {} \<Longrightarrow> bdd_below B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Inf B \<le> Inf A"
133.203 + by (metis cInf_greatest cInf_lower subsetD)
133.204 +
133.205 +lemma cSup_eq_maximum: "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X = z"
133.206 + by (intro antisym cSup_upper[of z X] cSup_least[of X z]) auto
133.207 +
133.208 +lemma cInf_eq_minimum: "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf X = z"
133.209 + by (intro antisym cInf_lower[of z X] cInf_greatest[of X z]) auto
133.210 +
133.211 +lemma cSup_le_iff: "S \<noteq> {} \<Longrightarrow> bdd_above S \<Longrightarrow> Sup S \<le> a \<longleftrightarrow> (\<forall>x\<in>S. x \<le> a)"
133.212 by (metis order_trans cSup_upper cSup_least)
133.213
133.214 -lemma le_cInf_iff: "S \<noteq> {} \<Longrightarrow> (\<And>a. a \<in> S \<Longrightarrow> z \<le> a) \<Longrightarrow> a \<le> Inf S \<longleftrightarrow> (\<forall>x\<in>S. a \<le> x)"
133.215 +lemma le_cInf_iff: "S \<noteq> {} \<Longrightarrow> bdd_below S \<Longrightarrow> a \<le> Inf S \<longleftrightarrow> (\<forall>x\<in>S. a \<le> x)"
133.216 by (metis order_trans cInf_lower cInf_greatest)
133.217
133.218 -lemma cSup_singleton [simp]: "Sup {x} = x"
133.219 - by (intro cSup_eq_maximum) auto
133.220 -
133.221 -lemma cInf_singleton [simp]: "Inf {x} = x"
133.222 - by (intro cInf_eq_minimum) auto
133.223 -
133.224 -lemma cSup_upper2: (*REAL_IMP_LE_SUP in HOL4*)
133.225 - "x \<in> X \<Longrightarrow> y \<le> x \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> y \<le> Sup X"
133.226 - by (metis cSup_upper order_trans)
133.227 -
133.228 -lemma cInf_lower2:
133.229 - "x \<in> X \<Longrightarrow> x \<le> y \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf X \<le> y"
133.230 - by (metis cInf_lower order_trans)
133.231 -
133.232 -lemma cSup_upper_EX: "x \<in> X \<Longrightarrow> \<exists>z. \<forall>x. x \<in> X \<longrightarrow> x \<le> z \<Longrightarrow> x \<le> Sup X"
133.233 - by (blast intro: cSup_upper)
133.234 -
133.235 -lemma cInf_lower_EX: "x \<in> X \<Longrightarrow> \<exists>z. \<forall>x. x \<in> X \<longrightarrow> z \<le> x \<Longrightarrow> Inf X \<le> x"
133.236 - by (blast intro: cInf_lower)
133.237 -
133.238 lemma cSup_eq_non_empty:
133.239 assumes 1: "X \<noteq> {}"
133.240 assumes 2: "\<And>x. x \<in> X \<Longrightarrow> x \<le> a"
133.241 @@ -77,67 +214,47 @@
133.242 shows "Inf X = a"
133.243 by (intro 3 1 antisym cInf_greatest) (auto intro: 2 1 cInf_lower)
133.244
133.245 -lemma cInf_cSup: "S \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf S = Sup {x. \<forall>s\<in>S. x \<le> s}"
133.246 - by (rule cInf_eq_non_empty) (auto intro: cSup_upper cSup_least)
133.247 +lemma cInf_cSup: "S \<noteq> {} \<Longrightarrow> bdd_below S \<Longrightarrow> Inf S = Sup {x. \<forall>s\<in>S. x \<le> s}"
133.248 + by (rule cInf_eq_non_empty) (auto intro!: cSup_upper cSup_least simp: bdd_below_def)
133.249
133.250 -lemma cSup_cInf: "S \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup S = Inf {x. \<forall>s\<in>S. s \<le> x}"
133.251 - by (rule cSup_eq_non_empty) (auto intro: cInf_lower cInf_greatest)
133.252 +lemma cSup_cInf: "S \<noteq> {} \<Longrightarrow> bdd_above S \<Longrightarrow> Sup S = Inf {x. \<forall>s\<in>S. s \<le> x}"
133.253 + by (rule cSup_eq_non_empty) (auto intro!: cInf_lower cInf_greatest simp: bdd_above_def)
133.254
133.255 -lemma cSup_insert:
133.256 - assumes x: "X \<noteq> {}"
133.257 - and z: "\<And>x. x \<in> X \<Longrightarrow> x \<le> z"
133.258 - shows "Sup (insert a X) = sup a (Sup X)"
133.259 -proof (intro cSup_eq_non_empty)
133.260 - fix y assume "\<And>x. x \<in> insert a X \<Longrightarrow> x \<le> y" with x show "sup a (Sup X) \<le> y" by (auto intro: cSup_least)
133.261 -qed (auto intro: le_supI2 z cSup_upper)
133.262 +lemma cSup_insert: "X \<noteq> {} \<Longrightarrow> bdd_above X \<Longrightarrow> Sup (insert a X) = sup a (Sup X)"
133.263 + by (intro cSup_eq_non_empty) (auto intro: le_supI2 cSup_upper cSup_least)
133.264
133.265 -lemma cInf_insert:
133.266 - assumes x: "X \<noteq> {}"
133.267 - and z: "\<And>x. x \<in> X \<Longrightarrow> z \<le> x"
133.268 - shows "Inf (insert a X) = inf a (Inf X)"
133.269 -proof (intro cInf_eq_non_empty)
133.270 - fix y assume "\<And>x. x \<in> insert a X \<Longrightarrow> y \<le> x" with x show "y \<le> inf a (Inf X)" by (auto intro: cInf_greatest)
133.271 -qed (auto intro: le_infI2 z cInf_lower)
133.272 +lemma cInf_insert: "X \<noteq> {} \<Longrightarrow> bdd_below X \<Longrightarrow> Inf (insert a X) = inf a (Inf X)"
133.273 + by (intro cInf_eq_non_empty) (auto intro: le_infI2 cInf_lower cInf_greatest)
133.274
133.275 -lemma cSup_insert_If:
133.276 - "(\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup (insert a X) = (if X = {} then a else sup a (Sup X))"
133.277 - using cSup_insert[of X z] by simp
133.278 +lemma cSup_singleton [simp]: "Sup {x} = x"
133.279 + by (intro cSup_eq_maximum) auto
133.280
133.281 -lemma cInf_insert_if:
133.282 - "(\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf (insert a X) = (if X = {} then a else inf a (Inf X))"
133.283 - using cInf_insert[of X z] by simp
133.284 +lemma cInf_singleton [simp]: "Inf {x} = x"
133.285 + by (intro cInf_eq_minimum) auto
133.286 +
133.287 +lemma cSup_insert_If: "bdd_above X \<Longrightarrow> Sup (insert a X) = (if X = {} then a else sup a (Sup X))"
133.288 + using cSup_insert[of X] by simp
133.289 +
133.290 +lemma cInf_insert_If: "bdd_below X \<Longrightarrow> Inf (insert a X) = (if X = {} then a else inf a (Inf X))"
133.291 + using cInf_insert[of X] by simp
133.292
133.293 lemma le_cSup_finite: "finite X \<Longrightarrow> x \<in> X \<Longrightarrow> x \<le> Sup X"
133.294 proof (induct X arbitrary: x rule: finite_induct)
133.295 case (insert x X y) then show ?case
133.296 - apply (cases "X = {}")
133.297 - apply simp
133.298 - apply (subst cSup_insert[of _ "Sup X"])
133.299 - apply (auto intro: le_supI2)
133.300 - done
133.301 + by (cases "X = {}") (auto simp: cSup_insert intro: le_supI2)
133.302 qed simp
133.303
133.304 lemma cInf_le_finite: "finite X \<Longrightarrow> x \<in> X \<Longrightarrow> Inf X \<le> x"
133.305 proof (induct X arbitrary: x rule: finite_induct)
133.306 case (insert x X y) then show ?case
133.307 - apply (cases "X = {}")
133.308 - apply simp
133.309 - apply (subst cInf_insert[of _ "Inf X"])
133.310 - apply (auto intro: le_infI2)
133.311 - done
133.312 + by (cases "X = {}") (auto simp: cInf_insert intro: le_infI2)
133.313 qed simp
133.314
133.315 lemma cSup_eq_Sup_fin: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup X = Sup_fin X"
133.316 -proof (induct X rule: finite_ne_induct)
133.317 - case (insert x X) then show ?case
133.318 - using cSup_insert[of X "Sup_fin X" x] le_cSup_finite[of X] by simp
133.319 -qed simp
133.320 + by (induct X rule: finite_ne_induct) (simp_all add: cSup_insert)
133.321
133.322 lemma cInf_eq_Inf_fin: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf X = Inf_fin X"
133.323 -proof (induct X rule: finite_ne_induct)
133.324 - case (insert x X) then show ?case
133.325 - using cInf_insert[of X "Inf_fin X" x] cInf_le_finite[of X] by simp
133.326 -qed simp
133.327 + by (induct X rule: finite_ne_induct) (simp_all add: cInf_insert)
133.328
133.329 lemma cSup_atMost[simp]: "Sup {..x} = x"
133.330 by (auto intro!: cSup_eq_maximum)
133.331 @@ -157,16 +274,91 @@
133.332 lemma cInf_atLeastAtMost[simp]: "y \<le> x \<Longrightarrow> Inf {y..x} = y"
133.333 by (auto intro!: cInf_eq_minimum)
133.334
133.335 +lemma cINF_lower: "bdd_below (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> INFI A f \<le> f x"
133.336 + unfolding INF_def by (rule cInf_lower) auto
133.337 +
133.338 +lemma cINF_greatest: "A \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> m \<le> f x) \<Longrightarrow> m \<le> INFI A f"
133.339 + unfolding INF_def by (rule cInf_greatest) auto
133.340 +
133.341 +lemma cSUP_upper: "x \<in> A \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> f x \<le> SUPR A f"
133.342 + unfolding SUP_def by (rule cSup_upper) auto
133.343 +
133.344 +lemma cSUP_least: "A \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<le> M) \<Longrightarrow> SUPR A f \<le> M"
133.345 + unfolding SUP_def by (rule cSup_least) auto
133.346 +
133.347 +lemma cINF_lower2: "bdd_below (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> f x \<le> u \<Longrightarrow> INFI A f \<le> u"
133.348 + by (auto intro: cINF_lower assms order_trans)
133.349 +
133.350 +lemma cSUP_upper2: "bdd_above (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> u \<le> f x \<Longrightarrow> u \<le> SUPR A f"
133.351 + by (auto intro: cSUP_upper assms order_trans)
133.352 +
133.353 +lemma cSUP_const: "A \<noteq> {} \<Longrightarrow> (SUP x:A. c) = c"
133.354 + by (intro antisym cSUP_least) (auto intro: cSUP_upper)
133.355 +
133.356 +lemma cINF_const: "A \<noteq> {} \<Longrightarrow> (INF x:A. c) = c"
133.357 + by (intro antisym cINF_greatest) (auto intro: cINF_lower)
133.358 +
133.359 +lemma le_cINF_iff: "A \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> u \<le> INFI A f \<longleftrightarrow> (\<forall>x\<in>A. u \<le> f x)"
133.360 + by (metis cINF_greatest cINF_lower assms order_trans)
133.361 +
133.362 +lemma cSUP_le_iff: "A \<noteq> {} \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> SUPR A f \<le> u \<longleftrightarrow> (\<forall>x\<in>A. f x \<le> u)"
133.363 + by (metis cSUP_least cSUP_upper assms order_trans)
133.364 +
133.365 +lemma less_cINF_D: "bdd_below (f`A) \<Longrightarrow> y < (INF i:A. f i) \<Longrightarrow> i \<in> A \<Longrightarrow> y < f i"
133.366 + by (metis cINF_lower less_le_trans)
133.367 +
133.368 +lemma cSUP_lessD: "bdd_above (f`A) \<Longrightarrow> (SUP i:A. f i) < y \<Longrightarrow> i \<in> A \<Longrightarrow> f i < y"
133.369 + by (metis cSUP_upper le_less_trans)
133.370 +
133.371 +lemma cINF_insert: "A \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> INFI (insert a A) f = inf (f a) (INFI A f)"
133.372 + by (metis INF_def cInf_insert assms empty_is_image image_insert)
133.373 +
133.374 +lemma cSUP_insert: "A \<noteq> {} \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> SUPR (insert a A) f = sup (f a) (SUPR A f)"
133.375 + by (metis SUP_def cSup_insert assms empty_is_image image_insert)
133.376 +
133.377 +lemma cINF_mono: "B \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> (\<And>m. m \<in> B \<Longrightarrow> \<exists>n\<in>A. f n \<le> g m) \<Longrightarrow> INFI A f \<le> INFI B g"
133.378 + unfolding INF_def by (auto intro: cInf_mono)
133.379 +
133.380 +lemma cSUP_mono: "A \<noteq> {} \<Longrightarrow> bdd_above (g ` B) \<Longrightarrow> (\<And>n. n \<in> A \<Longrightarrow> \<exists>m\<in>B. f n \<le> g m) \<Longrightarrow> SUPR A f \<le> SUPR B g"
133.381 + unfolding SUP_def by (auto intro: cSup_mono)
133.382 +
133.383 +lemma cINF_superset_mono: "A \<noteq> {} \<Longrightarrow> bdd_below (g ` B) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> g x \<le> f x) \<Longrightarrow> INFI B g \<le> INFI A f"
133.384 + by (rule cINF_mono) auto
133.385 +
133.386 +lemma cSUP_subset_mono: "A \<noteq> {} \<Longrightarrow> bdd_above (g ` B) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> f x \<le> g x) \<Longrightarrow> SUPR A f \<le> SUPR B g"
133.387 + by (rule cSUP_mono) auto
133.388 +
133.389 +lemma less_eq_cInf_inter: "bdd_below A \<Longrightarrow> bdd_below B \<Longrightarrow> A \<inter> B \<noteq> {} \<Longrightarrow> inf (Inf A) (Inf B) \<le> Inf (A \<inter> B)"
133.390 + by (metis cInf_superset_mono lattice_class.inf_sup_ord(1) le_infI1)
133.391 +
133.392 +lemma cSup_inter_less_eq: "bdd_above A \<Longrightarrow> bdd_above B \<Longrightarrow> A \<inter> B \<noteq> {} \<Longrightarrow> Sup (A \<inter> B) \<le> sup (Sup A) (Sup B) "
133.393 + by (metis cSup_subset_mono lattice_class.inf_sup_ord(1) le_supI1)
133.394 +
133.395 +lemma cInf_union_distrib: "A \<noteq> {} \<Longrightarrow> bdd_below A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_below B \<Longrightarrow> Inf (A \<union> B) = inf (Inf A) (Inf B)"
133.396 + by (intro antisym le_infI cInf_greatest cInf_lower) (auto intro: le_infI1 le_infI2 cInf_lower)
133.397 +
133.398 +lemma cINF_union: "A \<noteq> {} \<Longrightarrow> bdd_below (f`A) \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_below (f`B) \<Longrightarrow> INFI (A \<union> B) f = inf (INFI A f) (INFI B f)"
133.399 + unfolding INF_def using assms by (auto simp add: image_Un intro: cInf_union_distrib)
133.400 +
133.401 +lemma cSup_union_distrib: "A \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_above B \<Longrightarrow> Sup (A \<union> B) = sup (Sup A) (Sup B)"
133.402 + by (intro antisym le_supI cSup_least cSup_upper) (auto intro: le_supI1 le_supI2 cSup_upper)
133.403 +
133.404 +lemma cSUP_union: "A \<noteq> {} \<Longrightarrow> bdd_above (f`A) \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_above (f`B) \<Longrightarrow> SUPR (A \<union> B) f = sup (SUPR A f) (SUPR B f)"
133.405 + unfolding SUP_def by (auto simp add: image_Un intro: cSup_union_distrib)
133.406 +
133.407 +lemma cINF_inf_distrib: "A \<noteq> {} \<Longrightarrow> bdd_below (f`A) \<Longrightarrow> bdd_below (g`A) \<Longrightarrow> inf (INFI A f) (INFI A g) = (INF a:A. inf (f a) (g a))"
133.408 + by (intro antisym le_infI cINF_greatest cINF_lower2)
133.409 + (auto intro: le_infI1 le_infI2 cINF_greatest cINF_lower le_infI)
133.410 +
133.411 +lemma SUP_sup_distrib: "A \<noteq> {} \<Longrightarrow> bdd_above (f`A) \<Longrightarrow> bdd_above (g`A) \<Longrightarrow> sup (SUPR A f) (SUPR A g) = (SUP a:A. sup (f a) (g a))"
133.412 + by (intro antisym le_supI cSUP_least cSUP_upper2)
133.413 + (auto intro: le_supI1 le_supI2 cSUP_least cSUP_upper le_supI)
133.414 +
133.415 end
133.416
133.417 instance complete_lattice \<subseteq> conditionally_complete_lattice
133.418 by default (auto intro: Sup_upper Sup_least Inf_lower Inf_greatest)
133.419
133.420 -lemma isLub_cSup:
133.421 - "(S::'a :: conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> (\<exists>b. S *<= b) \<Longrightarrow> isLub UNIV S (Sup S)"
133.422 - by (auto simp add: isLub_def setle_def leastP_def isUb_def
133.423 - intro!: setgeI intro: cSup_upper cSup_least)
133.424 -
133.425 lemma cSup_eq:
133.426 fixes a :: "'a :: {conditionally_complete_lattice, no_bot}"
133.427 assumes upper: "\<And>x. x \<in> X \<Longrightarrow> x \<le> a"
133.428 @@ -185,33 +377,33 @@
133.429 assume "X = {}" with gt_ex[of a] least show ?thesis by (auto simp: less_le_not_le)
133.430 qed (intro cInf_eq_non_empty assms)
133.431
133.432 -lemma cSup_le: "(S::'a::conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> S *<= b \<Longrightarrow> Sup S \<le> b"
133.433 - by (metis cSup_least setle_def)
133.434 -
133.435 -lemma cInf_ge: "(S::'a :: conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> b <=* S \<Longrightarrow> Inf S \<ge> b"
133.436 - by (metis cInf_greatest setge_def)
133.437 -
133.438 class conditionally_complete_linorder = conditionally_complete_lattice + linorder
133.439 begin
133.440
133.441 lemma less_cSup_iff : (*REAL_SUP_LE in HOL4*)
133.442 - "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> y < Sup X \<longleftrightarrow> (\<exists>x\<in>X. y < x)"
133.443 + "X \<noteq> {} \<Longrightarrow> bdd_above X \<Longrightarrow> y < Sup X \<longleftrightarrow> (\<exists>x\<in>X. y < x)"
133.444 by (rule iffI) (metis cSup_least not_less, metis cSup_upper less_le_trans)
133.445
133.446 -lemma cInf_less_iff: "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf X < y \<longleftrightarrow> (\<exists>x\<in>X. x < y)"
133.447 +lemma cInf_less_iff: "X \<noteq> {} \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X < y \<longleftrightarrow> (\<exists>x\<in>X. x < y)"
133.448 by (rule iffI) (metis cInf_greatest not_less, metis cInf_lower le_less_trans)
133.449
133.450 +lemma cINF_less_iff: "A \<noteq> {} \<Longrightarrow> bdd_below (f`A) \<Longrightarrow> (INF i:A. f i) < a \<longleftrightarrow> (\<exists>x\<in>A. f x < a)"
133.451 + unfolding INF_def using cInf_less_iff[of "f`A"] by auto
133.452 +
133.453 +lemma less_cSUP_iff: "A \<noteq> {} \<Longrightarrow> bdd_above (f`A) \<Longrightarrow> a < (SUP i:A. f i) \<longleftrightarrow> (\<exists>x\<in>A. a < f x)"
133.454 + unfolding SUP_def using less_cSup_iff[of "f`A"] by auto
133.455 +
133.456 lemma less_cSupE:
133.457 assumes "y < Sup X" "X \<noteq> {}" obtains x where "x \<in> X" "y < x"
133.458 by (metis cSup_least assms not_le that)
133.459
133.460 lemma less_cSupD:
133.461 "X \<noteq> {} \<Longrightarrow> z < Sup X \<Longrightarrow> \<exists>x\<in>X. z < x"
133.462 - by (metis less_cSup_iff not_leE)
133.463 + by (metis less_cSup_iff not_leE bdd_above_def)
133.464
133.465 lemma cInf_lessD:
133.466 "X \<noteq> {} \<Longrightarrow> Inf X < z \<Longrightarrow> \<exists>x\<in>X. x < z"
133.467 - by (metis cInf_less_iff not_leE)
133.468 + by (metis cInf_less_iff not_leE bdd_below_def)
133.469
133.470 lemma complete_interval:
133.471 assumes "a < b" and "P a" and "\<not> P b"
133.472 @@ -219,7 +411,7 @@
133.473 (\<forall>d. (\<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x) \<longrightarrow> d \<le> c)"
133.474 proof (rule exI [where x = "Sup {d. \<forall>x. a \<le> x & x < d --> P x}"], auto)
133.475 show "a \<le> Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
133.476 - by (rule cSup_upper [where z=b], auto)
133.477 + by (rule cSup_upper, auto simp: bdd_above_def)
133.478 (metis `a < b` `\<not> P b` linear less_le)
133.479 next
133.480 show "Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c} \<le> b"
133.481 @@ -240,12 +432,36 @@
133.482 fix d
133.483 assume 0: "\<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x"
133.484 thus "d \<le> Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
133.485 - by (rule_tac z="b" in cSup_upper, auto)
133.486 + by (rule_tac cSup_upper, auto simp: bdd_above_def)
133.487 (metis `a<b` `~ P b` linear less_le)
133.488 qed
133.489
133.490 end
133.491
133.492 +lemma cSup_eq_Max: "finite (X::'a::conditionally_complete_linorder set) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup X = Max X"
133.493 + using cSup_eq_Sup_fin[of X] Sup_fin_eq_Max[of X] by simp
133.494 +
133.495 +lemma cInf_eq_Min: "finite (X::'a::conditionally_complete_linorder set) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf X = Min X"
133.496 + using cInf_eq_Inf_fin[of X] Inf_fin_eq_Min[of X] by simp
133.497 +
133.498 +lemma cSup_lessThan[simp]: "Sup {..<x::'a::{conditionally_complete_linorder, no_bot, dense_linorder}} = x"
133.499 + by (auto intro!: cSup_eq_non_empty intro: dense_le)
133.500 +
133.501 +lemma cSup_greaterThanLessThan[simp]: "y < x \<Longrightarrow> Sup {y<..<x::'a::{conditionally_complete_linorder, no_bot, dense_linorder}} = x"
133.502 + by (auto intro!: cSup_eq intro: dense_le_bounded)
133.503 +
133.504 +lemma cSup_atLeastLessThan[simp]: "y < x \<Longrightarrow> Sup {y..<x::'a::{conditionally_complete_linorder, no_bot, dense_linorder}} = x"
133.505 + by (auto intro!: cSup_eq intro: dense_le_bounded)
133.506 +
133.507 +lemma cInf_greaterThan[simp]: "Inf {x::'a::{conditionally_complete_linorder, no_top, dense_linorder} <..} = x"
133.508 + by (auto intro!: cInf_eq intro: dense_ge)
133.509 +
133.510 +lemma cInf_greaterThanAtMost[simp]: "y < x \<Longrightarrow> Inf {y<..x::'a::{conditionally_complete_linorder, no_top, dense_linorder}} = y"
133.511 + by (auto intro!: cInf_eq intro: dense_ge_bounded)
133.512 +
133.513 +lemma cInf_greaterThanLessThan[simp]: "y < x \<Longrightarrow> Inf {y<..<x::'a::{conditionally_complete_linorder, no_top, dense_linorder}} = y"
133.514 + by (auto intro!: cInf_eq intro: dense_ge_bounded)
133.515 +
133.516 class linear_continuum = conditionally_complete_linorder + dense_linorder +
133.517 assumes UNIV_not_singleton: "\<exists>a b::'a. a \<noteq> b"
133.518 begin
133.519 @@ -255,50 +471,92 @@
133.520
133.521 end
133.522
133.523 -lemma cSup_bounds:
133.524 - fixes S :: "'a :: conditionally_complete_lattice set"
133.525 - assumes Se: "S \<noteq> {}" and l: "a <=* S" and u: "S *<= b"
133.526 - shows "a \<le> Sup S \<and> Sup S \<le> b"
133.527 -proof-
133.528 - from isLub_cSup[OF Se] u have lub: "isLub UNIV S (Sup S)" by blast
133.529 - hence b: "Sup S \<le> b" using u
133.530 - by (auto simp add: isLub_def leastP_def setle_def setge_def isUb_def)
133.531 - from Se obtain y where y: "y \<in> S" by blast
133.532 - from lub l have "a \<le> Sup S"
133.533 - by (auto simp add: isLub_def leastP_def setle_def setge_def isUb_def)
133.534 - (metis le_iff_sup le_sup_iff y)
133.535 - with b show ?thesis by blast
133.536 +instantiation nat :: conditionally_complete_linorder
133.537 +begin
133.538 +
133.539 +definition "Sup (X::nat set) = Max X"
133.540 +definition "Inf (X::nat set) = (LEAST n. n \<in> X)"
133.541 +
133.542 +lemma bdd_above_nat: "bdd_above X \<longleftrightarrow> finite (X::nat set)"
133.543 +proof
133.544 + assume "bdd_above X"
133.545 + then obtain z where "X \<subseteq> {.. z}"
133.546 + by (auto simp: bdd_above_def)
133.547 + then show "finite X"
133.548 + by (rule finite_subset) simp
133.549 +qed simp
133.550 +
133.551 +instance
133.552 +proof
133.553 + fix x :: nat and X :: "nat set"
133.554 + { assume "x \<in> X" "bdd_below X" then show "Inf X \<le> x"
133.555 + by (simp add: Inf_nat_def Least_le) }
133.556 + { assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> x \<le> y" then show "x \<le> Inf X"
133.557 + unfolding Inf_nat_def ex_in_conv[symmetric] by (rule LeastI2_ex) }
133.558 + { assume "x \<in> X" "bdd_above X" then show "x \<le> Sup X"
133.559 + by (simp add: Sup_nat_def bdd_above_nat) }
133.560 + { assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> y \<le> x"
133.561 + moreover then have "bdd_above X"
133.562 + by (auto simp: bdd_above_def)
133.563 + ultimately show "Sup X \<le> x"
133.564 + by (simp add: Sup_nat_def bdd_above_nat) }
133.565 qed
133.566 +end
133.567
133.568 +instantiation int :: conditionally_complete_linorder
133.569 +begin
133.570
133.571 -lemma cSup_unique: "(S::'a :: {conditionally_complete_linorder, no_bot} set) *<= b \<Longrightarrow> (\<forall>b'<b. \<exists>x\<in>S. b' < x) \<Longrightarrow> Sup S = b"
133.572 - by (rule cSup_eq) (auto simp: not_le[symmetric] setle_def)
133.573 +definition "Sup (X::int set) = (THE x. x \<in> X \<and> (\<forall>y\<in>X. y \<le> x))"
133.574 +definition "Inf (X::int set) = - (Sup (uminus ` X))"
133.575
133.576 -lemma cInf_unique: "b <=* (S::'a :: {conditionally_complete_linorder, no_top} set) \<Longrightarrow> (\<forall>b'>b. \<exists>x\<in>S. b' > x) \<Longrightarrow> Inf S = b"
133.577 - by (rule cInf_eq) (auto simp: not_le[symmetric] setge_def)
133.578 +instance
133.579 +proof
133.580 + { fix x :: int and X :: "int set" assume "X \<noteq> {}" "bdd_above X"
133.581 + then obtain x y where "X \<subseteq> {..y}" "x \<in> X"
133.582 + by (auto simp: bdd_above_def)
133.583 + then have *: "finite (X \<inter> {x..y})" "X \<inter> {x..y} \<noteq> {}" and "x \<le> y"
133.584 + by (auto simp: subset_eq)
133.585 + have "\<exists>!x\<in>X. (\<forall>y\<in>X. y \<le> x)"
133.586 + proof
133.587 + { fix z assume "z \<in> X"
133.588 + have "z \<le> Max (X \<inter> {x..y})"
133.589 + proof cases
133.590 + assume "x \<le> z" with `z \<in> X` `X \<subseteq> {..y}` *(1) show ?thesis
133.591 + by (auto intro!: Max_ge)
133.592 + next
133.593 + assume "\<not> x \<le> z"
133.594 + then have "z < x" by simp
133.595 + also have "x \<le> Max (X \<inter> {x..y})"
133.596 + using `x \<in> X` *(1) `x \<le> y` by (intro Max_ge) auto
133.597 + finally show ?thesis by simp
133.598 + qed }
133.599 + note le = this
133.600 + with Max_in[OF *] show ex: "Max (X \<inter> {x..y}) \<in> X \<and> (\<forall>z\<in>X. z \<le> Max (X \<inter> {x..y}))" by auto
133.601
133.602 -lemma cSup_eq_Max: "finite (X::'a::conditionally_complete_linorder set) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup X = Max X"
133.603 - using cSup_eq_Sup_fin[of X] Sup_fin_eq_Max[of X] by simp
133.604 + fix z assume *: "z \<in> X \<and> (\<forall>y\<in>X. y \<le> z)"
133.605 + with le have "z \<le> Max (X \<inter> {x..y})"
133.606 + by auto
133.607 + moreover have "Max (X \<inter> {x..y}) \<le> z"
133.608 + using * ex by auto
133.609 + ultimately show "z = Max (X \<inter> {x..y})"
133.610 + by auto
133.611 + qed
133.612 + then have "Sup X \<in> X \<and> (\<forall>y\<in>X. y \<le> Sup X)"
133.613 + unfolding Sup_int_def by (rule theI') }
133.614 + note Sup_int = this
133.615
133.616 -lemma cInf_eq_Min: "finite (X::'a::conditionally_complete_linorder set) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf X = Min X"
133.617 - using cInf_eq_Inf_fin[of X] Inf_fin_eq_Min[of X] by simp
133.618 + { fix x :: int and X :: "int set" assume "x \<in> X" "bdd_above X" then show "x \<le> Sup X"
133.619 + using Sup_int[of X] by auto }
133.620 + note le_Sup = this
133.621 + { fix x :: int and X :: "int set" assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> y \<le> x" then show "Sup X \<le> x"
133.622 + using Sup_int[of X] by (auto simp: bdd_above_def) }
133.623 + note Sup_le = this
133.624
133.625 -lemma cSup_lessThan[simp]: "Sup {..<x::'a::{conditionally_complete_linorder, unbounded_dense_linorder}} = x"
133.626 - by (auto intro!: cSup_eq_non_empty intro: dense_le)
133.627 -
133.628 -lemma cSup_greaterThanLessThan[simp]: "y < x \<Longrightarrow> Sup {y<..<x::'a::{conditionally_complete_linorder, unbounded_dense_linorder}} = x"
133.629 - by (auto intro!: cSup_eq intro: dense_le_bounded)
133.630 -
133.631 -lemma cSup_atLeastLessThan[simp]: "y < x \<Longrightarrow> Sup {y..<x::'a::{conditionally_complete_linorder, unbounded_dense_linorder}} = x"
133.632 - by (auto intro!: cSup_eq intro: dense_le_bounded)
133.633 -
133.634 -lemma cInf_greaterThan[simp]: "Inf {x::'a::{conditionally_complete_linorder, unbounded_dense_linorder} <..} = x"
133.635 - by (auto intro!: cInf_eq intro: dense_ge)
133.636 -
133.637 -lemma cInf_greaterThanAtMost[simp]: "y < x \<Longrightarrow> Inf {y<..x::'a::{conditionally_complete_linorder, unbounded_dense_linorder}} = y"
133.638 - by (auto intro!: cInf_eq intro: dense_ge_bounded)
133.639 -
133.640 -lemma cInf_greaterThanLessThan[simp]: "y < x \<Longrightarrow> Inf {y<..<x::'a::{conditionally_complete_linorder, unbounded_dense_linorder}} = y"
133.641 - by (auto intro!: cInf_eq intro: dense_ge_bounded)
133.642 + { fix x :: int and X :: "int set" assume "x \<in> X" "bdd_below X" then show "Inf X \<le> x"
133.643 + using le_Sup[of "-x" "uminus ` X"] by (auto simp: Inf_int_def) }
133.644 + { fix x :: int and X :: "int set" assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> x \<le> y" then show "x \<le> Inf X"
133.645 + using Sup_le[of "uminus ` X" "-x"] by (force simp: Inf_int_def) }
133.646 +qed
133.647 +end
133.648
133.649 end
134.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
134.2 +++ b/src/HOL/Ctr_Sugar.thy Thu Dec 05 17:58:03 2013 +0100
134.3 @@ -0,0 +1,44 @@
134.4 +(* Title: HOL/Ctr_Sugar.thy
134.5 + Author: Jasmin Blanchette, TU Muenchen
134.6 + Copyright 2012, 2013
134.7 +
134.8 +Wrapping existing freely generated type's constructors.
134.9 +*)
134.10 +
134.11 +header {* Wrapping Existing Freely Generated Type's Constructors *}
134.12 +
134.13 +theory Ctr_Sugar
134.14 +imports HOL
134.15 +keywords
134.16 + "print_case_translations" :: diag and
134.17 + "wrap_free_constructors" :: thy_goal
134.18 +begin
134.19 +
134.20 +consts
134.21 + case_guard :: "bool \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b"
134.22 + case_nil :: "'a \<Rightarrow> 'b"
134.23 + case_cons :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
134.24 + case_elem :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b"
134.25 + case_abs :: "('c \<Rightarrow> 'b) \<Rightarrow> 'b"
134.26 +declare [[coercion_args case_guard - + -]]
134.27 +declare [[coercion_args case_cons - -]]
134.28 +declare [[coercion_args case_abs -]]
134.29 +declare [[coercion_args case_elem - +]]
134.30 +
134.31 +ML_file "Tools/case_translation.ML"
134.32 +setup Case_Translation.setup
134.33 +
134.34 +lemma iffI_np: "\<lbrakk>x \<Longrightarrow> \<not> y; \<not> x \<Longrightarrow> y\<rbrakk> \<Longrightarrow> \<not> x \<longleftrightarrow> y"
134.35 +by (erule iffI) (erule contrapos_pn)
134.36 +
134.37 +lemma iff_contradict:
134.38 +"\<not> P \<Longrightarrow> P \<longleftrightarrow> Q \<Longrightarrow> Q \<Longrightarrow> R"
134.39 +"\<not> Q \<Longrightarrow> P \<longleftrightarrow> Q \<Longrightarrow> P \<Longrightarrow> R"
134.40 +by blast+
134.41 +
134.42 +ML_file "Tools/ctr_sugar_util.ML"
134.43 +ML_file "Tools/ctr_sugar_tactics.ML"
134.44 +ML_file "Tools/ctr_sugar_code.ML"
134.45 +ML_file "Tools/ctr_sugar.ML"
134.46 +
134.47 +end
135.1 --- a/src/HOL/Datatype.thy Thu Dec 05 17:52:12 2013 +0100
135.2 +++ b/src/HOL/Datatype.thy Thu Dec 05 17:58:03 2013 +0100
135.3 @@ -499,7 +499,7 @@
135.4
135.5 (*Dependent version*)
135.6 lemma dprod_subset_Sigma2:
135.7 - "(dprod (Sigma A B) (Sigma C D)) <=
135.8 + "(dprod (Sigma A B) (Sigma C D)) <=
135.9 Sigma (uprod A C) (Split (%x y. uprod (B x) (D y)))"
135.10 by auto
135.11
135.12 @@ -522,4 +522,3 @@
135.13 setup Datatype_Realizer.setup
135.14
135.15 end
135.16 -
136.1 --- a/src/HOL/Decision_Procs/Approximation.thy Thu Dec 05 17:52:12 2013 +0100
136.2 +++ b/src/HOL/Decision_Procs/Approximation.thy Thu Dec 05 17:58:03 2013 +0100
136.3 @@ -11,8 +11,10 @@
136.4 "~~/src/HOL/Library/Code_Target_Numeral"
136.5 begin
136.6
136.7 -declare powr_numeral[simp]
136.8 -declare powr_neg_numeral[simp]
136.9 +declare powr_one [simp]
136.10 +declare powr_numeral [simp]
136.11 +declare powr_neg_one [simp]
136.12 +declare powr_neg_numeral [simp]
136.13
136.14 section "Horner Scheme"
136.15
136.16 @@ -29,7 +31,7 @@
136.17 have shift_pow: "\<And>i. - (x * ((-1)^i * a (Suc i) * x ^ i)) = (-1)^(Suc i) * a (Suc i) * x ^ (Suc i)"
136.18 by auto
136.19 show ?thesis
136.20 - unfolding setsum_right_distrib shift_pow diff_minus setsum_negf[symmetric]
136.21 + unfolding setsum_right_distrib shift_pow uminus_add_conv_diff [symmetric] setsum_negf[symmetric]
136.22 setsum_head_upt_Suc[OF zero_less_Suc]
136.23 setsum_reindex[OF inj_Suc, unfolded comp_def, symmetric, of "\<lambda> n. (-1)^n *a n * x^n"] by auto
136.24 qed
136.25 @@ -132,14 +134,7 @@
136.26 lemma get_odd[simp]: "odd (get_odd n)" unfolding get_odd_def by (cases "odd n", auto)
136.27 lemma get_even[simp]: "even (get_even n)" unfolding get_even_def by (cases "even n", auto)
136.28 lemma get_odd_ex: "\<exists> k. Suc k = get_odd n \<and> odd (Suc k)"
136.29 -proof (cases "odd n")
136.30 - case True hence "0 < n" by (rule odd_pos)
136.31 - from gr0_implies_Suc[OF this] obtain k where "Suc k = n" by auto
136.32 - thus ?thesis unfolding get_odd_def if_P[OF True] using True[unfolded `Suc k = n`[symmetric]] by blast
136.33 -next
136.34 - case False hence "odd (Suc n)" by auto
136.35 - thus ?thesis unfolding get_odd_def if_not_P[OF False] by blast
136.36 -qed
136.37 + by (auto simp: get_odd_def odd_pos intro!: exI[of _ "n - 1"])
136.38
136.39 lemma get_even_double: "\<exists>i. get_even n = 2 * i" using get_even[unfolded even_mult_two_ex] .
136.40 lemma get_odd_double: "\<exists>i. get_odd n = 2 * i + 1" using get_odd[unfolded odd_Suc_mult_two_ex] by auto
136.41 @@ -151,47 +146,9 @@
136.42 else if u < 0 then (u ^ n, l ^ n)
136.43 else (0, (max (-l) u) ^ n))"
136.44
136.45 -lemma float_power_bnds: fixes x :: real
136.46 - assumes "(l1, u1) = float_power_bnds n l u" and "x \<in> {l .. u}"
136.47 - shows "x ^ n \<in> {l1..u1}"
136.48 -proof (cases "even n")
136.49 - case True
136.50 - show ?thesis
136.51 - proof (cases "0 < l")
136.52 - case True hence "odd n \<or> 0 < l" and "0 \<le> real l" by auto
136.53 - have u1: "u1 = u ^ n" and l1: "l1 = l ^ n" using assms
136.54 - unfolding float_power_bnds_def if_P[OF `odd n \<or> 0 < l`] by auto
136.55 - have "real l ^ n \<le> x ^ n" and "x ^ n \<le> real u ^ n " using `0 \<le> real l` assms
136.56 - by (auto simp: power_mono)
136.57 - thus ?thesis using assms `0 < l` unfolding l1 u1 by auto
136.58 - next
136.59 - case False hence P: "\<not> (odd n \<or> 0 < l)" using `even n` by auto
136.60 - show ?thesis
136.61 - proof (cases "u < 0")
136.62 - case True hence "0 \<le> - real u" and "- real u \<le> - x" and "0 \<le> - x" and "-x \<le> - real l" using assms by auto
136.63 - hence "real u ^ n \<le> x ^ n" and "x ^ n \<le> real l ^ n" using power_mono[of "-x" "-real l" n] power_mono[of "-real u" "-x" n]
136.64 - unfolding power_minus_even[OF `even n`] by auto
136.65 - moreover have u1: "u1 = l ^ n" and l1: "l1 = u ^ n" using assms unfolding float_power_bnds_def if_not_P[OF P] if_P[OF True] by auto
136.66 - ultimately show ?thesis by auto
136.67 - next
136.68 - case False
136.69 - have "\<bar>x\<bar> \<le> real (max (-l) u)"
136.70 - proof (cases "-l \<le> u")
136.71 - case True thus ?thesis unfolding max_def if_P[OF True] using assms by auto
136.72 - next
136.73 - case False thus ?thesis unfolding max_def if_not_P[OF False] using assms by auto
136.74 - qed
136.75 - hence x_abs: "\<bar>x\<bar> \<le> \<bar>real (max (-l) u)\<bar>" by auto
136.76 - have u1: "u1 = (max (-l) u) ^ n" and l1: "l1 = 0" using assms unfolding float_power_bnds_def if_not_P[OF P] if_not_P[OF False] by auto
136.77 - show ?thesis unfolding atLeastAtMost_iff l1 u1 using zero_le_even_power[OF `even n`] power_mono_even[OF `even n` x_abs] by auto
136.78 - qed
136.79 - qed
136.80 -next
136.81 - case False hence "odd n \<or> 0 < l" by auto
136.82 - have u1: "u1 = u ^ n" and l1: "l1 = l ^ n" using assms unfolding float_power_bnds_def if_P[OF `odd n \<or> 0 < l`] by auto
136.83 - have "real l ^ n \<le> x ^ n" and "x ^ n \<le> real u ^ n " using assms unfolding atLeastAtMost_iff using power_mono_odd[OF False] by auto
136.84 - thus ?thesis unfolding atLeastAtMost_iff l1 u1 less_float_def by auto
136.85 -qed
136.86 +lemma float_power_bnds: "(l1, u1) = float_power_bnds n l u \<Longrightarrow> x \<in> {l .. u} \<Longrightarrow> (x::real) ^ n \<in> {l1..u1}"
136.87 + by (auto simp: float_power_bnds_def max_def split: split_if_asm
136.88 + intro: power_mono_odd power_mono power_mono_even zero_le_even_power)
136.89
136.90 lemma bnds_power: "\<forall> (x::real) l u. (l1, u1) = float_power_bnds n l u \<and> x \<in> {l .. u} \<longrightarrow> l1 \<le> x ^ n \<and> x ^ n \<le> u1"
136.91 using float_power_bnds by auto
136.92 @@ -244,7 +201,7 @@
136.93 qed
136.94
136.95 lemma sqrt_iteration_bound: assumes "0 < real x"
136.96 - shows "sqrt x < (sqrt_iteration prec n x)"
136.97 + shows "sqrt x < sqrt_iteration prec n x"
136.98 proof (induct n)
136.99 case 0
136.100 show ?case
136.101 @@ -356,20 +313,8 @@
136.102 note ub = this
136.103
136.104 show ?thesis
136.105 - proof (cases "0 < x")
136.106 - case True with lb ub show ?thesis by auto
136.107 - next case False show ?thesis
136.108 - proof (cases "real x = 0")
136.109 - case True thus ?thesis
136.110 - by (auto simp add: lb_sqrt.simps ub_sqrt.simps)
136.111 - next
136.112 - case False with `\<not> 0 < x` have "x < 0" and "0 < -x"
136.113 - by auto
136.114 -
136.115 - with `\<not> 0 < x`
136.116 - show ?thesis using lb[OF `0 < -x`] ub[OF `0 < -x`]
136.117 - by (auto simp add: real_sqrt_minus lb_sqrt.simps ub_sqrt.simps)
136.118 - qed qed
136.119 + using lb[of "-x"] ub[of "-x"] lb[of x] ub[of x]
136.120 + by (auto simp add: lb_sqrt.simps ub_sqrt.simps real_sqrt_minus)
136.121 qed
136.122
136.123 lemma bnds_sqrt: "\<forall> (x::real) lx ux. (l, u) = (lb_sqrt prec lx, ub_sqrt prec ux) \<and> x \<in> {lx .. ux} \<longrightarrow> l \<le> sqrt x \<and> sqrt x \<le> u"
136.124 @@ -412,8 +357,8 @@
136.125 assumes "0 \<le> real x" "real x \<le> 1" and "even n"
136.126 shows "arctan x \<in> {(x * lb_arctan_horner prec n 1 (x * x)) .. (x * ub_arctan_horner prec (Suc n) 1 (x * x))}"
136.127 proof -
136.128 - let "?c i" = "-1^i * (1 / (i * 2 + (1::nat)) * real x ^ (i * 2 + 1))"
136.129 - let "?S n" = "\<Sum> i=0..<n. ?c i"
136.130 + let ?c = "\<lambda>i. -1^i * (1 / (i * 2 + (1::nat)) * real x ^ (i * 2 + 1))"
136.131 + let ?S = "\<lambda>n. \<Sum> i=0..<n. ?c i"
136.132
136.133 have "0 \<le> real (x * x)" by auto
136.134 from `even n` obtain m where "2 * m = n" unfolding even_mult_two_ex by auto
136.135 @@ -457,30 +402,11 @@
136.136
136.137 lemma arctan_0_1_bounds: assumes "0 \<le> real x" "real x \<le> 1"
136.138 shows "arctan x \<in> {(x * lb_arctan_horner prec (get_even n) 1 (x * x)) .. (x * ub_arctan_horner prec (get_odd n) 1 (x * x))}"
136.139 -proof (cases "even n")
136.140 - case True
136.141 - obtain n' where "Suc n' = get_odd n" and "odd (Suc n')" using get_odd_ex by auto
136.142 - hence "even n'" unfolding even_Suc by auto
136.143 - have "arctan x \<le> x * ub_arctan_horner prec (get_odd n) 1 (x * x)"
136.144 - unfolding `Suc n' = get_odd n`[symmetric] using arctan_0_1_bounds'[OF `0 \<le> real x` `real x \<le> 1` `even n'`] by auto
136.145 - moreover
136.146 - have "x * lb_arctan_horner prec (get_even n) 1 (x * x) \<le> arctan x"
136.147 - unfolding get_even_def if_P[OF True] using arctan_0_1_bounds'[OF `0 \<le> real x` `real x \<le> 1` `even n`] by auto
136.148 - ultimately show ?thesis by auto
136.149 -next
136.150 - case False hence "0 < n" by (rule odd_pos)
136.151 - from gr0_implies_Suc[OF this] obtain n' where "n = Suc n'" ..
136.152 - from False[unfolded this even_Suc]
136.153 - have "even n'" and "even (Suc (Suc n'))" by auto
136.154 - have "get_odd n = Suc n'" unfolding get_odd_def if_P[OF False] using `n = Suc n'` .
136.155 -
136.156 - have "arctan x \<le> x * ub_arctan_horner prec (get_odd n) 1 (x * x)"
136.157 - unfolding `get_odd n = Suc n'` using arctan_0_1_bounds'[OF `0 \<le> real x` `real x \<le> 1` `even n'`] by auto
136.158 - moreover
136.159 - have "(x * lb_arctan_horner prec (get_even n) 1 (x * x)) \<le> arctan x"
136.160 - unfolding get_even_def if_not_P[OF False] unfolding `n = Suc n'` using arctan_0_1_bounds'[OF `0 \<le> real x` `real x \<le> 1` `even (Suc (Suc n'))`] by auto
136.161 - ultimately show ?thesis by auto
136.162 -qed
136.163 + using
136.164 + arctan_0_1_bounds'[OF assms, of n prec]
136.165 + arctan_0_1_bounds'[OF assms, of "n + 1" prec]
136.166 + arctan_0_1_bounds'[OF assms, of "n - 1" prec]
136.167 + by (auto simp: get_even_def get_odd_def odd_pos simp del: ub_arctan_horner.simps lb_arctan_horner.simps)
136.168
136.169 subsection "Compute \<pi>"
136.170
136.171 @@ -530,16 +456,11 @@
136.172 finally have "?k * lb_arctan_horner prec (get_even n) 1 (?k * ?k) \<le> arctan (1 / k)" .
136.173 } note lb_arctan = this
136.174
136.175 - have "pi \<le> ub_pi n"
136.176 - unfolding ub_pi_def machin_pi Let_def unfolding Float_num
136.177 - using lb_arctan[of 239] ub_arctan[of 5] powr_realpow[of 2 2]
136.178 - by (auto intro!: mult_left_mono add_mono simp add: diff_minus)
136.179 - moreover
136.180 - have "lb_pi n \<le> pi"
136.181 - unfolding lb_pi_def machin_pi Let_def Float_num
136.182 - using lb_arctan[of 5] ub_arctan[of 239] powr_realpow[of 2 2]
136.183 - by (auto intro!: mult_left_mono add_mono simp add: diff_minus)
136.184 - ultimately show ?thesis by auto
136.185 + have "pi \<le> ub_pi n \<and> lb_pi n \<le> pi"
136.186 + unfolding lb_pi_def ub_pi_def machin_pi Let_def unfolding Float_num
136.187 + using lb_arctan[of 5] ub_arctan[of 239] lb_arctan[of 239] ub_arctan[of 5] powr_realpow[of 2 2]
136.188 + by (auto intro!: mult_left_mono add_mono simp add: uminus_add_conv_diff [symmetric] simp del: uminus_add_conv_diff)
136.189 + then show ?thesis by auto
136.190 qed
136.191
136.192 subsection "Compute arcus tangens in the entire domain"
136.193 @@ -1208,8 +1129,8 @@
136.194 using x unfolding k[symmetric]
136.195 by (cases "k = 0")
136.196 (auto intro!: add_mono
136.197 - simp add: diff_minus k[symmetric]
136.198 - simp del: float_of_numeral)
136.199 + simp add: k [symmetric] uminus_add_conv_diff [symmetric]
136.200 + simp del: float_of_numeral uminus_add_conv_diff)
136.201 note lx = this[THEN conjunct1] and ux = this[THEN conjunct2]
136.202 hence lx_less_ux: "?lx \<le> real ?ux" by (rule order_trans)
136.203
136.204 @@ -1223,7 +1144,7 @@
136.205 also have "\<dots> \<le> cos (x + (-k) * (2 * pi))"
136.206 using cos_monotone_minus_pi_0'[OF pi_lx lx x_le_0]
136.207 by (simp only: uminus_float.rep_eq real_of_int_minus
136.208 - cos_minus diff_minus mult_minus_left)
136.209 + cos_minus mult_minus_left) simp
136.210 finally have "(lb_cos prec (- ?lx)) \<le> cos x"
136.211 unfolding cos_periodic_int . }
136.212 note negative_lx = this
136.213 @@ -1236,7 +1157,7 @@
136.214 have "cos (x + (-k) * (2 * pi)) \<le> cos ?lx"
136.215 using cos_monotone_0_pi'[OF lx_0 lx pi_x]
136.216 by (simp only: real_of_int_minus
136.217 - cos_minus diff_minus mult_minus_left)
136.218 + cos_minus mult_minus_left) simp
136.219 also have "\<dots> \<le> (ub_cos prec ?lx)"
136.220 using lb_cos[OF lx_0 pi_lx] by simp
136.221 finally have "cos x \<le> (ub_cos prec ?lx)"
136.222 @@ -1251,7 +1172,7 @@
136.223 have "cos (x + (-k) * (2 * pi)) \<le> cos (real (- ?ux))"
136.224 using cos_monotone_minus_pi_0'[OF pi_x ux ux_0]
136.225 by (simp only: uminus_float.rep_eq real_of_int_minus
136.226 - cos_minus diff_minus mult_minus_left)
136.227 + cos_minus mult_minus_left) simp
136.228 also have "\<dots> \<le> (ub_cos prec (- ?ux))"
136.229 using lb_cos_minus[OF pi_ux ux_0, of prec] by simp
136.230 finally have "cos x \<le> (ub_cos prec (- ?ux))"
136.231 @@ -1268,7 +1189,7 @@
136.232 also have "\<dots> \<le> cos (x + (-k) * (2 * pi))"
136.233 using cos_monotone_0_pi'[OF x_ge_0 ux pi_ux]
136.234 by (simp only: real_of_int_minus
136.235 - cos_minus diff_minus mult_minus_left)
136.236 + cos_minus mult_minus_left) simp
136.237 finally have "(lb_cos prec ?ux) \<le> cos x"
136.238 unfolding cos_periodic_int . }
136.239 note positive_ux = this
136.240 @@ -1342,8 +1263,8 @@
136.241 unfolding cos_periodic_int ..
136.242 also have "\<dots> \<le> cos ((?ux - 2 * ?lpi))"
136.243 using cos_monotone_minus_pi_0'[OF pi_x x_le_ux ux_0]
136.244 - by (simp only: minus_float.rep_eq real_of_int_minus real_of_one minus_one[symmetric]
136.245 - diff_minus mult_minus_left mult_1_left)
136.246 + by (simp only: minus_float.rep_eq real_of_int_minus real_of_one
136.247 + mult_minus_left mult_1_left) simp
136.248 also have "\<dots> = cos ((- (?ux - 2 * ?lpi)))"
136.249 unfolding uminus_float.rep_eq cos_minus ..
136.250 also have "\<dots> \<le> (ub_cos prec (- (?ux - 2 * ?lpi)))"
136.251 @@ -1387,7 +1308,7 @@
136.252 also have "\<dots> \<le> cos ((?lx + 2 * ?lpi))"
136.253 using cos_monotone_0_pi'[OF lx_0 lx_le_x pi_x]
136.254 by (simp only: minus_float.rep_eq real_of_int_minus real_of_one
136.255 - minus_one[symmetric] diff_minus mult_minus_left mult_1_left)
136.256 + mult_minus_left mult_1_left) simp
136.257 also have "\<dots> \<le> (ub_cos prec (?lx + 2 * ?lpi))"
136.258 using lb_cos[OF lx_0 pi_lx] by simp
136.259 finally show ?thesis unfolding u by (simp add: real_of_float_max)
136.260 @@ -1808,10 +1729,8 @@
136.261 done
136.262
136.263 lemma Float_pos_eq_mantissa_pos: "Float m e > 0 \<longleftrightarrow> m > 0"
136.264 - apply (auto simp add: zero_less_mult_iff zero_float_def powr_gt_zero[of 2 "exponent x"] dest: less_zeroE)
136.265 using powr_gt_zero[of 2 "e"]
136.266 - apply simp
136.267 - done
136.268 + by (auto simp add: zero_less_mult_iff zero_float_def simp del: powr_gt_zero dest: less_zeroE)
136.269
136.270 lemma Float_representation_aux:
136.271 fixes m e
136.272 @@ -2164,12 +2083,12 @@
136.273 unfolding divide_inverse interpret_floatarith.simps ..
136.274
136.275 lemma interpret_floatarith_diff: "interpret_floatarith (Add a (Minus b)) vs = (interpret_floatarith a vs) - (interpret_floatarith b vs)"
136.276 - unfolding diff_minus interpret_floatarith.simps ..
136.277 + unfolding interpret_floatarith.simps by simp
136.278
136.279 lemma interpret_floatarith_sin: "interpret_floatarith (Cos (Add (Mult Pi (Num (Float 1 -1))) (Minus a))) vs =
136.280 sin (interpret_floatarith a vs)"
136.281 unfolding sin_cos_eq interpret_floatarith.simps
136.282 - interpret_floatarith_divide interpret_floatarith_diff diff_minus
136.283 + interpret_floatarith_divide interpret_floatarith_diff
136.284 by auto
136.285
136.286 lemma interpret_floatarith_tan:
136.287 @@ -2187,8 +2106,9 @@
136.288 lemma interpret_floatarith_num:
136.289 shows "interpret_floatarith (Num (Float 0 0)) vs = 0"
136.290 and "interpret_floatarith (Num (Float 1 0)) vs = 1"
136.291 + and "interpret_floatarith (Num (Float (- 1) 0)) vs = - 1"
136.292 and "interpret_floatarith (Num (Float (numeral a) 0)) vs = numeral a"
136.293 - and "interpret_floatarith (Num (Float (neg_numeral a) 0)) vs = neg_numeral a" by auto
136.294 + and "interpret_floatarith (Num (Float (- numeral a) 0)) vs = - numeral a" by auto
136.295
136.296 subsection "Implement approximation function"
136.297
136.298 @@ -3192,7 +3112,7 @@
136.299
136.300 from approx_tse[OF this _ _ _ _ tse[symmetric], of l' u'] x'
136.301 have "ly \<le> interpret_floatarith a [x] - interpret_floatarith b [x]"
136.302 - by (auto simp add: diff_minus)
136.303 + by auto
136.304 from order_less_le_trans[OF _ this, of 0] `0 < ly`
136.305 show ?thesis by auto
136.306 qed
136.307 @@ -3214,7 +3134,7 @@
136.308
136.309 from approx_tse[OF this _ _ _ _ tse[symmetric], of l' u'] x'
136.310 have "ly \<le> interpret_floatarith a [x] - interpret_floatarith b [x]"
136.311 - by (auto simp add: diff_minus)
136.312 + by auto
136.313 from order_trans[OF _ this, of 0] `0 \<le> ly`
136.314 show ?thesis by auto
136.315 qed
137.1 --- a/src/HOL/Decision_Procs/Cooper.thy Thu Dec 05 17:52:12 2013 +0100
137.2 +++ b/src/HOL/Decision_Procs/Cooper.thy Thu Dec 05 17:58:03 2013 +0100
137.3 @@ -1400,9 +1400,8 @@
137.4 also have "\<dots> = (j dvd (- (c*x - ?e)))"
137.5 by (simp only: dvd_minus_iff)
137.6 also have "\<dots> = (j dvd (c* (- x)) + ?e)"
137.7 - apply (simp only: minus_mult_right[symmetric] minus_mult_left[symmetric] diff_minus add_ac minus_add_distrib)
137.8 - apply (simp add: algebra_simps)
137.9 - done
137.10 + by (simp only: minus_mult_right[symmetric] minus_mult_left[symmetric] add_ac minus_add_distrib)
137.11 + (simp add: algebra_simps)
137.12 also have "\<dots> = Ifm bbs ((- x)#bs) (Dvd j (CN 0 c e))"
137.13 using numbound0_I[OF nb, where bs="bs" and b="x" and b'="- x"] by simp
137.14 finally show ?case .
137.15 @@ -1413,9 +1412,8 @@
137.16 also have "\<dots> = (j dvd (- (c*x - ?e)))"
137.17 by (simp only: dvd_minus_iff)
137.18 also have "\<dots> = (j dvd (c* (- x)) + ?e)"
137.19 - apply (simp only: minus_mult_right[symmetric] minus_mult_left[symmetric] diff_minus add_ac minus_add_distrib)
137.20 - apply (simp add: algebra_simps)
137.21 - done
137.22 + by (simp only: minus_mult_right[symmetric] minus_mult_left[symmetric] add_ac minus_add_distrib)
137.23 + (simp add: algebra_simps)
137.24 also have "\<dots> = Ifm bbs ((- x)#bs) (Dvd j (CN 0 c e))"
137.25 using numbound0_I[OF nb, where bs="bs" and b="x" and b'="- x"] by simp
137.26 finally show ?case by simp
137.27 @@ -2008,9 +2006,10 @@
137.28 | SOME n => @{code Bound} (@{code nat_of_integer} n))
137.29 | num_of_term vs @{term "0::int"} = @{code C} (@{code int_of_integer} 0)
137.30 | num_of_term vs @{term "1::int"} = @{code C} (@{code int_of_integer} 1)
137.31 + | num_of_term vs @{term "- 1::int"} = @{code C} (@{code int_of_integer} (~ 1))
137.32 | num_of_term vs (@{term "numeral :: _ \<Rightarrow> int"} $ t) =
137.33 @{code C} (@{code int_of_integer} (HOLogic.dest_num t))
137.34 - | num_of_term vs (@{term "neg_numeral :: _ \<Rightarrow> int"} $ t) =
137.35 + | num_of_term vs (@{term "- numeral :: _ \<Rightarrow> int"} $ t) =
137.36 @{code C} (@{code int_of_integer} (~(HOLogic.dest_num t)))
137.37 | num_of_term vs (Bound i) = @{code Bound} (@{code nat_of_integer} i)
137.38 | num_of_term vs (@{term "uminus :: int \<Rightarrow> int"} $ t') = @{code Neg} (num_of_term vs t')
138.1 --- a/src/HOL/Decision_Procs/MIR.thy Thu Dec 05 17:52:12 2013 +0100
138.2 +++ b/src/HOL/Decision_Procs/MIR.thy Thu Dec 05 17:58:03 2013 +0100
138.3 @@ -1727,7 +1727,7 @@
138.4 {assume cp: "?c > 0" and cnz: "?c\<noteq>0" hence l: "?L (?l (Lt a))"
138.5 by (simp add: nb Let_def split_def isint_Floor isint_neg)
138.6 have "?I (Lt a) = (real (?c * i) + (?N ?r) < 0)" using Ia by (simp add: Let_def split_def)
138.7 - also have "\<dots> = (?I (?l (Lt a)))" apply (simp only: split_int_less_real'[where a="?c*i" and b="?N ?r"]) by (simp add: Ia cp cnz Let_def split_def diff_minus)
138.8 + also have "\<dots> = (?I (?l (Lt a)))" apply (simp only: split_int_less_real'[where a="?c*i" and b="?N ?r"]) by (simp add: Ia cp cnz Let_def split_def)
138.9 finally have ?case using l by simp}
138.10 moreover
138.11 {assume cn: "?c < 0" and cnz: "?c\<noteq>0" hence l: "?L (?l (Lt a))"
138.12 @@ -1752,13 +1752,13 @@
138.13 {assume cp: "?c > 0" and cnz: "?c\<noteq>0" hence l: "?L (?l (Le a))"
138.14 by (simp add: nb Let_def split_def isint_Floor isint_neg)
138.15 have "?I (Le a) = (real (?c * i) + (?N ?r) \<le> 0)" using Ia by (simp add: Let_def split_def)
138.16 - also have "\<dots> = (?I (?l (Le a)))" by (simp only: split_int_le_real'[where a="?c*i" and b="?N ?r"]) (simp add: Ia cp cnz Let_def split_def diff_minus)
138.17 + also have "\<dots> = (?I (?l (Le a)))" by (simp only: split_int_le_real'[where a="?c*i" and b="?N ?r"]) (simp add: Ia cp cnz Let_def split_def)
138.18 finally have ?case using l by simp}
138.19 moreover
138.20 {assume cn: "?c < 0" and cnz: "?c\<noteq>0" hence l: "?L (?l (Le a))"
138.21 by (simp add: nb Let_def split_def isint_Floor isint_neg)
138.22 have "?I (Le a) = (real (?c * i) + (?N ?r) \<le> 0)" using Ia by (simp add: Let_def split_def)
138.23 - also from cn cnz have "\<dots> = (?I (?l (Le a)))" by (simp only: split_int_le_real'[where a="?c*i" and b="?N ?r"]) (simp add: Ia Let_def split_def diff_minus[symmetric] add_ac ,arith)
138.24 + also from cn cnz have "\<dots> = (?I (?l (Le a)))" by (simp only: split_int_le_real'[where a="?c*i" and b="?N ?r"]) (simp add: Ia Let_def split_def add_ac, arith)
138.25 finally have ?case using l by simp}
138.26 ultimately show ?case by blast
138.27 next
138.28 @@ -1777,13 +1777,13 @@
138.29 {assume cp: "?c > 0" and cnz: "?c\<noteq>0" hence l: "?L (?l (Gt a))"
138.30 by (simp add: nb Let_def split_def isint_Floor isint_neg)
138.31 have "?I (Gt a) = (real (?c * i) + (?N ?r) > 0)" using Ia by (simp add: Let_def split_def)
138.32 - also have "\<dots> = (?I (?l (Gt a)))" by (simp only: split_int_gt_real'[where a="?c*i" and b="?N ?r"]) (simp add: Ia cp cnz Let_def split_def diff_minus)
138.33 + also have "\<dots> = (?I (?l (Gt a)))" by (simp only: split_int_gt_real'[where a="?c*i" and b="?N ?r"]) (simp add: Ia cp cnz Let_def split_def)
138.34 finally have ?case using l by simp}
138.35 moreover
138.36 {assume cn: "?c < 0" and cnz: "?c\<noteq>0" hence l: "?L (?l (Gt a))"
138.37 by (simp add: nb Let_def split_def isint_Floor isint_neg)
138.38 have "?I (Gt a) = (real (?c * i) + (?N ?r) > 0)" using Ia by (simp add: Let_def split_def)
138.39 - also from cn cnz have "\<dots> = (?I (?l (Gt a)))" by (simp only: split_int_gt_real'[where a="?c*i" and b="?N ?r"]) (simp add: Ia Let_def split_def diff_minus[symmetric] add_ac, arith)
138.40 + also from cn cnz have "\<dots> = (?I (?l (Gt a)))" by (simp only: split_int_gt_real'[where a="?c*i" and b="?N ?r"]) (simp add: Ia Let_def split_def add_ac, arith)
138.41 finally have ?case using l by simp}
138.42 ultimately show ?case by blast
138.43 next
138.44 @@ -1802,13 +1802,13 @@
138.45 {assume cp: "?c > 0" and cnz: "?c\<noteq>0" hence l: "?L (?l (Ge a))"
138.46 by (simp add: nb Let_def split_def isint_Floor isint_neg)
138.47 have "?I (Ge a) = (real (?c * i) + (?N ?r) \<ge> 0)" using Ia by (simp add: Let_def split_def)
138.48 - also have "\<dots> = (?I (?l (Ge a)))" by (simp only: split_int_ge_real'[where a="?c*i" and b="?N ?r"]) (simp add: Ia cp cnz Let_def split_def diff_minus)
138.49 + also have "\<dots> = (?I (?l (Ge a)))" by (simp only: split_int_ge_real'[where a="?c*i" and b="?N ?r"]) (simp add: Ia cp cnz Let_def split_def)
138.50 finally have ?case using l by simp}
138.51 moreover
138.52 {assume cn: "?c < 0" and cnz: "?c\<noteq>0" hence l: "?L (?l (Ge a))"
138.53 by (simp add: nb Let_def split_def isint_Floor isint_neg)
138.54 have "?I (Ge a) = (real (?c * i) + (?N ?r) \<ge> 0)" using Ia by (simp add: Let_def split_def)
138.55 - also from cn cnz have "\<dots> = (?I (?l (Ge a)))" by (simp only: split_int_ge_real'[where a="?c*i" and b="?N ?r"]) (simp add: Ia Let_def split_def diff_minus[symmetric] add_ac, arith)
138.56 + also from cn cnz have "\<dots> = (?I (?l (Ge a)))" by (simp only: split_int_ge_real'[where a="?c*i" and b="?N ?r"]) (simp add: Ia Let_def split_def add_ac, arith)
138.57 finally have ?case using l by simp}
138.58 ultimately show ?case by blast
138.59 next
138.60 @@ -3125,7 +3125,8 @@
138.61 hence pid: "c*i + ?fe \<le> c*d" by (simp only: real_of_int_le_iff)
138.62 with pi' have "\<exists> j1\<in> {1 .. c*d}. c*i + ?fe = j1" by auto
138.63 hence "\<exists> j1\<in> {1 .. c*d}. real (c*i) = - ?N i e + real j1"
138.64 - by (simp only: real_of_int_mult real_of_int_add real_of_int_inject[symmetric] ei[simplified isint_iff] algebra_simps)
138.65 + by (simp only: real_of_int_mult real_of_int_add real_of_int_inject[symmetric] ei[simplified isint_iff])
138.66 + (simp add: algebra_simps)
138.67 with nob have ?case by blast }
138.68 ultimately show ?case by blast
138.69 next
138.70 @@ -3148,11 +3149,12 @@
138.71 hence pid: "c*i + 1 + ?fe \<le> c*d" by (simp only: real_of_int_le_iff)
138.72 with pi' have "\<exists> j1\<in> {1 .. c*d}. c*i + 1+ ?fe = j1" by auto
138.73 hence "\<exists> j1\<in> {1 .. c*d}. real (c*i) + 1= - ?N i e + real j1"
138.74 - by (simp only: real_of_int_mult real_of_int_add real_of_int_inject[symmetric] ei[simplified isint_iff] algebra_simps real_of_one)
138.75 + by (simp only: real_of_int_mult real_of_int_add real_of_int_inject[symmetric] ei[simplified isint_iff] real_of_one)
138.76 + (simp add: algebra_simps)
138.77 hence "\<exists> j1\<in> {1 .. c*d}. real (c*i) = (- ?N i e + real j1) - 1"
138.78 by (simp only: algebra_simps)
138.79 hence "\<exists> j1\<in> {1 .. c*d}. real (c*i) = - 1 - ?N i e + real j1"
138.80 - by (simp only: add_ac diff_minus)
138.81 + by (simp add: algebra_simps)
138.82 with nob have ?case by blast }
138.83 ultimately show ?case by blast
138.84 next
138.85 @@ -3477,10 +3479,7 @@
138.86 qed
138.87 next
138.88 case (3 a b) then show ?case
138.89 - apply auto
138.90 - apply (erule_tac x = "(aa, aaa, ba)" in ballE) apply simp_all
138.91 - apply (erule_tac x = "(ab, ac, baa)" in ballE) apply simp_all
138.92 - done
138.93 + by auto
138.94 qed (auto simp add: Let_def split_def algebra_simps)
138.95
138.96 lemma real_in_int_intervals:
138.97 @@ -3615,7 +3614,7 @@
138.98 by(simp only: myle[of _ "real n * x + Inum (x # bs) s - Inum (x # bs) (Floor s)"] less_iff_diff_less_0[where a="real n *x + ?N s - ?N (Floor s)"])
138.99 hence "\<exists> j\<in> {n .. 0}. 0 \<ge> - (real n *x + ?N s - ?N (Floor s) - real j) \<and> - (real n *x + ?N s - ?N (Floor s) - real (j+1)) > 0" by (simp only: th1[rule_format] th2[rule_format])
138.100 hence "\<exists> j\<in> {n.. 0}. ?I (?p (p,n,s) j)"
138.101 - using pns by (simp add: fp_def nn diff_minus add_ac mult_ac
138.102 + using pns by (simp add: fp_def nn algebra_simps
138.103 del: diff_less_0_iff_less diff_le_0_iff_le)
138.104 then obtain "j" where j_def: "j\<in> {n .. 0} \<and> ?I (?p (p,n,s) j)" by blast
138.105 hence "\<exists>x \<in> {?p (p,n,s) j |j. n\<le> j \<and> j \<le> 0 }. ?I x" by auto
138.106 @@ -4832,7 +4831,7 @@
138.107 shows "(Ifm bs (E p)) = (\<exists> (i::int). Ifm (real i#bs) (E (And (And (Ge(CN 0 1 (C 0))) (Lt (CN 0 1 (C (- 1))))) (exsplit p))))" (is "?lhs = ?rhs")
138.108 proof-
138.109 have "?rhs = (\<exists> (i::int). \<exists> x. 0\<le> x \<and> x < 1 \<and> Ifm (x#(real i)#bs) (exsplit p))"
138.110 - by (simp add: myless[of _ "1"] myless[of _ "0"] add_ac diff_minus)
138.111 + by (simp add: myless[of _ "1"] myless[of _ "0"] add_ac)
138.112 also have "\<dots> = (\<exists> (i::int). \<exists> x. 0\<le> x \<and> x < 1 \<and> Ifm ((real i + x) #bs) p)"
138.113 by (simp only: exsplit[OF qf] add_ac)
138.114 also have "\<dots> = (\<exists> x. Ifm (x#bs) p)"
138.115 @@ -5196,7 +5195,7 @@
138.116 hence "\<forall> j\<in> set ?js. bound0 (subst0 (C j) ?smq)"
138.117 by (auto simp only: subst0_bound0[OF qfmq])
138.118 hence th: "\<forall> j\<in> set ?js. bound0 (simpfm (subst0 (C j) ?smq))"
138.119 - by (auto simp add: simpfm_bound0)
138.120 + by auto
138.121 from evaldjf_bound0[OF th] have mdb: "bound0 ?md" by simp
138.122 from Bn jsnb have "\<forall> (b,j) \<in> set ?bjs. numbound0 (Add b (C j))"
138.123 by simp
138.124 @@ -5550,6 +5549,7 @@
138.125 | num_of_term vs @{term "real (1::int)"} = mk_C 1
138.126 | num_of_term vs @{term "0::real"} = mk_C 0
138.127 | num_of_term vs @{term "1::real"} = mk_C 1
138.128 + | num_of_term vs @{term "- 1::real"} = mk_C (~ 1)
138.129 | num_of_term vs (Bound i) = mk_Bound i
138.130 | num_of_term vs (@{term "uminus :: real \<Rightarrow> real"} $ t') = @{code Neg} (num_of_term vs t')
138.131 | num_of_term vs (@{term "op + :: real \<Rightarrow> real \<Rightarrow> real"} $ t1 $ t2) =
138.132 @@ -5562,7 +5562,7 @@
138.133 | _ => error "num_of_term: unsupported Multiplication")
138.134 | num_of_term vs (@{term "real :: int \<Rightarrow> real"} $ (@{term "numeral :: _ \<Rightarrow> int"} $ t')) =
138.135 mk_C (HOLogic.dest_num t')
138.136 - | num_of_term vs (@{term "real :: int \<Rightarrow> real"} $ (@{term "neg_numeral :: _ \<Rightarrow> int"} $ t')) =
138.137 + | num_of_term vs (@{term "real :: int \<Rightarrow> real"} $ (@{term "- numeral :: _ \<Rightarrow> int"} $ t')) =
138.138 mk_C (~ (HOLogic.dest_num t'))
138.139 | num_of_term vs (@{term "real :: int \<Rightarrow> real"} $ (@{term "floor :: real \<Rightarrow> int"} $ t')) =
138.140 @{code Floor} (num_of_term vs t')
138.141 @@ -5570,7 +5570,7 @@
138.142 @{code Neg} (@{code Floor} (@{code Neg} (num_of_term vs t')))
138.143 | num_of_term vs (@{term "numeral :: _ \<Rightarrow> real"} $ t') =
138.144 mk_C (HOLogic.dest_num t')
138.145 - | num_of_term vs (@{term "neg_numeral :: _ \<Rightarrow> real"} $ t') =
138.146 + | num_of_term vs (@{term "- numeral :: _ \<Rightarrow> real"} $ t') =
138.147 mk_C (~ (HOLogic.dest_num t'))
138.148 | num_of_term vs t = error ("num_of_term: unknown term " ^ Syntax.string_of_term @{context} t);
138.149
138.150 @@ -5584,7 +5584,7 @@
138.151 @{code Eq} (@{code Sub} (num_of_term vs t1, num_of_term vs t2))
138.152 | fm_of_term vs (@{term "op rdvd"} $ (@{term "real :: int \<Rightarrow> real"} $ (@{term "numeral :: _ \<Rightarrow> int"} $ t1)) $ t2) =
138.153 mk_Dvd (HOLogic.dest_num t1, num_of_term vs t2)
138.154 - | fm_of_term vs (@{term "op rdvd"} $ (@{term "real :: int \<Rightarrow> real"} $ (@{term "neg_numeral :: _ \<Rightarrow> int"} $ t1)) $ t2) =
138.155 + | fm_of_term vs (@{term "op rdvd"} $ (@{term "real :: int \<Rightarrow> real"} $ (@{term "- numeral :: _ \<Rightarrow> int"} $ t1)) $ t2) =
138.156 mk_Dvd (~ (HOLogic.dest_num t1), num_of_term vs t2)
138.157 | fm_of_term vs (@{term "op = :: bool \<Rightarrow> bool \<Rightarrow> bool"} $ t1 $ t2) =
138.158 @{code Iff} (fm_of_term vs t1, fm_of_term vs t2)
139.1 --- a/src/HOL/Decision_Procs/Parametric_Ferrante_Rackoff.thy Thu Dec 05 17:52:12 2013 +0100
139.2 +++ b/src/HOL/Decision_Procs/Parametric_Ferrante_Rackoff.thy Thu Dec 05 17:58:03 2013 +0100
139.3 @@ -1959,7 +1959,7 @@
139.4 by (simp add: field_simps)
139.5 have "?rhs \<longleftrightarrow> Ifm vs (- (?d * ?t + ?c* ?s )/ (2*?c*?d) # bs) (Eq (CNP 0 a r))" by (simp only: th)
139.6 also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r = 0"
139.7 - by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / (2 * ?c * ?d)"])
139.8 + by (simp add: r [of "(- (?d * ?t) - (?c *?s)) / (2 * ?c * ?d)"])
139.9 also have "\<dots> \<longleftrightarrow> (2 * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r) =0 "
139.10 using c d mult_cancel_left[of "2 * ?c * ?d" "?a * (- (?d * ?t + ?c* ?s)/ (2*?c*?d)) + ?r" 0] by simp
139.11 also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )) + 2*?c*?d*?r =0"
139.12 @@ -2041,7 +2041,7 @@
139.13 by (simp add: field_simps)
139.14 have "?rhs \<longleftrightarrow> Ifm vs (- (?d * ?t + ?c* ?s )/ (2*?c*?d) # bs) (NEq (CNP 0 a r))" by (simp only: th)
139.15 also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r \<noteq> 0"
139.16 - by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / (2 * ?c * ?d)"])
139.17 + by (simp add: r [of "(- (?d * ?t) - (?c *?s)) / (2 * ?c * ?d)"])
139.18 also have "\<dots> \<longleftrightarrow> (2 * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r) \<noteq> 0 "
139.19 using c d mult_cancel_left[of "2 * ?c * ?d" "?a * (- (?d * ?t + ?c* ?s)/ (2*?c*?d)) + ?r" 0] by simp
139.20 also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )) + 2*?c*?d*?r \<noteq> 0"
139.21 @@ -2106,7 +2106,7 @@
139.22 by (simp add: field_simps)
139.23 have "?rhs \<longleftrightarrow> Ifm vs (- (?d * ?t + ?c* ?s )/ (2*?c*?d) # bs) (Lt (CNP 0 a r))" by (simp only: th)
139.24 also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r < 0"
139.25 - by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / (2 * ?c * ?d)"])
139.26 + by (simp add: r[of "(- (?d * ?t) - (?c *?s)) / (2 * ?c * ?d)"])
139.27 also have "\<dots> \<longleftrightarrow> (2 * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r) < 0"
139.28
139.29 using dc' dc'' mult_less_cancel_left_disj[of "2 * ?c * ?d" "?a * (- (?d * ?t + ?c* ?s)/ (2*?c*?d)) + ?r" 0] by simp
139.30 @@ -2127,7 +2127,7 @@
139.31 by (simp add: field_simps)
139.32 have "?rhs \<longleftrightarrow> Ifm vs (- (?d * ?t + ?c* ?s )/ (2*?c*?d) # bs) (Lt (CNP 0 a r))" by (simp only: th)
139.33 also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r < 0"
139.34 - by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / (2 * ?c * ?d)"])
139.35 + by (simp add: r[of "(- (?d * ?t) - (?c *?s)) / (2 * ?c * ?d)"])
139.36
139.37 also have "\<dots> \<longleftrightarrow> (2 * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r) > 0"
139.38
139.39 @@ -2251,7 +2251,7 @@
139.40 by (simp add: field_simps)
139.41 have "?rhs \<longleftrightarrow> Ifm vs (- (?d * ?t + ?c* ?s )/ (2*?c*?d) # bs) (Le (CNP 0 a r))" by (simp only: th)
139.42 also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r <= 0"
139.43 - by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / (2 * ?c * ?d)"])
139.44 + by (simp add: r[of "(- (?d * ?t) - (?c *?s)) / (2 * ?c * ?d)"])
139.45 also have "\<dots> \<longleftrightarrow> (2 * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r) <= 0"
139.46
139.47 using dc' dc'' mult_le_cancel_left[of "2 * ?c * ?d" "?a * (- (?d * ?t + ?c* ?s)/ (2*?c*?d)) + ?r" 0] by simp
139.48 @@ -2272,7 +2272,7 @@
139.49 by (simp add: field_simps)
139.50 have "?rhs \<longleftrightarrow> Ifm vs (- (?d * ?t + ?c* ?s )/ (2*?c*?d) # bs) (Le (CNP 0 a r))" by (simp only: th)
139.51 also have "\<dots> \<longleftrightarrow> ?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r <= 0"
139.52 - by (simp add: r[of "(- (?d * ?t) + - (?c *?s)) / (2 * ?c * ?d)"])
139.53 + by (simp add: r[of "(- (?d * ?t) - (?c *?s)) / (2 * ?c * ?d)"])
139.54
139.55 also have "\<dots> \<longleftrightarrow> (2 * ?c * ?d) * (?a * (- (?d * ?t + ?c* ?s )/ (2*?c*?d)) + ?r) >= 0"
139.56
139.57 @@ -2356,8 +2356,11 @@
139.58
139.59 lemma msubst_I: assumes lp: "islin p" and nc: "isnpoly c" and nd: "isnpoly d"
139.60 shows "Ifm vs (x#bs) (msubst p ((c,t),(d,s))) = Ifm vs (((- Itm vs (x#bs) t / Ipoly vs c + - Itm vs (x#bs) s / Ipoly vs d) /2)#bs) p"
139.61 - using lp
139.62 -by (induct p rule: islin.induct, auto simp add: tmbound0_I[where b="(- (Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>) + - (Itm vs (x # bs) s / \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>)) / 2" and b'=x and bs = bs and vs=vs] bound0_I[where b="(- (Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>) + - (Itm vs (x # bs) s / \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>)) / 2" and b'=x and bs = bs and vs=vs] msubsteq msubstneq msubstlt[OF nc nd] msubstle[OF nc nd])
139.63 + using lp by (induct p rule: islin.induct)
139.64 + (auto simp add: tmbound0_I
139.65 + [where b = "(- (Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup>) - (Itm vs (x # bs) s / \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>)) / 2"
139.66 + and b' = x and bs = bs and vs = vs]
139.67 + msubsteq msubstneq msubstlt [OF nc nd] msubstle [OF nc nd])
139.68
139.69 lemma msubst_nb: assumes lp: "islin p" and t: "tmbound0 t" and s: "tmbound0 s"
139.70 shows "bound0 (msubst p ((c,t),(d,s)))"
139.71 @@ -2429,7 +2432,7 @@
139.72 with evaldjf_bound0[of ?Up "(simpfm o (msubst (simpfm p)))"]
139.73 have "bound0 (evaldjf (simpfm o (msubst (simpfm p))) ?Up)" by blast
139.74 with mp_nb pp_nb
139.75 - have th1: "bound0 (disj ?mp (disj ?pp (evaldjf (simpfm o (msubst ?q)) ?Up )))" by (simp add: disj_nb)
139.76 + have th1: "bound0 (disj ?mp (disj ?pp (evaldjf (simpfm o (msubst ?q)) ?Up )))" by simp
139.77 from decr0_qf[OF th1] have thqf: "qfree (ferrack p)" by (simp add: ferrack_def Let_def)
139.78 have "?lhs \<longleftrightarrow> (\<exists>x. Ifm vs (x#bs) ?q)" by simp
139.79 also have "\<dots> \<longleftrightarrow> ?I ?mp \<or> ?I ?pp \<or> (\<exists>(c, t)\<in>set ?U. \<exists>(d, s)\<in>set ?U. ?I (msubst (simpfm p) ((c, t), d, s)))" using fr_eq_msubst[OF lq, of vs bs x] by simp
139.80 @@ -2612,7 +2615,7 @@
139.81 lemma msubst2_nb: assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})" and lp: "islin p" and tnb: "tmbound0 t"
139.82 shows "bound0 (msubst2 p c t)"
139.83 using lp tnb
139.84 -by (simp add: msubst2_def msubstneg_nb msubstpos_nb conj_nb disj_nb lt_nb simpfm_bound0)
139.85 +by (simp add: msubst2_def msubstneg_nb msubstpos_nb lt_nb simpfm_bound0)
139.86
139.87 lemma mult_minus2_left: "-2 * (x::'a::comm_ring_1) = - (2 * x)"
139.88 by simp
139.89 @@ -2666,8 +2669,8 @@
139.90 using H(3) by (auto simp add: msubst2_def lt[OF stupid(1)] lt[OF stupid(2)] zero_less_mult_iff mult_less_0_iff)
139.91 from msubst2[OF lp nn nn'(1), of x bs ] H(3) nn'
139.92 have "\<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0 \<and> \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0 \<and> Ifm vs ((- Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>) / 2 # bs) p"
139.93 - apply (simp add: add_divide_distrib mult_minus2_left)
139.94 - by (simp add: mult_commute)}
139.95 + by (simp add: add_divide_distrib diff_divide_distrib mult_minus2_left mult_commute)
139.96 + }
139.97 moreover
139.98 {fix c t d s assume H: "(c,t) \<in> set (uset p)" "(d,s) \<in> set (uset p)"
139.99 "\<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0" "\<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0" "Ifm vs ((- Itm vs (x # bs) t / \<lparr>c\<rparr>\<^sub>p\<^bsup>vs\<^esup> + - Itm vs (x # bs) s / \<lparr>d\<rparr>\<^sub>p\<^bsup>vs\<^esup>) / 2 # bs) p"
139.100 @@ -2675,7 +2678,9 @@
139.101 hence nn: "isnpoly (C (-2, 1) *\<^sub>p c*\<^sub>p d)" "\<lparr>(C (-2, 1) *\<^sub>p c*\<^sub>p d)\<rparr>\<^sub>p\<^bsup>vs\<^esup> \<noteq> 0"
139.102 using H(3,4) by (simp_all add: polymul_norm n2)
139.103 from msubst2[OF lp nn, of x bs ] H(3,4,5)
139.104 - have "Ifm vs (x#bs) (msubst2 p (C (-2, 1) *\<^sub>p c*\<^sub>p d) (Add (Mul d t) (Mul c s)))" apply (simp add: add_divide_distrib mult_minus2_left) by (simp add: mult_commute)}
139.105 + have "Ifm vs (x#bs) (msubst2 p (C (-2, 1) *\<^sub>p c*\<^sub>p d) (Add (Mul d t) (Mul c s)))"
139.106 + by (simp add: diff_divide_distrib add_divide_distrib mult_minus2_left mult_commute)
139.107 + }
139.108 ultimately show ?thesis by blast
139.109 qed
139.110 from fr_eq2[OF lp, of vs bs x] show ?thesis
140.1 --- a/src/HOL/Decision_Procs/Polynomial_List.thy Thu Dec 05 17:52:12 2013 +0100
140.2 +++ b/src/HOL/Decision_Procs/Polynomial_List.thy Thu Dec 05 17:58:03 2013 +0100
140.3 @@ -2,371 +2,379 @@
140.4 Author: Amine Chaieb
140.5 *)
140.6
140.7 -header {* Univariate Polynomials as Lists *}
140.8 +header {* Univariate Polynomials as lists *}
140.9
140.10 theory Polynomial_List
140.11 -imports Main
140.12 +imports Complex_Main
140.13 begin
140.14
140.15 -text{* Application of polynomial as a real function. *}
140.16 +text{* Application of polynomial as a function. *}
140.17
140.18 -primrec poly :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a::comm_ring"
140.19 +primrec (in semiring_0) poly :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a"
140.20 where
140.21 poly_Nil: "poly [] x = 0"
140.22 -| poly_Cons: "poly (h # t) x = h + x * poly t x"
140.23 +| poly_Cons: "poly (h#t) x = h + x * poly t x"
140.24
140.25
140.26 subsection{*Arithmetic Operations on Polynomials*}
140.27
140.28 text{*addition*}
140.29 -primrec padd :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a::comm_ring_1 list" (infixl "+++" 65)
140.30 +
140.31 +primrec (in semiring_0) padd :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "+++" 65)
140.32 where
140.33 padd_Nil: "[] +++ l2 = l2"
140.34 -| padd_Cons: "(h # t) +++ l2 = (if l2 = [] then h # t else (h + hd l2) # (t +++ tl l2))"
140.35 +| padd_Cons: "(h#t) +++ l2 = (if l2 = [] then h#t else (h + hd l2)#(t +++ tl l2))"
140.36
140.37 text{*Multiplication by a constant*}
140.38 -primrec cmult :: "'a::comm_ring_1 \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "%*" 70)
140.39 -where
140.40 +primrec (in semiring_0) cmult :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "%*" 70) where
140.41 cmult_Nil: "c %* [] = []"
140.42 -| cmult_Cons: "c %* (h # t) = (c * h) # (c %* t)"
140.43 +| cmult_Cons: "c %* (h#t) = (c * h)#(c %* t)"
140.44
140.45 text{*Multiplication by a polynomial*}
140.46 -primrec pmult :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a::comm_ring_1 list" (infixl "***" 70)
140.47 +primrec (in semiring_0) pmult :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "***" 70)
140.48 where
140.49 pmult_Nil: "[] *** l2 = []"
140.50 -| pmult_Cons: "(h # t) *** l2 =
140.51 - (if t = [] then h %* l2 else (h %* l2) +++ (0 # (t *** l2)))"
140.52 +| pmult_Cons: "(h#t) *** l2 = (if t = [] then h %* l2
140.53 + else (h %* l2) +++ ((0) # (t *** l2)))"
140.54
140.55 text{*Repeated multiplication by a polynomial*}
140.56 -primrec mulexp :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a::comm_ring_1 list"
140.57 -where
140.58 +primrec (in semiring_0) mulexp :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
140.59 mulexp_zero: "mulexp 0 p q = q"
140.60 | mulexp_Suc: "mulexp (Suc n) p q = p *** mulexp n p q"
140.61
140.62 text{*Exponential*}
140.63 -primrec pexp :: "'a list \<Rightarrow> nat \<Rightarrow> 'a::comm_ring_1 list" (infixl "%^" 80)
140.64 -where
140.65 +primrec (in semiring_1) pexp :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" (infixl "%^" 80) where
140.66 pexp_0: "p %^ 0 = [1]"
140.67 | pexp_Suc: "p %^ (Suc n) = p *** (p %^ n)"
140.68
140.69 text{*Quotient related value of dividing a polynomial by x + a*}
140.70 (* Useful for divisor properties in inductive proofs *)
140.71 -primrec pquot :: "'a list \<Rightarrow> 'a::field \<Rightarrow> 'a list"
140.72 +primrec (in field) "pquot" :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list"
140.73 where
140.74 - pquot_Nil: "pquot [] a = []"
140.75 -| pquot_Cons: "pquot (h # t) a =
140.76 - (if t = [] then [h] else (inverse a * (h - hd (pquot t a))) # pquot t a)"
140.77 -
140.78 + pquot_Nil: "pquot [] a= []"
140.79 +| pquot_Cons: "pquot (h#t) a =
140.80 + (if t = [] then [h] else (inverse(a) * (h - hd( pquot t a)))#(pquot t a))"
140.81
140.82 text{*normalization of polynomials (remove extra 0 coeff)*}
140.83 -primrec pnormalize :: "'a::comm_ring_1 list \<Rightarrow> 'a list"
140.84 -where
140.85 +primrec (in semiring_0) pnormalize :: "'a list \<Rightarrow> 'a list" where
140.86 pnormalize_Nil: "pnormalize [] = []"
140.87 -| pnormalize_Cons: "pnormalize (h # p) =
140.88 - (if (pnormalize p = []) then (if h = 0 then [] else [h])
140.89 - else (h # pnormalize p))"
140.90 +| pnormalize_Cons: "pnormalize (h#p) =
140.91 + (if pnormalize p = [] then (if h = 0 then [] else [h]) else h # pnormalize p)"
140.92
140.93 -definition "pnormal p = ((pnormalize p = p) \<and> p \<noteq> [])"
140.94 -definition "nonconstant p = (pnormal p \<and> (\<forall>x. p \<noteq> [x]))"
140.95 +definition (in semiring_0) "pnormal p = ((pnormalize p = p) \<and> p \<noteq> [])"
140.96 +definition (in semiring_0) "nonconstant p = (pnormal p \<and> (\<forall>x. p \<noteq> [x]))"
140.97 text{*Other definitions*}
140.98
140.99 -definition poly_minus :: "'a list => ('a :: comm_ring_1) list" ("-- _" [80] 80)
140.100 +definition (in ring_1) poly_minus :: "'a list \<Rightarrow> 'a list" ("-- _" [80] 80)
140.101 where "-- p = (- 1) %* p"
140.102
140.103 -definition divides :: "'a::comm_ring_1 list \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "divides" 70)
140.104 - where "p1 divides p2 = (\<exists>q. poly p2 = poly (p1 *** q))"
140.105 +definition (in semiring_0) divides :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "divides" 70)
140.106 + where "p1 divides p2 = (\<exists>q. poly p2 = poly(p1 *** q))"
140.107
140.108 -definition order :: "'a::comm_ring_1 \<Rightarrow> 'a list \<Rightarrow> nat" --{*order of a polynomial*}
140.109 - where "order a p = (SOME n. ([-a, 1] %^ n) divides p & ~ (([-a, 1] %^ Suc n) divides p))"
140.110 +lemma (in semiring_0) dividesI:
140.111 + "poly p2 = poly (p1 *** q) \<Longrightarrow> p1 divides p2"
140.112 + by (auto simp add: divides_def)
140.113
140.114 -definition degree :: "'a::comm_ring_1 list \<Rightarrow> nat" --{*degree of a polynomial*}
140.115 +lemma (in semiring_0) dividesE:
140.116 + assumes "p1 divides p2"
140.117 + obtains q where "poly p2 = poly (p1 *** q)"
140.118 + using assms by (auto simp add: divides_def)
140.119 +
140.120 + --{*order of a polynomial*}
140.121 +definition (in ring_1) order :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
140.122 + "order a p = (SOME n. ([-a, 1] %^ n) divides p \<and> ~ (([-a, 1] %^ (Suc n)) divides p))"
140.123 +
140.124 + --{*degree of a polynomial*}
140.125 +definition (in semiring_0) degree :: "'a list \<Rightarrow> nat"
140.126 where "degree p = length (pnormalize p) - 1"
140.127
140.128 -definition rsquarefree :: "'a::comm_ring_1 list \<Rightarrow> bool"
140.129 - where --{*squarefree polynomials --- NB with respect to real roots only.*}
140.130 - "rsquarefree p = (poly p \<noteq> poly [] \<and> (\<forall>a. order a p = 0 \<or> order a p = 1))"
140.131 + --{*squarefree polynomials --- NB with respect to real roots only.*}
140.132 +definition (in ring_1) rsquarefree :: "'a list \<Rightarrow> bool"
140.133 + where "rsquarefree p \<longleftrightarrow> poly p \<noteq> poly [] \<and> (\<forall>a. order a p = 0 \<or> order a p = 1)"
140.134
140.135 -lemma padd_Nil2 [simp]: "p +++ [] = p"
140.136 +context semiring_0
140.137 +begin
140.138 +
140.139 +lemma padd_Nil2[simp]: "p +++ [] = p"
140.140 by (induct p) auto
140.141
140.142 lemma padd_Cons_Cons: "(h1 # p1) +++ (h2 # p2) = (h1 + h2) # (p1 +++ p2)"
140.143 by auto
140.144
140.145 -lemma pminus_Nil [simp]: "-- [] = []"
140.146 +lemma pminus_Nil: "-- [] = []"
140.147 by (simp add: poly_minus_def)
140.148
140.149 -lemma pmult_singleton: "[h1] *** p1 = h1 %* p1"
140.150 - by simp
140.151 +lemma pmult_singleton: "[h1] *** p1 = h1 %* p1" by simp
140.152
140.153 -lemma poly_ident_mult [simp]: "1 %* t = t"
140.154 - by (induct t) auto
140.155 +end
140.156
140.157 -lemma poly_simple_add_Cons [simp]: "[a] +++ ((0)#t) = (a#t)"
140.158 +lemma (in semiring_1) poly_ident_mult[simp]: "1 %* t = t" by (induct t) auto
140.159 +
140.160 +lemma (in semiring_0) poly_simple_add_Cons[simp]: "[a] +++ ((0)#t) = (a#t)"
140.161 by simp
140.162
140.163 text{*Handy general properties*}
140.164
140.165 -lemma padd_commut: "b +++ a = a +++ b"
140.166 - apply (induct b arbitrary: a)
140.167 - apply auto
140.168 - apply (rule padd_Cons [THEN ssubst])
140.169 - apply (case_tac aa)
140.170 - apply auto
140.171 +lemma (in comm_semiring_0) padd_commut: "b +++ a = a +++ b"
140.172 +proof (induct b arbitrary: a)
140.173 + case Nil
140.174 + thus ?case by auto
140.175 +next
140.176 + case (Cons b bs a)
140.177 + thus ?case by (cases a) (simp_all add: add_commute)
140.178 +qed
140.179 +
140.180 +lemma (in comm_semiring_0) padd_assoc: "\<forall>b c. (a +++ b) +++ c = a +++ (b +++ c)"
140.181 + apply (induct a)
140.182 + apply (simp, clarify)
140.183 + apply (case_tac b, simp_all add: add_ac)
140.184 done
140.185
140.186 -lemma padd_assoc: "(a +++ b) +++ c = a +++ (b +++ c)"
140.187 - apply (induct a arbitrary: b c)
140.188 +lemma (in semiring_0) poly_cmult_distr: "a %* ( p +++ q) = (a %* p +++ a %* q)"
140.189 + apply (induct p arbitrary: q)
140.190 apply simp
140.191 - apply (case_tac b)
140.192 - apply simp_all
140.193 + apply (case_tac q, simp_all add: distrib_left)
140.194 done
140.195
140.196 -lemma poly_cmult_distr: "a %* ( p +++ q) = (a %* p +++ a %* q)"
140.197 - apply (induct p arbitrary: q)
140.198 +lemma (in ring_1) pmult_by_x[simp]: "[0, 1] *** t = ((0)#t)"
140.199 + apply (induct t)
140.200 apply simp
140.201 - apply (case_tac q)
140.202 - apply (simp_all add: distrib_left)
140.203 + apply (auto simp add: padd_commut)
140.204 + apply (case_tac t, auto)
140.205 done
140.206
140.207 -lemma pmult_by_x [simp]: "[0, 1] *** t = ((0)#t)"
140.208 - by (induct t) (auto simp add: padd_commut)
140.209 -
140.210 -
140.211 text{*properties of evaluation of polynomials.*}
140.212
140.213 -lemma poly_add: "poly (p1 +++ p2) x = poly p1 x + poly p2 x"
140.214 - apply (induct p1 arbitrary: p2)
140.215 - apply auto
140.216 - apply (case_tac "p2")
140.217 - apply (auto simp add: distrib_left)
140.218 - done
140.219 +lemma (in semiring_0) poly_add: "poly (p1 +++ p2) x = poly p1 x + poly p2 x"
140.220 +proof(induct p1 arbitrary: p2)
140.221 + case Nil
140.222 + thus ?case by simp
140.223 +next
140.224 + case (Cons a as p2)
140.225 + thus ?case
140.226 + by (cases p2) (simp_all add: add_ac distrib_left)
140.227 +qed
140.228
140.229 -lemma poly_cmult: "poly (c %* p) x = c * poly p x"
140.230 +lemma (in comm_semiring_0) poly_cmult: "poly (c %* p) x = c * poly p x"
140.231 apply (induct p)
140.232 - apply simp
140.233 - apply (cases "x = 0")
140.234 + apply (case_tac [2] "x = zero")
140.235 apply (auto simp add: distrib_left mult_ac)
140.236 done
140.237
140.238 -lemma poly_minus: "poly (-- p) x = - (poly p x)"
140.239 - by (simp add: poly_minus_def poly_cmult)
140.240 +lemma (in comm_semiring_0) poly_cmult_map: "poly (map (op * c) p) x = c*poly p x"
140.241 + by (induct p) (auto simp add: distrib_left mult_ac)
140.242
140.243 -lemma poly_mult: "poly (p1 *** p2) x = poly p1 x * poly p2 x"
140.244 - apply (induct p1 arbitrary: p2)
140.245 - apply (case_tac p1)
140.246 - apply (auto simp add: poly_cmult poly_add distrib_right distrib_left mult_ac)
140.247 +lemma (in comm_ring_1) poly_minus: "poly (-- p) x = - (poly p x)"
140.248 + apply (simp add: poly_minus_def)
140.249 + apply (auto simp add: poly_cmult)
140.250 done
140.251
140.252 -lemma poly_exp: "poly (p %^ n) (x::'a::comm_ring_1) = (poly p x) ^ n"
140.253 +lemma (in comm_semiring_0) poly_mult: "poly (p1 *** p2) x = poly p1 x * poly p2 x"
140.254 +proof (induct p1 arbitrary: p2)
140.255 + case Nil
140.256 + thus ?case by simp
140.257 +next
140.258 + case (Cons a as p2)
140.259 + thus ?case by (cases as)
140.260 + (simp_all add: poly_cmult poly_add distrib_right distrib_left mult_ac)
140.261 +qed
140.262 +
140.263 +class idom_char_0 = idom + ring_char_0
140.264 +
140.265 +subclass (in field_char_0) idom_char_0 ..
140.266 +
140.267 +lemma (in comm_ring_1) poly_exp: "poly (p %^ n) x = (poly p x) ^ n"
140.268 by (induct n) (auto simp add: poly_cmult poly_mult)
140.269
140.270 text{*More Polynomial Evaluation Lemmas*}
140.271
140.272 -lemma poly_add_rzero [simp]: "poly (a +++ []) x = poly a x"
140.273 +lemma (in semiring_0) poly_add_rzero[simp]: "poly (a +++ []) x = poly a x"
140.274 by simp
140.275
140.276 -lemma poly_mult_assoc: "poly ((a *** b) *** c) x = poly (a *** (b *** c)) x"
140.277 +lemma (in comm_semiring_0) poly_mult_assoc: "poly ((a *** b) *** c) x = poly (a *** (b *** c)) x"
140.278 by (simp add: poly_mult mult_assoc)
140.279
140.280 -lemma poly_mult_Nil2 [simp]: "poly (p *** []) x = 0"
140.281 +lemma (in semiring_0) poly_mult_Nil2[simp]: "poly (p *** []) x = 0"
140.282 by (induct p) auto
140.283
140.284 -lemma poly_exp_add: "poly (p %^ (n + d)) x = poly( p %^ n *** p %^ d) x"
140.285 +lemma (in comm_semiring_1) poly_exp_add: "poly (p %^ (n + d)) x = poly( p %^ n *** p %^ d) x"
140.286 by (induct n) (auto simp add: poly_mult mult_assoc)
140.287
140.288 subsection{*Key Property: if @{term "f(a) = 0"} then @{term "(x - a)"} divides
140.289 @{term "p(x)"} *}
140.290
140.291 -lemma poly_linear_rem: "\<exists>q r. h # t = [r] +++ [-a, 1] *** q"
140.292 - apply (induct t arbitrary: h)
140.293 - apply (rule_tac x = "[]" in exI)
140.294 - apply (rule_tac x = h in exI)
140.295 - apply simp
140.296 - apply (drule_tac x = aa in meta_spec)
140.297 - apply safe
140.298 - apply (rule_tac x = "r#q" in exI)
140.299 - apply (rule_tac x = "a*r + h" in exI)
140.300 - apply (case_tac q)
140.301 - apply auto
140.302 - done
140.303 +lemma (in comm_ring_1) lemma_poly_linear_rem: "\<forall>h. \<exists>q r. h#t = [r] +++ [-a, 1] *** q"
140.304 +proof(induct t)
140.305 + case Nil
140.306 + { fix h have "[h] = [h] +++ [- a, 1] *** []" by simp }
140.307 + thus ?case by blast
140.308 +next
140.309 + case (Cons x xs)
140.310 + { fix h
140.311 + from Cons.hyps[rule_format, of x]
140.312 + obtain q r where qr: "x#xs = [r] +++ [- a, 1] *** q" by blast
140.313 + have "h#x#xs = [a*r + h] +++ [-a, 1] *** (r#q)"
140.314 + using qr by (cases q) (simp_all add: algebra_simps)
140.315 + hence "\<exists>q r. h#x#xs = [r] +++ [-a, 1] *** q" by blast}
140.316 + thus ?case by blast
140.317 +qed
140.318
140.319 -lemma poly_linear_divides: "poly p a = 0 \<longleftrightarrow> p = [] \<or> (\<exists>q. p = [-a, 1] *** q)"
140.320 - apply (auto simp add: poly_add poly_cmult distrib_left)
140.321 - apply (case_tac p)
140.322 - apply simp
140.323 - apply (cut_tac h = aa and t = list and a = a in poly_linear_rem)
140.324 - apply safe
140.325 - apply (case_tac q)
140.326 - apply auto
140.327 - apply (drule_tac x = "[]" in spec)
140.328 - apply simp
140.329 - apply (auto simp add: poly_add poly_cmult add_assoc)
140.330 - apply (drule_tac x = "aa#lista" in spec)
140.331 - apply auto
140.332 - done
140.333 +lemma (in comm_ring_1) poly_linear_rem: "\<exists>q r. h#t = [r] +++ [-a, 1] *** q"
140.334 + using lemma_poly_linear_rem [where t = t and a = a] by auto
140.335
140.336 -lemma lemma_poly_length_mult [simp]: "length (k %* p +++ (h # (a %* p))) = Suc (length p)"
140.337 - by (induct p arbitrary: h k a) auto
140.338
140.339 -lemma lemma_poly_length_mult2 [simp]: "length (k %* p +++ (h # p)) = Suc (length p)"
140.340 - by (induct p arbitrary: h k) auto
140.341 +lemma (in comm_ring_1) poly_linear_divides: "(poly p a = 0) = ((p = []) | (\<exists>q. p = [-a, 1] *** q))"
140.342 +proof -
140.343 + { assume p: "p = []" hence ?thesis by simp }
140.344 + moreover
140.345 + {
140.346 + fix x xs assume p: "p = x#xs"
140.347 + {
140.348 + fix q assume "p = [-a, 1] *** q"
140.349 + hence "poly p a = 0" by (simp add: poly_add poly_cmult)
140.350 + }
140.351 + moreover
140.352 + { assume p0: "poly p a = 0"
140.353 + from poly_linear_rem[of x xs a] obtain q r
140.354 + where qr: "x#xs = [r] +++ [- a, 1] *** q" by blast
140.355 + have "r = 0" using p0 by (simp only: p qr poly_mult poly_add) simp
140.356 + hence "\<exists>q. p = [- a, 1] *** q"
140.357 + using p qr
140.358 + apply -
140.359 + apply (rule exI[where x=q])
140.360 + apply auto
140.361 + apply (cases q)
140.362 + apply auto
140.363 + done
140.364 + }
140.365 + ultimately have ?thesis using p by blast
140.366 + }
140.367 + ultimately show ?thesis by (cases p) auto
140.368 +qed
140.369
140.370 -lemma poly_length_mult [simp]: "length([-a, 1] *** q) = Suc (length q)"
140.371 +lemma (in semiring_0) lemma_poly_length_mult[simp]: "\<forall>h k a. length (k %* p +++ (h # (a %* p))) = Suc (length p)"
140.372 + by (induct p) auto
140.373 +
140.374 +lemma (in semiring_0) lemma_poly_length_mult2[simp]: "\<forall>h k. length (k %* p +++ (h # p)) = Suc (length p)"
140.375 + by (induct p) auto
140.376 +
140.377 +lemma (in ring_1) poly_length_mult[simp]: "length([-a,1] *** q) = Suc (length q)"
140.378 by auto
140.379
140.380 -
140.381 subsection{*Polynomial length*}
140.382
140.383 -lemma poly_cmult_length [simp]: "length (a %* p) = length p"
140.384 +lemma (in semiring_0) poly_cmult_length[simp]: "length (a %* p) = length p"
140.385 by (induct p) auto
140.386
140.387 -lemma poly_add_length:
140.388 - "length (p1 +++ p2) = (if (length p1 < length p2) then length p2 else length p1)"
140.389 - by (induct p1 arbitrary: p2) auto
140.390 +lemma (in semiring_0) poly_add_length: "length (p1 +++ p2) = max (length p1) (length p2)"
140.391 + by (induct p1 arbitrary: p2) (simp_all, arith)
140.392
140.393 -lemma poly_root_mult_length [simp]: "length ([a, b] *** p) = Suc (length p)"
140.394 - by simp
140.395 +lemma (in semiring_0) poly_root_mult_length[simp]: "length([a,b] *** p) = Suc (length p)"
140.396 + by (simp add: poly_add_length)
140.397
140.398 -lemma poly_mult_not_eq_poly_Nil [simp]:
140.399 - "poly (p *** q) x \<noteq> poly [] x \<longleftrightarrow> poly p x \<noteq> poly [] x \<and> poly q x \<noteq> poly [] (x::'a::idom)"
140.400 +lemma (in idom) poly_mult_not_eq_poly_Nil[simp]:
140.401 + "poly (p *** q) x \<noteq> poly [] x \<longleftrightarrow> poly p x \<noteq> poly [] x \<and> poly q x \<noteq> poly [] x"
140.402 by (auto simp add: poly_mult)
140.403
140.404 -lemma poly_mult_eq_zero_disj: "poly (p *** q) (x::'a::idom) = 0 \<longleftrightarrow> poly p x = 0 \<or> poly q x = 0"
140.405 +lemma (in idom) poly_mult_eq_zero_disj: "poly (p *** q) x = 0 \<longleftrightarrow> poly p x = 0 \<or> poly q x = 0"
140.406 by (auto simp add: poly_mult)
140.407
140.408 text{*Normalisation Properties*}
140.409
140.410 -lemma poly_normalized_nil: "pnormalize p = [] \<longrightarrow> poly p x = 0"
140.411 +lemma (in semiring_0) poly_normalized_nil: "(pnormalize p = []) --> (poly p x = 0)"
140.412 by (induct p) auto
140.413
140.414 text{*A nontrivial polynomial of degree n has no more than n roots*}
140.415 +lemma (in idom) poly_roots_index_lemma:
140.416 + assumes p: "poly p x \<noteq> poly [] x" and n: "length p = n"
140.417 + shows "\<exists>i. \<forall>x. poly p x = 0 \<longrightarrow> (\<exists>m\<le>n. x = i m)"
140.418 + using p n
140.419 +proof (induct n arbitrary: p x)
140.420 + case 0
140.421 + thus ?case by simp
140.422 +next
140.423 + case (Suc n p x)
140.424 + {
140.425 + assume C: "\<And>i. \<exists>x. poly p x = 0 \<and> (\<forall>m\<le>Suc n. x \<noteq> i m)"
140.426 + from Suc.prems have p0: "poly p x \<noteq> 0" "p\<noteq> []" by auto
140.427 + from p0(1)[unfolded poly_linear_divides[of p x]]
140.428 + have "\<forall>q. p \<noteq> [- x, 1] *** q" by blast
140.429 + from C obtain a where a: "poly p a = 0" by blast
140.430 + from a[unfolded poly_linear_divides[of p a]] p0(2)
140.431 + obtain q where q: "p = [-a, 1] *** q" by blast
140.432 + have lg: "length q = n" using q Suc.prems(2) by simp
140.433 + from q p0 have qx: "poly q x \<noteq> poly [] x"
140.434 + by (auto simp add: poly_mult poly_add poly_cmult)
140.435 + from Suc.hyps[OF qx lg] obtain i where
140.436 + i: "\<forall>x. poly q x = 0 \<longrightarrow> (\<exists>m\<le>n. x = i m)" by blast
140.437 + let ?i = "\<lambda>m. if m = Suc n then a else i m"
140.438 + from C[of ?i] obtain y where y: "poly p y = 0" "\<forall>m\<le> Suc n. y \<noteq> ?i m"
140.439 + by blast
140.440 + from y have "y = a \<or> poly q y = 0"
140.441 + by (simp only: q poly_mult_eq_zero_disj poly_add) (simp add: algebra_simps)
140.442 + with i[rule_format, of y] y(1) y(2) have False
140.443 + apply auto
140.444 + apply (erule_tac x = "m" in allE)
140.445 + apply auto
140.446 + done
140.447 + }
140.448 + thus ?case by blast
140.449 +qed
140.450
140.451 -lemma poly_roots_index_lemma0 [rule_format]:
140.452 - "\<forall>p x. poly p x \<noteq> poly [] x & length p = n
140.453 - --> (\<exists>i. \<forall>x. (poly p x = (0::'a::idom)) --> (\<exists>m. (m \<le> n & x = i m)))"
140.454 - apply (induct n)
140.455 - apply safe
140.456 - apply (rule ccontr)
140.457 - apply (subgoal_tac "\<exists>a. poly p a = 0")
140.458 - apply safe
140.459 - apply (drule poly_linear_divides [THEN iffD1])
140.460 - apply safe
140.461 - apply (drule_tac x = q in spec)
140.462 - apply (drule_tac x = x in spec)
140.463 - apply (simp del: poly_Nil pmult_Cons)
140.464 - apply (erule exE)
140.465 - apply (drule_tac x = "%m. if m = Suc n then a else i m" in spec)
140.466 - apply safe
140.467 - apply (drule poly_mult_eq_zero_disj [THEN iffD1])
140.468 - apply safe
140.469 - apply (drule_tac x = "Suc (length q)" in spec)
140.470 - apply (auto simp add: field_simps)
140.471 - apply (drule_tac x = xa in spec)
140.472 - apply (clarsimp simp add: field_simps)
140.473 - apply (drule_tac x = m in spec)
140.474 - apply (auto simp add:field_simps)
140.475 - done
140.476 -lemmas poly_roots_index_lemma1 = conjI [THEN poly_roots_index_lemma0]
140.477
140.478 -lemma poly_roots_index_length0:
140.479 - "poly p (x::'a::idom) \<noteq> poly [] x \<Longrightarrow>
140.480 - \<exists>i. \<forall>x. (poly p x = 0) \<longrightarrow> (\<exists>n. n \<le> length p & x = i n)"
140.481 - by (blast intro: poly_roots_index_lemma1)
140.482 +lemma (in idom) poly_roots_index_length:
140.483 + "poly p x \<noteq> poly [] x \<Longrightarrow> \<exists>i. \<forall>x. (poly p x = 0) \<longrightarrow> (\<exists>n. n \<le> length p \<and> x = i n)"
140.484 + by (blast intro: poly_roots_index_lemma)
140.485
140.486 -lemma poly_roots_finite_lemma:
140.487 - "poly p (x::'a::idom) \<noteq> poly [] x \<Longrightarrow>
140.488 - \<exists>N i. \<forall>x. (poly p x = 0) \<longrightarrow> (\<exists>n. (n::nat) < N & x = i n)"
140.489 - apply (drule poly_roots_index_length0)
140.490 - apply safe
140.491 +lemma (in idom) poly_roots_finite_lemma1:
140.492 + "poly p x \<noteq> poly [] x \<Longrightarrow> \<exists>N i. \<forall>x. (poly p x = 0) \<longrightarrow> (\<exists>n. (n::nat) < N \<and> x = i n)"
140.493 + apply (drule poly_roots_index_length, safe)
140.494 apply (rule_tac x = "Suc (length p)" in exI)
140.495 apply (rule_tac x = i in exI)
140.496 apply (simp add: less_Suc_eq_le)
140.497 done
140.498
140.499 -
140.500 -lemma real_finite_lemma:
140.501 - assumes "\<forall>x. P x \<longrightarrow> (\<exists>n. n < length j & x = j!n)"
140.502 - shows "finite {(x::'a::idom). P x}"
140.503 +lemma (in idom) idom_finite_lemma:
140.504 + assumes P: "\<forall>x. P x --> (\<exists>n. n < length j \<and> x = j!n)"
140.505 + shows "finite {x. P x}"
140.506 proof -
140.507 let ?M = "{x. P x}"
140.508 let ?N = "set j"
140.509 - have "?M \<subseteq> ?N" using assms by auto
140.510 - then show ?thesis using finite_subset by auto
140.511 + have "?M \<subseteq> ?N" using P by auto
140.512 + thus ?thesis using finite_subset by auto
140.513 qed
140.514
140.515 -lemma poly_roots_index_lemma [rule_format]:
140.516 - "\<forall>p x. poly p x \<noteq> poly [] x & length p = n
140.517 - \<longrightarrow> (\<exists>i. \<forall>x. (poly p x = (0::'a::{idom})) \<longrightarrow> x \<in> set i)"
140.518 - apply (induct n)
140.519 - apply safe
140.520 - apply (rule ccontr)
140.521 - apply (subgoal_tac "\<exists>a. poly p a = 0")
140.522 - apply safe
140.523 - apply (drule poly_linear_divides [THEN iffD1])
140.524 - apply safe
140.525 - apply (drule_tac x = q in spec)
140.526 - apply (drule_tac x = x in spec)
140.527 - apply (auto simp del: poly_Nil pmult_Cons)
140.528 - apply (drule_tac x = "a#i" in spec)
140.529 - apply (auto simp only: poly_mult List.list.size)
140.530 - apply (drule_tac x = xa in spec)
140.531 - apply (clarsimp simp add: field_simps)
140.532 +lemma (in idom) poly_roots_finite_lemma2:
140.533 + "poly p x \<noteq> poly [] x \<Longrightarrow> \<exists>i. \<forall>x. poly p x = 0 \<longrightarrow> x \<in> set i"
140.534 + apply (drule poly_roots_index_length, safe)
140.535 + apply (rule_tac x="map (\<lambda>n. i n) [0 ..< Suc (length p)]" in exI)
140.536 + apply (auto simp add: image_iff)
140.537 + apply (erule_tac x="x" in allE, clarsimp)
140.538 + apply (case_tac "n = length p")
140.539 + apply (auto simp add: order_le_less)
140.540 done
140.541
140.542 -lemmas poly_roots_index_lemma2 = conjI [THEN poly_roots_index_lemma]
140.543 -
140.544 -lemma poly_roots_index_length:
140.545 - "poly p (x::'a::idom) \<noteq> poly [] x \<Longrightarrow>
140.546 - \<exists>i. \<forall>x. (poly p x = 0) --> x \<in> set i"
140.547 - by (blast intro: poly_roots_index_lemma2)
140.548 -
140.549 -lemma poly_roots_finite_lemma':
140.550 - "poly p (x::'a::idom) \<noteq> poly [] x \<Longrightarrow>
140.551 - \<exists>i. \<forall>x. (poly p x = 0) --> x \<in> set i"
140.552 - apply (drule poly_roots_index_length)
140.553 - apply auto
140.554 - done
140.555 -
140.556 -lemma UNIV_nat_infinite: "\<not> finite (UNIV :: nat set)"
140.557 - unfolding finite_conv_nat_seg_image
140.558 -proof (auto simp add: set_eq_iff image_iff)
140.559 - fix n::nat and f:: "nat \<Rightarrow> nat"
140.560 - let ?N = "{i. i < n}"
140.561 - let ?fN = "f ` ?N"
140.562 - let ?y = "Max ?fN + 1"
140.563 - from nat_seg_image_imp_finite[of "?fN" "f" n]
140.564 - have thfN: "finite ?fN" by simp
140.565 - { assume "n =0" hence "\<exists>x. \<forall>xa<n. x \<noteq> f xa" by auto }
140.566 - moreover
140.567 - { assume nz: "n \<noteq> 0"
140.568 - hence thne: "?fN \<noteq> {}" by auto
140.569 - have "\<forall>x\<in> ?fN. Max ?fN \<ge> x" using nz Max_ge_iff[OF thfN thne] by auto
140.570 - hence "\<forall>x\<in> ?fN. ?y > x" by (auto simp add: less_Suc_eq_le)
140.571 - hence "?y \<notin> ?fN" by auto
140.572 - hence "\<exists>x. \<forall>xa<n. x \<noteq> f xa" by auto }
140.573 - ultimately show "\<exists>x. \<forall>xa<n. x \<noteq> f xa" by blast
140.574 +lemma (in ring_char_0) UNIV_ring_char_0_infinte: "\<not> (finite (UNIV:: 'a set))"
140.575 +proof
140.576 + assume F: "finite (UNIV :: 'a set)"
140.577 + have "finite (UNIV :: nat set)"
140.578 + proof (rule finite_imageD)
140.579 + have "of_nat ` UNIV \<subseteq> UNIV" by simp
140.580 + then show "finite (of_nat ` UNIV :: 'a set)" using F by (rule finite_subset)
140.581 + show "inj (of_nat :: nat \<Rightarrow> 'a)" by (simp add: inj_on_def)
140.582 + qed
140.583 + with infinite_UNIV_nat show False ..
140.584 qed
140.585
140.586 -lemma UNIV_ring_char_0_infinte: "\<not> finite (UNIV:: ('a::ring_char_0) set)"
140.587 +lemma (in idom_char_0) poly_roots_finite: "poly p \<noteq> poly [] \<longleftrightarrow> finite {x. poly p x = 0}"
140.588 proof
140.589 - assume F: "finite (UNIV :: 'a set)"
140.590 - have th0: "of_nat ` UNIV \<subseteq> (UNIV :: 'a set)" by simp
140.591 - from finite_subset[OF th0 F] have th: "finite (of_nat ` UNIV :: 'a set)" .
140.592 - have th': "inj_on (of_nat::nat \<Rightarrow> 'a) UNIV"
140.593 - unfolding inj_on_def by auto
140.594 - from finite_imageD[OF th th'] UNIV_nat_infinite
140.595 - show False by blast
140.596 -qed
140.597 -
140.598 -lemma poly_roots_finite: "poly p \<noteq> poly [] \<longleftrightarrow> finite {x. poly p x = (0::'a::{idom,ring_char_0})}"
140.599 -proof
140.600 - assume "poly p \<noteq> poly []"
140.601 - then show "finite {x. poly p x = (0::'a)}"
140.602 + assume H: "poly p \<noteq> poly []"
140.603 + show "finite {x. poly p x = (0::'a)}"
140.604 + using H
140.605 apply -
140.606 - apply (erule contrapos_np)
140.607 - apply (rule ext)
140.608 + apply (erule contrapos_np, rule ext)
140.609 apply (rule ccontr)
140.610 - apply (clarify dest!: poly_roots_finite_lemma')
140.611 + apply (clarify dest!: poly_roots_finite_lemma2)
140.612 using finite_subset
140.613 proof -
140.614 fix x i
140.615 @@ -377,119 +385,142 @@
140.616 with finite_subset F show False by auto
140.617 qed
140.618 next
140.619 - assume "finite {x. poly p x = (0\<Colon>'a)}"
140.620 - then show "poly p \<noteq> poly []"
140.621 - using UNIV_ring_char_0_infinte by auto
140.622 + assume F: "finite {x. poly p x = (0\<Colon>'a)}"
140.623 + show "poly p \<noteq> poly []" using F UNIV_ring_char_0_infinte by auto
140.624 qed
140.625
140.626 text{*Entirety and Cancellation for polynomials*}
140.627
140.628 -lemma poly_entire_lemma:
140.629 - "poly (p:: ('a::{idom,ring_char_0}) list) \<noteq> poly [] \<Longrightarrow> poly q \<noteq> poly [] \<Longrightarrow>
140.630 - poly (p *** q) \<noteq> poly []"
140.631 - by (auto simp add: poly_roots_finite poly_mult Collect_disj_eq)
140.632 +lemma (in idom_char_0) poly_entire_lemma2:
140.633 + assumes p0: "poly p \<noteq> poly []"
140.634 + and q0: "poly q \<noteq> poly []"
140.635 + shows "poly (p***q) \<noteq> poly []"
140.636 +proof -
140.637 + let ?S = "\<lambda>p. {x. poly p x = 0}"
140.638 + have "?S (p *** q) = ?S p \<union> ?S q" by (auto simp add: poly_mult)
140.639 + with p0 q0 show ?thesis unfolding poly_roots_finite by auto
140.640 +qed
140.641
140.642 -lemma poly_entire:
140.643 - "poly (p *** q) = poly ([]::('a::{idom,ring_char_0}) list) \<longleftrightarrow>
140.644 - (poly p = poly [] \<or> poly q = poly [])"
140.645 - apply (auto dest: fun_cong simp add: poly_entire_lemma poly_mult)
140.646 - apply (blast intro: ccontr dest: poly_entire_lemma poly_mult [THEN subst])
140.647 - done
140.648 +lemma (in idom_char_0) poly_entire:
140.649 + "poly (p *** q) = poly [] \<longleftrightarrow> poly p = poly [] \<or> poly q = poly []"
140.650 + using poly_entire_lemma2[of p q]
140.651 + by (auto simp add: fun_eq_iff poly_mult)
140.652
140.653 -lemma poly_entire_neg:
140.654 - "poly (p *** q) \<noteq> poly ([]::('a::{idom,ring_char_0}) list) \<longleftrightarrow>
140.655 - poly p \<noteq> poly [] \<and> poly q \<noteq> poly []"
140.656 +lemma (in idom_char_0) poly_entire_neg:
140.657 + "poly (p *** q) \<noteq> poly [] \<longleftrightarrow> poly p \<noteq> poly [] \<and> poly q \<noteq> poly []"
140.658 by (simp add: poly_entire)
140.659
140.660 lemma fun_eq: "f = g \<longleftrightarrow> (\<forall>x. f x = g x)"
140.661 by auto
140.662
140.663 -lemma poly_add_minus_zero_iff: "poly (p +++ -- q) = poly [] \<longleftrightarrow> poly p = poly q"
140.664 - by (auto simp add: field_simps poly_add poly_minus_def fun_eq poly_cmult)
140.665 +lemma (in comm_ring_1) poly_add_minus_zero_iff:
140.666 + "poly (p +++ -- q) = poly [] \<longleftrightarrow> poly p = poly q"
140.667 + by (auto simp add: algebra_simps poly_add poly_minus_def fun_eq poly_cmult)
140.668
140.669 -lemma poly_add_minus_mult_eq: "poly (p *** q +++ --(p *** r)) = poly (p *** (q +++ -- r))"
140.670 - by (auto simp add: poly_add poly_minus_def fun_eq poly_mult poly_cmult distrib_left)
140.671 +lemma (in comm_ring_1) poly_add_minus_mult_eq:
140.672 + "poly (p *** q +++ --(p *** r)) = poly (p *** (q +++ -- r))"
140.673 + by (auto simp add: poly_add poly_minus_def fun_eq poly_mult poly_cmult algebra_simps)
140.674
140.675 -lemma poly_mult_left_cancel:
140.676 - "(poly (p *** q) = poly (p *** r)) =
140.677 - (poly p = poly ([]::('a::{idom,ring_char_0}) list) | poly q = poly r)"
140.678 - apply (rule_tac p1 = "p *** q" in poly_add_minus_zero_iff [THEN subst])
140.679 - apply (auto simp add: poly_add_minus_mult_eq poly_entire poly_add_minus_zero_iff)
140.680 - done
140.681 +subclass (in idom_char_0) comm_ring_1 ..
140.682
140.683 -lemma poly_exp_eq_zero [simp]:
140.684 - "poly (p %^ n) = poly ([]::('a::idom) list) \<longleftrightarrow> poly p = poly [] \<and> n \<noteq> 0"
140.685 +lemma (in idom_char_0) poly_mult_left_cancel:
140.686 + "poly (p *** q) = poly (p *** r) \<longleftrightarrow> poly p = poly [] \<or> poly q = poly r"
140.687 +proof -
140.688 + have "poly (p *** q) = poly (p *** r) \<longleftrightarrow> poly (p *** q +++ -- (p *** r)) = poly []"
140.689 + by (simp only: poly_add_minus_zero_iff)
140.690 + also have "\<dots> \<longleftrightarrow> poly p = poly [] \<or> poly q = poly r"
140.691 + by (auto intro: simp add: poly_add_minus_mult_eq poly_entire poly_add_minus_zero_iff)
140.692 + finally show ?thesis .
140.693 +qed
140.694 +
140.695 +lemma (in idom) poly_exp_eq_zero[simp]:
140.696 + "poly (p %^ n) = poly [] \<longleftrightarrow> poly p = poly [] \<and> n \<noteq> 0"
140.697 apply (simp only: fun_eq add: HOL.all_simps [symmetric])
140.698 apply (rule arg_cong [where f = All])
140.699 apply (rule ext)
140.700 - apply (induct_tac n)
140.701 - apply (auto simp add: poly_mult)
140.702 + apply (induct n)
140.703 + apply (auto simp add: poly_exp poly_mult)
140.704 done
140.705
140.706 -lemma poly_prime_eq_zero [simp]: "poly [a, 1::'a::comm_ring_1] \<noteq> poly []"
140.707 +lemma (in comm_ring_1) poly_prime_eq_zero[simp]: "poly [a,1] \<noteq> poly []"
140.708 apply (simp add: fun_eq)
140.709 - apply (rule_tac x = "1 - a" in exI)
140.710 - apply simp
140.711 + apply (rule_tac x = "minus one a" in exI)
140.712 + apply (simp add: add_commute [of a])
140.713 done
140.714
140.715 -lemma poly_exp_prime_eq_zero [simp]: "poly ([a, (1::'a::idom)] %^ n) \<noteq> poly []"
140.716 +lemma (in idom) poly_exp_prime_eq_zero: "poly ([a, 1] %^ n) \<noteq> poly []"
140.717 by auto
140.718
140.719 text{*A more constructive notion of polynomials being trivial*}
140.720
140.721 -lemma poly_zero_lemma':
140.722 - "poly (h # t) = poly [] \<Longrightarrow> h = (0::'a::{idom,ring_char_0}) & poly t = poly []"
140.723 +lemma (in idom_char_0) poly_zero_lemma': "poly (h # t) = poly [] \<Longrightarrow> h = 0 \<and> poly t = poly []"
140.724 apply (simp add: fun_eq)
140.725 - apply (case_tac "h = 0")
140.726 - apply (drule_tac [2] x = 0 in spec)
140.727 - apply auto
140.728 - apply (case_tac "poly t = poly []")
140.729 - apply simp
140.730 + apply (case_tac "h = zero")
140.731 + apply (drule_tac [2] x = zero in spec, auto)
140.732 + apply (cases "poly t = poly []", simp)
140.733 proof -
140.734 fix x
140.735 - assume H: "\<forall>x. x = (0\<Colon>'a) \<or> poly t x = (0\<Colon>'a)" and pnz: "poly t \<noteq> poly []"
140.736 + assume H: "\<forall>x. x = (0\<Colon>'a) \<or> poly t x = (0\<Colon>'a)"
140.737 + and pnz: "poly t \<noteq> poly []"
140.738 let ?S = "{x. poly t x = 0}"
140.739 from H have "\<forall>x. x \<noteq>0 \<longrightarrow> poly t x = 0" by blast
140.740 hence th: "?S \<supseteq> UNIV - {0}" by auto
140.741 from poly_roots_finite pnz have th': "finite ?S" by blast
140.742 - from finite_subset[OF th th'] UNIV_ring_char_0_infinte[where ?'a = 'a]
140.743 - show "poly t x = (0\<Colon>'a)" by simp
140.744 + from finite_subset[OF th th'] UNIV_ring_char_0_infinte show "poly t x = (0\<Colon>'a)"
140.745 + by simp
140.746 qed
140.747
140.748 -lemma poly_zero: "poly p = poly [] \<longleftrightarrow> list_all (\<lambda>c. c = (0::'a::{idom,ring_char_0})) p"
140.749 +lemma (in idom_char_0) poly_zero: "(poly p = poly []) = list_all (%c. c = 0) p"
140.750 apply (induct p)
140.751 apply simp
140.752 apply (rule iffI)
140.753 - apply (drule poly_zero_lemma')
140.754 - apply auto
140.755 + apply (drule poly_zero_lemma', auto)
140.756 done
140.757
140.758 +lemma (in idom_char_0) poly_0: "list_all (\<lambda>c. c = 0) p \<Longrightarrow> poly p x = 0"
140.759 + unfolding poly_zero[symmetric] by simp
140.760 +
140.761 +
140.762
140.763 text{*Basics of divisibility.*}
140.764
140.765 -lemma poly_primes: "[a, (1::'a::idom)] divides (p *** q) \<longleftrightarrow> [a, 1] divides p \<or> [a, 1] divides q"
140.766 +lemma (in idom) poly_primes:
140.767 + "[a, 1] divides (p *** q) \<longleftrightarrow> [a, 1] divides p \<or> [a, 1] divides q"
140.768 apply (auto simp add: divides_def fun_eq poly_mult poly_add poly_cmult distrib_right [symmetric])
140.769 - apply (drule_tac x = "-a" in spec)
140.770 + apply (drule_tac x = "uminus a" in spec)
140.771 + apply (simp add: poly_linear_divides poly_add poly_cmult distrib_right [symmetric])
140.772 + apply (cases "p = []")
140.773 + apply (rule exI[where x="[]"])
140.774 + apply simp
140.775 + apply (cases "q = []")
140.776 + apply (erule allE[where x="[]"], simp)
140.777 +
140.778 + apply clarsimp
140.779 + apply (cases "\<exists>q\<Colon>'a list. p = a %* q +++ ((0\<Colon>'a) # q)")
140.780 + apply (clarsimp simp add: poly_add poly_cmult)
140.781 + apply (rule_tac x="qa" in exI)
140.782 + apply (simp add: distrib_right [symmetric])
140.783 + apply clarsimp
140.784 +
140.785 apply (auto simp add: poly_linear_divides poly_add poly_cmult distrib_right [symmetric])
140.786 - apply (rule_tac x = "qa *** q" in exI)
140.787 - apply (rule_tac [2] x = "p *** qa" in exI)
140.788 + apply (rule_tac x = "pmult qa q" in exI)
140.789 + apply (rule_tac [2] x = "pmult p qa" in exI)
140.790 apply (auto simp add: poly_add poly_mult poly_cmult mult_ac)
140.791 done
140.792
140.793 -lemma poly_divides_refl [simp]: "p divides p"
140.794 +lemma (in comm_semiring_1) poly_divides_refl[simp]: "p divides p"
140.795 apply (simp add: divides_def)
140.796 - apply (rule_tac x = "[1]" in exI)
140.797 + apply (rule_tac x = "[one]" in exI)
140.798 apply (auto simp add: poly_mult fun_eq)
140.799 done
140.800
140.801 -lemma poly_divides_trans: "p divides q \<Longrightarrow> q divides r \<Longrightarrow> p divides r"
140.802 - apply (simp add: divides_def)
140.803 - apply safe
140.804 - apply (rule_tac x = "qa *** qaa" in exI)
140.805 +lemma (in comm_semiring_1) poly_divides_trans: "p divides q \<Longrightarrow> q divides r \<Longrightarrow> p divides r"
140.806 + apply (simp add: divides_def, safe)
140.807 + apply (rule_tac x = "pmult qa qaa" in exI)
140.808 apply (auto simp add: poly_mult fun_eq mult_assoc)
140.809 done
140.810
140.811 -lemma poly_divides_exp: "m \<le> n \<Longrightarrow> (p %^ m) divides (p %^ n)"
140.812 +lemma (in comm_semiring_1) poly_divides_exp: "m \<le> n \<Longrightarrow> (p %^ m) divides (p %^ n)"
140.813 apply (auto simp add: le_iff_add)
140.814 apply (induct_tac k)
140.815 apply (rule_tac [2] poly_divides_trans)
140.816 @@ -498,34 +529,37 @@
140.817 apply (auto simp add: poly_mult fun_eq mult_ac)
140.818 done
140.819
140.820 -lemma poly_exp_divides: "(p %^ n) divides q \<Longrightarrow> m \<le> n \<Longrightarrow> (p %^ m) divides q"
140.821 +lemma (in comm_semiring_1) poly_exp_divides:
140.822 + "(p %^ n) divides q \<Longrightarrow> m \<le> n \<Longrightarrow> (p %^ m) divides q"
140.823 by (blast intro: poly_divides_exp poly_divides_trans)
140.824
140.825 -lemma poly_divides_add: "p divides q \<Longrightarrow> p divides r \<Longrightarrow> p divides (q +++ r)"
140.826 - apply (simp add: divides_def)
140.827 - apply auto
140.828 - apply (rule_tac x = "qa +++ qaa" in exI)
140.829 +lemma (in comm_semiring_0) poly_divides_add:
140.830 + "p divides q \<Longrightarrow> p divides r \<Longrightarrow> p divides (q +++ r)"
140.831 + apply (simp add: divides_def, auto)
140.832 + apply (rule_tac x = "padd qa qaa" in exI)
140.833 apply (auto simp add: poly_add fun_eq poly_mult distrib_left)
140.834 done
140.835
140.836 -lemma poly_divides_diff: "p divides q \<Longrightarrow> p divides (q +++ r) \<Longrightarrow> p divides r"
140.837 - apply (auto simp add: divides_def)
140.838 - apply (rule_tac x = "qaa +++ -- qa" in exI)
140.839 +lemma (in comm_ring_1) poly_divides_diff:
140.840 + "p divides q \<Longrightarrow> p divides (q +++ r) \<Longrightarrow> p divides r"
140.841 + apply (simp add: divides_def, auto)
140.842 + apply (rule_tac x = "padd qaa (poly_minus qa)" in exI)
140.843 apply (auto simp add: poly_add fun_eq poly_mult poly_minus algebra_simps)
140.844 done
140.845
140.846 -lemma poly_divides_diff2: "p divides r \<Longrightarrow> p divides (q +++ r) \<Longrightarrow> p divides q"
140.847 +lemma (in comm_ring_1) poly_divides_diff2:
140.848 + "p divides r \<Longrightarrow> p divides (q +++ r) \<Longrightarrow> p divides q"
140.849 apply (erule poly_divides_diff)
140.850 apply (auto simp add: poly_add fun_eq poly_mult divides_def add_ac)
140.851 done
140.852
140.853 -lemma poly_divides_zero: "poly p = poly [] \<Longrightarrow> q divides p"
140.854 +lemma (in semiring_0) poly_divides_zero: "poly p = poly [] \<Longrightarrow> q divides p"
140.855 apply (simp add: divides_def)
140.856 - apply (rule exI [where x = "[]"])
140.857 + apply (rule exI[where x="[]"])
140.858 apply (auto simp add: fun_eq poly_mult)
140.859 done
140.860
140.861 -lemma poly_divides_zero2 [simp]: "q divides []"
140.862 +lemma (in semiring_0) poly_divides_zero2 [simp]: "q divides []"
140.863 apply (simp add: divides_def)
140.864 apply (rule_tac x = "[]" in exI)
140.865 apply (auto simp add: fun_eq)
140.866 @@ -533,195 +567,256 @@
140.867
140.868 text{*At last, we can consider the order of a root.*}
140.869
140.870 -lemma poly_order_exists_lemma [rule_format]:
140.871 - "\<forall>p. length p = d \<longrightarrow> poly p \<noteq> poly [] \<longrightarrow>
140.872 - (\<exists>n q. p = mulexp n [-a, (1::'a::{idom,ring_char_0})] q & poly q a \<noteq> 0)"
140.873 - apply (induct "d")
140.874 - apply (simp add: fun_eq)
140.875 - apply safe
140.876 - apply (case_tac "poly p a = 0")
140.877 - apply (drule_tac poly_linear_divides [THEN iffD1])
140.878 - apply safe
140.879 - apply (drule_tac x = q in spec)
140.880 - apply (drule_tac poly_entire_neg [THEN iffD1])
140.881 - apply safe
140.882 - apply force
140.883 - apply (rule_tac x = "Suc n" in exI)
140.884 - apply (rule_tac x = qa in exI)
140.885 - apply (simp del: pmult_Cons)
140.886 - apply (rule_tac x = 0 in exI)
140.887 - apply force
140.888 - done
140.889 +lemma (in idom_char_0) poly_order_exists_lemma:
140.890 + assumes lp: "length p = d"
140.891 + and p: "poly p \<noteq> poly []"
140.892 + shows "\<exists>n q. p = mulexp n [-a, 1] q \<and> poly q a \<noteq> 0"
140.893 + using lp p
140.894 +proof (induct d arbitrary: p)
140.895 + case 0
140.896 + thus ?case by simp
140.897 +next
140.898 + case (Suc n p)
140.899 + show ?case
140.900 + proof (cases "poly p a = 0")
140.901 + case True
140.902 + from Suc.prems have h: "length p = Suc n" "poly p \<noteq> poly []" by auto
140.903 + hence pN: "p \<noteq> []" by auto
140.904 + from True[unfolded poly_linear_divides] pN obtain q where q: "p = [-a, 1] *** q"
140.905 + by blast
140.906 + from q h True have qh: "length q = n" "poly q \<noteq> poly []"
140.907 + apply -
140.908 + apply simp
140.909 + apply (simp only: fun_eq)
140.910 + apply (rule ccontr)
140.911 + apply (simp add: fun_eq poly_add poly_cmult)
140.912 + done
140.913 + from Suc.hyps[OF qh] obtain m r where mr: "q = mulexp m [-a,1] r" "poly r a \<noteq> 0"
140.914 + by blast
140.915 + from mr q have "p = mulexp (Suc m) [-a,1] r \<and> poly r a \<noteq> 0" by simp
140.916 + then show ?thesis by blast
140.917 + next
140.918 + case False
140.919 + then show ?thesis
140.920 + using Suc.prems
140.921 + apply simp
140.922 + apply (rule exI[where x="0::nat"])
140.923 + apply simp
140.924 + done
140.925 + qed
140.926 +qed
140.927 +
140.928 +
140.929 +lemma (in comm_semiring_1) poly_mulexp: "poly (mulexp n p q) x = (poly p x) ^ n * poly q x"
140.930 + by (induct n) (auto simp add: poly_mult mult_ac)
140.931 +
140.932 +lemma (in comm_semiring_1) divides_left_mult:
140.933 + assumes d:"(p***q) divides r" shows "p divides r \<and> q divides r"
140.934 +proof-
140.935 + from d obtain t where r:"poly r = poly (p***q *** t)"
140.936 + unfolding divides_def by blast
140.937 + hence "poly r = poly (p *** (q *** t))"
140.938 + "poly r = poly (q *** (p***t))" by(auto simp add: fun_eq poly_mult mult_ac)
140.939 + thus ?thesis unfolding divides_def by blast
140.940 +qed
140.941 +
140.942
140.943 (* FIXME: Tidy up *)
140.944 -lemma poly_order_exists:
140.945 - "length p = d \<Longrightarrow> poly p \<noteq> poly [] \<Longrightarrow>
140.946 - \<exists>n. ([-a, 1] %^ n) divides p \<and> \<not> (([-a, (1::'a::{idom,ring_char_0})] %^ (Suc n)) divides p)"
140.947 - apply (drule poly_order_exists_lemma [where a=a])
140.948 - apply assumption
140.949 - apply clarify
140.950 - apply (rule_tac x = n in exI)
140.951 - apply safe
140.952 - apply (unfold divides_def)
140.953 - apply (rule_tac x = q in exI)
140.954 - apply (induct_tac n)
140.955 - apply simp
140.956 - apply (simp add: poly_add poly_cmult poly_mult distrib_left mult_ac)
140.957 - apply safe
140.958 - apply (subgoal_tac "poly (mulexp n [- a, 1] q) \<noteq> poly ([- a, 1] %^ Suc n *** qa)")
140.959 - apply simp
140.960 - apply (induct_tac n)
140.961 - apply (simp del: pmult_Cons pexp_Suc)
140.962 - apply (erule_tac Q = "poly q a = 0" in contrapos_np)
140.963 - apply (simp add: poly_add poly_cmult)
140.964 - apply (rule pexp_Suc [THEN ssubst])
140.965 - apply (rule ccontr)
140.966 - apply (simp add: poly_mult_left_cancel poly_mult_assoc del: pmult_Cons pexp_Suc)
140.967 - done
140.968
140.969 -lemma poly_one_divides [simp]: "[1] divides p"
140.970 - by (auto simp: divides_def)
140.971 +lemma (in semiring_1) zero_power_iff: "0 ^ n = (if n = 0 then 1 else 0)"
140.972 + by (induct n) simp_all
140.973
140.974 -lemma poly_order: "poly p \<noteq> poly [] \<Longrightarrow>
140.975 - \<exists>! n. ([-a, (1::'a::{idom,ring_char_0})] %^ n) divides p \<and> \<not> (([-a, 1] %^ Suc n) divides p)"
140.976 +lemma (in idom_char_0) poly_order_exists:
140.977 + assumes "length p = d" and "poly p \<noteq> poly []"
140.978 + shows "\<exists>n. [- a, 1] %^ n divides p \<and> \<not> [- a, 1] %^ Suc n divides p"
140.979 +proof -
140.980 + from assms have "\<exists>n q. p = mulexp n [- a, 1] q \<and> poly q a \<noteq> 0"
140.981 + by (rule poly_order_exists_lemma)
140.982 + then obtain n q where p: "p = mulexp n [- a, 1] q" and "poly q a \<noteq> 0" by blast
140.983 + have "[- a, 1] %^ n divides mulexp n [- a, 1] q"
140.984 + proof (rule dividesI)
140.985 + show "poly (mulexp n [- a, 1] q) = poly ([- a, 1] %^ n *** q)"
140.986 + by (induct n) (simp_all add: poly_add poly_cmult poly_mult algebra_simps)
140.987 + qed
140.988 + moreover have "\<not> [- a, 1] %^ Suc n divides mulexp n [- a, 1] q"
140.989 + proof
140.990 + assume "[- a, 1] %^ Suc n divides mulexp n [- a, 1] q"
140.991 + then obtain m where "poly (mulexp n [- a, 1] q) = poly ([- a, 1] %^ Suc n *** m)"
140.992 + by (rule dividesE)
140.993 + moreover have "poly (mulexp n [- a, 1] q) \<noteq> poly ([- a, 1] %^ Suc n *** m)"
140.994 + proof (induct n)
140.995 + case 0 show ?case
140.996 + proof (rule ccontr)
140.997 + assume "\<not> poly (mulexp 0 [- a, 1] q) \<noteq> poly ([- a, 1] %^ Suc 0 *** m)"
140.998 + then have "poly q a = 0"
140.999 + by (simp add: poly_add poly_cmult)
140.1000 + with `poly q a \<noteq> 0` show False by simp
140.1001 + qed
140.1002 + next
140.1003 + case (Suc n) show ?case
140.1004 + by (rule pexp_Suc [THEN ssubst], rule ccontr)
140.1005 + (simp add: poly_mult_left_cancel poly_mult_assoc Suc del: pmult_Cons pexp_Suc)
140.1006 + qed
140.1007 + ultimately show False by simp
140.1008 + qed
140.1009 + ultimately show ?thesis by (auto simp add: p)
140.1010 +qed
140.1011 +
140.1012 +lemma (in semiring_1) poly_one_divides[simp]: "[1] divides p"
140.1013 + by (auto simp add: divides_def)
140.1014 +
140.1015 +lemma (in idom_char_0) poly_order:
140.1016 + "poly p \<noteq> poly [] \<Longrightarrow> \<exists>!n. ([-a, 1] %^ n) divides p \<and> \<not> (([-a, 1] %^ Suc n) divides p)"
140.1017 apply (auto intro: poly_order_exists simp add: less_linear simp del: pmult_Cons pexp_Suc)
140.1018 apply (cut_tac x = y and y = n in less_linear)
140.1019 apply (drule_tac m = n in poly_exp_divides)
140.1020 apply (auto dest: Suc_le_eq [THEN iffD2, THEN [2] poly_exp_divides]
140.1021 - simp del: pmult_Cons pexp_Suc)
140.1022 + simp del: pmult_Cons pexp_Suc)
140.1023 done
140.1024
140.1025 text{*Order*}
140.1026
140.1027 -lemma some1_equalityD: "n = (SOME n. P n) \<Longrightarrow> EX! n. P n \<Longrightarrow> P n"
140.1028 +lemma some1_equalityD: "n = (SOME n. P n) \<Longrightarrow> \<exists>!n. P n \<Longrightarrow> P n"
140.1029 by (blast intro: someI2)
140.1030
140.1031 -lemma order:
140.1032 - "(([-a, (1::'a::{idom,ring_char_0})] %^ n) divides p &
140.1033 - ~(([-a, 1] %^ (Suc n)) divides p)) =
140.1034 - ((n = order a p) & ~(poly p = poly []))"
140.1035 +lemma (in idom_char_0) order:
140.1036 + "(([-a, 1] %^ n) divides p \<and>
140.1037 + ~(([-a, 1] %^ (Suc n)) divides p)) =
140.1038 + ((n = order a p) \<and> ~(poly p = poly []))"
140.1039 apply (unfold order_def)
140.1040 apply (rule iffI)
140.1041 apply (blast dest: poly_divides_zero intro!: some1_equality [symmetric] poly_order)
140.1042 apply (blast intro!: poly_order [THEN [2] some1_equalityD])
140.1043 done
140.1044
140.1045 -lemma order2: "poly p \<noteq> poly [] \<Longrightarrow>
140.1046 - ([-a, (1::'a::{idom,ring_char_0})] %^ (order a p)) divides p &
140.1047 - ~(([-a, 1] %^ (Suc(order a p))) divides p)"
140.1048 +lemma (in idom_char_0) order2:
140.1049 + "poly p \<noteq> poly [] \<Longrightarrow>
140.1050 + ([-a, 1] %^ (order a p)) divides p \<and> \<not> (([-a, 1] %^ (Suc (order a p))) divides p)"
140.1051 by (simp add: order del: pexp_Suc)
140.1052
140.1053 -lemma order_unique: "poly p \<noteq> poly [] \<Longrightarrow> ([-a, 1] %^ n) divides p \<Longrightarrow>
140.1054 - \<not> (([-a, (1::'a::{idom,ring_char_0})] %^ (Suc n)) divides p) \<Longrightarrow> n = order a p"
140.1055 +lemma (in idom_char_0) order_unique:
140.1056 + "poly p \<noteq> poly [] \<Longrightarrow> ([-a, 1] %^ n) divides p \<Longrightarrow> ~(([-a, 1] %^ (Suc n)) divides p) \<Longrightarrow>
140.1057 + n = order a p"
140.1058 using order [of a n p] by auto
140.1059
140.1060 -lemma order_unique_lemma:
140.1061 - "(poly p \<noteq> poly [] \<and> ([-a, 1] %^ n) divides p \<and>
140.1062 - \<not> (([-a, (1::'a::{idom,ring_char_0})] %^ (Suc n)) divides p)) \<Longrightarrow>
140.1063 +lemma (in idom_char_0) order_unique_lemma:
140.1064 + "poly p \<noteq> poly [] \<and> ([-a, 1] %^ n) divides p \<and> ~(([-a, 1] %^ (Suc n)) divides p) \<Longrightarrow>
140.1065 n = order a p"
140.1066 by (blast intro: order_unique)
140.1067
140.1068 -lemma order_poly: "poly p = poly q ==> order a p = order a q"
140.1069 +lemma (in ring_1) order_poly: "poly p = poly q \<Longrightarrow> order a p = order a q"
140.1070 by (auto simp add: fun_eq divides_def poly_mult order_def)
140.1071
140.1072 -lemma pexp_one [simp]: "p %^ (Suc 0) = p"
140.1073 - by (induct p) simp_all
140.1074 +lemma (in semiring_1) pexp_one[simp]: "p %^ (Suc 0) = p"
140.1075 + by (induct "p") auto
140.1076
140.1077 -lemma lemma_order_root:
140.1078 - "0 < n & [- a, 1] %^ n divides p & ~ [- a, 1] %^ (Suc n) divides p \<Longrightarrow> poly p a = 0"
140.1079 - apply (induct n arbitrary: p a)
140.1080 - apply blast
140.1081 - apply (auto simp add: divides_def poly_mult simp del: pmult_Cons)
140.1082 +lemma (in comm_ring_1) lemma_order_root:
140.1083 + "0 < n \<and> [- a, 1] %^ n divides p \<and> ~ [- a, 1] %^ (Suc n) divides p \<Longrightarrow> poly p a = 0"
140.1084 + by (induct n arbitrary: a p) (auto simp add: divides_def poly_mult simp del: pmult_Cons)
140.1085 +
140.1086 +lemma (in idom_char_0) order_root:
140.1087 + "poly p a = 0 \<longleftrightarrow> poly p = poly [] \<or> order a p \<noteq> 0"
140.1088 + apply (cases "poly p = poly []")
140.1089 + apply auto
140.1090 + apply (simp add: poly_linear_divides del: pmult_Cons, safe)
140.1091 + apply (drule_tac [!] a = a in order2)
140.1092 + apply (rule ccontr)
140.1093 + apply (simp add: divides_def poly_mult fun_eq del: pmult_Cons, blast)
140.1094 + using neq0_conv
140.1095 + apply (blast intro: lemma_order_root)
140.1096 done
140.1097
140.1098 -lemma order_root: "poly p a = (0::'a::{idom,ring_char_0}) \<longleftrightarrow> poly p = poly [] \<or> order a p \<noteq> 0"
140.1099 - apply (cases "poly p = poly []")
140.1100 - apply auto
140.1101 - apply (simp add: poly_linear_divides del: pmult_Cons)
140.1102 - apply safe
140.1103 - apply (drule_tac [!] a = a in order2)
140.1104 - apply (rule ccontr)
140.1105 - apply (simp add: divides_def poly_mult fun_eq del: pmult_Cons)
140.1106 - apply blast
140.1107 - using neq0_conv apply (blast intro: lemma_order_root)
140.1108 - done
140.1109 -
140.1110 -lemma order_divides: "([-a, 1::'a::{idom,ring_char_0}] %^ n) divides p \<longleftrightarrow>
140.1111 - poly p = poly [] \<or> n \<le> order a p"
140.1112 +lemma (in idom_char_0) order_divides:
140.1113 + "([-a, 1] %^ n) divides p \<longleftrightarrow> poly p = poly [] \<or> n \<le> order a p"
140.1114 apply (cases "poly p = poly []")
140.1115 apply auto
140.1116 apply (simp add: divides_def fun_eq poly_mult)
140.1117 apply (rule_tac x = "[]" in exI)
140.1118 - apply (auto dest!: order2 [where a = a] intro: poly_exp_divides simp del: pexp_Suc)
140.1119 + apply (auto dest!: order2 [where a=a] intro: poly_exp_divides simp del: pexp_Suc)
140.1120 done
140.1121
140.1122 -lemma order_decomp:
140.1123 - "poly p \<noteq> poly [] \<Longrightarrow>
140.1124 - \<exists>q. poly p = poly (([-a, 1] %^ (order a p)) *** q) \<and>
140.1125 - \<not> ([-a, 1::'a::{idom,ring_char_0}] divides q)"
140.1126 +lemma (in idom_char_0) order_decomp:
140.1127 + "poly p \<noteq> poly [] \<Longrightarrow> \<exists>q. poly p = poly (([-a, 1] %^ (order a p)) *** q) \<and> ~([-a, 1] divides q)"
140.1128 apply (unfold divides_def)
140.1129 apply (drule order2 [where a = a])
140.1130 - apply (simp add: divides_def del: pexp_Suc pmult_Cons)
140.1131 - apply safe
140.1132 - apply (rule_tac x = q in exI)
140.1133 - apply safe
140.1134 + apply (simp add: divides_def del: pexp_Suc pmult_Cons, safe)
140.1135 + apply (rule_tac x = q in exI, safe)
140.1136 apply (drule_tac x = qa in spec)
140.1137 apply (auto simp add: poly_mult fun_eq poly_exp mult_ac simp del: pmult_Cons)
140.1138 done
140.1139
140.1140 text{*Important composition properties of orders.*}
140.1141 -
140.1142 -lemma order_mult: "poly (p *** q) \<noteq> poly [] \<Longrightarrow>
140.1143 - order a (p *** q) = order a p + order (a::'a::{idom,ring_char_0}) q"
140.1144 - apply (cut_tac a = a and p = "p***q" and n = "order a p + order a q" in order)
140.1145 +lemma order_mult:
140.1146 + "poly (p *** q) \<noteq> poly [] \<Longrightarrow>
140.1147 + order a (p *** q) = order a p + order (a::'a::{idom_char_0}) q"
140.1148 + apply (cut_tac a = a and p = "p *** q" and n = "order a p + order a q" in order)
140.1149 apply (auto simp add: poly_entire simp del: pmult_Cons)
140.1150 apply (drule_tac a = a in order2)+
140.1151 apply safe
140.1152 - apply (simp add: divides_def fun_eq poly_exp_add poly_mult del: pmult_Cons)
140.1153 - apply safe
140.1154 + apply (simp add: divides_def fun_eq poly_exp_add poly_mult del: pmult_Cons, safe)
140.1155 apply (rule_tac x = "qa *** qaa" in exI)
140.1156 apply (simp add: poly_mult mult_ac del: pmult_Cons)
140.1157 apply (drule_tac a = a in order_decomp)+
140.1158 apply safe
140.1159 - apply (subgoal_tac "[-a, 1] divides (qa *** qaa) ")
140.1160 + apply (subgoal_tac "[-a,1] divides (qa *** qaa) ")
140.1161 apply (simp add: poly_primes del: pmult_Cons)
140.1162 apply (auto simp add: divides_def simp del: pmult_Cons)
140.1163 apply (rule_tac x = qb in exI)
140.1164 - apply (subgoal_tac "poly ([-a, 1] %^ (order a p) *** (qa *** qaa)) =
140.1165 - poly ([-a, 1] %^ (order a p) *** ([-a, 1] *** qb))")
140.1166 - apply (drule poly_mult_left_cancel [THEN iffD1])
140.1167 - apply force
140.1168 - apply (subgoal_tac "poly ([-a, 1] %^ (order a q) *** ([-a, 1] %^ (order a p) *** (qa *** qaa))) =
140.1169 - poly ([-a, 1] %^ (order a q) *** ([-a, 1] %^ (order a p) *** ([-a, 1] *** qb))) ")
140.1170 - apply (drule poly_mult_left_cancel [THEN iffD1])
140.1171 - apply force
140.1172 + apply (subgoal_tac "poly ([-a, 1] %^ (order a p) *** (qa *** qaa)) = poly ([-a, 1] %^ (order a p) *** ([-a, 1] *** qb))")
140.1173 + apply (drule poly_mult_left_cancel [THEN iffD1], force)
140.1174 + apply (subgoal_tac "poly ([-a, 1] %^ (order a q) *** ([-a, 1] %^ (order a p) *** (qa *** qaa))) = poly ([-a, 1] %^ (order a q) *** ([-a, 1] %^ (order a p) *** ([-a, 1] *** qb))) ")
140.1175 + apply (drule poly_mult_left_cancel [THEN iffD1], force)
140.1176 apply (simp add: fun_eq poly_exp_add poly_mult mult_ac del: pmult_Cons)
140.1177 done
140.1178
140.1179 -lemma order_root2: "poly p \<noteq> poly [] \<Longrightarrow> poly p a = 0 \<longleftrightarrow> order (a::'a::{idom,ring_char_0}) p \<noteq> 0"
140.1180 +lemma (in idom_char_0) order_mult:
140.1181 + assumes "poly (p *** q) \<noteq> poly []"
140.1182 + shows "order a (p *** q) = order a p + order a q"
140.1183 + using assms
140.1184 + apply (cut_tac a = a and p = "pmult p q" and n = "order a p + order a q" in order)
140.1185 + apply (auto simp add: poly_entire simp del: pmult_Cons)
140.1186 + apply (drule_tac a = a in order2)+
140.1187 + apply safe
140.1188 + apply (simp add: divides_def fun_eq poly_exp_add poly_mult del: pmult_Cons, safe)
140.1189 + apply (rule_tac x = "pmult qa qaa" in exI)
140.1190 + apply (simp add: poly_mult mult_ac del: pmult_Cons)
140.1191 + apply (drule_tac a = a in order_decomp)+
140.1192 + apply safe
140.1193 + apply (subgoal_tac "[uminus a, one] divides pmult qa qaa")
140.1194 + apply (simp add: poly_primes del: pmult_Cons)
140.1195 + apply (auto simp add: divides_def simp del: pmult_Cons)
140.1196 + apply (rule_tac x = qb in exI)
140.1197 + apply (subgoal_tac "poly (pmult (pexp [uminus a, one] (order a p)) (pmult qa qaa)) =
140.1198 + poly (pmult (pexp [uminus a, one] (?order a p)) (pmult [uminus a, one] qb))")
140.1199 + apply (drule poly_mult_left_cancel [THEN iffD1], force)
140.1200 + apply (subgoal_tac "poly (pmult (pexp [uminus a, one] (order a q))
140.1201 + (pmult (pexp [uminus a, one] (order a p)) (pmult qa qaa))) =
140.1202 + poly (pmult (pexp [uminus a, one] (order a q))
140.1203 + (pmult (pexp [uminus a, one] (order a p)) (pmult [uminus a, one] qb)))")
140.1204 + apply (drule poly_mult_left_cancel [THEN iffD1], force)
140.1205 + apply (simp add: fun_eq poly_exp_add poly_mult mult_ac del: pmult_Cons)
140.1206 + done
140.1207 +
140.1208 +lemma (in idom_char_0) order_root2: "poly p \<noteq> poly [] \<Longrightarrow> poly p a = 0 \<longleftrightarrow> order a p \<noteq> 0"
140.1209 by (rule order_root [THEN ssubst]) auto
140.1210
140.1211 -lemma pmult_one [simp]: "[1] *** p = p"
140.1212 - by auto
140.1213 +lemma (in semiring_1) pmult_one[simp]: "[1] *** p = p" by auto
140.1214
140.1215 -lemma poly_Nil_zero: "poly [] = poly [0]"
140.1216 +lemma (in semiring_0) poly_Nil_zero: "poly [] = poly [0]"
140.1217 by (simp add: fun_eq)
140.1218
140.1219 -lemma rsquarefree_decomp:
140.1220 - "rsquarefree p \<Longrightarrow> poly p a = (0::'a::{idom,ring_char_0}) \<Longrightarrow>
140.1221 +lemma (in idom_char_0) rsquarefree_decomp:
140.1222 + "rsquarefree p \<Longrightarrow> poly p a = 0 \<Longrightarrow>
140.1223 \<exists>q. poly p = poly ([-a, 1] *** q) \<and> poly q a \<noteq> 0"
140.1224 - apply (simp add: rsquarefree_def)
140.1225 - apply safe
140.1226 + apply (simp add: rsquarefree_def, safe)
140.1227 apply (frule_tac a = a in order_decomp)
140.1228 apply (drule_tac x = a in spec)
140.1229 apply (drule_tac a = a in order_root2 [symmetric])
140.1230 apply (auto simp del: pmult_Cons)
140.1231 - apply (rule_tac x = q in exI)
140.1232 - apply safe
140.1233 + apply (rule_tac x = q in exI, safe)
140.1234 apply (simp add: poly_mult fun_eq)
140.1235 apply (drule_tac p1 = q in poly_linear_divides [THEN iffD1])
140.1236 - apply (simp add: divides_def del: pmult_Cons)
140.1237 - apply safe
140.1238 + apply (simp add: divides_def del: pmult_Cons, safe)
140.1239 apply (drule_tac x = "[]" in spec)
140.1240 apply (auto simp add: fun_eq)
140.1241 done
140.1242 @@ -729,72 +824,222 @@
140.1243
140.1244 text{*Normalization of a polynomial.*}
140.1245
140.1246 -lemma poly_normalize [simp]: "poly (pnormalize p) = poly p"
140.1247 +lemma (in semiring_0) poly_normalize[simp]: "poly (pnormalize p) = poly p"
140.1248 by (induct p) (auto simp add: fun_eq)
140.1249
140.1250 -
140.1251 text{*The degree of a polynomial.*}
140.1252
140.1253 -lemma lemma_degree_zero: "list_all (\<lambda>c. c = 0) p \<longleftrightarrow> pnormalize p = []"
140.1254 +lemma (in semiring_0) lemma_degree_zero: "list_all (%c. c = 0) p \<longleftrightarrow> pnormalize p = []"
140.1255 by (induct p) auto
140.1256
140.1257 -lemma degree_zero: "poly p = poly ([] :: 'a::{idom,ring_char_0} list) \<Longrightarrow> degree p = 0"
140.1258 - apply (cases "pnormalize p = []")
140.1259 - apply (simp add: degree_def)
140.1260 - apply (auto simp add: poly_zero lemma_degree_zero)
140.1261 - done
140.1262 +lemma (in idom_char_0) degree_zero:
140.1263 + assumes "poly p = poly []"
140.1264 + shows "degree p = 0"
140.1265 + using assms
140.1266 + by (cases "pnormalize p = []") (auto simp add: degree_def poly_zero lemma_degree_zero)
140.1267
140.1268 -lemma pnormalize_sing: "pnormalize [x] = [x] \<longleftrightarrow> x \<noteq> 0"
140.1269 +lemma (in semiring_0) pnormalize_sing: "(pnormalize [x] = [x]) \<longleftrightarrow> x \<noteq> 0"
140.1270 by simp
140.1271
140.1272 -lemma pnormalize_pair: "y \<noteq> 0 \<longleftrightarrow> (pnormalize [x, y] = [x, y])"
140.1273 +lemma (in semiring_0) pnormalize_pair: "y \<noteq> 0 \<longleftrightarrow> (pnormalize [x, y] = [x, y])"
140.1274 by simp
140.1275
140.1276 -lemma pnormal_cons: "pnormal p \<Longrightarrow> pnormal (c # p)"
140.1277 +lemma (in semiring_0) pnormal_cons: "pnormal p \<Longrightarrow> pnormal (c#p)"
140.1278 unfolding pnormal_def by simp
140.1279
140.1280 -lemma pnormal_tail: "p \<noteq> [] \<Longrightarrow> pnormal (c # p) \<Longrightarrow> pnormal p"
140.1281 - unfolding pnormal_def
140.1282 - apply (cases "pnormalize p = []")
140.1283 +lemma (in semiring_0) pnormal_tail: "p\<noteq>[] \<Longrightarrow> pnormal (c#p) \<Longrightarrow> pnormal p"
140.1284 + unfolding pnormal_def by(auto split: split_if_asm)
140.1285 +
140.1286 +
140.1287 +lemma (in semiring_0) pnormal_last_nonzero: "pnormal p \<Longrightarrow> last p \<noteq> 0"
140.1288 + by (induct p) (simp_all add: pnormal_def split: split_if_asm)
140.1289 +
140.1290 +lemma (in semiring_0) pnormal_length: "pnormal p \<Longrightarrow> 0 < length p"
140.1291 + unfolding pnormal_def length_greater_0_conv by blast
140.1292 +
140.1293 +lemma (in semiring_0) pnormal_last_length: "0 < length p \<Longrightarrow> last p \<noteq> 0 \<Longrightarrow> pnormal p"
140.1294 + by (induct p) (auto simp: pnormal_def split: split_if_asm)
140.1295 +
140.1296 +
140.1297 +lemma (in semiring_0) pnormal_id: "pnormal p \<longleftrightarrow> 0 < length p \<and> last p \<noteq> 0"
140.1298 + using pnormal_last_length pnormal_length pnormal_last_nonzero by blast
140.1299 +
140.1300 +lemma (in idom_char_0) poly_Cons_eq:
140.1301 + "poly (c # cs) = poly (d # ds) \<longleftrightarrow> c = d \<and> poly cs = poly ds"
140.1302 + (is "?lhs \<longleftrightarrow> ?rhs")
140.1303 +proof
140.1304 + assume eq: ?lhs
140.1305 + hence "\<And>x. poly ((c#cs) +++ -- (d#ds)) x = 0"
140.1306 + by (simp only: poly_minus poly_add algebra_simps) (simp add: algebra_simps)
140.1307 + hence "poly ((c#cs) +++ -- (d#ds)) = poly []" by(simp add: fun_eq_iff)
140.1308 + hence "c = d \<and> list_all (\<lambda>x. x=0) ((cs +++ -- ds))"
140.1309 + unfolding poly_zero by (simp add: poly_minus_def algebra_simps)
140.1310 + hence "c = d \<and> (\<forall>x. poly (cs +++ -- ds) x = 0)"
140.1311 + unfolding poly_zero[symmetric] by simp
140.1312 + then show ?rhs by (simp add: poly_minus poly_add algebra_simps fun_eq_iff)
140.1313 +next
140.1314 + assume ?rhs
140.1315 + then show ?lhs by(simp add:fun_eq_iff)
140.1316 +qed
140.1317 +
140.1318 +lemma (in idom_char_0) pnormalize_unique: "poly p = poly q \<Longrightarrow> pnormalize p = pnormalize q"
140.1319 +proof (induct q arbitrary: p)
140.1320 + case Nil
140.1321 + thus ?case by (simp only: poly_zero lemma_degree_zero) simp
140.1322 +next
140.1323 + case (Cons c cs p)
140.1324 + thus ?case
140.1325 + proof (induct p)
140.1326 + case Nil
140.1327 + hence "poly [] = poly (c#cs)" by blast
140.1328 + then have "poly (c#cs) = poly [] " by simp
140.1329 + thus ?case by (simp only: poly_zero lemma_degree_zero) simp
140.1330 + next
140.1331 + case (Cons d ds)
140.1332 + hence eq: "poly (d # ds) = poly (c # cs)" by blast
140.1333 + hence eq': "\<And>x. poly (d # ds) x = poly (c # cs) x" by simp
140.1334 + hence "poly (d # ds) 0 = poly (c # cs) 0" by blast
140.1335 + hence dc: "d = c" by auto
140.1336 + with eq have "poly ds = poly cs"
140.1337 + unfolding poly_Cons_eq by simp
140.1338 + with Cons.prems have "pnormalize ds = pnormalize cs" by blast
140.1339 + with dc show ?case by simp
140.1340 + qed
140.1341 +qed
140.1342 +
140.1343 +lemma (in idom_char_0) degree_unique:
140.1344 + assumes pq: "poly p = poly q"
140.1345 + shows "degree p = degree q"
140.1346 + using pnormalize_unique[OF pq] unfolding degree_def by simp
140.1347 +
140.1348 +lemma (in semiring_0) pnormalize_length:
140.1349 + "length (pnormalize p) \<le> length p" by (induct p) auto
140.1350 +
140.1351 +lemma (in semiring_0) last_linear_mul_lemma:
140.1352 + "last ((a %* p) +++ (x#(b %* p))) = (if p = [] then x else b * last p)"
140.1353 + apply (induct p arbitrary: a x b)
140.1354 apply auto
140.1355 - apply (cases "c = 0")
140.1356 + apply (subgoal_tac "padd (cmult aa p) (times b a # cmult b p) \<noteq> []")
140.1357 + apply simp
140.1358 + apply (induct_tac p)
140.1359 apply auto
140.1360 done
140.1361
140.1362 -lemma pnormal_last_nonzero: "pnormal p \<Longrightarrow> last p \<noteq> 0"
140.1363 - apply (induct p)
140.1364 - apply (auto simp add: pnormal_def)
140.1365 - apply (case_tac "pnormalize p = []")
140.1366 - apply auto
140.1367 - apply (case_tac "a = 0")
140.1368 - apply auto
140.1369 - done
140.1370 +lemma (in semiring_1) last_linear_mul:
140.1371 + assumes p: "p \<noteq> []"
140.1372 + shows "last ([a,1] *** p) = last p"
140.1373 +proof -
140.1374 + from p obtain c cs where cs: "p = c#cs" by (cases p) auto
140.1375 + from cs have eq: "[a,1] *** p = (a %* (c#cs)) +++ (0#(1 %* (c#cs)))"
140.1376 + by (simp add: poly_cmult_distr)
140.1377 + show ?thesis using cs
140.1378 + unfolding eq last_linear_mul_lemma by simp
140.1379 +qed
140.1380
140.1381 -lemma pnormal_length: "pnormal p \<Longrightarrow> 0 < length p"
140.1382 - unfolding pnormal_def length_greater_0_conv by blast
140.1383 +lemma (in semiring_0) pnormalize_eq: "last p \<noteq> 0 \<Longrightarrow> pnormalize p = p"
140.1384 + by (induct p) (auto split: split_if_asm)
140.1385
140.1386 -lemma pnormal_last_length: "0 < length p \<Longrightarrow> last p \<noteq> 0 \<Longrightarrow> pnormal p"
140.1387 - apply (induct p)
140.1388 - apply auto
140.1389 - apply (case_tac "p = []")
140.1390 - apply auto
140.1391 - apply (simp add: pnormal_def)
140.1392 - apply (rule pnormal_cons)
140.1393 - apply auto
140.1394 - done
140.1395 +lemma (in semiring_0) last_pnormalize: "pnormalize p \<noteq> [] \<Longrightarrow> last (pnormalize p) \<noteq> 0"
140.1396 + by (induct p) auto
140.1397
140.1398 -lemma pnormal_id: "pnormal p \<longleftrightarrow> 0 < length p \<and> last p \<noteq> 0"
140.1399 - using pnormal_last_length pnormal_length pnormal_last_nonzero by blast
140.1400 +lemma (in semiring_0) pnormal_degree: "last p \<noteq> 0 \<Longrightarrow> degree p = length p - 1"
140.1401 + using pnormalize_eq[of p] unfolding degree_def by simp
140.1402 +
140.1403 +lemma (in semiring_0) poly_Nil_ext: "poly [] = (\<lambda>x. 0)"
140.1404 + by (rule ext) simp
140.1405 +
140.1406 +lemma (in idom_char_0) linear_mul_degree:
140.1407 + assumes p: "poly p \<noteq> poly []"
140.1408 + shows "degree ([a,1] *** p) = degree p + 1"
140.1409 +proof -
140.1410 + from p have pnz: "pnormalize p \<noteq> []"
140.1411 + unfolding poly_zero lemma_degree_zero .
140.1412 +
140.1413 + from last_linear_mul[OF pnz, of a] last_pnormalize[OF pnz]
140.1414 + have l0: "last ([a, 1] *** pnormalize p) \<noteq> 0" by simp
140.1415 + from last_pnormalize[OF pnz] last_linear_mul[OF pnz, of a]
140.1416 + pnormal_degree[OF l0] pnormal_degree[OF last_pnormalize[OF pnz]] pnz
140.1417 +
140.1418 + have th: "degree ([a,1] *** pnormalize p) = degree (pnormalize p) + 1"
140.1419 + by simp
140.1420 +
140.1421 + have eqs: "poly ([a,1] *** pnormalize p) = poly ([a,1] *** p)"
140.1422 + by (rule ext) (simp add: poly_mult poly_add poly_cmult)
140.1423 + from degree_unique[OF eqs] th
140.1424 + show ?thesis by (simp add: degree_unique[OF poly_normalize])
140.1425 +qed
140.1426 +
140.1427 +lemma (in idom_char_0) linear_pow_mul_degree:
140.1428 + "degree([a,1] %^n *** p) = (if poly p = poly [] then 0 else degree p + n)"
140.1429 +proof (induct n arbitrary: a p)
140.1430 + case (0 a p)
140.1431 + show ?case
140.1432 + proof (cases "poly p = poly []")
140.1433 + case True
140.1434 + then show ?thesis
140.1435 + using degree_unique[OF True] by (simp add: degree_def)
140.1436 + next
140.1437 + case False
140.1438 + then show ?thesis by (auto simp add: poly_Nil_ext)
140.1439 + qed
140.1440 +next
140.1441 + case (Suc n a p)
140.1442 + have eq: "poly ([a,1] %^(Suc n) *** p) = poly ([a,1] %^ n *** ([a,1] *** p))"
140.1443 + apply (rule ext)
140.1444 + apply (simp add: poly_mult poly_add poly_cmult)
140.1445 + apply (simp add: mult_ac add_ac distrib_left)
140.1446 + done
140.1447 + note deq = degree_unique[OF eq]
140.1448 + show ?case
140.1449 + proof (cases "poly p = poly []")
140.1450 + case True
140.1451 + with eq have eq': "poly ([a,1] %^(Suc n) *** p) = poly []"
140.1452 + apply -
140.1453 + apply (rule ext)
140.1454 + apply (simp add: poly_mult poly_cmult poly_add)
140.1455 + done
140.1456 + from degree_unique[OF eq'] True show ?thesis
140.1457 + by (simp add: degree_def)
140.1458 + next
140.1459 + case False
140.1460 + then have ap: "poly ([a,1] *** p) \<noteq> poly []"
140.1461 + using poly_mult_not_eq_poly_Nil unfolding poly_entire by auto
140.1462 + have eq: "poly ([a,1] %^(Suc n) *** p) = poly ([a,1]%^n *** ([a,1] *** p))"
140.1463 + by (rule ext, simp add: poly_mult poly_add poly_exp poly_cmult algebra_simps)
140.1464 + from ap have ap': "(poly ([a,1] *** p) = poly []) = False"
140.1465 + by blast
140.1466 + have th0: "degree ([a,1]%^n *** ([a,1] *** p)) = degree ([a,1] *** p) + n"
140.1467 + apply (simp only: Suc.hyps[of a "pmult [a,one] p"] ap')
140.1468 + apply simp
140.1469 + done
140.1470 + from degree_unique[OF eq] ap False th0 linear_mul_degree[OF False, of a]
140.1471 + show ?thesis by (auto simp del: poly.simps)
140.1472 + qed
140.1473 +qed
140.1474 +
140.1475 +lemma (in idom_char_0) order_degree:
140.1476 + assumes p0: "poly p \<noteq> poly []"
140.1477 + shows "order a p \<le> degree p"
140.1478 +proof -
140.1479 + from order2[OF p0, unfolded divides_def]
140.1480 + obtain q where q: "poly p = poly ([- a, 1]%^ (order a p) *** q)" by blast
140.1481 + {
140.1482 + assume "poly q = poly []"
140.1483 + with q p0 have False by (simp add: poly_mult poly_entire)
140.1484 + }
140.1485 + with degree_unique[OF q, unfolded linear_pow_mul_degree] show ?thesis
140.1486 + by auto
140.1487 +qed
140.1488
140.1489 text{*Tidier versions of finiteness of roots.*}
140.1490
140.1491 -lemma poly_roots_finite_set:
140.1492 - "poly p \<noteq> poly [] \<Longrightarrow> finite {x::'a::{idom,ring_char_0}. poly p x = 0}"
140.1493 +lemma (in idom_char_0) poly_roots_finite_set:
140.1494 + "poly p \<noteq> poly [] \<Longrightarrow> finite {x. poly p x = 0}"
140.1495 unfolding poly_roots_finite .
140.1496
140.1497 text{*bound for polynomial.*}
140.1498
140.1499 -lemma poly_mono: "abs x \<le> k \<Longrightarrow> abs (poly p (x::'a::{linordered_idom})) \<le> poly (map abs p) k"
140.1500 +lemma poly_mono: "abs(x) \<le> k \<Longrightarrow> abs(poly p (x::'a::{linordered_idom})) \<le> poly (map abs p) k"
140.1501 apply (induct p)
140.1502 apply auto
140.1503 apply (rule_tac y = "abs a + abs (x * poly p x)" in order_trans)
140.1504 @@ -802,7 +1047,6 @@
140.1505 apply (auto intro!: mult_mono simp add: abs_mult)
140.1506 done
140.1507
140.1508 -lemma poly_Sing: "poly [c] x = c"
140.1509 - by simp
140.1510 +lemma (in semiring_0) poly_Sing: "poly [c] x = c" by simp
140.1511
140.1512 end
141.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
141.2 +++ b/src/HOL/Decision_Procs/Rat_Pair.thy Thu Dec 05 17:58:03 2013 +0100
141.3 @@ -0,0 +1,522 @@
141.4 +(* Title: HOL/Decision_Procs/Rat_Pair.thy
141.5 + Author: Amine Chaieb
141.6 +*)
141.7 +
141.8 +header {* Rational numbers as pairs *}
141.9 +
141.10 +theory Rat_Pair
141.11 +imports Complex_Main
141.12 +begin
141.13 +
141.14 +type_synonym Num = "int \<times> int"
141.15 +
141.16 +abbreviation Num0_syn :: Num ("0\<^sub>N")
141.17 + where "0\<^sub>N \<equiv> (0, 0)"
141.18 +
141.19 +abbreviation Numi_syn :: "int \<Rightarrow> Num" ("'((_)')\<^sub>N")
141.20 + where "(i)\<^sub>N \<equiv> (i, 1)"
141.21 +
141.22 +definition isnormNum :: "Num \<Rightarrow> bool" where
141.23 + "isnormNum = (\<lambda>(a,b). (if a = 0 then b = 0 else b > 0 \<and> gcd a b = 1))"
141.24 +
141.25 +definition normNum :: "Num \<Rightarrow> Num" where
141.26 + "normNum = (\<lambda>(a,b).
141.27 + (if a=0 \<or> b = 0 then (0,0) else
141.28 + (let g = gcd a b
141.29 + in if b > 0 then (a div g, b div g) else (- (a div g), - (b div g)))))"
141.30 +
141.31 +declare gcd_dvd1_int[presburger] gcd_dvd2_int[presburger]
141.32 +
141.33 +lemma normNum_isnormNum [simp]: "isnormNum (normNum x)"
141.34 +proof -
141.35 + obtain a b where x: "x = (a, b)" by (cases x)
141.36 + { assume "a=0 \<or> b = 0" hence ?thesis by (simp add: x normNum_def isnormNum_def) }
141.37 + moreover
141.38 + { assume anz: "a \<noteq> 0" and bnz: "b \<noteq> 0"
141.39 + let ?g = "gcd a b"
141.40 + let ?a' = "a div ?g"
141.41 + let ?b' = "b div ?g"
141.42 + let ?g' = "gcd ?a' ?b'"
141.43 + from anz bnz have "?g \<noteq> 0" by simp with gcd_ge_0_int[of a b]
141.44 + have gpos: "?g > 0" by arith
141.45 + have gdvd: "?g dvd a" "?g dvd b" by arith+
141.46 + from dvd_mult_div_cancel[OF gdvd(1)] dvd_mult_div_cancel[OF gdvd(2)] anz bnz
141.47 + have nz': "?a' \<noteq> 0" "?b' \<noteq> 0" by - (rule notI, simp)+
141.48 + from anz bnz have stupid: "a \<noteq> 0 \<or> b \<noteq> 0" by arith
141.49 + from div_gcd_coprime_int[OF stupid] have gp1: "?g' = 1" .
141.50 + from bnz have "b < 0 \<or> b > 0" by arith
141.51 + moreover
141.52 + { assume b: "b > 0"
141.53 + from b have "?b' \<ge> 0"
141.54 + by (presburger add: pos_imp_zdiv_nonneg_iff[OF gpos])
141.55 + with nz' have b': "?b' > 0" by arith
141.56 + from b b' anz bnz nz' gp1 have ?thesis
141.57 + by (simp add: x isnormNum_def normNum_def Let_def split_def) }
141.58 + moreover {
141.59 + assume b: "b < 0"
141.60 + { assume b': "?b' \<ge> 0"
141.61 + from gpos have th: "?g \<ge> 0" by arith
141.62 + from mult_nonneg_nonneg[OF th b'] dvd_mult_div_cancel[OF gdvd(2)]
141.63 + have False using b by arith }
141.64 + hence b': "?b' < 0" by (presburger add: linorder_not_le[symmetric])
141.65 + from anz bnz nz' b b' gp1 have ?thesis
141.66 + by (simp add: x isnormNum_def normNum_def Let_def split_def) }
141.67 + ultimately have ?thesis by blast
141.68 + }
141.69 + ultimately show ?thesis by blast
141.70 +qed
141.71 +
141.72 +text {* Arithmetic over Num *}
141.73 +
141.74 +definition Nadd :: "Num \<Rightarrow> Num \<Rightarrow> Num" (infixl "+\<^sub>N" 60) where
141.75 + "Nadd = (\<lambda>(a,b) (a',b'). if a = 0 \<or> b = 0 then normNum(a',b')
141.76 + else if a'=0 \<or> b' = 0 then normNum(a,b)
141.77 + else normNum(a*b' + b*a', b*b'))"
141.78 +
141.79 +definition Nmul :: "Num \<Rightarrow> Num \<Rightarrow> Num" (infixl "*\<^sub>N" 60) where
141.80 + "Nmul = (\<lambda>(a,b) (a',b'). let g = gcd (a*a') (b*b')
141.81 + in (a*a' div g, b*b' div g))"
141.82 +
141.83 +definition Nneg :: "Num \<Rightarrow> Num" ("~\<^sub>N")
141.84 + where "Nneg \<equiv> (\<lambda>(a,b). (-a,b))"
141.85 +
141.86 +definition Nsub :: "Num \<Rightarrow> Num \<Rightarrow> Num" (infixl "-\<^sub>N" 60)
141.87 + where "Nsub = (\<lambda>a b. a +\<^sub>N ~\<^sub>N b)"
141.88 +
141.89 +definition Ninv :: "Num \<Rightarrow> Num"
141.90 + where "Ninv = (\<lambda>(a,b). if a < 0 then (-b, \<bar>a\<bar>) else (b,a))"
141.91 +
141.92 +definition Ndiv :: "Num \<Rightarrow> Num \<Rightarrow> Num" (infixl "\<div>\<^sub>N" 60)
141.93 + where "Ndiv = (\<lambda>a b. a *\<^sub>N Ninv b)"
141.94 +
141.95 +lemma Nneg_normN[simp]: "isnormNum x \<Longrightarrow> isnormNum (~\<^sub>N x)"
141.96 + by (simp add: isnormNum_def Nneg_def split_def)
141.97 +
141.98 +lemma Nadd_normN[simp]: "isnormNum (x +\<^sub>N y)"
141.99 + by (simp add: Nadd_def split_def)
141.100 +
141.101 +lemma Nsub_normN[simp]: "\<lbrakk> isnormNum y\<rbrakk> \<Longrightarrow> isnormNum (x -\<^sub>N y)"
141.102 + by (simp add: Nsub_def split_def)
141.103 +
141.104 +lemma Nmul_normN[simp]:
141.105 + assumes xn: "isnormNum x" and yn: "isnormNum y"
141.106 + shows "isnormNum (x *\<^sub>N y)"
141.107 +proof -
141.108 + obtain a b where x: "x = (a, b)" by (cases x)
141.109 + obtain a' b' where y: "y = (a', b')" by (cases y)
141.110 + { assume "a = 0"
141.111 + hence ?thesis using xn x y
141.112 + by (simp add: isnormNum_def Let_def Nmul_def split_def) }
141.113 + moreover
141.114 + { assume "a' = 0"
141.115 + hence ?thesis using yn x y
141.116 + by (simp add: isnormNum_def Let_def Nmul_def split_def) }
141.117 + moreover
141.118 + { assume a: "a \<noteq>0" and a': "a'\<noteq>0"
141.119 + hence bp: "b > 0" "b' > 0" using xn yn x y by (simp_all add: isnormNum_def)
141.120 + from mult_pos_pos[OF bp] have "x *\<^sub>N y = normNum (a * a', b * b')"
141.121 + using x y a a' bp by (simp add: Nmul_def Let_def split_def normNum_def)
141.122 + hence ?thesis by simp }
141.123 + ultimately show ?thesis by blast
141.124 +qed
141.125 +
141.126 +lemma Ninv_normN[simp]: "isnormNum x \<Longrightarrow> isnormNum (Ninv x)"
141.127 + by (simp add: Ninv_def isnormNum_def split_def)
141.128 + (cases "fst x = 0", auto simp add: gcd_commute_int)
141.129 +
141.130 +lemma isnormNum_int[simp]:
141.131 + "isnormNum 0\<^sub>N" "isnormNum ((1::int)\<^sub>N)" "i \<noteq> 0 \<Longrightarrow> isnormNum (i)\<^sub>N"
141.132 + by (simp_all add: isnormNum_def)
141.133 +
141.134 +
141.135 +text {* Relations over Num *}
141.136 +
141.137 +definition Nlt0:: "Num \<Rightarrow> bool" ("0>\<^sub>N")
141.138 + where "Nlt0 = (\<lambda>(a,b). a < 0)"
141.139 +
141.140 +definition Nle0:: "Num \<Rightarrow> bool" ("0\<ge>\<^sub>N")
141.141 + where "Nle0 = (\<lambda>(a,b). a \<le> 0)"
141.142 +
141.143 +definition Ngt0:: "Num \<Rightarrow> bool" ("0<\<^sub>N")
141.144 + where "Ngt0 = (\<lambda>(a,b). a > 0)"
141.145 +
141.146 +definition Nge0:: "Num \<Rightarrow> bool" ("0\<le>\<^sub>N")
141.147 + where "Nge0 = (\<lambda>(a,b). a \<ge> 0)"
141.148 +
141.149 +definition Nlt :: "Num \<Rightarrow> Num \<Rightarrow> bool" (infix "<\<^sub>N" 55)
141.150 + where "Nlt = (\<lambda>a b. 0>\<^sub>N (a -\<^sub>N b))"
141.151 +
141.152 +definition Nle :: "Num \<Rightarrow> Num \<Rightarrow> bool" (infix "\<le>\<^sub>N" 55)
141.153 + where "Nle = (\<lambda>a b. 0\<ge>\<^sub>N (a -\<^sub>N b))"
141.154 +
141.155 +definition "INum = (\<lambda>(a,b). of_int a / of_int b)"
141.156 +
141.157 +lemma INum_int [simp]: "INum (i)\<^sub>N = ((of_int i) ::'a::field)" "INum 0\<^sub>N = (0::'a::field)"
141.158 + by (simp_all add: INum_def)
141.159 +
141.160 +lemma isnormNum_unique[simp]:
141.161 + assumes na: "isnormNum x" and nb: "isnormNum y"
141.162 + shows "((INum x ::'a::{field_char_0, field_inverse_zero}) = INum y) = (x = y)" (is "?lhs = ?rhs")
141.163 +proof
141.164 + obtain a b where x: "x = (a, b)" by (cases x)
141.165 + obtain a' b' where y: "y = (a', b')" by (cases y)
141.166 + assume H: ?lhs
141.167 + { assume "a = 0 \<or> b = 0 \<or> a' = 0 \<or> b' = 0"
141.168 + hence ?rhs using na nb H
141.169 + by (simp add: x y INum_def split_def isnormNum_def split: split_if_asm) }
141.170 + moreover
141.171 + { assume az: "a \<noteq> 0" and bz: "b \<noteq> 0" and a'z: "a'\<noteq>0" and b'z: "b'\<noteq>0"
141.172 + from az bz a'z b'z na nb have pos: "b > 0" "b' > 0" by (simp_all add: x y isnormNum_def)
141.173 + from H bz b'z have eq: "a * b' = a'*b"
141.174 + by (simp add: x y INum_def eq_divide_eq divide_eq_eq of_int_mult[symmetric] del: of_int_mult)
141.175 + from az a'z na nb have gcd1: "gcd a b = 1" "gcd b a = 1" "gcd a' b' = 1" "gcd b' a' = 1"
141.176 + by (simp_all add: x y isnormNum_def add: gcd_commute_int)
141.177 + from eq have raw_dvd: "a dvd a' * b" "b dvd b' * a" "a' dvd a * b'" "b' dvd b * a'"
141.178 + apply -
141.179 + apply algebra
141.180 + apply algebra
141.181 + apply simp
141.182 + apply algebra
141.183 + done
141.184 + from zdvd_antisym_abs[OF coprime_dvd_mult_int[OF gcd1(2) raw_dvd(2)]
141.185 + coprime_dvd_mult_int[OF gcd1(4) raw_dvd(4)]]
141.186 + have eq1: "b = b'" using pos by arith
141.187 + with eq have "a = a'" using pos by simp
141.188 + with eq1 have ?rhs by (simp add: x y) }
141.189 + ultimately show ?rhs by blast
141.190 +next
141.191 + assume ?rhs thus ?lhs by simp
141.192 +qed
141.193 +
141.194 +
141.195 +lemma isnormNum0[simp]:
141.196 + "isnormNum x \<Longrightarrow> (INum x = (0::'a::{field_char_0, field_inverse_zero})) = (x = 0\<^sub>N)"
141.197 + unfolding INum_int(2)[symmetric]
141.198 + by (rule isnormNum_unique) simp_all
141.199 +
141.200 +lemma of_int_div_aux: "d ~= 0 ==> ((of_int x)::'a::field_char_0) / (of_int d) =
141.201 + of_int (x div d) + (of_int (x mod d)) / ((of_int d)::'a)"
141.202 +proof -
141.203 + assume "d ~= 0"
141.204 + let ?t = "of_int (x div d) * ((of_int d)::'a) + of_int(x mod d)"
141.205 + let ?f = "\<lambda>x. x / of_int d"
141.206 + have "x = (x div d) * d + x mod d"
141.207 + by auto
141.208 + then have eq: "of_int x = ?t"
141.209 + by (simp only: of_int_mult[symmetric] of_int_add [symmetric])
141.210 + then have "of_int x / of_int d = ?t / of_int d"
141.211 + using cong[OF refl[of ?f] eq] by simp
141.212 + then show ?thesis by (simp add: add_divide_distrib algebra_simps `d ~= 0`)
141.213 +qed
141.214 +
141.215 +lemma of_int_div: "(d::int) ~= 0 ==> d dvd n ==>
141.216 + (of_int(n div d)::'a::field_char_0) = of_int n / of_int d"
141.217 + apply (frule of_int_div_aux [of d n, where ?'a = 'a])
141.218 + apply simp
141.219 + apply (simp add: dvd_eq_mod_eq_0)
141.220 + done
141.221 +
141.222 +
141.223 +lemma normNum[simp]: "INum (normNum x) = (INum x :: 'a::{field_char_0, field_inverse_zero})"
141.224 +proof -
141.225 + obtain a b where x: "x = (a, b)" by (cases x)
141.226 + { assume "a = 0 \<or> b = 0"
141.227 + hence ?thesis by (simp add: x INum_def normNum_def split_def Let_def) }
141.228 + moreover
141.229 + { assume a: "a \<noteq> 0" and b: "b \<noteq> 0"
141.230 + let ?g = "gcd a b"
141.231 + from a b have g: "?g \<noteq> 0"by simp
141.232 + from of_int_div[OF g, where ?'a = 'a]
141.233 + have ?thesis by (auto simp add: x INum_def normNum_def split_def Let_def) }
141.234 + ultimately show ?thesis by blast
141.235 +qed
141.236 +
141.237 +lemma INum_normNum_iff:
141.238 + "(INum x ::'a::{field_char_0, field_inverse_zero}) = INum y \<longleftrightarrow> normNum x = normNum y"
141.239 + (is "?lhs = ?rhs")
141.240 +proof -
141.241 + have "normNum x = normNum y \<longleftrightarrow> (INum (normNum x) :: 'a) = INum (normNum y)"
141.242 + by (simp del: normNum)
141.243 + also have "\<dots> = ?lhs" by simp
141.244 + finally show ?thesis by simp
141.245 +qed
141.246 +
141.247 +lemma Nadd[simp]: "INum (x +\<^sub>N y) = INum x + (INum y :: 'a :: {field_char_0, field_inverse_zero})"
141.248 +proof -
141.249 + let ?z = "0:: 'a"
141.250 + obtain a b where x: "x = (a, b)" by (cases x)
141.251 + obtain a' b' where y: "y = (a', b')" by (cases y)
141.252 + { assume "a=0 \<or> a'= 0 \<or> b =0 \<or> b' = 0"
141.253 + hence ?thesis
141.254 + apply (cases "a=0", simp_all add: x y Nadd_def)
141.255 + apply (cases "b= 0", simp_all add: INum_def)
141.256 + apply (cases "a'= 0", simp_all)
141.257 + apply (cases "b'= 0", simp_all)
141.258 + done }
141.259 + moreover
141.260 + { assume aa': "a \<noteq> 0" "a'\<noteq> 0" and bb': "b \<noteq> 0" "b' \<noteq> 0"
141.261 + { assume z: "a * b' + b * a' = 0"
141.262 + hence "of_int (a*b' + b*a') / (of_int b* of_int b') = ?z" by simp
141.263 + hence "of_int b' * of_int a / (of_int b * of_int b') +
141.264 + of_int b * of_int a' / (of_int b * of_int b') = ?z"
141.265 + by (simp add:add_divide_distrib)
141.266 + hence th: "of_int a / of_int b + of_int a' / of_int b' = ?z" using bb' aa'
141.267 + by simp
141.268 + from z aa' bb' have ?thesis
141.269 + by (simp add: x y th Nadd_def normNum_def INum_def split_def) }
141.270 + moreover {
141.271 + assume z: "a * b' + b * a' \<noteq> 0"
141.272 + let ?g = "gcd (a * b' + b * a') (b * b')"
141.273 + have gz: "?g \<noteq> 0" using z by simp
141.274 + have ?thesis using aa' bb' z gz
141.275 + of_int_div[where ?'a = 'a, OF gz gcd_dvd1_int[where x="a * b' + b * a'" and y="b*b'"]]
141.276 + of_int_div[where ?'a = 'a, OF gz gcd_dvd2_int[where x="a * b' + b * a'" and y="b*b'"]]
141.277 + by (simp add: x y Nadd_def INum_def normNum_def Let_def) (simp add: field_simps)
141.278 + }
141.279 + ultimately have ?thesis using aa' bb'
141.280 + by (simp add: x y Nadd_def INum_def normNum_def Let_def) }
141.281 + ultimately show ?thesis by blast
141.282 +qed
141.283 +
141.284 +lemma Nmul[simp]: "INum (x *\<^sub>N y) = INum x * (INum y:: 'a :: {field_char_0, field_inverse_zero})"
141.285 +proof -
141.286 + let ?z = "0::'a"
141.287 + obtain a b where x: "x = (a, b)" by (cases x)
141.288 + obtain a' b' where y: "y = (a', b')" by (cases y)
141.289 + { assume "a=0 \<or> a'= 0 \<or> b = 0 \<or> b' = 0"
141.290 + hence ?thesis
141.291 + apply (cases "a=0", simp_all add: x y Nmul_def INum_def Let_def)
141.292 + apply (cases "b=0", simp_all)
141.293 + apply (cases "a'=0", simp_all)
141.294 + done }
141.295 + moreover
141.296 + { assume z: "a \<noteq> 0" "a' \<noteq> 0" "b \<noteq> 0" "b' \<noteq> 0"
141.297 + let ?g="gcd (a*a') (b*b')"
141.298 + have gz: "?g \<noteq> 0" using z by simp
141.299 + from z of_int_div[where ?'a = 'a, OF gz gcd_dvd1_int[where x="a*a'" and y="b*b'"]]
141.300 + of_int_div[where ?'a = 'a , OF gz gcd_dvd2_int[where x="a*a'" and y="b*b'"]]
141.301 + have ?thesis by (simp add: Nmul_def x y Let_def INum_def) }
141.302 + ultimately show ?thesis by blast
141.303 +qed
141.304 +
141.305 +lemma Nneg[simp]: "INum (~\<^sub>N x) = - (INum x ::'a:: field)"
141.306 + by (simp add: Nneg_def split_def INum_def)
141.307 +
141.308 +lemma Nsub[simp]: "INum (x -\<^sub>N y) = INum x - (INum y:: 'a :: {field_char_0, field_inverse_zero})"
141.309 + by (simp add: Nsub_def split_def)
141.310 +
141.311 +lemma Ninv[simp]: "INum (Ninv x) = (1::'a :: field_inverse_zero) / (INum x)"
141.312 + by (simp add: Ninv_def INum_def split_def)
141.313 +
141.314 +lemma Ndiv[simp]: "INum (x \<div>\<^sub>N y) = INum x / (INum y ::'a :: {field_char_0, field_inverse_zero})"
141.315 + by (simp add: Ndiv_def)
141.316 +
141.317 +lemma Nlt0_iff[simp]:
141.318 + assumes nx: "isnormNum x"
141.319 + shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero})< 0) = 0>\<^sub>N x"
141.320 +proof -
141.321 + obtain a b where x: "x = (a, b)" by (cases x)
141.322 + { assume "a = 0" hence ?thesis by (simp add: x Nlt0_def INum_def) }
141.323 + moreover
141.324 + { assume a: "a \<noteq> 0" hence b: "(of_int b::'a) > 0"
141.325 + using nx by (simp add: x isnormNum_def)
141.326 + from pos_divide_less_eq[OF b, where b="of_int a" and a="0::'a"]
141.327 + have ?thesis by (simp add: x Nlt0_def INum_def) }
141.328 + ultimately show ?thesis by blast
141.329 +qed
141.330 +
141.331 +lemma Nle0_iff[simp]:
141.332 + assumes nx: "isnormNum x"
141.333 + shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero}) \<le> 0) = 0\<ge>\<^sub>N x"
141.334 +proof -
141.335 + obtain a b where x: "x = (a, b)" by (cases x)
141.336 + { assume "a = 0" hence ?thesis by (simp add: x Nle0_def INum_def) }
141.337 + moreover
141.338 + { assume a: "a \<noteq> 0" hence b: "(of_int b :: 'a) > 0"
141.339 + using nx by (simp add: x isnormNum_def)
141.340 + from pos_divide_le_eq[OF b, where b="of_int a" and a="0::'a"]
141.341 + have ?thesis by (simp add: x Nle0_def INum_def) }
141.342 + ultimately show ?thesis by blast
141.343 +qed
141.344 +
141.345 +lemma Ngt0_iff[simp]:
141.346 + assumes nx: "isnormNum x"
141.347 + shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero})> 0) = 0<\<^sub>N x"
141.348 +proof -
141.349 + obtain a b where x: "x = (a, b)" by (cases x)
141.350 + { assume "a = 0" hence ?thesis by (simp add: x Ngt0_def INum_def) }
141.351 + moreover
141.352 + { assume a: "a \<noteq> 0" hence b: "(of_int b::'a) > 0" using nx
141.353 + by (simp add: x isnormNum_def)
141.354 + from pos_less_divide_eq[OF b, where b="of_int a" and a="0::'a"]
141.355 + have ?thesis by (simp add: x Ngt0_def INum_def) }
141.356 + ultimately show ?thesis by blast
141.357 +qed
141.358 +
141.359 +lemma Nge0_iff[simp]:
141.360 + assumes nx: "isnormNum x"
141.361 + shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero}) \<ge> 0) = 0\<le>\<^sub>N x"
141.362 +proof -
141.363 + obtain a b where x: "x = (a, b)" by (cases x)
141.364 + { assume "a = 0" hence ?thesis by (simp add: x Nge0_def INum_def) }
141.365 + moreover
141.366 + { assume "a \<noteq> 0" hence b: "(of_int b::'a) > 0" using nx
141.367 + by (simp add: x isnormNum_def)
141.368 + from pos_le_divide_eq[OF b, where b="of_int a" and a="0::'a"]
141.369 + have ?thesis by (simp add: x Nge0_def INum_def) }
141.370 + ultimately show ?thesis by blast
141.371 +qed
141.372 +
141.373 +lemma Nlt_iff[simp]:
141.374 + assumes nx: "isnormNum x" and ny: "isnormNum y"
141.375 + shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero}) < INum y) = (x <\<^sub>N y)"
141.376 +proof -
141.377 + let ?z = "0::'a"
141.378 + have "((INum x ::'a) < INum y) = (INum (x -\<^sub>N y) < ?z)"
141.379 + using nx ny by simp
141.380 + also have "\<dots> = (0>\<^sub>N (x -\<^sub>N y))"
141.381 + using Nlt0_iff[OF Nsub_normN[OF ny]] by simp
141.382 + finally show ?thesis by (simp add: Nlt_def)
141.383 +qed
141.384 +
141.385 +lemma Nle_iff[simp]:
141.386 + assumes nx: "isnormNum x" and ny: "isnormNum y"
141.387 + shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero})\<le> INum y) = (x \<le>\<^sub>N y)"
141.388 +proof -
141.389 + have "((INum x ::'a) \<le> INum y) = (INum (x -\<^sub>N y) \<le> (0::'a))"
141.390 + using nx ny by simp
141.391 + also have "\<dots> = (0\<ge>\<^sub>N (x -\<^sub>N y))"
141.392 + using Nle0_iff[OF Nsub_normN[OF ny]] by simp
141.393 + finally show ?thesis by (simp add: Nle_def)
141.394 +qed
141.395 +
141.396 +lemma Nadd_commute:
141.397 + assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
141.398 + shows "x +\<^sub>N y = y +\<^sub>N x"
141.399 +proof -
141.400 + have n: "isnormNum (x +\<^sub>N y)" "isnormNum (y +\<^sub>N x)" by simp_all
141.401 + have "(INum (x +\<^sub>N y)::'a) = INum (y +\<^sub>N x)" by simp
141.402 + with isnormNum_unique[OF n] show ?thesis by simp
141.403 +qed
141.404 +
141.405 +lemma [simp]:
141.406 + assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
141.407 + shows "(0, b) +\<^sub>N y = normNum y"
141.408 + and "(a, 0) +\<^sub>N y = normNum y"
141.409 + and "x +\<^sub>N (0, b) = normNum x"
141.410 + and "x +\<^sub>N (a, 0) = normNum x"
141.411 + apply (simp add: Nadd_def split_def)
141.412 + apply (simp add: Nadd_def split_def)
141.413 + apply (subst Nadd_commute, simp add: Nadd_def split_def)
141.414 + apply (subst Nadd_commute, simp add: Nadd_def split_def)
141.415 + done
141.416 +
141.417 +lemma normNum_nilpotent_aux[simp]:
141.418 + assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
141.419 + assumes nx: "isnormNum x"
141.420 + shows "normNum x = x"
141.421 +proof -
141.422 + let ?a = "normNum x"
141.423 + have n: "isnormNum ?a" by simp
141.424 + have th: "INum ?a = (INum x ::'a)" by simp
141.425 + with isnormNum_unique[OF n nx] show ?thesis by simp
141.426 +qed
141.427 +
141.428 +lemma normNum_nilpotent[simp]:
141.429 + assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
141.430 + shows "normNum (normNum x) = normNum x"
141.431 + by simp
141.432 +
141.433 +lemma normNum0[simp]: "normNum (0,b) = 0\<^sub>N" "normNum (a,0) = 0\<^sub>N"
141.434 + by (simp_all add: normNum_def)
141.435 +
141.436 +lemma normNum_Nadd:
141.437 + assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
141.438 + shows "normNum (x +\<^sub>N y) = x +\<^sub>N y" by simp
141.439 +
141.440 +lemma Nadd_normNum1[simp]:
141.441 + assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
141.442 + shows "normNum x +\<^sub>N y = x +\<^sub>N y"
141.443 +proof -
141.444 + have n: "isnormNum (normNum x +\<^sub>N y)" "isnormNum (x +\<^sub>N y)" by simp_all
141.445 + have "INum (normNum x +\<^sub>N y) = INum x + (INum y :: 'a)" by simp
141.446 + also have "\<dots> = INum (x +\<^sub>N y)" by simp
141.447 + finally show ?thesis using isnormNum_unique[OF n] by simp
141.448 +qed
141.449 +
141.450 +lemma Nadd_normNum2[simp]:
141.451 + assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
141.452 + shows "x +\<^sub>N normNum y = x +\<^sub>N y"
141.453 +proof -
141.454 + have n: "isnormNum (x +\<^sub>N normNum y)" "isnormNum (x +\<^sub>N y)" by simp_all
141.455 + have "INum (x +\<^sub>N normNum y) = INum x + (INum y :: 'a)" by simp
141.456 + also have "\<dots> = INum (x +\<^sub>N y)" by simp
141.457 + finally show ?thesis using isnormNum_unique[OF n] by simp
141.458 +qed
141.459 +
141.460 +lemma Nadd_assoc:
141.461 + assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
141.462 + shows "x +\<^sub>N y +\<^sub>N z = x +\<^sub>N (y +\<^sub>N z)"
141.463 +proof -
141.464 + have n: "isnormNum (x +\<^sub>N y +\<^sub>N z)" "isnormNum (x +\<^sub>N (y +\<^sub>N z))" by simp_all
141.465 + have "INum (x +\<^sub>N y +\<^sub>N z) = (INum (x +\<^sub>N (y +\<^sub>N z)) :: 'a)" by simp
141.466 + with isnormNum_unique[OF n] show ?thesis by simp
141.467 +qed
141.468 +
141.469 +lemma Nmul_commute: "isnormNum x \<Longrightarrow> isnormNum y \<Longrightarrow> x *\<^sub>N y = y *\<^sub>N x"
141.470 + by (simp add: Nmul_def split_def Let_def gcd_commute_int mult_commute)
141.471 +
141.472 +lemma Nmul_assoc:
141.473 + assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
141.474 + assumes nx: "isnormNum x" and ny: "isnormNum y" and nz: "isnormNum z"
141.475 + shows "x *\<^sub>N y *\<^sub>N z = x *\<^sub>N (y *\<^sub>N z)"
141.476 +proof -
141.477 + from nx ny nz have n: "isnormNum (x *\<^sub>N y *\<^sub>N z)" "isnormNum (x *\<^sub>N (y *\<^sub>N z))"
141.478 + by simp_all
141.479 + have "INum (x +\<^sub>N y +\<^sub>N z) = (INum (x +\<^sub>N (y +\<^sub>N z)) :: 'a)" by simp
141.480 + with isnormNum_unique[OF n] show ?thesis by simp
141.481 +qed
141.482 +
141.483 +lemma Nsub0:
141.484 + assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
141.485 + assumes x: "isnormNum x" and y: "isnormNum y"
141.486 + shows "x -\<^sub>N y = 0\<^sub>N \<longleftrightarrow> x = y"
141.487 +proof -
141.488 + fix h :: 'a
141.489 + from isnormNum_unique[where 'a = 'a, OF Nsub_normN[OF y], where y="0\<^sub>N"]
141.490 + have "(x -\<^sub>N y = 0\<^sub>N) = (INum (x -\<^sub>N y) = (INum 0\<^sub>N :: 'a)) " by simp
141.491 + also have "\<dots> = (INum x = (INum y :: 'a))" by simp
141.492 + also have "\<dots> = (x = y)" using x y by simp
141.493 + finally show ?thesis .
141.494 +qed
141.495 +
141.496 +lemma Nmul0[simp]: "c *\<^sub>N 0\<^sub>N = 0\<^sub>N" " 0\<^sub>N *\<^sub>N c = 0\<^sub>N"
141.497 + by (simp_all add: Nmul_def Let_def split_def)
141.498 +
141.499 +lemma Nmul_eq0[simp]:
141.500 + assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
141.501 + assumes nx: "isnormNum x" and ny: "isnormNum y"
141.502 + shows "x*\<^sub>N y = 0\<^sub>N \<longleftrightarrow> x = 0\<^sub>N \<or> y = 0\<^sub>N"
141.503 +proof -
141.504 + fix h :: 'a
141.505 + obtain a b where x: "x = (a, b)" by (cases x)
141.506 + obtain a' b' where y: "y = (a', b')" by (cases y)
141.507 + have n0: "isnormNum 0\<^sub>N" by simp
141.508 + show ?thesis using nx ny
141.509 + apply (simp only: isnormNum_unique[where ?'a = 'a, OF Nmul_normN[OF nx ny] n0, symmetric]
141.510 + Nmul[where ?'a = 'a])
141.511 + apply (simp add: x y INum_def split_def isnormNum_def split: split_if_asm)
141.512 + done
141.513 +qed
141.514 +
141.515 +lemma Nneg_Nneg[simp]: "~\<^sub>N (~\<^sub>N c) = c"
141.516 + by (simp add: Nneg_def split_def)
141.517 +
141.518 +lemma Nmul1[simp]:
141.519 + "isnormNum c \<Longrightarrow> (1)\<^sub>N *\<^sub>N c = c"
141.520 + "isnormNum c \<Longrightarrow> c *\<^sub>N (1)\<^sub>N = c"
141.521 + apply (simp_all add: Nmul_def Let_def split_def isnormNum_def)
141.522 + apply (cases "fst c = 0", simp_all, cases c, simp_all)+
141.523 + done
141.524 +
141.525 +end
142.1 --- a/src/HOL/Decision_Procs/Reflected_Multivariate_Polynomial.thy Thu Dec 05 17:52:12 2013 +0100
142.2 +++ b/src/HOL/Decision_Procs/Reflected_Multivariate_Polynomial.thy Thu Dec 05 17:58:03 2013 +0100
142.3 @@ -5,7 +5,7 @@
142.4 header {* Implementation and verification of multivariate polynomials *}
142.5
142.6 theory Reflected_Multivariate_Polynomial
142.7 -imports Complex_Main "~~/src/HOL/Library/Abstract_Rat" Polynomial_List
142.8 +imports Complex_Main Rat_Pair Polynomial_List
142.9 begin
142.10
142.11 subsection{* Datatype of polynomial expressions *}
142.12 @@ -1256,12 +1256,10 @@
142.13 apply (case_tac n', simp, simp)
142.14 apply (case_tac n, simp, simp)
142.15 apply (case_tac n, case_tac n', simp add: Let_def)
142.16 - apply (case_tac "pa +\<^sub>p p' = 0\<^sub>p")
142.17 - apply (auto simp add: polyadd_eq_const_degree)
142.18 + apply (auto simp add: polyadd_eq_const_degree)[2]
142.19 apply (metis head_nz)
142.20 apply (metis head_nz)
142.21 apply (metis degree.simps(9) gr0_conv_Suc head.simps(1) less_Suc0 not_less_eq)
142.22 - apply (metis degree.simps(9) gr0_conv_Suc nat_less_le order_le_less_trans)
142.23 done
142.24
142.25 lemma polymul_head_polyeq:
143.1 --- a/src/HOL/Decision_Procs/mir_tac.ML Thu Dec 05 17:52:12 2013 +0100
143.2 +++ b/src/HOL/Decision_Procs/mir_tac.ML Thu Dec 05 17:58:03 2013 +0100
143.3 @@ -34,7 +34,7 @@
143.4 @{thm "divide_zero"},
143.5 @{thm "divide_divide_eq_left"}, @{thm "times_divide_eq_right"},
143.6 @{thm "times_divide_eq_left"}, @{thm "divide_divide_eq_right"},
143.7 - @{thm "diff_minus"}, @{thm "minus_divide_left"}]
143.8 + @{thm uminus_add_conv_diff [symmetric]}, @{thm "minus_divide_left"}]
143.9 val comp_ths = ths @ comp_arith @ @{thms simp_thms};
143.10
143.11
144.1 --- a/src/HOL/Deriv.thy Thu Dec 05 17:52:12 2013 +0100
144.2 +++ b/src/HOL/Deriv.thy Thu Dec 05 17:58:03 2013 +0100
144.3 @@ -98,7 +98,7 @@
144.4
144.5 lemma FDERIV_diff[simp, FDERIV_intros]:
144.6 "(f has_derivative f') F \<Longrightarrow> (g has_derivative g') F \<Longrightarrow> ((\<lambda>x. f x - g x) has_derivative (\<lambda>x. f' x - g' x)) F"
144.7 - by (simp only: diff_minus FDERIV_add FDERIV_minus)
144.8 + by (simp only: diff_conv_add_uminus FDERIV_add FDERIV_minus)
144.9
144.10 abbreviation
144.11 -- {* Frechet derivative: D is derivative of function f at x within s *}
144.12 @@ -718,13 +718,13 @@
144.13 ((%x. (f(x)-f(a)) / (x-a)) -- a --> D)"
144.14 apply (rule iffI)
144.15 apply (drule_tac k="- a" in LIM_offset)
144.16 -apply (simp add: diff_minus)
144.17 +apply simp
144.18 apply (drule_tac k="a" in LIM_offset)
144.19 apply (simp add: add_commute)
144.20 done
144.21
144.22 lemma DERIV_iff2: "(DERIV f x :> D) \<longleftrightarrow> (\<lambda>z. (f z - f x) / (z - x)) --x --> D"
144.23 - by (simp add: deriv_def diff_minus [symmetric] DERIV_LIM_iff)
144.24 + by (simp add: deriv_def DERIV_LIM_iff)
144.25
144.26 lemma DERIV_cong_ev: "x = y \<Longrightarrow> eventually (\<lambda>x. f x = g x) (nhds x) \<Longrightarrow> u = v \<Longrightarrow>
144.27 DERIV f x :> u \<longleftrightarrow> DERIV g y :> v"
144.28 @@ -758,8 +758,7 @@
144.29 let ?g = "(%z. if z = x then l else (f z - f x) / (z-x))"
144.30 show "\<forall>z. f z - f x = ?g z * (z-x)" by simp
144.31 show "isCont ?g x" using der
144.32 - by (simp add: isCont_iff DERIV_iff diff_minus
144.33 - cong: LIM_equal [rule_format])
144.34 + by (simp add: isCont_iff DERIV_iff cong: LIM_equal [rule_format])
144.35 show "?g x = l" by simp
144.36 qed
144.37 next
144.38 @@ -787,7 +786,7 @@
144.39 proof -
144.40 from l der [THEN DERIV_D, THEN LIM_D [where r = "l"]]
144.41 have "\<exists>s > 0. (\<forall>z. z \<noteq> 0 \<and> \<bar>z\<bar> < s \<longrightarrow> \<bar>(f(x+z) - f x) / z - l\<bar> < l)"
144.42 - by (simp add: diff_minus)
144.43 + by simp
144.44 then obtain s
144.45 where s: "0 < s"
144.46 and all: "!!z. z \<noteq> 0 \<and> \<bar>z\<bar> < s \<longrightarrow> \<bar>(f(x+z) - f x) / z - l\<bar> < l"
144.47 @@ -798,8 +797,7 @@
144.48 fix h::real
144.49 assume "0 < h" "h < s"
144.50 with all [of h] show "f x < f (x+h)"
144.51 - proof (simp add: abs_if pos_less_divide_eq diff_minus [symmetric]
144.52 - split add: split_if_asm)
144.53 + proof (simp add: abs_if pos_less_divide_eq split add: split_if_asm)
144.54 assume "~ (f (x+h) - f x) / h < l" and h: "0 < h"
144.55 with l
144.56 have "0 < (f (x+h) - f x) / h" by arith
144.57 @@ -817,7 +815,7 @@
144.58 proof -
144.59 from l der [THEN DERIV_D, THEN LIM_D [where r = "-l"]]
144.60 have "\<exists>s > 0. (\<forall>z. z \<noteq> 0 \<and> \<bar>z\<bar> < s \<longrightarrow> \<bar>(f(x+z) - f x) / z - l\<bar> < -l)"
144.61 - by (simp add: diff_minus)
144.62 + by simp
144.63 then obtain s
144.64 where s: "0 < s"
144.65 and all: "!!z. z \<noteq> 0 \<and> \<bar>z\<bar> < s \<longrightarrow> \<bar>(f(x+z) - f x) / z - l\<bar> < -l"
144.66 @@ -828,8 +826,7 @@
144.67 fix h::real
144.68 assume "0 < h" "h < s"
144.69 with all [of "-h"] show "f x < f (x-h)"
144.70 - proof (simp add: abs_if pos_less_divide_eq diff_minus [symmetric]
144.71 - split add: split_if_asm)
144.72 + proof (simp add: abs_if pos_less_divide_eq split add: split_if_asm)
144.73 assume " - ((f (x-h) - f x) / h) < l" and h: "0 < h"
144.74 with l
144.75 have "0 < (f (x-h) - f x) / h" by arith
144.76 @@ -1131,7 +1128,7 @@
144.77 apply (rule linorder_cases [of a b], auto)
144.78 apply (drule_tac [!] f = f in MVT)
144.79 apply (auto dest: DERIV_isCont DERIV_unique simp add: differentiable_def)
144.80 -apply (auto dest: DERIV_unique simp add: ring_distribs diff_minus)
144.81 +apply (auto dest: DERIV_unique simp add: ring_distribs)
144.82 done
144.83
144.84 lemma DERIV_const_ratio_const2:
145.1 --- a/src/HOL/Divides.thy Thu Dec 05 17:52:12 2013 +0100
145.2 +++ b/src/HOL/Divides.thy Thu Dec 05 17:58:03 2013 +0100
145.3 @@ -53,6 +53,16 @@
145.4 shows "(a + b * c) div b = c + a div b"
145.5 using assms div_mult_self1 [of b a c] by (simp add: mult_commute)
145.6
145.7 +lemma div_mult_self3 [simp]:
145.8 + assumes "b \<noteq> 0"
145.9 + shows "(c * b + a) div b = c + a div b"
145.10 + using assms by (simp add: add.commute)
145.11 +
145.12 +lemma div_mult_self4 [simp]:
145.13 + assumes "b \<noteq> 0"
145.14 + shows "(b * c + a) div b = c + a div b"
145.15 + using assms by (simp add: add.commute)
145.16 +
145.17 lemma mod_mult_self1 [simp]: "(a + c * b) mod b = a mod b"
145.18 proof (cases "b = 0")
145.19 case True then show ?thesis by simp
145.20 @@ -70,9 +80,18 @@
145.21 then show ?thesis by simp
145.22 qed
145.23
145.24 -lemma mod_mult_self2 [simp]: "(a + b * c) mod b = a mod b"
145.25 +lemma mod_mult_self2 [simp]:
145.26 + "(a + b * c) mod b = a mod b"
145.27 by (simp add: mult_commute [of b])
145.28
145.29 +lemma mod_mult_self3 [simp]:
145.30 + "(c * b + a) mod b = a mod b"
145.31 + by (simp add: add.commute)
145.32 +
145.33 +lemma mod_mult_self4 [simp]:
145.34 + "(b * c + a) mod b = a mod b"
145.35 + by (simp add: add.commute)
145.36 +
145.37 lemma div_mult_self1_is_id [simp]: "b \<noteq> 0 \<Longrightarrow> b * a div b = a"
145.38 using div_mult_self2 [of b 0 a] by simp
145.39
145.40 @@ -420,24 +439,23 @@
145.41
145.42 text {* Subtraction respects modular equivalence. *}
145.43
145.44 -lemma mod_diff_left_eq: "(a - b) mod c = (a mod c - b) mod c"
145.45 - unfolding diff_minus
145.46 - by (intro mod_add_cong mod_minus_cong) simp_all
145.47 -
145.48 -lemma mod_diff_right_eq: "(a - b) mod c = (a - b mod c) mod c"
145.49 - unfolding diff_minus
145.50 - by (intro mod_add_cong mod_minus_cong) simp_all
145.51 -
145.52 -lemma mod_diff_eq: "(a - b) mod c = (a mod c - b mod c) mod c"
145.53 - unfolding diff_minus
145.54 - by (intro mod_add_cong mod_minus_cong) simp_all
145.55 +lemma mod_diff_left_eq:
145.56 + "(a - b) mod c = (a mod c - b) mod c"
145.57 + using mod_add_cong [of a c "a mod c" "- b" "- b"] by simp
145.58 +
145.59 +lemma mod_diff_right_eq:
145.60 + "(a - b) mod c = (a - b mod c) mod c"
145.61 + using mod_add_cong [of a c a "- b" "- (b mod c)"] mod_minus_cong [of "b mod c" c b] by simp
145.62 +
145.63 +lemma mod_diff_eq:
145.64 + "(a - b) mod c = (a mod c - b mod c) mod c"
145.65 + using mod_add_cong [of a c "a mod c" "- b" "- (b mod c)"] mod_minus_cong [of "b mod c" c b] by simp
145.66
145.67 lemma mod_diff_cong:
145.68 assumes "a mod c = a' mod c"
145.69 assumes "b mod c = b' mod c"
145.70 shows "(a - b) mod c = (a' - b') mod c"
145.71 - unfolding diff_minus using assms
145.72 - by (intro mod_add_cong mod_minus_cong)
145.73 + using assms mod_add_cong [of a c a' "- b" "- b'"] mod_minus_cong [of b c "b'"] by simp
145.74
145.75 lemma dvd_neg_div: "y dvd x \<Longrightarrow> -x div y = - (x div y)"
145.76 apply (case_tac "y = 0") apply simp
145.77 @@ -477,6 +495,34 @@
145.78 lemma mod_minus1_right [simp]: "a mod (-1) = 0"
145.79 using mod_minus_right [of a 1] by simp
145.80
145.81 +lemma minus_mod_self2 [simp]:
145.82 + "(a - b) mod b = a mod b"
145.83 + by (simp add: mod_diff_right_eq)
145.84 +
145.85 +lemma minus_mod_self1 [simp]:
145.86 + "(b - a) mod b = - a mod b"
145.87 + using mod_add_self2 [of "- a" b] by simp
145.88 +
145.89 +end
145.90 +
145.91 +class semiring_div_parity = semiring_div + semiring_numeral +
145.92 + assumes parity: "a mod 2 = 0 \<or> a mod 2 = 1"
145.93 +begin
145.94 +
145.95 +lemma parity_cases [case_names even odd]:
145.96 + assumes "a mod 2 = 0 \<Longrightarrow> P"
145.97 + assumes "a mod 2 = 1 \<Longrightarrow> P"
145.98 + shows P
145.99 + using assms parity by blast
145.100 +
145.101 +lemma not_mod_2_eq_0_eq_1 [simp]:
145.102 + "a mod 2 \<noteq> 0 \<longleftrightarrow> a mod 2 = 1"
145.103 + by (cases a rule: parity_cases) simp_all
145.104 +
145.105 +lemma not_mod_2_eq_1_eq_0 [simp]:
145.106 + "a mod 2 \<noteq> 1 \<longleftrightarrow> a mod 2 = 0"
145.107 + by (cases a rule: parity_cases) simp_all
145.108 +
145.109 end
145.110
145.111
145.112 @@ -490,7 +536,6 @@
145.113 and less technical class hierarchy.
145.114 *}
145.115
145.116 -
145.117 class semiring_numeral_div = linordered_semidom + minus + semiring_div +
145.118 assumes diff_invert_add1: "a + b = c \<Longrightarrow> a = c - b"
145.119 and le_add_diff_inverse2: "b \<le> a \<Longrightarrow> a - b + b = a"
145.120 @@ -510,18 +555,21 @@
145.121 "a - 0 = a"
145.122 by (rule diff_invert_add1 [symmetric]) simp
145.123
145.124 -lemma parity:
145.125 - "a mod 2 = 0 \<or> a mod 2 = 1"
145.126 -proof (rule ccontr)
145.127 - assume "\<not> (a mod 2 = 0 \<or> a mod 2 = 1)"
145.128 - then have "a mod 2 \<noteq> 0" and "a mod 2 \<noteq> 1" by simp_all
145.129 - have "0 < 2" by simp
145.130 - with pos_mod_bound pos_mod_sign have "0 \<le> a mod 2" "a mod 2 < 2" by simp_all
145.131 - with `a mod 2 \<noteq> 0` have "0 < a mod 2" by simp
145.132 - with discrete have "1 \<le> a mod 2" by simp
145.133 - with `a mod 2 \<noteq> 1` have "1 < a mod 2" by simp
145.134 - with discrete have "2 \<le> a mod 2" by simp
145.135 - with `a mod 2 < 2` show False by simp
145.136 +subclass semiring_div_parity
145.137 +proof
145.138 + fix a
145.139 + show "a mod 2 = 0 \<or> a mod 2 = 1"
145.140 + proof (rule ccontr)
145.141 + assume "\<not> (a mod 2 = 0 \<or> a mod 2 = 1)"
145.142 + then have "a mod 2 \<noteq> 0" and "a mod 2 \<noteq> 1" by simp_all
145.143 + have "0 < 2" by simp
145.144 + with pos_mod_bound pos_mod_sign have "0 \<le> a mod 2" "a mod 2 < 2" by simp_all
145.145 + with `a mod 2 \<noteq> 0` have "0 < a mod 2" by simp
145.146 + with discrete have "1 \<le> a mod 2" by simp
145.147 + with `a mod 2 \<noteq> 1` have "1 < a mod 2" by simp
145.148 + with discrete have "2 \<le> a mod 2" by simp
145.149 + with `a mod 2 < 2` show False by simp
145.150 + qed
145.151 qed
145.152
145.153 lemma divmod_digit_1:
145.154 @@ -1697,7 +1745,7 @@
145.155 val div_mod_eqs = map mk_meta_eq [@{thm div_mod_equality}, @{thm div_mod_equality2}];
145.156
145.157 val prove_eq_sums = Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac
145.158 - (@{thm diff_minus} :: @{thms add_0s} @ @{thms add_ac}))
145.159 + (@{thm diff_conv_add_uminus} :: @{thms add_0s} @ @{thms add_ac}))
145.160 )
145.161 *}
145.162
145.163 @@ -1871,10 +1919,9 @@
145.164 val zero = @{term "0 :: int"}
145.165 val less = @{term "op < :: int \<Rightarrow> int \<Rightarrow> bool"}
145.166 val le = @{term "op \<le> :: int \<Rightarrow> int \<Rightarrow> bool"}
145.167 - val simps = @{thms arith_simps} @ @{thms rel_simps} @
145.168 - map (fn th => th RS sym) [@{thm numeral_1_eq_1}]
145.169 - fun prove ctxt goal = Goal.prove ctxt [] [] (HOLogic.mk_Trueprop goal)
145.170 - (K (ALLGOALS (full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps simps))));
145.171 + val simps = @{thms arith_simps} @ @{thms rel_simps} @ [@{thm numeral_1_eq_1 [symmetric]}]
145.172 + fun prove ctxt goal = (writeln "prove"; Goal.prove ctxt [] [] (HOLogic.mk_Trueprop goal)
145.173 + (K (ALLGOALS (full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps simps)))));
145.174 fun binary_proc proc ctxt ct =
145.175 (case Thm.term_of ct of
145.176 _ $ t $ u =>
145.177 @@ -1897,23 +1944,23 @@
145.178
145.179 simproc_setup binary_int_div
145.180 ("numeral m div numeral n :: int" |
145.181 - "numeral m div neg_numeral n :: int" |
145.182 - "neg_numeral m div numeral n :: int" |
145.183 - "neg_numeral m div neg_numeral n :: int") =
145.184 + "numeral m div - numeral n :: int" |
145.185 + "- numeral m div numeral n :: int" |
145.186 + "- numeral m div - numeral n :: int") =
145.187 {* K (divmod_proc @{thm int_div_pos_eq} @{thm int_div_neg_eq}) *}
145.188
145.189 simproc_setup binary_int_mod
145.190 ("numeral m mod numeral n :: int" |
145.191 - "numeral m mod neg_numeral n :: int" |
145.192 - "neg_numeral m mod numeral n :: int" |
145.193 - "neg_numeral m mod neg_numeral n :: int") =
145.194 + "numeral m mod - numeral n :: int" |
145.195 + "- numeral m mod numeral n :: int" |
145.196 + "- numeral m mod - numeral n :: int") =
145.197 {* K (divmod_proc @{thm int_mod_pos_eq} @{thm int_mod_neg_eq}) *}
145.198
145.199 lemmas posDivAlg_eqn_numeral [simp] =
145.200 posDivAlg_eqn [of "numeral v" "numeral w", OF zero_less_numeral] for v w
145.201
145.202 lemmas negDivAlg_eqn_numeral [simp] =
145.203 - negDivAlg_eqn [of "numeral v" "neg_numeral w", OF zero_less_numeral] for v w
145.204 + negDivAlg_eqn [of "numeral v" "- numeral w", OF zero_less_numeral] for v w
145.205
145.206
145.207 text{*Special-case simplification *}
145.208 @@ -1925,14 +1972,14 @@
145.209 div_pos_pos [OF zero_less_one, of "numeral w", OF zero_le_numeral] for w
145.210
145.211 lemmas div_pos_neg_1_numeral [simp] =
145.212 - div_pos_neg [OF zero_less_one, of "neg_numeral w",
145.213 + div_pos_neg [OF zero_less_one, of "- numeral w",
145.214 OF neg_numeral_less_zero] for w
145.215
145.216 lemmas mod_pos_pos_1_numeral [simp] =
145.217 mod_pos_pos [OF zero_less_one, of "numeral w", OF zero_le_numeral] for w
145.218
145.219 lemmas mod_pos_neg_1_numeral [simp] =
145.220 - mod_pos_neg [OF zero_less_one, of "neg_numeral w",
145.221 + mod_pos_neg [OF zero_less_one, of "- numeral w",
145.222 OF neg_numeral_less_zero] for w
145.223
145.224 lemmas posDivAlg_eqn_1_numeral [simp] =
145.225 @@ -2242,6 +2289,8 @@
145.226 shows "divmod_int_rel (1 + 2*a) (2*b) (q, 1 + 2*r)"
145.227 using assms unfolding divmod_int_rel_def by auto
145.228
145.229 +declaration {* K (Lin_Arith.add_simps @{thms uminus_numeral_One}) *}
145.230 +
145.231 lemma neg_divmod_int_rel_mult_2:
145.232 assumes "b \<le> 0"
145.233 assumes "divmod_int_rel (a + 1) b (q, r)"
145.234 @@ -2379,13 +2428,13 @@
145.235
145.236 lemma dvd_neg_numeral_left [simp]:
145.237 fixes y :: "'a::comm_ring_1"
145.238 - shows "(neg_numeral k) dvd y \<longleftrightarrow> (numeral k) dvd y"
145.239 - unfolding neg_numeral_def minus_dvd_iff ..
145.240 + shows "(- numeral k) dvd y \<longleftrightarrow> (numeral k) dvd y"
145.241 + by (fact minus_dvd_iff)
145.242
145.243 lemma dvd_neg_numeral_right [simp]:
145.244 fixes x :: "'a::comm_ring_1"
145.245 - shows "x dvd (neg_numeral k) \<longleftrightarrow> x dvd (numeral k)"
145.246 - unfolding neg_numeral_def dvd_minus_iff ..
145.247 + shows "x dvd (- numeral k) \<longleftrightarrow> x dvd (numeral k)"
145.248 + by (fact dvd_minus_iff)
145.249
145.250 lemmas dvd_eq_mod_eq_0_numeral [simp] =
145.251 dvd_eq_mod_eq_0 [of "numeral x" "numeral y"] for x y
145.252 @@ -2568,11 +2617,6 @@
145.253 "Suc 0 mod numeral v' = nat (1 mod numeral v')"
145.254 by (subst nat_mod_distrib) simp_all
145.255
145.256 -lemma mod_2_not_eq_zero_eq_one_int:
145.257 - fixes k :: int
145.258 - shows "k mod 2 \<noteq> 0 \<longleftrightarrow> k mod 2 = 1"
145.259 - by auto
145.260 -
145.261 instance int :: semiring_numeral_div
145.262 by intro_classes (auto intro: zmod_le_nonneg_dividend
145.263 simp add: zmult_div_cancel
146.1 --- a/src/HOL/Enum.thy Thu Dec 05 17:52:12 2013 +0100
146.2 +++ b/src/HOL/Enum.thy Thu Dec 05 17:58:03 2013 +0100
146.3 @@ -156,11 +156,11 @@
146.4 "Id = image (\<lambda>x. (x, x)) (set Enum.enum)"
146.5 by (auto intro: imageI in_enum)
146.6
146.7 -lemma tranclp_unfold [code, no_atp]:
146.8 +lemma tranclp_unfold [code]:
146.9 "tranclp r a b \<longleftrightarrow> (a, b) \<in> trancl {(x, y). r x y}"
146.10 by (simp add: trancl_def)
146.11
146.12 -lemma rtranclp_rtrancl_eq [code, no_atp]:
146.13 +lemma rtranclp_rtrancl_eq [code]:
146.14 "rtranclp r x y \<longleftrightarrow> (x, y) \<in> rtrancl {(x, y). r x y}"
146.15 by (simp add: rtrancl_def)
146.16
146.17 @@ -178,13 +178,9 @@
146.18
146.19 lemma [code]:
146.20 fixes xs :: "('a::finite \<times> 'a) list"
146.21 - shows "acc (set xs) = bacc (set xs) (card_UNIV TYPE('a))"
146.22 + shows "Wellfounded.acc (set xs) = bacc (set xs) (card_UNIV TYPE('a))"
146.23 by (simp add: card_UNIV_def acc_bacc_eq)
146.24
146.25 -lemma [code]:
146.26 - "accp r = (\<lambda>x. x \<in> acc {(x, y). r x y})"
146.27 - by (simp add: acc_def)
146.28 -
146.29
146.30 subsection {* Default instances for @{class enum} *}
146.31
147.1 --- a/src/HOL/Fields.thy Thu Dec 05 17:52:12 2013 +0100
147.2 +++ b/src/HOL/Fields.thy Thu Dec 05 17:58:03 2013 +0100
147.3 @@ -152,11 +152,11 @@
147.4 lemma nonzero_minus_divide_divide: "b \<noteq> 0 ==> (-a) / (-b) = a / b"
147.5 by (simp add: divide_inverse nonzero_inverse_minus_eq)
147.6
147.7 -lemma divide_minus_left [simp, no_atp]: "(-a) / b = - (a / b)"
147.8 +lemma divide_minus_left [simp]: "(-a) / b = - (a / b)"
147.9 by (simp add: divide_inverse)
147.10
147.11 lemma diff_divide_distrib: "(a - b) / c = a / c - b / c"
147.12 - by (simp add: diff_minus add_divide_distrib)
147.13 + using add_divide_distrib [of a "- b" c] by simp
147.14
147.15 lemma nonzero_eq_divide_eq [field_simps]: "c \<noteq> 0 \<Longrightarrow> a = b / c \<longleftrightarrow> a * c = b"
147.16 proof -
147.17 @@ -252,7 +252,7 @@
147.18 ==> inverse a + inverse b = (a + b) * inverse a * inverse b"
147.19 by (simp add: division_ring_inverse_add mult_ac)
147.20
147.21 -lemma nonzero_mult_divide_mult_cancel_left [simp, no_atp]:
147.22 +lemma nonzero_mult_divide_mult_cancel_left [simp]:
147.23 assumes [simp]: "b\<noteq>0" and [simp]: "c\<noteq>0" shows "(c*a)/(c*b) = a/b"
147.24 proof -
147.25 have "(c*a)/(c*b) = c * a * (inverse b * inverse c)"
147.26 @@ -263,7 +263,7 @@
147.27 finally show ?thesis by (simp add: divide_inverse)
147.28 qed
147.29
147.30 -lemma nonzero_mult_divide_mult_cancel_right [simp, no_atp]:
147.31 +lemma nonzero_mult_divide_mult_cancel_right [simp]:
147.32 "\<lbrakk>b \<noteq> 0; c \<noteq> 0\<rbrakk> \<Longrightarrow> (a * c) / (b * c) = a / b"
147.33 by (simp add: mult_commute [of _ c])
147.34
147.35 @@ -275,7 +275,7 @@
147.36 fraction, like a*b*c / x*y*z. The rationale for that is unclear, but
147.37 many proofs seem to need them.*}
147.38
147.39 -lemmas times_divide_eq [no_atp] = times_divide_eq_right times_divide_eq_left
147.40 +lemmas times_divide_eq = times_divide_eq_right times_divide_eq_left
147.41
147.42 lemma add_frac_eq:
147.43 assumes "y \<noteq> 0" and "z \<noteq> 0"
147.44 @@ -291,27 +291,27 @@
147.45
147.46 text{*Special Cancellation Simprules for Division*}
147.47
147.48 -lemma nonzero_mult_divide_cancel_right [simp, no_atp]:
147.49 +lemma nonzero_mult_divide_cancel_right [simp]:
147.50 "b \<noteq> 0 \<Longrightarrow> a * b / b = a"
147.51 using nonzero_mult_divide_mult_cancel_right [of 1 b a] by simp
147.52
147.53 -lemma nonzero_mult_divide_cancel_left [simp, no_atp]:
147.54 +lemma nonzero_mult_divide_cancel_left [simp]:
147.55 "a \<noteq> 0 \<Longrightarrow> a * b / a = b"
147.56 using nonzero_mult_divide_mult_cancel_left [of 1 a b] by simp
147.57
147.58 -lemma nonzero_divide_mult_cancel_right [simp, no_atp]:
147.59 +lemma nonzero_divide_mult_cancel_right [simp]:
147.60 "\<lbrakk>a \<noteq> 0; b \<noteq> 0\<rbrakk> \<Longrightarrow> b / (a * b) = 1 / a"
147.61 using nonzero_mult_divide_mult_cancel_right [of a b 1] by simp
147.62
147.63 -lemma nonzero_divide_mult_cancel_left [simp, no_atp]:
147.64 +lemma nonzero_divide_mult_cancel_left [simp]:
147.65 "\<lbrakk>a \<noteq> 0; b \<noteq> 0\<rbrakk> \<Longrightarrow> a / (a * b) = 1 / b"
147.66 using nonzero_mult_divide_mult_cancel_left [of b a 1] by simp
147.67
147.68 -lemma nonzero_mult_divide_mult_cancel_left2 [simp, no_atp]:
147.69 +lemma nonzero_mult_divide_mult_cancel_left2 [simp]:
147.70 "\<lbrakk>b \<noteq> 0; c \<noteq> 0\<rbrakk> \<Longrightarrow> (c * a) / (b * c) = a / b"
147.71 using nonzero_mult_divide_mult_cancel_left [of b c a] by (simp add: mult_ac)
147.72
147.73 -lemma nonzero_mult_divide_mult_cancel_right2 [simp, no_atp]:
147.74 +lemma nonzero_mult_divide_mult_cancel_right2 [simp]:
147.75 "\<lbrakk>b \<noteq> 0; c \<noteq> 0\<rbrakk> \<Longrightarrow> (a * c) / (c * b) = a / b"
147.76 using nonzero_mult_divide_mult_cancel_right [of b c a] by (simp add: mult_ac)
147.77
147.78 @@ -383,18 +383,18 @@
147.79 apply simp_all
147.80 done
147.81
147.82 -lemma divide_divide_eq_right [simp, no_atp]:
147.83 +lemma divide_divide_eq_right [simp]:
147.84 "a / (b / c) = (a * c) / b"
147.85 by (simp add: divide_inverse mult_ac)
147.86
147.87 -lemma divide_divide_eq_left [simp, no_atp]:
147.88 +lemma divide_divide_eq_left [simp]:
147.89 "(a / b) / c = a / (b * c)"
147.90 by (simp add: divide_inverse mult_assoc)
147.91
147.92
147.93 text {*Special Cancellation Simprules for Division*}
147.94
147.95 -lemma mult_divide_mult_cancel_left_if [simp,no_atp]:
147.96 +lemma mult_divide_mult_cancel_left_if [simp]:
147.97 shows "(c * a) / (c * b) = (if c = 0 then 0 else a / b)"
147.98 by (simp add: mult_divide_mult_cancel_left)
147.99
147.100 @@ -405,7 +405,7 @@
147.101 "- (a / b) = a / - b"
147.102 by (simp add: divide_inverse)
147.103
147.104 -lemma divide_minus_right [simp, no_atp]:
147.105 +lemma divide_minus_right [simp]:
147.106 "a / - b = - (a / b)"
147.107 by (simp add: divide_inverse)
147.108
147.109 @@ -427,29 +427,29 @@
147.110 "inverse x = 1 \<longleftrightarrow> x = 1"
147.111 by (insert inverse_eq_iff_eq [of x 1], simp)
147.112
147.113 -lemma divide_eq_0_iff [simp, no_atp]:
147.114 +lemma divide_eq_0_iff [simp]:
147.115 "a / b = 0 \<longleftrightarrow> a = 0 \<or> b = 0"
147.116 by (simp add: divide_inverse)
147.117
147.118 -lemma divide_cancel_right [simp, no_atp]:
147.119 +lemma divide_cancel_right [simp]:
147.120 "a / c = b / c \<longleftrightarrow> c = 0 \<or> a = b"
147.121 apply (cases "c=0", simp)
147.122 apply (simp add: divide_inverse)
147.123 done
147.124
147.125 -lemma divide_cancel_left [simp, no_atp]:
147.126 +lemma divide_cancel_left [simp]:
147.127 "c / a = c / b \<longleftrightarrow> c = 0 \<or> a = b"
147.128 apply (cases "c=0", simp)
147.129 apply (simp add: divide_inverse)
147.130 done
147.131
147.132 -lemma divide_eq_1_iff [simp, no_atp]:
147.133 +lemma divide_eq_1_iff [simp]:
147.134 "a / b = 1 \<longleftrightarrow> b \<noteq> 0 \<and> a = b"
147.135 apply (cases "b=0", simp)
147.136 apply (simp add: right_inverse_eq)
147.137 done
147.138
147.139 -lemma one_eq_divide_iff [simp, no_atp]:
147.140 +lemma one_eq_divide_iff [simp]:
147.141 "1 = a / b \<longleftrightarrow> b \<noteq> 0 \<and> a = b"
147.142 by (simp add: eq_commute [of 1])
147.143
147.144 @@ -559,7 +559,7 @@
147.145 done
147.146
147.147 text{*Both premises are essential. Consider -1 and 1.*}
147.148 -lemma inverse_less_iff_less [simp,no_atp]:
147.149 +lemma inverse_less_iff_less [simp]:
147.150 "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> inverse a < inverse b \<longleftrightarrow> b < a"
147.151 by (blast intro: less_imp_inverse_less dest: inverse_less_imp_less)
147.152
147.153 @@ -567,7 +567,7 @@
147.154 "a \<le> b \<Longrightarrow> 0 < a \<Longrightarrow> inverse b \<le> inverse a"
147.155 by (force simp add: le_less less_imp_inverse_less)
147.156
147.157 -lemma inverse_le_iff_le [simp,no_atp]:
147.158 +lemma inverse_le_iff_le [simp]:
147.159 "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> inverse a \<le> inverse b \<longleftrightarrow> b \<le> a"
147.160 by (blast intro: le_imp_inverse_le dest: inverse_le_imp_le)
147.161
147.162 @@ -601,7 +601,7 @@
147.163 apply (simp add: nonzero_inverse_minus_eq)
147.164 done
147.165
147.166 -lemma inverse_less_iff_less_neg [simp,no_atp]:
147.167 +lemma inverse_less_iff_less_neg [simp]:
147.168 "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> inverse a < inverse b \<longleftrightarrow> b < a"
147.169 apply (insert inverse_less_iff_less [of "-b" "-a"])
147.170 apply (simp del: inverse_less_iff_less
147.171 @@ -612,7 +612,7 @@
147.172 "a \<le> b \<Longrightarrow> b < 0 ==> inverse b \<le> inverse a"
147.173 by (force simp add: le_less less_imp_inverse_less_neg)
147.174
147.175 -lemma inverse_le_iff_le_neg [simp,no_atp]:
147.176 +lemma inverse_le_iff_le_neg [simp]:
147.177 "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> inverse a \<le> inverse b \<longleftrightarrow> b \<le> a"
147.178 by (blast intro: le_imp_inverse_le_neg dest: inverse_le_imp_le_neg)
147.179
147.180 @@ -713,11 +713,9 @@
147.181 sign_simps} to @{text field_simps} because the former can lead to case
147.182 explosions. *}
147.183
147.184 -lemmas sign_simps [no_atp] = algebra_simps
147.185 - zero_less_mult_iff mult_less_0_iff
147.186 +lemmas sign_simps = algebra_simps zero_less_mult_iff mult_less_0_iff
147.187
147.188 -lemmas (in -) sign_simps [no_atp] = algebra_simps
147.189 - zero_less_mult_iff mult_less_0_iff
147.190 +lemmas (in -) sign_simps = algebra_simps zero_less_mult_iff mult_less_0_iff
147.191
147.192 (* Only works once linear arithmetic is installed:
147.193 text{*An example:*}
147.194 @@ -847,7 +845,7 @@
147.195 fix x y :: 'a
147.196 from less_add_one show "\<exists>y. x < y" ..
147.197 from less_add_one have "x + (- 1) < (x + 1) + (- 1)" by (rule add_strict_right_mono)
147.198 - then have "x - 1 < x + 1 - 1" by (simp only: diff_minus [symmetric])
147.199 + then have "x - 1 < x + 1 - 1" by simp
147.200 then have "x - 1 < x" by (simp add: algebra_simps)
147.201 then show "\<exists>y. y < x" ..
147.202 show "x < y \<Longrightarrow> \<exists>z>x. z < y" by (blast intro!: less_half_sum gt_half_sum)
147.203 @@ -998,13 +996,13 @@
147.204
147.205 text{*Simplify expressions equated with 1*}
147.206
147.207 -lemma zero_eq_1_divide_iff [simp,no_atp]:
147.208 +lemma zero_eq_1_divide_iff [simp]:
147.209 "(0 = 1/a) = (a = 0)"
147.210 apply (cases "a=0", simp)
147.211 apply (auto simp add: nonzero_eq_divide_eq)
147.212 done
147.213
147.214 -lemma one_divide_eq_0_iff [simp,no_atp]:
147.215 +lemma one_divide_eq_0_iff [simp]:
147.216 "(1/a = 0) = (a = 0)"
147.217 apply (cases "a=0", simp)
147.218 apply (insert zero_neq_one [THEN not_sym])
147.219 @@ -1013,19 +1011,19 @@
147.220
147.221 text{*Simplify expressions such as @{text "0 < 1/x"} to @{text "0 < x"}*}
147.222
147.223 -lemma zero_le_divide_1_iff [simp, no_atp]:
147.224 +lemma zero_le_divide_1_iff [simp]:
147.225 "0 \<le> 1 / a \<longleftrightarrow> 0 \<le> a"
147.226 by (simp add: zero_le_divide_iff)
147.227
147.228 -lemma zero_less_divide_1_iff [simp, no_atp]:
147.229 +lemma zero_less_divide_1_iff [simp]:
147.230 "0 < 1 / a \<longleftrightarrow> 0 < a"
147.231 by (simp add: zero_less_divide_iff)
147.232
147.233 -lemma divide_le_0_1_iff [simp, no_atp]:
147.234 +lemma divide_le_0_1_iff [simp]:
147.235 "1 / a \<le> 0 \<longleftrightarrow> a \<le> 0"
147.236 by (simp add: divide_le_0_iff)
147.237
147.238 -lemma divide_less_0_1_iff [simp, no_atp]:
147.239 +lemma divide_less_0_1_iff [simp]:
147.240 "1 / a < 0 \<longleftrightarrow> a < 0"
147.241 by (simp add: divide_less_0_iff)
147.242
147.243 @@ -1080,62 +1078,62 @@
147.244
147.245 text{*Simplify quotients that are compared with the value 1.*}
147.246
147.247 -lemma le_divide_eq_1 [no_atp]:
147.248 +lemma le_divide_eq_1:
147.249 "(1 \<le> b / a) = ((0 < a & a \<le> b) | (a < 0 & b \<le> a))"
147.250 by (auto simp add: le_divide_eq)
147.251
147.252 -lemma divide_le_eq_1 [no_atp]:
147.253 +lemma divide_le_eq_1:
147.254 "(b / a \<le> 1) = ((0 < a & b \<le> a) | (a < 0 & a \<le> b) | a=0)"
147.255 by (auto simp add: divide_le_eq)
147.256
147.257 -lemma less_divide_eq_1 [no_atp]:
147.258 +lemma less_divide_eq_1:
147.259 "(1 < b / a) = ((0 < a & a < b) | (a < 0 & b < a))"
147.260 by (auto simp add: less_divide_eq)
147.261
147.262 -lemma divide_less_eq_1 [no_atp]:
147.263 +lemma divide_less_eq_1:
147.264 "(b / a < 1) = ((0 < a & b < a) | (a < 0 & a < b) | a=0)"
147.265 by (auto simp add: divide_less_eq)
147.266
147.267
147.268 text {*Conditional Simplification Rules: No Case Splits*}
147.269
147.270 -lemma le_divide_eq_1_pos [simp,no_atp]:
147.271 +lemma le_divide_eq_1_pos [simp]:
147.272 "0 < a \<Longrightarrow> (1 \<le> b/a) = (a \<le> b)"
147.273 by (auto simp add: le_divide_eq)
147.274
147.275 -lemma le_divide_eq_1_neg [simp,no_atp]:
147.276 +lemma le_divide_eq_1_neg [simp]:
147.277 "a < 0 \<Longrightarrow> (1 \<le> b/a) = (b \<le> a)"
147.278 by (auto simp add: le_divide_eq)
147.279
147.280 -lemma divide_le_eq_1_pos [simp,no_atp]:
147.281 +lemma divide_le_eq_1_pos [simp]:
147.282 "0 < a \<Longrightarrow> (b/a \<le> 1) = (b \<le> a)"
147.283 by (auto simp add: divide_le_eq)
147.284
147.285 -lemma divide_le_eq_1_neg [simp,no_atp]:
147.286 +lemma divide_le_eq_1_neg [simp]:
147.287 "a < 0 \<Longrightarrow> (b/a \<le> 1) = (a \<le> b)"
147.288 by (auto simp add: divide_le_eq)
147.289
147.290 -lemma less_divide_eq_1_pos [simp,no_atp]:
147.291 +lemma less_divide_eq_1_pos [simp]:
147.292 "0 < a \<Longrightarrow> (1 < b/a) = (a < b)"
147.293 by (auto simp add: less_divide_eq)
147.294
147.295 -lemma less_divide_eq_1_neg [simp,no_atp]:
147.296 +lemma less_divide_eq_1_neg [simp]:
147.297 "a < 0 \<Longrightarrow> (1 < b/a) = (b < a)"
147.298 by (auto simp add: less_divide_eq)
147.299
147.300 -lemma divide_less_eq_1_pos [simp,no_atp]:
147.301 +lemma divide_less_eq_1_pos [simp]:
147.302 "0 < a \<Longrightarrow> (b/a < 1) = (b < a)"
147.303 by (auto simp add: divide_less_eq)
147.304
147.305 -lemma divide_less_eq_1_neg [simp,no_atp]:
147.306 +lemma divide_less_eq_1_neg [simp]:
147.307 "a < 0 \<Longrightarrow> b/a < 1 <-> a < b"
147.308 by (auto simp add: divide_less_eq)
147.309
147.310 -lemma eq_divide_eq_1 [simp,no_atp]:
147.311 +lemma eq_divide_eq_1 [simp]:
147.312 "(1 = b/a) = ((a \<noteq> 0 & a = b))"
147.313 by (auto simp add: eq_divide_eq)
147.314
147.315 -lemma divide_eq_eq_1 [simp,no_atp]:
147.316 +lemma divide_eq_eq_1 [simp]:
147.317 "(b/a = 1) = ((a \<noteq> 0 & a = b))"
147.318 by (auto simp add: divide_eq_eq)
147.319
148.1 --- a/src/HOL/Finite_Set.thy Thu Dec 05 17:52:12 2013 +0100
148.2 +++ b/src/HOL/Finite_Set.thy Thu Dec 05 17:58:03 2013 +0100
148.3 @@ -18,6 +18,8 @@
148.4
148.5 simproc_setup finite_Collect ("finite (Collect P)") = {* K Set_Comprehension_Pointfree.simproc *}
148.6
148.7 +declare [[simproc del: finite_Collect]]
148.8 +
148.9 lemma finite_induct [case_names empty insert, induct set: finite]:
148.10 -- {* Discharging @{text "x \<notin> F"} entails extra work. *}
148.11 assumes "finite F"
148.12 @@ -518,7 +520,6 @@
148.13 then show ?thesis by simp
148.14 qed
148.15
148.16 -
148.17 subsection {* Class @{text finite} *}
148.18
148.19 class finite =
148.20 @@ -1188,7 +1189,7 @@
148.21 "card A > 0 \<Longrightarrow> finite A"
148.22 by (rule ccontr) simp
148.23
148.24 -lemma card_0_eq [simp, no_atp]:
148.25 +lemma card_0_eq [simp]:
148.26 "finite A \<Longrightarrow> card A = 0 \<longleftrightarrow> A = {}"
148.27 by (auto dest: mk_disjoint_insert)
148.28
148.29 @@ -1333,6 +1334,58 @@
148.30 lemma card_psubset: "finite B ==> A \<subseteq> B ==> card A < card B ==> A < B"
148.31 by (erule psubsetI, blast)
148.32
148.33 +lemma card_le_inj:
148.34 + assumes fA: "finite A"
148.35 + and fB: "finite B"
148.36 + and c: "card A \<le> card B"
148.37 + shows "\<exists>f. f ` A \<subseteq> B \<and> inj_on f A"
148.38 + using fA fB c
148.39 +proof (induct arbitrary: B rule: finite_induct)
148.40 + case empty
148.41 + then show ?case by simp
148.42 +next
148.43 + case (insert x s t)
148.44 + then show ?case
148.45 + proof (induct rule: finite_induct[OF "insert.prems"(1)])
148.46 + case 1
148.47 + then show ?case by simp
148.48 + next
148.49 + case (2 y t)
148.50 + from "2.prems"(1,2,5) "2.hyps"(1,2) have cst: "card s \<le> card t"
148.51 + by simp
148.52 + from "2.prems"(3) [OF "2.hyps"(1) cst]
148.53 + obtain f where "f ` s \<subseteq> t" "inj_on f s"
148.54 + by blast
148.55 + with "2.prems"(2) "2.hyps"(2) show ?case
148.56 + apply -
148.57 + apply (rule exI[where x = "\<lambda>z. if z = x then y else f z"])
148.58 + apply (auto simp add: inj_on_def)
148.59 + done
148.60 + qed
148.61 +qed
148.62 +
148.63 +lemma card_subset_eq:
148.64 + assumes fB: "finite B"
148.65 + and AB: "A \<subseteq> B"
148.66 + and c: "card A = card B"
148.67 + shows "A = B"
148.68 +proof -
148.69 + from fB AB have fA: "finite A"
148.70 + by (auto intro: finite_subset)
148.71 + from fA fB have fBA: "finite (B - A)"
148.72 + by auto
148.73 + have e: "A \<inter> (B - A) = {}"
148.74 + by blast
148.75 + have eq: "A \<union> (B - A) = B"
148.76 + using AB by blast
148.77 + from card_Un_disjoint[OF fA fBA e, unfolded eq c] have "card (B - A) = 0"
148.78 + by arith
148.79 + then have "B - A = {}"
148.80 + unfolding card_eq_0_iff using fA fB by simp
148.81 + with AB show "A = B"
148.82 + by blast
148.83 +qed
148.84 +
148.85 lemma insert_partition:
148.86 "\<lbrakk> x \<notin> F; \<forall>c1 \<in> insert x F. \<forall>c2 \<in> insert x F. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {} \<rbrakk>
148.87 \<Longrightarrow> x \<inter> \<Union> F = {}"
148.88 @@ -1359,6 +1412,32 @@
148.89 with fin show "P A" using major by blast
148.90 qed
148.91
148.92 +lemma finite_induct_select[consumes 1, case_names empty select]:
148.93 + assumes "finite S"
148.94 + assumes "P {}"
148.95 + assumes select: "\<And>T. T \<subset> S \<Longrightarrow> P T \<Longrightarrow> \<exists>s\<in>S - T. P (insert s T)"
148.96 + shows "P S"
148.97 +proof -
148.98 + have "0 \<le> card S" by simp
148.99 + then have "\<exists>T \<subseteq> S. card T = card S \<and> P T"
148.100 + proof (induct rule: dec_induct)
148.101 + case base with `P {}` show ?case
148.102 + by (intro exI[of _ "{}"]) auto
148.103 + next
148.104 + case (step n)
148.105 + then obtain T where T: "T \<subseteq> S" "card T = n" "P T"
148.106 + by auto
148.107 + with `n < card S` have "T \<subset> S" "P T"
148.108 + by auto
148.109 + with select[of T] obtain s where "s \<in> S" "s \<notin> T" "P (insert s T)"
148.110 + by auto
148.111 + with step(2) T `finite S` show ?case
148.112 + by (intro exI[of _ "insert s T"]) (auto dest: finite_subset)
148.113 + qed
148.114 + with `finite S` show "P S"
148.115 + by (auto dest: card_subset_eq)
148.116 +qed
148.117 +
148.118 text{* main cardinality theorem *}
148.119 lemma card_partition [rule_format]:
148.120 "finite C ==>
148.121 @@ -1411,12 +1490,10 @@
148.122 lemma card_Suc_eq:
148.123 "(card A = Suc k) =
148.124 (\<exists>b B. A = insert b B & b \<notin> B & card B = k & (k=0 \<longrightarrow> B={}))"
148.125 -apply(rule iffI)
148.126 - apply(erule card_eq_SucD)
148.127 -apply(auto)
148.128 -apply(subst card.insert)
148.129 - apply(auto intro:ccontr)
148.130 -done
148.131 + apply(auto elim!: card_eq_SucD)
148.132 + apply(subst card.insert)
148.133 + apply(auto simp add: intro:ccontr)
148.134 + done
148.135
148.136 lemma card_le_Suc_iff: "finite A \<Longrightarrow>
148.137 Suc n \<le> card A = (\<exists>a B. A = insert a B \<and> a \<notin> B \<and> n \<le> card B \<and> finite B)"
148.138 @@ -1443,11 +1520,8 @@
148.139
148.140 subsubsection {* Cardinality of image *}
148.141
148.142 -lemma card_image_le: "finite A ==> card (f ` A) <= card A"
148.143 -apply (induct rule: finite_induct)
148.144 - apply simp
148.145 -apply (simp add: le_SucI card_insert_if)
148.146 -done
148.147 +lemma card_image_le: "finite A ==> card (f ` A) \<le> card A"
148.148 + by (induct rule: finite_induct) (simp_all add: le_SucI card_insert_if)
148.149
148.150 lemma card_image:
148.151 assumes "inj_on f A"
148.152 @@ -1466,24 +1540,27 @@
148.153 by (simp add: card_seteq card_image)
148.154
148.155 lemma eq_card_imp_inj_on:
148.156 - "[| finite A; card(f ` A) = card A |] ==> inj_on f A"
148.157 -apply (induct rule:finite_induct)
148.158 -apply simp
148.159 -apply(frule card_image_le[where f = f])
148.160 -apply(simp add:card_insert_if split:if_splits)
148.161 -done
148.162 + assumes "finite A" "card(f ` A) = card A" shows "inj_on f A"
148.163 +using assms
148.164 +proof (induct rule:finite_induct)
148.165 + case empty show ?case by simp
148.166 +next
148.167 + case (insert x A)
148.168 + then show ?case using card_image_le [of A f]
148.169 + by (simp add: card_insert_if split: if_splits)
148.170 +qed
148.171
148.172 -lemma inj_on_iff_eq_card:
148.173 - "finite A ==> inj_on f A = (card(f ` A) = card A)"
148.174 -by(blast intro: card_image eq_card_imp_inj_on)
148.175 -
148.176 +lemma inj_on_iff_eq_card: "finite A \<Longrightarrow> inj_on f A \<longleftrightarrow> card(f ` A) = card A"
148.177 + by (blast intro: card_image eq_card_imp_inj_on)
148.178
148.179 lemma card_inj_on_le:
148.180 - "[|inj_on f A; f ` A \<subseteq> B; finite B |] ==> card A \<le> card B"
148.181 -apply (subgoal_tac "finite A")
148.182 - apply (force intro: card_mono simp add: card_image [symmetric])
148.183 -apply (blast intro: finite_imageD dest: finite_subset)
148.184 -done
148.185 + assumes "inj_on f A" "f ` A \<subseteq> B" "finite B" shows "card A \<le> card B"
148.186 +proof -
148.187 + have "finite A" using assms
148.188 + by (blast intro: finite_imageD dest: finite_subset)
148.189 + then show ?thesis using assms
148.190 + by (force intro: card_mono simp: card_image [symmetric])
148.191 +qed
148.192
148.193 lemma card_bij_eq:
148.194 "[|inj_on f A; f ` A \<subseteq> B; inj_on g B; g ` B \<subseteq> A;
148.195 @@ -1565,44 +1642,52 @@
148.196
148.197 subsubsection {* Cardinality of the Powerset *}
148.198
148.199 -lemma card_Pow: "finite A ==> card (Pow A) = 2 ^ card A"
148.200 -apply (induct rule: finite_induct)
148.201 - apply (simp_all add: Pow_insert)
148.202 -apply (subst card_Un_disjoint, blast)
148.203 - apply (blast, blast)
148.204 -apply (subgoal_tac "inj_on (insert x) (Pow F)")
148.205 - apply (subst mult_2)
148.206 - apply (simp add: card_image Pow_insert)
148.207 -apply (unfold inj_on_def)
148.208 -apply (blast elim!: equalityE)
148.209 -done
148.210 +lemma card_Pow: "finite A \<Longrightarrow> card (Pow A) = 2 ^ card A"
148.211 +proof (induct rule: finite_induct)
148.212 + case empty
148.213 + show ?case by auto
148.214 +next
148.215 + case (insert x A)
148.216 + then have "inj_on (insert x) (Pow A)"
148.217 + unfolding inj_on_def by (blast elim!: equalityE)
148.218 + then have "card (Pow A) + card (insert x ` Pow A) = 2 * 2 ^ card A"
148.219 + by (simp add: mult_2 card_image Pow_insert insert.hyps)
148.220 + then show ?case using insert
148.221 + apply (simp add: Pow_insert)
148.222 + apply (subst card_Un_disjoint, auto)
148.223 + done
148.224 +qed
148.225
148.226 text {* Relates to equivalence classes. Based on a theorem of F. Kamm\"uller. *}
148.227
148.228 lemma dvd_partition:
148.229 - "finite (Union C) ==>
148.230 - ALL c : C. k dvd card c ==>
148.231 - (ALL c1: C. ALL c2: C. c1 \<noteq> c2 --> c1 Int c2 = {}) ==>
148.232 - k dvd card (Union C)"
148.233 -apply (frule finite_UnionD)
148.234 -apply (rotate_tac -1)
148.235 -apply (induct rule: finite_induct)
148.236 -apply simp_all
148.237 -apply clarify
148.238 -apply (subst card_Un_disjoint)
148.239 - apply (auto simp add: disjoint_eq_subset_Compl)
148.240 -done
148.241 -
148.242 + assumes f: "finite (\<Union>C)" and "\<forall>c\<in>C. k dvd card c" "\<forall>c1\<in>C. \<forall>c2\<in>C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {}"
148.243 + shows "k dvd card (\<Union>C)"
148.244 +proof -
148.245 + have "finite C"
148.246 + by (rule finite_UnionD [OF f])
148.247 + then show ?thesis using assms
148.248 + proof (induct rule: finite_induct)
148.249 + case empty show ?case by simp
148.250 + next
148.251 + case (insert c C)
148.252 + then show ?case
148.253 + apply simp
148.254 + apply (subst card_Un_disjoint)
148.255 + apply (auto simp add: disjoint_eq_subset_Compl)
148.256 + done
148.257 + qed
148.258 +qed
148.259
148.260 subsubsection {* Relating injectivity and surjectivity *}
148.261
148.262 -lemma finite_surj_inj: "finite A \<Longrightarrow> A \<subseteq> f ` A \<Longrightarrow> inj_on f A"
148.263 -apply(rule eq_card_imp_inj_on, assumption)
148.264 -apply(frule finite_imageI)
148.265 -apply(drule (1) card_seteq)
148.266 - apply(erule card_image_le)
148.267 -apply simp
148.268 -done
148.269 +lemma finite_surj_inj: assumes "finite A" "A \<subseteq> f ` A" shows "inj_on f A"
148.270 +proof -
148.271 + have "f ` A = A"
148.272 + by (rule card_seteq [THEN sym]) (auto simp add: assms card_image_le)
148.273 + then show ?thesis using assms
148.274 + by (simp add: eq_card_imp_inj_on)
148.275 +qed
148.276
148.277 lemma finite_UNIV_surj_inj: fixes f :: "'a \<Rightarrow> 'a"
148.278 shows "finite(UNIV:: 'a set) \<Longrightarrow> surj f \<Longrightarrow> inj f"
148.279 @@ -1620,8 +1705,7 @@
148.280 show False by simp (blast dest: Suc_neq_Zero surjD)
148.281 qed
148.282
148.283 -(* Often leads to bogus ATP proofs because of reduced type information, hence no_atp *)
148.284 -lemma infinite_UNIV_char_0 [no_atp]:
148.285 +lemma infinite_UNIV_char_0:
148.286 "\<not> finite (UNIV :: 'a::semiring_char_0 set)"
148.287 proof
148.288 assume "finite (UNIV :: 'a set)"
149.1 --- a/src/HOL/Fun.thy Thu Dec 05 17:52:12 2013 +0100
149.2 +++ b/src/HOL/Fun.thy Thu Dec 05 17:58:03 2013 +0100
149.3 @@ -308,6 +308,16 @@
149.4 show ?thesis ..
149.5 qed
149.6
149.7 +lemma linorder_injI:
149.8 + assumes hyp: "\<And>x y. x < (y::'a::linorder) \<Longrightarrow> f x \<noteq> f y"
149.9 + shows "inj f"
149.10 + -- {* Courtesy of Stephan Merz *}
149.11 +proof (rule inj_onI)
149.12 + fix x y
149.13 + assume f_eq: "f x = f y"
149.14 + show "x = y" by (rule linorder_cases) (auto dest: hyp simp: f_eq)
149.15 +qed
149.16 +
149.17 lemma surj_def: "surj f \<longleftrightarrow> (\<forall>y. \<exists>x. y = f x)"
149.18 by auto
149.19
149.20 @@ -775,7 +785,7 @@
149.21
149.22 subsection {* Cantor's Paradox *}
149.23
149.24 -lemma Cantors_paradox [no_atp]:
149.25 +lemma Cantors_paradox:
149.26 "\<not>(\<exists>f. f ` A = Pow A)"
149.27 proof clarify
149.28 fix f assume "f ` A = Pow A" hence *: "Pow A \<le> f ` A" by blast
150.1 --- a/src/HOL/FunDef.thy Thu Dec 05 17:52:12 2013 +0100
150.2 +++ b/src/HOL/FunDef.thy Thu Dec 05 17:58:03 2013 +0100
150.3 @@ -310,7 +310,7 @@
150.4 ML_file "Tools/Function/scnp_reconstruct.ML"
150.5 ML_file "Tools/Function/fun_cases.ML"
150.6
150.7 -setup {* ScnpReconstruct.setup *}
150.8 +setup ScnpReconstruct.setup
150.9
150.10 ML_val -- "setup inactive"
150.11 {*
151.1 --- a/src/HOL/GCD.thy Thu Dec 05 17:52:12 2013 +0100
151.2 +++ b/src/HOL/GCD.thy Thu Dec 05 17:58:03 2013 +0100
151.3 @@ -134,6 +134,14 @@
151.4 lemma gcd_neg2_int [simp]: "gcd (x::int) (-y) = gcd x y"
151.5 by (simp add: gcd_int_def)
151.6
151.7 +lemma gcd_neg_numeral_1_int [simp]:
151.8 + "gcd (- numeral n :: int) x = gcd (numeral n) x"
151.9 + by (fact gcd_neg1_int)
151.10 +
151.11 +lemma gcd_neg_numeral_2_int [simp]:
151.12 + "gcd x (- numeral n :: int) = gcd x (numeral n)"
151.13 + by (fact gcd_neg2_int)
151.14 +
151.15 lemma abs_gcd_int[simp]: "abs(gcd (x::int) y) = gcd x y"
151.16 by(simp add: gcd_int_def)
151.17
151.18 @@ -1555,8 +1563,8 @@
151.19 interpretation gcd_lcm_complete_lattice_nat:
151.20 complete_lattice Gcd Lcm gcd Rings.dvd "\<lambda>m n. m dvd n \<and> \<not> n dvd m" lcm 1 "0::nat"
151.21 where
151.22 - "complete_lattice.INFI Gcd A f = Gcd (f ` A :: nat set)"
151.23 - and "complete_lattice.SUPR Lcm A f = Lcm (f ` A)"
151.24 + "Inf.INFI Gcd A f = Gcd (f ` A :: nat set)"
151.25 + and "Sup.SUPR Lcm A f = Lcm (f ` A)"
151.26 proof -
151.27 show "class.complete_lattice Gcd Lcm gcd Rings.dvd (\<lambda>m n. m dvd n \<and> \<not> n dvd m) lcm 1 (0::nat)"
151.28 proof
151.29 @@ -1574,8 +1582,8 @@
151.30 qed
151.31 then interpret gcd_lcm_complete_lattice_nat:
151.32 complete_lattice Gcd Lcm gcd Rings.dvd "\<lambda>m n. m dvd n \<and> \<not> n dvd m" lcm 1 "0::nat" .
151.33 - from gcd_lcm_complete_lattice_nat.INF_def show "complete_lattice.INFI Gcd A f = Gcd (f ` A)" .
151.34 - from gcd_lcm_complete_lattice_nat.SUP_def show "complete_lattice.SUPR Lcm A f = Lcm (f ` A)" .
151.35 + from gcd_lcm_complete_lattice_nat.INF_def show "Inf.INFI Gcd A f = Gcd (f ` A)" .
151.36 + from gcd_lcm_complete_lattice_nat.SUP_def show "Sup.SUPR Lcm A f = Lcm (f ` A)" .
151.37 qed
151.38
151.39 lemma Lcm_empty_nat: "Lcm {} = (1::nat)"
151.40 @@ -1654,11 +1662,11 @@
151.41 apply (metis Lcm0_iff dvd_Lcm_nat dvd_imp_le neq0_conv)
151.42 done
151.43
151.44 -lemma Lcm_set_nat [code_unfold]:
151.45 +lemma Lcm_set_nat [code, code_unfold]:
151.46 "Lcm (set ns) = fold lcm ns (1::nat)"
151.47 by (fact gcd_lcm_complete_lattice_nat.Sup_set_fold)
151.48
151.49 -lemma Gcd_set_nat [code_unfold]:
151.50 +lemma Gcd_set_nat [code, code_unfold]:
151.51 "Gcd (set ns) = fold gcd ns (0::nat)"
151.52 by (fact gcd_lcm_complete_lattice_nat.Inf_set_fold)
151.53
151.54 @@ -1730,11 +1738,11 @@
151.55 assumes "\<forall>m\<in>M. n dvd m" shows "n dvd Gcd M"
151.56 using assms by (simp add: Gcd_int_def dvd_int_iff)
151.57
151.58 -lemma Lcm_set_int [code_unfold]:
151.59 +lemma Lcm_set_int [code, code_unfold]:
151.60 "Lcm (set xs) = fold lcm xs (1::int)"
151.61 by (induct xs rule: rev_induct, simp_all add: lcm_commute_int)
151.62
151.63 -lemma Gcd_set_int [code_unfold]:
151.64 +lemma Gcd_set_int [code, code_unfold]:
151.65 "Gcd (set xs) = fold gcd xs (0::int)"
151.66 by (induct xs rule: rev_induct, simp_all add: gcd_commute_int)
151.67
152.1 --- a/src/HOL/Groebner_Basis.thy Thu Dec 05 17:52:12 2013 +0100
152.2 +++ b/src/HOL/Groebner_Basis.thy Thu Dec 05 17:58:03 2013 +0100
152.3 @@ -10,20 +10,23 @@
152.4
152.5 subsection {* Groebner Bases *}
152.6
152.7 -lemmas bool_simps = simp_thms(1-34)
152.8 +lemmas bool_simps = simp_thms(1-34) -- {* FIXME move to @{theory HOL} *}
152.9 +
152.10 +lemma nnf_simps: -- {* FIXME shadows fact binding in @{theory HOL} *}
152.11 + "(\<not>(P \<and> Q)) = (\<not>P \<or> \<not>Q)" "(\<not>(P \<or> Q)) = (\<not>P \<and> \<not>Q)"
152.12 + "(P \<longrightarrow> Q) = (\<not>P \<or> Q)"
152.13 + "(P = Q) = ((P \<and> Q) \<or> (\<not>P \<and> \<not> Q))" "(\<not> \<not>(P)) = P"
152.14 + by blast+
152.15
152.16 lemma dnf:
152.17 - "(P & (Q | R)) = ((P&Q) | (P&R))" "((Q | R) & P) = ((Q&P) | (R&P))"
152.18 - "(P \<and> Q) = (Q \<and> P)" "(P \<or> Q) = (Q \<or> P)"
152.19 + "(P & (Q | R)) = ((P&Q) | (P&R))"
152.20 + "((Q | R) & P) = ((Q&P) | (R&P))"
152.21 + "(P \<and> Q) = (Q \<and> P)"
152.22 + "(P \<or> Q) = (Q \<or> P)"
152.23 by blast+
152.24
152.25 lemmas weak_dnf_simps = dnf bool_simps
152.26
152.27 -lemma nnf_simps:
152.28 - "(\<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)"
152.29 - "(P = Q) = ((P \<and> Q) \<or> (\<not>P \<and> \<not> Q))" "(\<not> \<not>(P)) = P"
152.30 - by blast+
152.31 -
152.32 lemma PFalse:
152.33 "P \<equiv> False \<Longrightarrow> \<not> P"
152.34 "\<not> P \<Longrightarrow> (P \<equiv> False)"
153.1 --- a/src/HOL/Groups.thy Thu Dec 05 17:52:12 2013 +0100
153.2 +++ b/src/HOL/Groups.thy Thu Dec 05 17:58:03 2013 +0100
153.3 @@ -321,9 +321,13 @@
153.4
153.5 class group_add = minus + uminus + monoid_add +
153.6 assumes left_minus [simp]: "- a + a = 0"
153.7 - assumes diff_minus: "a - b = a + (- b)"
153.8 + assumes add_uminus_conv_diff [simp]: "a + (- b) = a - b"
153.9 begin
153.10
153.11 +lemma diff_conv_add_uminus:
153.12 + "a - b = a + (- b)"
153.13 + by simp
153.14 +
153.15 lemma minus_unique:
153.16 assumes "a + b = 0" shows "- a = b"
153.17 proof -
153.18 @@ -332,8 +336,6 @@
153.19 finally show ?thesis .
153.20 qed
153.21
153.22 -lemmas equals_zero_I = minus_unique (* legacy name *)
153.23 -
153.24 lemma minus_zero [simp]: "- 0 = 0"
153.25 proof -
153.26 have "0 + 0 = 0" by (rule add_0_right)
153.27 @@ -346,13 +348,17 @@
153.28 thus "- (- a) = a" by (rule minus_unique)
153.29 qed
153.30
153.31 -lemma right_minus [simp]: "a + - a = 0"
153.32 +lemma right_minus: "a + - a = 0"
153.33 proof -
153.34 have "a + - a = - (- a) + - a" by simp
153.35 also have "\<dots> = 0" by (rule left_minus)
153.36 finally show ?thesis .
153.37 qed
153.38
153.39 +lemma diff_self [simp]:
153.40 + "a - a = 0"
153.41 + using right_minus [of a] by simp
153.42 +
153.43 subclass cancel_semigroup_add
153.44 proof
153.45 fix a b c :: 'a
153.46 @@ -367,41 +373,57 @@
153.47 then show "b = c" unfolding add_assoc by simp
153.48 qed
153.49
153.50 -lemma minus_add_cancel: "- a + (a + b) = b"
153.51 -by (simp add: add_assoc [symmetric])
153.52 +lemma minus_add_cancel [simp]:
153.53 + "- a + (a + b) = b"
153.54 + by (simp add: add_assoc [symmetric])
153.55
153.56 -lemma add_minus_cancel: "a + (- a + b) = b"
153.57 -by (simp add: add_assoc [symmetric])
153.58 +lemma add_minus_cancel [simp]:
153.59 + "a + (- a + b) = b"
153.60 + by (simp add: add_assoc [symmetric])
153.61
153.62 -lemma minus_add: "- (a + b) = - b + - a"
153.63 +lemma diff_add_cancel [simp]:
153.64 + "a - b + b = a"
153.65 + by (simp only: diff_conv_add_uminus add_assoc) simp
153.66 +
153.67 +lemma add_diff_cancel [simp]:
153.68 + "a + b - b = a"
153.69 + by (simp only: diff_conv_add_uminus add_assoc) simp
153.70 +
153.71 +lemma minus_add:
153.72 + "- (a + b) = - b + - a"
153.73 proof -
153.74 have "(a + b) + (- b + - a) = 0"
153.75 - by (simp add: add_assoc add_minus_cancel)
153.76 - thus "- (a + b) = - b + - a"
153.77 + by (simp only: add_assoc add_minus_cancel) simp
153.78 + then show "- (a + b) = - b + - a"
153.79 by (rule minus_unique)
153.80 qed
153.81
153.82 -lemma right_minus_eq: "a - b = 0 \<longleftrightarrow> a = b"
153.83 +lemma right_minus_eq [simp]:
153.84 + "a - b = 0 \<longleftrightarrow> a = b"
153.85 proof
153.86 assume "a - b = 0"
153.87 - have "a = (a - b) + b" by (simp add:diff_minus add_assoc)
153.88 + have "a = (a - b) + b" by (simp add: add_assoc)
153.89 also have "\<dots> = b" using `a - b = 0` by simp
153.90 finally show "a = b" .
153.91 next
153.92 - assume "a = b" thus "a - b = 0" by (simp add: diff_minus)
153.93 + assume "a = b" thus "a - b = 0" by simp
153.94 qed
153.95
153.96 -lemma diff_self [simp]: "a - a = 0"
153.97 -by (simp add: diff_minus)
153.98 +lemma eq_iff_diff_eq_0:
153.99 + "a = b \<longleftrightarrow> a - b = 0"
153.100 + by (fact right_minus_eq [symmetric])
153.101
153.102 -lemma diff_0 [simp]: "0 - a = - a"
153.103 -by (simp add: diff_minus)
153.104 +lemma diff_0 [simp]:
153.105 + "0 - a = - a"
153.106 + by (simp only: diff_conv_add_uminus add_0_left)
153.107
153.108 -lemma diff_0_right [simp]: "a - 0 = a"
153.109 -by (simp add: diff_minus)
153.110 +lemma diff_0_right [simp]:
153.111 + "a - 0 = a"
153.112 + by (simp only: diff_conv_add_uminus minus_zero add_0_right)
153.113
153.114 -lemma diff_minus_eq_add [simp]: "a - - b = a + b"
153.115 -by (simp add: diff_minus)
153.116 +lemma diff_minus_eq_add [simp]:
153.117 + "a - - b = a + b"
153.118 + by (simp only: diff_conv_add_uminus minus_minus)
153.119
153.120 lemma neg_equal_iff_equal [simp]:
153.121 "- a = - b \<longleftrightarrow> a = b"
153.122 @@ -416,11 +438,11 @@
153.123
153.124 lemma neg_equal_0_iff_equal [simp]:
153.125 "- a = 0 \<longleftrightarrow> a = 0"
153.126 -by (subst neg_equal_iff_equal [symmetric], simp)
153.127 + by (subst neg_equal_iff_equal [symmetric]) simp
153.128
153.129 lemma neg_0_equal_iff_equal [simp]:
153.130 "0 = - a \<longleftrightarrow> 0 = a"
153.131 -by (subst neg_equal_iff_equal [symmetric], simp)
153.132 + by (subst neg_equal_iff_equal [symmetric]) simp
153.133
153.134 text{*The next two equations can make the simplifier loop!*}
153.135
153.136 @@ -438,15 +460,8 @@
153.137 thus ?thesis by (simp add: eq_commute)
153.138 qed
153.139
153.140 -lemma diff_add_cancel: "a - b + b = a"
153.141 -by (simp add: diff_minus add_assoc)
153.142 -
153.143 -lemma add_diff_cancel: "a + b - b = a"
153.144 -by (simp add: diff_minus add_assoc)
153.145 -
153.146 -declare diff_minus[symmetric, algebra_simps, field_simps]
153.147 -
153.148 -lemma eq_neg_iff_add_eq_0: "a = - b \<longleftrightarrow> a + b = 0"
153.149 +lemma eq_neg_iff_add_eq_0:
153.150 + "a = - b \<longleftrightarrow> a + b = 0"
153.151 proof
153.152 assume "a = - b" then show "a + b = 0" by simp
153.153 next
153.154 @@ -456,72 +471,88 @@
153.155 ultimately show "a = - b" by simp
153.156 qed
153.157
153.158 -lemma add_eq_0_iff: "x + y = 0 \<longleftrightarrow> y = - x"
153.159 - unfolding eq_neg_iff_add_eq_0 [symmetric]
153.160 - by (rule equation_minus_iff)
153.161 +lemma add_eq_0_iff2:
153.162 + "a + b = 0 \<longleftrightarrow> a = - b"
153.163 + by (fact eq_neg_iff_add_eq_0 [symmetric])
153.164
153.165 -lemma minus_diff_eq [simp]: "- (a - b) = b - a"
153.166 - by (simp add: diff_minus minus_add)
153.167 +lemma neg_eq_iff_add_eq_0:
153.168 + "- a = b \<longleftrightarrow> a + b = 0"
153.169 + by (auto simp add: add_eq_0_iff2)
153.170
153.171 -lemma add_diff_eq[algebra_simps, field_simps]: "a + (b - c) = (a + b) - c"
153.172 - by (simp add: diff_minus add_assoc)
153.173 +lemma add_eq_0_iff:
153.174 + "a + b = 0 \<longleftrightarrow> b = - a"
153.175 + by (auto simp add: neg_eq_iff_add_eq_0 [symmetric])
153.176
153.177 -lemma diff_eq_eq[algebra_simps, field_simps]: "a - b = c \<longleftrightarrow> a = c + b"
153.178 - by (auto simp add: diff_minus add_assoc)
153.179 +lemma minus_diff_eq [simp]:
153.180 + "- (a - b) = b - a"
153.181 + by (simp only: neg_eq_iff_add_eq_0 diff_conv_add_uminus add_assoc minus_add_cancel) simp
153.182
153.183 -lemma eq_diff_eq[algebra_simps, field_simps]: "a = c - b \<longleftrightarrow> a + b = c"
153.184 - by (auto simp add: diff_minus add_assoc)
153.185 +lemma add_diff_eq [algebra_simps, field_simps]:
153.186 + "a + (b - c) = (a + b) - c"
153.187 + by (simp only: diff_conv_add_uminus add_assoc)
153.188
153.189 -lemma diff_diff_eq2[algebra_simps, field_simps]: "a - (b - c) = (a + c) - b"
153.190 - by (simp add: diff_minus minus_add add_assoc)
153.191 +lemma diff_add_eq_diff_diff_swap:
153.192 + "a - (b + c) = a - c - b"
153.193 + by (simp only: diff_conv_add_uminus add_assoc minus_add)
153.194
153.195 -lemma eq_iff_diff_eq_0: "a = b \<longleftrightarrow> a - b = 0"
153.196 - by (fact right_minus_eq [symmetric])
153.197 +lemma diff_eq_eq [algebra_simps, field_simps]:
153.198 + "a - b = c \<longleftrightarrow> a = c + b"
153.199 + by auto
153.200 +
153.201 +lemma eq_diff_eq [algebra_simps, field_simps]:
153.202 + "a = c - b \<longleftrightarrow> a + b = c"
153.203 + by auto
153.204 +
153.205 +lemma diff_diff_eq2 [algebra_simps, field_simps]:
153.206 + "a - (b - c) = (a + c) - b"
153.207 + by (simp only: diff_conv_add_uminus add_assoc) simp
153.208
153.209 lemma diff_eq_diff_eq:
153.210 "a - b = c - d \<Longrightarrow> a = b \<longleftrightarrow> c = d"
153.211 - by (simp add: eq_iff_diff_eq_0 [of a b] eq_iff_diff_eq_0 [of c d])
153.212 + by (simp only: eq_iff_diff_eq_0 [of a b] eq_iff_diff_eq_0 [of c d])
153.213
153.214 end
153.215
153.216 class ab_group_add = minus + uminus + comm_monoid_add +
153.217 assumes ab_left_minus: "- a + a = 0"
153.218 - assumes ab_diff_minus: "a - b = a + (- b)"
153.219 + assumes ab_add_uminus_conv_diff: "a - b = a + (- b)"
153.220 begin
153.221
153.222 subclass group_add
153.223 - proof qed (simp_all add: ab_left_minus ab_diff_minus)
153.224 + proof qed (simp_all add: ab_left_minus ab_add_uminus_conv_diff)
153.225
153.226 subclass cancel_comm_monoid_add
153.227 proof
153.228 fix a b c :: 'a
153.229 assume "a + b = a + c"
153.230 then have "- a + a + b = - a + a + c"
153.231 - unfolding add_assoc by simp
153.232 + by (simp only: add_assoc)
153.233 then show "b = c" by simp
153.234 qed
153.235
153.236 -lemma uminus_add_conv_diff[algebra_simps, field_simps]:
153.237 +lemma uminus_add_conv_diff [simp]:
153.238 "- a + b = b - a"
153.239 -by (simp add:diff_minus add_commute)
153.240 + by (simp add: add_commute)
153.241
153.242 lemma minus_add_distrib [simp]:
153.243 "- (a + b) = - a + - b"
153.244 -by (rule minus_unique) (simp add: add_ac)
153.245 + by (simp add: algebra_simps)
153.246
153.247 -lemma diff_add_eq[algebra_simps, field_simps]: "(a - b) + c = (a + c) - b"
153.248 -by (simp add: diff_minus add_ac)
153.249 +lemma diff_add_eq [algebra_simps, field_simps]:
153.250 + "(a - b) + c = (a + c) - b"
153.251 + by (simp add: algebra_simps)
153.252
153.253 -lemma diff_diff_eq[algebra_simps, field_simps]: "(a - b) - c = a - (b + c)"
153.254 -by (simp add: diff_minus add_ac)
153.255 +lemma diff_diff_eq [algebra_simps, field_simps]:
153.256 + "(a - b) - c = a - (b + c)"
153.257 + by (simp add: algebra_simps)
153.258
153.259 -(* FIXME: duplicates right_minus_eq from class group_add *)
153.260 -(* but only this one is declared as a simp rule. *)
153.261 -lemma diff_eq_0_iff_eq [simp, no_atp]: "a - b = 0 \<longleftrightarrow> a = b"
153.262 - by (rule right_minus_eq)
153.263 +lemma diff_add_eq_diff_diff:
153.264 + "a - (b + c) = a - b - c"
153.265 + using diff_add_eq_diff_diff_swap [of a c b] by (simp add: add.commute)
153.266
153.267 -lemma add_diff_cancel_left: "(c + a) - (c + b) = a - b"
153.268 - by (simp add: diff_minus add_ac)
153.269 +lemma add_diff_cancel_left [simp]:
153.270 + "(c + a) - (c + b) = a - b"
153.271 + by (simp add: algebra_simps)
153.272
153.273 end
153.274
153.275 @@ -622,19 +653,19 @@
153.276
153.277 lemma add_less_cancel_left [simp]:
153.278 "c + a < c + b \<longleftrightarrow> a < b"
153.279 -by (blast intro: add_less_imp_less_left add_strict_left_mono)
153.280 + by (blast intro: add_less_imp_less_left add_strict_left_mono)
153.281
153.282 lemma add_less_cancel_right [simp]:
153.283 "a + c < b + c \<longleftrightarrow> a < b"
153.284 -by (blast intro: add_less_imp_less_right add_strict_right_mono)
153.285 + by (blast intro: add_less_imp_less_right add_strict_right_mono)
153.286
153.287 lemma add_le_cancel_left [simp]:
153.288 "c + a \<le> c + b \<longleftrightarrow> a \<le> b"
153.289 -by (auto, drule add_le_imp_le_left, simp_all add: add_left_mono)
153.290 + by (auto, drule add_le_imp_le_left, simp_all add: add_left_mono)
153.291
153.292 lemma add_le_cancel_right [simp]:
153.293 "a + c \<le> b + c \<longleftrightarrow> a \<le> b"
153.294 -by (simp add: add_commute [of a c] add_commute [of b c])
153.295 + by (simp add: add_commute [of a c] add_commute [of b c])
153.296
153.297 lemma add_le_imp_le_right:
153.298 "a + c \<le> b + c \<Longrightarrow> a \<le> b"
153.299 @@ -806,6 +837,22 @@
153.300 then show "x + y = 0" by simp
153.301 qed
153.302
153.303 +lemma add_increasing:
153.304 + "0 \<le> a \<Longrightarrow> b \<le> c \<Longrightarrow> b \<le> a + c"
153.305 + by (insert add_mono [of 0 a b c], simp)
153.306 +
153.307 +lemma add_increasing2:
153.308 + "0 \<le> c \<Longrightarrow> b \<le> a \<Longrightarrow> b \<le> a + c"
153.309 + by (simp add: add_increasing add_commute [of a])
153.310 +
153.311 +lemma add_strict_increasing:
153.312 + "0 < a \<Longrightarrow> b \<le> c \<Longrightarrow> b < a + c"
153.313 + by (insert add_less_le_mono [of 0 a b c], simp)
153.314 +
153.315 +lemma add_strict_increasing2:
153.316 + "0 \<le> a \<Longrightarrow> b < c \<Longrightarrow> b < a + c"
153.317 + by (insert add_le_less_mono [of 0 a b c], simp)
153.318 +
153.319 end
153.320
153.321 class ordered_ab_group_add =
153.322 @@ -825,21 +872,53 @@
153.323
153.324 subclass ordered_comm_monoid_add ..
153.325
153.326 +lemma add_less_same_cancel1 [simp]:
153.327 + "b + a < b \<longleftrightarrow> a < 0"
153.328 + using add_less_cancel_left [of _ _ 0] by simp
153.329 +
153.330 +lemma add_less_same_cancel2 [simp]:
153.331 + "a + b < b \<longleftrightarrow> a < 0"
153.332 + using add_less_cancel_right [of _ _ 0] by simp
153.333 +
153.334 +lemma less_add_same_cancel1 [simp]:
153.335 + "a < a + b \<longleftrightarrow> 0 < b"
153.336 + using add_less_cancel_left [of _ 0] by simp
153.337 +
153.338 +lemma less_add_same_cancel2 [simp]:
153.339 + "a < b + a \<longleftrightarrow> 0 < b"
153.340 + using add_less_cancel_right [of 0] by simp
153.341 +
153.342 +lemma add_le_same_cancel1 [simp]:
153.343 + "b + a \<le> b \<longleftrightarrow> a \<le> 0"
153.344 + using add_le_cancel_left [of _ _ 0] by simp
153.345 +
153.346 +lemma add_le_same_cancel2 [simp]:
153.347 + "a + b \<le> b \<longleftrightarrow> a \<le> 0"
153.348 + using add_le_cancel_right [of _ _ 0] by simp
153.349 +
153.350 +lemma le_add_same_cancel1 [simp]:
153.351 + "a \<le> a + b \<longleftrightarrow> 0 \<le> b"
153.352 + using add_le_cancel_left [of _ 0] by simp
153.353 +
153.354 +lemma le_add_same_cancel2 [simp]:
153.355 + "a \<le> b + a \<longleftrightarrow> 0 \<le> b"
153.356 + using add_le_cancel_right [of 0] by simp
153.357 +
153.358 lemma max_diff_distrib_left:
153.359 shows "max x y - z = max (x - z) (y - z)"
153.360 -by (simp add: diff_minus, rule max_add_distrib_left)
153.361 + using max_add_distrib_left [of x y "- z"] by simp
153.362
153.363 lemma min_diff_distrib_left:
153.364 shows "min x y - z = min (x - z) (y - z)"
153.365 -by (simp add: diff_minus, rule min_add_distrib_left)
153.366 + using min_add_distrib_left [of x y "- z"] by simp
153.367
153.368 lemma le_imp_neg_le:
153.369 assumes "a \<le> b" shows "-b \<le> -a"
153.370 proof -
153.371 have "-a+a \<le> -a+b" using `a \<le> b` by (rule add_left_mono)
153.372 - hence "0 \<le> -a+b" by simp
153.373 - hence "0 + (-b) \<le> (-a + b) + (-b)" by (rule add_right_mono)
153.374 - thus ?thesis by (simp add: add_assoc)
153.375 + then have "0 \<le> -a+b" by simp
153.376 + then have "0 + (-b) \<le> (-a + b) + (-b)" by (rule add_right_mono)
153.377 + then show ?thesis by (simp add: algebra_simps)
153.378 qed
153.379
153.380 lemma neg_le_iff_le [simp]: "- b \<le> - a \<longleftrightarrow> a \<le> b"
153.381 @@ -896,35 +975,37 @@
153.382 lemma minus_le_iff: "- a \<le> b \<longleftrightarrow> - b \<le> a"
153.383 by (auto simp add: le_less minus_less_iff)
153.384
153.385 -lemma diff_less_0_iff_less [simp, no_atp]:
153.386 +lemma diff_less_0_iff_less [simp]:
153.387 "a - b < 0 \<longleftrightarrow> a < b"
153.388 proof -
153.389 - have "a - b < 0 \<longleftrightarrow> a + (- b) < b + (- b)" by (simp add: diff_minus)
153.390 + have "a - b < 0 \<longleftrightarrow> a + (- b) < b + (- b)" by simp
153.391 also have "... \<longleftrightarrow> a < b" by (simp only: add_less_cancel_right)
153.392 finally show ?thesis .
153.393 qed
153.394
153.395 lemmas less_iff_diff_less_0 = diff_less_0_iff_less [symmetric]
153.396
153.397 -lemma diff_less_eq[algebra_simps, field_simps]: "a - b < c \<longleftrightarrow> a < c + b"
153.398 +lemma diff_less_eq [algebra_simps, field_simps]:
153.399 + "a - b < c \<longleftrightarrow> a < c + b"
153.400 apply (subst less_iff_diff_less_0 [of a])
153.401 apply (rule less_iff_diff_less_0 [of _ c, THEN ssubst])
153.402 -apply (simp add: diff_minus add_ac)
153.403 +apply (simp add: algebra_simps)
153.404 done
153.405
153.406 -lemma less_diff_eq[algebra_simps, field_simps]: "a < c - b \<longleftrightarrow> a + b < c"
153.407 +lemma less_diff_eq[algebra_simps, field_simps]:
153.408 + "a < c - b \<longleftrightarrow> a + b < c"
153.409 apply (subst less_iff_diff_less_0 [of "a + b"])
153.410 apply (subst less_iff_diff_less_0 [of a])
153.411 -apply (simp add: diff_minus add_ac)
153.412 +apply (simp add: algebra_simps)
153.413 done
153.414
153.415 lemma diff_le_eq[algebra_simps, field_simps]: "a - b \<le> c \<longleftrightarrow> a \<le> c + b"
153.416 -by (auto simp add: le_less diff_less_eq diff_add_cancel add_diff_cancel)
153.417 +by (auto simp add: le_less diff_less_eq )
153.418
153.419 lemma le_diff_eq[algebra_simps, field_simps]: "a \<le> c - b \<longleftrightarrow> a + b \<le> c"
153.420 -by (auto simp add: le_less less_diff_eq diff_add_cancel add_diff_cancel)
153.421 +by (auto simp add: le_less less_diff_eq)
153.422
153.423 -lemma diff_le_0_iff_le [simp, no_atp]:
153.424 +lemma diff_le_0_iff_le [simp]:
153.425 "a - b \<le> 0 \<longleftrightarrow> a \<le> b"
153.426 by (simp add: algebra_simps)
153.427
153.428 @@ -992,63 +1073,6 @@
153.429
153.430 subclass linordered_cancel_ab_semigroup_add ..
153.431
153.432 -lemma neg_less_eq_nonneg [simp]:
153.433 - "- a \<le> a \<longleftrightarrow> 0 \<le> a"
153.434 -proof
153.435 - assume A: "- a \<le> a" show "0 \<le> a"
153.436 - proof (rule classical)
153.437 - assume "\<not> 0 \<le> a"
153.438 - then have "a < 0" by auto
153.439 - with A have "- a < 0" by (rule le_less_trans)
153.440 - then show ?thesis by auto
153.441 - qed
153.442 -next
153.443 - assume A: "0 \<le> a" show "- a \<le> a"
153.444 - proof (rule order_trans)
153.445 - show "- a \<le> 0" using A by (simp add: minus_le_iff)
153.446 - next
153.447 - show "0 \<le> a" using A .
153.448 - qed
153.449 -qed
153.450 -
153.451 -lemma neg_less_nonneg [simp]:
153.452 - "- a < a \<longleftrightarrow> 0 < a"
153.453 -proof
153.454 - assume A: "- a < a" show "0 < a"
153.455 - proof (rule classical)
153.456 - assume "\<not> 0 < a"
153.457 - then have "a \<le> 0" by auto
153.458 - with A have "- a < 0" by (rule less_le_trans)
153.459 - then show ?thesis by auto
153.460 - qed
153.461 -next
153.462 - assume A: "0 < a" show "- a < a"
153.463 - proof (rule less_trans)
153.464 - show "- a < 0" using A by (simp add: minus_le_iff)
153.465 - next
153.466 - show "0 < a" using A .
153.467 - qed
153.468 -qed
153.469 -
153.470 -lemma less_eq_neg_nonpos [simp]:
153.471 - "a \<le> - a \<longleftrightarrow> a \<le> 0"
153.472 -proof
153.473 - assume A: "a \<le> - a" show "a \<le> 0"
153.474 - proof (rule classical)
153.475 - assume "\<not> a \<le> 0"
153.476 - then have "0 < a" by auto
153.477 - then have "0 < - a" using A by (rule less_le_trans)
153.478 - then show ?thesis by auto
153.479 - qed
153.480 -next
153.481 - assume A: "a \<le> 0" show "a \<le> - a"
153.482 - proof (rule order_trans)
153.483 - show "0 \<le> - a" using A by (simp add: minus_le_iff)
153.484 - next
153.485 - show "a \<le> 0" using A .
153.486 - qed
153.487 -qed
153.488 -
153.489 lemma equal_neg_zero [simp]:
153.490 "a = - a \<longleftrightarrow> a = 0"
153.491 proof
153.492 @@ -1070,6 +1094,37 @@
153.493 "- a = a \<longleftrightarrow> a = 0"
153.494 by (auto dest: sym)
153.495
153.496 +lemma neg_less_eq_nonneg [simp]:
153.497 + "- a \<le> a \<longleftrightarrow> 0 \<le> a"
153.498 +proof
153.499 + assume A: "- a \<le> a" show "0 \<le> a"
153.500 + proof (rule classical)
153.501 + assume "\<not> 0 \<le> a"
153.502 + then have "a < 0" by auto
153.503 + with A have "- a < 0" by (rule le_less_trans)
153.504 + then show ?thesis by auto
153.505 + qed
153.506 +next
153.507 + assume A: "0 \<le> a" show "- a \<le> a"
153.508 + proof (rule order_trans)
153.509 + show "- a \<le> 0" using A by (simp add: minus_le_iff)
153.510 + next
153.511 + show "0 \<le> a" using A .
153.512 + qed
153.513 +qed
153.514 +
153.515 +lemma neg_less_pos [simp]:
153.516 + "- a < a \<longleftrightarrow> 0 < a"
153.517 + by (auto simp add: less_le)
153.518 +
153.519 +lemma less_eq_neg_nonpos [simp]:
153.520 + "a \<le> - a \<longleftrightarrow> a \<le> 0"
153.521 + using neg_less_eq_nonneg [of "- a"] by simp
153.522 +
153.523 +lemma less_neg_neg [simp]:
153.524 + "a < - a \<longleftrightarrow> a < 0"
153.525 + using neg_less_pos [of "- a"] by simp
153.526 +
153.527 lemma double_zero [simp]:
153.528 "a + a = 0 \<longleftrightarrow> a = 0"
153.529 proof
153.530 @@ -1088,7 +1143,7 @@
153.531 assume "0 < a + a"
153.532 then have "0 - a < a" by (simp only: diff_less_eq)
153.533 then have "- a < a" by simp
153.534 - then show "0 < a" by (simp only: neg_less_nonneg)
153.535 + then show "0 < a" by simp
153.536 next
153.537 assume "0 < a"
153.538 with this have "0 + 0 < a + a"
153.539 @@ -1116,24 +1171,6 @@
153.540 then show ?thesis by simp
153.541 qed
153.542
153.543 -lemma le_minus_self_iff:
153.544 - "a \<le> - a \<longleftrightarrow> a \<le> 0"
153.545 -proof -
153.546 - from add_le_cancel_left [of "- a" "a + a" 0]
153.547 - have "a \<le> - a \<longleftrightarrow> a + a \<le> 0"
153.548 - by (simp add: add_assoc [symmetric])
153.549 - thus ?thesis by simp
153.550 -qed
153.551 -
153.552 -lemma minus_le_self_iff:
153.553 - "- a \<le> a \<longleftrightarrow> 0 \<le> a"
153.554 -proof -
153.555 - from add_le_cancel_left [of "- a" 0 "a + a"]
153.556 - have "- a \<le> a \<longleftrightarrow> 0 \<le> a + a"
153.557 - by (simp add: add_assoc [symmetric])
153.558 - thus ?thesis by simp
153.559 -qed
153.560 -
153.561 lemma minus_max_eq_min:
153.562 "- max x y = min (-x) (-y)"
153.563 by (auto simp add: max_def min_def)
153.564 @@ -1144,27 +1181,6 @@
153.565
153.566 end
153.567
153.568 -context ordered_comm_monoid_add
153.569 -begin
153.570 -
153.571 -lemma add_increasing:
153.572 - "0 \<le> a \<Longrightarrow> b \<le> c \<Longrightarrow> b \<le> a + c"
153.573 - by (insert add_mono [of 0 a b c], simp)
153.574 -
153.575 -lemma add_increasing2:
153.576 - "0 \<le> c \<Longrightarrow> b \<le> a \<Longrightarrow> b \<le> a + c"
153.577 - by (simp add: add_increasing add_commute [of a])
153.578 -
153.579 -lemma add_strict_increasing:
153.580 - "0 < a \<Longrightarrow> b \<le> c \<Longrightarrow> b < a + c"
153.581 - by (insert add_less_le_mono [of 0 a b c], simp)
153.582 -
153.583 -lemma add_strict_increasing2:
153.584 - "0 \<le> a \<Longrightarrow> b < c \<Longrightarrow> b < a + c"
153.585 - by (insert add_le_less_mono [of 0 a b c], simp)
153.586 -
153.587 -end
153.588 -
153.589 class abs =
153.590 fixes abs :: "'a \<Rightarrow> 'a"
153.591 begin
153.592 @@ -1231,7 +1247,7 @@
153.593 lemma abs_zero [simp]: "\<bar>0\<bar> = 0"
153.594 by simp
153.595
153.596 -lemma abs_0_eq [simp, no_atp]: "0 = \<bar>a\<bar> \<longleftrightarrow> a = 0"
153.597 +lemma abs_0_eq [simp]: "0 = \<bar>a\<bar> \<longleftrightarrow> a = 0"
153.598 proof -
153.599 have "0 = \<bar>a\<bar> \<longleftrightarrow> \<bar>a\<bar> = 0" by (simp only: eq_ac)
153.600 thus ?thesis by simp
153.601 @@ -1299,7 +1315,7 @@
153.602 lemma abs_triangle_ineq2: "\<bar>a\<bar> - \<bar>b\<bar> \<le> \<bar>a - b\<bar>"
153.603 proof -
153.604 have "\<bar>a\<bar> = \<bar>b + (a - b)\<bar>"
153.605 - by (simp add: algebra_simps add_diff_cancel)
153.606 + by (simp add: algebra_simps)
153.607 then have "\<bar>a\<bar> \<le> \<bar>b\<bar> + \<bar>a - b\<bar>"
153.608 by (simp add: abs_triangle_ineq)
153.609 then show ?thesis
153.610 @@ -1314,14 +1330,14 @@
153.611
153.612 lemma abs_triangle_ineq4: "\<bar>a - b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
153.613 proof -
153.614 - have "\<bar>a - b\<bar> = \<bar>a + - b\<bar>" by (subst diff_minus, rule refl)
153.615 + have "\<bar>a - b\<bar> = \<bar>a + - b\<bar>" by (simp add: algebra_simps)
153.616 also have "... \<le> \<bar>a\<bar> + \<bar>- b\<bar>" by (rule abs_triangle_ineq)
153.617 finally show ?thesis by simp
153.618 qed
153.619
153.620 lemma abs_diff_triangle_ineq: "\<bar>a + b - (c + d)\<bar> \<le> \<bar>a - c\<bar> + \<bar>b - d\<bar>"
153.621 proof -
153.622 - have "\<bar>a + b - (c+d)\<bar> = \<bar>(a-c) + (b-d)\<bar>" by (simp add: diff_minus add_ac)
153.623 + have "\<bar>a + b - (c+d)\<bar> = \<bar>(a-c) + (b-d)\<bar>" by (simp add: algebra_simps)
153.624 also have "... \<le> \<bar>a-c\<bar> + \<bar>b-d\<bar>" by (rule abs_triangle_ineq)
153.625 finally show ?thesis .
153.626 qed
153.627 @@ -1341,7 +1357,7 @@
153.628
153.629 subsection {* Tools setup *}
153.630
153.631 -lemma add_mono_thms_linordered_semiring [no_atp]:
153.632 +lemma add_mono_thms_linordered_semiring:
153.633 fixes i j k :: "'a\<Colon>ordered_ab_semigroup_add"
153.634 shows "i \<le> j \<and> k \<le> l \<Longrightarrow> i + k \<le> j + l"
153.635 and "i = j \<and> k \<le> l \<Longrightarrow> i + k \<le> j + l"
153.636 @@ -1349,7 +1365,7 @@
153.637 and "i = j \<and> k = l \<Longrightarrow> i + k = j + l"
153.638 by (rule add_mono, clarify+)+
153.639
153.640 -lemma add_mono_thms_linordered_field [no_atp]:
153.641 +lemma add_mono_thms_linordered_field:
153.642 fixes i j k :: "'a\<Colon>ordered_cancel_ab_semigroup_add"
153.643 shows "i < j \<and> k = l \<Longrightarrow> i + k < j + l"
153.644 and "i = j \<and> k < l \<Longrightarrow> i + k < j + l"
153.645 @@ -1362,10 +1378,5 @@
153.646 code_identifier
153.647 code_module Groups \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
153.648
153.649 -
153.650 -text {* Legacy *}
153.651 -
153.652 -lemmas diff_def = diff_minus
153.653 -
153.654 end
153.655
154.1 --- a/src/HOL/Hahn_Banach/Bounds.thy Thu Dec 05 17:52:12 2013 +0100
154.2 +++ b/src/HOL/Hahn_Banach/Bounds.thy Thu Dec 05 17:58:03 2013 +0100
154.3 @@ -57,25 +57,7 @@
154.4 finally show ?thesis .
154.5 qed
154.6
154.7 -lemma lub_compat: "lub A x = isLub UNIV A x"
154.8 -proof -
154.9 - have "isUb UNIV A = (\<lambda>x. A *<= x \<and> x \<in> UNIV)"
154.10 - by (rule ext) (simp only: isUb_def)
154.11 - then show ?thesis
154.12 - by (simp only: lub_def isLub_def leastP_def setge_def setle_def) blast
154.13 -qed
154.14 -
154.15 -lemma real_complete:
154.16 - fixes A :: "real set"
154.17 - assumes nonempty: "\<exists>a. a \<in> A"
154.18 - and ex_upper: "\<exists>y. \<forall>a \<in> A. a \<le> y"
154.19 - shows "\<exists>x. lub A x"
154.20 -proof -
154.21 - from ex_upper have "\<exists>y. isUb UNIV A y"
154.22 - unfolding isUb_def setle_def by blast
154.23 - with nonempty have "\<exists>x. isLub UNIV A x"
154.24 - by (rule reals_complete)
154.25 - then show ?thesis by (simp only: lub_compat)
154.26 -qed
154.27 +lemma real_complete: "\<exists>a::real. a \<in> A \<Longrightarrow> \<exists>y. \<forall>a \<in> A. a \<le> y \<Longrightarrow> \<exists>x. lub A x"
154.28 + by (intro exI[of _ "Sup A"]) (auto intro!: cSup_upper cSup_least simp: lub_def)
154.29
154.30 end
155.1 --- a/src/HOL/Hahn_Banach/Vector_Space.thy Thu Dec 05 17:52:12 2013 +0100
155.2 +++ b/src/HOL/Hahn_Banach/Vector_Space.thy Thu Dec 05 17:58:03 2013 +0100
155.3 @@ -112,7 +112,7 @@
155.4 proof -
155.5 assume x: "x \<in> V"
155.6 have " (a - b) \<cdot> x = (a + - b) \<cdot> x"
155.7 - by (simp add: diff_minus)
155.8 + by simp
155.9 also from x have "\<dots> = a \<cdot> x + (- b) \<cdot> x"
155.10 by (rule add_mult_distrib2)
155.11 also from x have "\<dots> = a \<cdot> x + - (b \<cdot> x)"
156.1 --- a/src/HOL/Hilbert_Choice.thy Thu Dec 05 17:52:12 2013 +0100
156.2 +++ b/src/HOL/Hilbert_Choice.thy Thu Dec 05 17:58:03 2013 +0100
156.3 @@ -272,6 +272,41 @@
156.4 ultimately show "finite (UNIV :: 'a set)" by simp
156.5 qed
156.6
156.7 +text {*
156.8 + Every infinite set contains a countable subset. More precisely we
156.9 + show that a set @{text S} is infinite if and only if there exists an
156.10 + injective function from the naturals into @{text S}.
156.11 +
156.12 + The ``only if'' direction is harder because it requires the
156.13 + construction of a sequence of pairwise different elements of an
156.14 + infinite set @{text S}. The idea is to construct a sequence of
156.15 + non-empty and infinite subsets of @{text S} obtained by successively
156.16 + removing elements of @{text S}.
156.17 +*}
156.18 +
156.19 +lemma infinite_countable_subset:
156.20 + assumes inf: "\<not> finite (S::'a set)"
156.21 + shows "\<exists>f. inj (f::nat \<Rightarrow> 'a) \<and> range f \<subseteq> S"
156.22 + -- {* Courtesy of Stephan Merz *}
156.23 +proof -
156.24 + def Sseq \<equiv> "nat_rec S (\<lambda>n T. T - {SOME e. e \<in> T})"
156.25 + def pick \<equiv> "\<lambda>n. (SOME e. e \<in> Sseq n)"
156.26 + { fix n have "Sseq n \<subseteq> S" "\<not> finite (Sseq n)" by (induct n) (auto simp add: Sseq_def inf) }
156.27 + moreover then have *: "\<And>n. pick n \<in> Sseq n" by (metis someI_ex pick_def ex_in_conv finite.simps)
156.28 + ultimately have "range pick \<subseteq> S" by auto
156.29 + moreover
156.30 + { fix n m
156.31 + have "pick n \<notin> Sseq (n + Suc m)" by (induct m) (auto simp add: Sseq_def pick_def)
156.32 + hence "pick n \<noteq> pick (n + Suc m)" by (metis *)
156.33 + }
156.34 + then have "inj pick" by (intro linorder_injI) (auto simp add: less_iff_Suc_add)
156.35 + ultimately show ?thesis by blast
156.36 +qed
156.37 +
156.38 +lemma infinite_iff_countable_subset: "\<not> finite S \<longleftrightarrow> (\<exists>f. inj (f::nat \<Rightarrow> 'a) \<and> range f \<subseteq> S)"
156.39 + -- {* Courtesy of Stephan Merz *}
156.40 + by (metis finite_imageD finite_subset infinite_UNIV_char_0 infinite_countable_subset)
156.41 +
156.42 lemma image_inv_into_cancel:
156.43 assumes SURJ: "f`A=A'" and SUB: "B' \<le> A'"
156.44 shows "f `((inv_into A f)`B') = B'"
156.45 @@ -741,7 +776,7 @@
156.46 | "bacc r (Suc n) = (bacc r n \<union> {x. \<forall>y. (y, x) \<in> r \<longrightarrow> y \<in> bacc r n})"
156.47
156.48 lemma bacc_subseteq_acc:
156.49 - "bacc r n \<subseteq> acc r"
156.50 + "bacc r n \<subseteq> Wellfounded.acc r"
156.51 by (induct n) (auto intro: acc.intros)
156.52
156.53 lemma bacc_mono:
156.54 @@ -761,10 +796,10 @@
156.55
156.56 lemma acc_subseteq_bacc:
156.57 assumes "finite r"
156.58 - shows "acc r \<subseteq> (\<Union>n. bacc r n)"
156.59 + shows "Wellfounded.acc r \<subseteq> (\<Union>n. bacc r n)"
156.60 proof
156.61 fix x
156.62 - assume "x : acc r"
156.63 + assume "x : Wellfounded.acc r"
156.64 then have "\<exists> n. x : bacc r n"
156.65 proof (induct x arbitrary: rule: acc.induct)
156.66 case (accI x)
156.67 @@ -788,7 +823,7 @@
156.68 lemma acc_bacc_eq:
156.69 fixes A :: "('a :: finite \<times> 'a) set"
156.70 assumes "finite A"
156.71 - shows "acc A = bacc A (card (UNIV :: 'a set))"
156.72 + shows "Wellfounded.acc A = bacc A (card (UNIV :: 'a set))"
156.73 using assms by (metis acc_subseteq_bacc bacc_subseteq_acc bacc_upper_bound order_eq_iff)
156.74
156.75
157.1 --- a/src/HOL/IMP/AExp.thy Thu Dec 05 17:52:12 2013 +0100
157.2 +++ b/src/HOL/IMP/AExp.thy Thu Dec 05 17:58:03 2013 +0100
157.3 @@ -33,11 +33,12 @@
157.4 "_State" :: "updbinds => 'a" ("<_>")
157.5 translations
157.6 "_State ms" == "_Update <> ms"
157.7 + "_State (_updbinds b bs)" <= "_Update (_State b) bs"
157.8
157.9 text {* \noindent
157.10 We can now write a series of updates to the function @{text "\<lambda>x. 0"} compactly:
157.11 *}
157.12 -lemma "<a := Suc 0, b := 2> = (<> (a := Suc 0)) (b := 2)"
157.13 +lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
157.14 by (rule refl)
157.15
157.16 value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"
158.1 --- a/src/HOL/IMP/Abs_Int_ITP/Abs_Int1_ITP.thy Thu Dec 05 17:52:12 2013 +0100
158.2 +++ b/src/HOL/IMP/Abs_Int_ITP/Abs_Int1_ITP.thy Thu Dec 05 17:58:03 2013 +0100
158.3 @@ -135,8 +135,6 @@
158.4
158.5 subsubsection "Ascending Chain Condition"
158.6
158.7 -hide_const (open) acc
158.8 -
158.9 abbreviation "strict r == r \<inter> -(r^-1)"
158.10 abbreviation "acc r == wf((strict r)^-1)"
158.11
159.1 --- a/src/HOL/IMP/Big_Step.thy Thu Dec 05 17:52:12 2013 +0100
159.2 +++ b/src/HOL/IMP/Big_Step.thy Thu Dec 05 17:58:03 2013 +0100
159.3 @@ -268,11 +268,9 @@
159.4 subsection "Execution is deterministic"
159.5
159.6 text {* This proof is automatic. *}
159.7 -text_raw{*\snip{BigStepDeterministic}{0}{1}{% *}
159.8 +
159.9 theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
159.10 by (induction arbitrary: u rule: big_step.induct) blast+
159.11 -text_raw{*}%endsnip*}
159.12 -
159.13
159.14 text {*
159.15 This is the proof as you might present it in a lecture. The remaining
160.1 --- a/src/HOL/IMP/Compiler.thy Thu Dec 05 17:52:12 2013 +0100
160.2 +++ b/src/HOL/IMP/Compiler.thy Thu Dec 05 17:58:03 2013 +0100
160.3 @@ -138,11 +138,12 @@
160.4 by (drule exec_appendL[where P'="[instr]"]) simp
160.5
160.6 lemma exec_appendL_if[intro]:
160.7 - fixes i i' :: int
160.8 + fixes i i' j :: int
160.9 shows
160.10 "size P' <= i
160.11 - \<Longrightarrow> P \<turnstile> (i - size P',s,stk) \<rightarrow>* (i',s',stk')
160.12 - \<Longrightarrow> P' @ P \<turnstile> (i,s,stk) \<rightarrow>* (size P' + i',s',stk')"
160.13 + \<Longrightarrow> P \<turnstile> (i - size P',s,stk) \<rightarrow>* (j,s',stk')
160.14 + \<Longrightarrow> i' = size P' + j
160.15 + \<Longrightarrow> P' @ P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')"
160.16 by (drule exec_appendL[where P'=P']) simp
160.17
160.18 text{* Split the execution of a compound program up into the excution of its
161.1 --- a/src/HOL/IMP/Fold.thy Thu Dec 05 17:52:12 2013 +0100
161.2 +++ b/src/HOL/IMP/Fold.thy Thu Dec 05 17:58:03 2013 +0100
161.3 @@ -1,5 +1,3 @@
161.4 -header "Constant Folding"
161.5 -
161.6 theory Fold imports Sem_Equiv Vars begin
161.7
161.8 subsection "Simple folding of arithmetic expressions"
162.1 --- a/src/HOL/IMP/Hoare_Examples.thy Thu Dec 05 17:52:12 2013 +0100
162.2 +++ b/src/HOL/IMP/Hoare_Examples.thy Thu Dec 05 17:58:03 2013 +0100
162.3 @@ -2,17 +2,6 @@
162.4
162.5 theory Hoare_Examples imports Hoare begin
162.6
162.7 -text{* Improves proof automation for negative numerals: *}
162.8 -
162.9 -lemma add_neg1R[simp]:
162.10 - "x + -1 = x - (1 :: int)"
162.11 -by arith
162.12 -
162.13 -lemma add_neg_numeralR[simp]:
162.14 - "x + neg_numeral n = (x::'a::neg_numeral) - numeral(n)"
162.15 -by (simp only: diff_minus_eq_add[symmetric] minus_neg_numeral)
162.16 -
162.17 -
162.18 text{* Summing up the first @{text x} natural numbers in variable @{text y}. *}
162.19
162.20 fun sum :: "int \<Rightarrow> int" where
163.1 --- a/src/HOL/IMP/Sem_Equiv.thy Thu Dec 05 17:52:12 2013 +0100
163.2 +++ b/src/HOL/IMP/Sem_Equiv.thy Thu Dec 05 17:58:03 2013 +0100
163.3 @@ -1,9 +1,11 @@
163.4 -header "Semantic Equivalence up to a Condition"
163.5 +header "Constant Folding"
163.6
163.7 theory Sem_Equiv
163.8 imports Big_Step
163.9 begin
163.10
163.11 +subsection "Semantic Equivalence up to a Condition"
163.12 +
163.13 type_synonym assn = "state \<Rightarrow> bool"
163.14
163.15 definition
164.1 --- a/src/HOL/IMP/Small_Step.thy Thu Dec 05 17:52:12 2013 +0100
164.2 +++ b/src/HOL/IMP/Small_Step.thy Thu Dec 05 17:58:03 2013 +0100
164.3 @@ -4,7 +4,6 @@
164.4
164.5 subsection "The transition relation"
164.6
164.7 -text_raw{*\snip{SmallStepDef}{0}{2}{% *}
164.8 inductive
164.9 small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
164.10 where
164.11 @@ -18,7 +17,6 @@
164.12
164.13 While: "(WHILE b DO c,s) \<rightarrow>
164.14 (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"
164.15 -text_raw{*}%endsnip*}
164.16
164.17
164.18 abbreviation
165.1 --- a/src/HOL/IMP/Types.thy Thu Dec 05 17:52:12 2013 +0100
165.2 +++ b/src/HOL/IMP/Types.thy Thu Dec 05 17:58:03 2013 +0100
165.3 @@ -113,10 +113,10 @@
165.4 "type (Iv i) = Ity" |
165.5 "type (Rv r) = Rty"
165.6
165.7 -lemma [simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
165.8 +lemma type_eq_Ity[simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
165.9 by (cases v) simp_all
165.10
165.11 -lemma [simp]: "type v = Rty \<longleftrightarrow> (\<exists>r. v = Rv r)"
165.12 +lemma type_eq_Rty[simp]: "type v = Rty \<longleftrightarrow> (\<exists>r. v = Rv r)"
165.13 by (cases v) simp_all
165.14
165.15 definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50)
166.1 --- a/src/HOL/Imperative_HOL/Heap_Monad.thy Thu Dec 05 17:52:12 2013 +0100
166.2 +++ b/src/HOL/Imperative_HOL/Heap_Monad.thy Thu Dec 05 17:58:03 2013 +0100
166.3 @@ -415,6 +415,9 @@
166.4 definition Heap_lub :: "'a Heap set \<Rightarrow> 'a Heap" where
166.5 "Heap_lub = img_lub execute Heap (fun_lub (flat_lub None))"
166.6
166.7 +lemma Heap_lub_empty: "Heap_lub {} = Heap Map.empty"
166.8 +by(simp add: Heap_lub_def img_lub_def fun_lub_def flat_lub_def)
166.9 +
166.10 lemma heap_interpretation: "partial_function_definitions Heap_ord Heap_lub"
166.11 proof -
166.12 have "partial_function_definitions (fun_ord option_ord) (fun_lub (flat_lub None))"
166.13 @@ -427,7 +430,8 @@
166.14 qed
166.15
166.16 interpretation heap!: partial_function_definitions Heap_ord Heap_lub
166.17 -by (fact heap_interpretation)
166.18 + where "Heap_lub {} \<equiv> Heap Map.empty"
166.19 +by (fact heap_interpretation)(simp add: Heap_lub_empty)
166.20
166.21 lemma heap_step_admissible:
166.22 "option.admissible
166.23 @@ -473,6 +477,7 @@
166.24 assumes defined: "effect (U f x) h h' r"
166.25 shows "P x h h' r"
166.26 using step defined heap.fixp_induct_uc[of U F C, OF mono eq inverse2 admissible_heap, of P]
166.27 + unfolding effect_def execute.simps
166.28 by blast
166.29
166.30 declaration {* Partial_Function.init "heap" @{term heap.fixp_fun}
167.1 --- a/src/HOL/Inductive.thy Thu Dec 05 17:52:12 2013 +0100
167.2 +++ b/src/HOL/Inductive.thy Thu Dec 05 17:58:03 2013 +0100
167.3 @@ -4,12 +4,12 @@
167.4
167.5 header {* Knaster-Tarski Fixpoint Theorem and inductive definitions *}
167.6
167.7 -theory Inductive
167.8 -imports Complete_Lattices
167.9 +theory Inductive
167.10 +imports Complete_Lattices Ctr_Sugar
167.11 keywords
167.12 "inductive" "coinductive" :: thy_decl and
167.13 "inductive_cases" "inductive_simps" :: thy_script and "monos" and
167.14 - "print_inductives" "print_case_translations" :: diag and
167.15 + "print_inductives" :: diag and
167.16 "rep_datatype" :: thy_goal and
167.17 "primrec" :: thy_decl
167.18 begin
167.19 @@ -30,7 +30,7 @@
167.20
167.21 subsection{* Proof of Knaster-Tarski Theorem using @{term lfp} *}
167.22
167.23 -text{*@{term "lfp f"} is the least upper bound of
167.24 +text{*@{term "lfp f"} is the least upper bound of
167.25 the set @{term "{u. f(u) \<le> u}"} *}
167.26
167.27 lemma lfp_lowerbound: "f A \<le> A ==> lfp f \<le> A"
167.28 @@ -273,23 +273,8 @@
167.29 ML_file "Tools/Datatype/datatype_aux.ML"
167.30 ML_file "Tools/Datatype/datatype_prop.ML"
167.31 ML_file "Tools/Datatype/datatype_data.ML" setup Datatype_Data.setup
167.32 -
167.33 -consts
167.34 - case_guard :: "bool \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b"
167.35 - case_nil :: "'a \<Rightarrow> 'b"
167.36 - case_cons :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
167.37 - case_elem :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b"
167.38 - case_abs :: "('c \<Rightarrow> 'b) \<Rightarrow> 'b"
167.39 -declare [[coercion_args case_guard - + -]]
167.40 -declare [[coercion_args case_cons - -]]
167.41 -declare [[coercion_args case_abs -]]
167.42 -declare [[coercion_args case_elem - +]]
167.43 -
167.44 -ML_file "Tools/case_translation.ML"
167.45 -setup Case_Translation.setup
167.46 -
167.47 ML_file "Tools/Datatype/rep_datatype.ML"
167.48 -ML_file "Tools/Datatype/datatype_codegen.ML" setup Datatype_Codegen.setup
167.49 +ML_file "Tools/Datatype/datatype_codegen.ML"
167.50 ML_file "Tools/Datatype/primrec.ML"
167.51
167.52 text{* Lambda-abstractions with pattern matching: *}
168.1 --- a/src/HOL/Int.thy Thu Dec 05 17:52:12 2013 +0100
168.2 +++ b/src/HOL/Int.thy Thu Dec 05 17:58:03 2013 +0100
168.3 @@ -220,7 +220,7 @@
168.4 by (transfer fixing: uminus) clarsimp
168.5
168.6 lemma of_int_diff [simp]: "of_int (w - z) = of_int w - of_int z"
168.7 -by (simp add: diff_minus Groups.diff_minus)
168.8 + using of_int_add [of w "- z"] by simp
168.9
168.10 lemma of_int_mult [simp]: "of_int (w*z) = of_int w * of_int z"
168.11 by (transfer fixing: times) (clarsimp simp add: algebra_simps of_nat_mult)
168.12 @@ -232,9 +232,8 @@
168.13 lemma of_int_numeral [simp, code_post]: "of_int (numeral k) = numeral k"
168.14 by (simp add: of_nat_numeral [symmetric] of_int_of_nat_eq [symmetric])
168.15
168.16 -lemma of_int_neg_numeral [simp, code_post]: "of_int (neg_numeral k) = neg_numeral k"
168.17 - unfolding neg_numeral_def neg_numeral_class.neg_numeral_def
168.18 - by (simp only: of_int_minus of_int_numeral)
168.19 +lemma of_int_neg_numeral [code_post]: "of_int (- numeral k) = - numeral k"
168.20 + by simp
168.21
168.22 lemma of_int_power:
168.23 "of_int (z ^ n) = of_int z ^ n"
168.24 @@ -349,12 +348,33 @@
168.25 shows P
168.26 using assms by (blast dest: nat_0_le sym)
168.27
168.28 -lemma nat_eq_iff: "(nat w = m) = (if 0 \<le> w then w = int m else m=0)"
168.29 +lemma nat_eq_iff:
168.30 + "nat w = m \<longleftrightarrow> (if 0 \<le> w then w = int m else m = 0)"
168.31 by transfer (clarsimp simp add: le_imp_diff_is_add)
168.32 +
168.33 +corollary nat_eq_iff2:
168.34 + "m = nat w \<longleftrightarrow> (if 0 \<le> w then w = int m else m = 0)"
168.35 + using nat_eq_iff [of w m] by auto
168.36
168.37 -corollary nat_eq_iff2: "(m = nat w) = (if 0 \<le> w then w = int m else m=0)"
168.38 -by (simp only: eq_commute [of m] nat_eq_iff)
168.39 +lemma nat_0 [simp]:
168.40 + "nat 0 = 0"
168.41 + by (simp add: nat_eq_iff)
168.42
168.43 +lemma nat_1 [simp]:
168.44 + "nat 1 = Suc 0"
168.45 + by (simp add: nat_eq_iff)
168.46 +
168.47 +lemma nat_numeral [simp]:
168.48 + "nat (numeral k) = numeral k"
168.49 + by (simp add: nat_eq_iff)
168.50 +
168.51 +lemma nat_neg_numeral [simp]:
168.52 + "nat (- numeral k) = 0"
168.53 + by simp
168.54 +
168.55 +lemma nat_2: "nat 2 = Suc (Suc 0)"
168.56 + by simp
168.57 +
168.58 lemma nat_less_iff: "0 \<le> w ==> (nat w < m) = (w < of_nat m)"
168.59 by transfer (clarsimp, arith)
168.60
168.61 @@ -374,12 +394,16 @@
168.62 by (insert zless_nat_conj [of 0], auto)
168.63
168.64 lemma nat_add_distrib:
168.65 - "[| (0::int) \<le> z; 0 \<le> z' |] ==> nat (z+z') = nat z + nat z'"
168.66 + "0 \<le> z \<Longrightarrow> 0 \<le> z' \<Longrightarrow> nat (z + z') = nat z + nat z'"
168.67 by transfer clarsimp
168.68
168.69 +lemma nat_diff_distrib':
168.70 + "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> nat (x - y) = nat x - nat y"
168.71 + by transfer clarsimp
168.72 +
168.73 lemma nat_diff_distrib:
168.74 - "[| (0::int) \<le> z'; z' \<le> z |] ==> nat (z-z') = nat z - nat z'"
168.75 - by transfer clarsimp
168.76 + "0 \<le> z' \<Longrightarrow> z' \<le> z \<Longrightarrow> nat (z - z') = nat z - nat z'"
168.77 + by (rule nat_diff_distrib') auto
168.78
168.79 lemma nat_zminus_int [simp]: "nat (- int n) = 0"
168.80 by transfer simp
168.81 @@ -399,6 +423,11 @@
168.82
168.83 end
168.84
168.85 +lemma diff_nat_numeral [simp]:
168.86 + "(numeral v :: nat) - numeral v' = nat (numeral v - numeral v')"
168.87 + by (simp only: nat_diff_distrib' zero_le_numeral nat_numeral)
168.88 +
168.89 +
168.90 text {* For termination proofs: *}
168.91 lemma measure_function_int[measure_function]: "is_measure (nat o abs)" ..
168.92
168.93 @@ -450,7 +479,7 @@
168.94 It is proved here because attribute @{text arith_split} is not available
168.95 in theory @{text Rings}.
168.96 But is it really better than just rewriting with @{text abs_if}?*}
168.97 -lemma abs_split [arith_split,no_atp]:
168.98 +lemma abs_split [arith_split, no_atp]:
168.99 "P(abs(a::'a::linordered_idom)) = ((0 \<le> a --> P a) & (a < 0 --> P(-a)))"
168.100 by (force dest: order_less_le_trans simp add: abs_if linorder_not_less)
168.101
168.102 @@ -481,13 +510,13 @@
168.103
168.104 lemma nonneg_int_cases:
168.105 assumes "0 \<le> k" obtains n where "k = int n"
168.106 - using assms by (cases k, simp, simp del: of_nat_Suc)
168.107 + using assms by (rule nonneg_eq_int)
168.108
168.109 lemma Let_numeral [simp]: "Let (numeral v) f = f (numeral v)"
168.110 -- {* Unfold all @{text let}s involving constants *}
168.111 unfolding Let_def ..
168.112
168.113 -lemma Let_neg_numeral [simp]: "Let (neg_numeral v) f = f (neg_numeral v)"
168.114 +lemma Let_neg_numeral [simp]: "Let (- numeral v) f = f (- numeral v)"
168.115 -- {* Unfold all @{text let}s involving constants *}
168.116 unfolding Let_def ..
168.117
168.118 @@ -495,15 +524,15 @@
168.119
168.120 lemmas max_number_of [simp] =
168.121 max_def [of "numeral u" "numeral v"]
168.122 - max_def [of "numeral u" "neg_numeral v"]
168.123 - max_def [of "neg_numeral u" "numeral v"]
168.124 - max_def [of "neg_numeral u" "neg_numeral v"] for u v
168.125 + max_def [of "numeral u" "- numeral v"]
168.126 + max_def [of "- numeral u" "numeral v"]
168.127 + max_def [of "- numeral u" "- numeral v"] for u v
168.128
168.129 lemmas min_number_of [simp] =
168.130 min_def [of "numeral u" "numeral v"]
168.131 - min_def [of "numeral u" "neg_numeral v"]
168.132 - min_def [of "neg_numeral u" "numeral v"]
168.133 - min_def [of "neg_numeral u" "neg_numeral v"] for u v
168.134 + min_def [of "numeral u" "- numeral v"]
168.135 + min_def [of "- numeral u" "numeral v"]
168.136 + min_def [of "- numeral u" "- numeral v"] for u v
168.137
168.138
168.139 subsubsection {* Binary comparisons *}
168.140 @@ -722,14 +751,11 @@
168.141
168.142 subsection {* Setting up simplification procedures *}
168.143
168.144 +lemmas of_int_simps =
168.145 + of_int_0 of_int_1 of_int_add of_int_mult
168.146 +
168.147 lemmas int_arith_rules =
168.148 - neg_le_iff_le numeral_One
168.149 - minus_zero diff_minus left_minus right_minus
168.150 - mult_zero_left mult_zero_right mult_1_left mult_1_right
168.151 - mult_minus_left mult_minus_right
168.152 - minus_add_distrib minus_minus mult_assoc
168.153 - of_nat_0 of_nat_1 of_nat_Suc of_nat_add of_nat_mult
168.154 - of_int_0 of_int_1 of_int_add of_int_mult
168.155 + numeral_One more_arith_simps of_nat_simps of_int_simps
168.156
168.157 ML_file "Tools/int_arith.ML"
168.158 declaration {* K Int_Arith.setup *}
168.159 @@ -768,16 +794,6 @@
168.160 subsection{*The functions @{term nat} and @{term int}*}
168.161
168.162 text{*Simplify the term @{term "w + - z"}*}
168.163 -lemmas diff_int_def_symmetric = diff_def [where 'a=int, symmetric, simp]
168.164 -
168.165 -lemma nat_0 [simp]: "nat 0 = 0"
168.166 -by (simp add: nat_eq_iff)
168.167 -
168.168 -lemma nat_1 [simp]: "nat 1 = Suc 0"
168.169 -by (subst nat_eq_iff, simp)
168.170 -
168.171 -lemma nat_2: "nat 2 = Suc (Suc 0)"
168.172 -by (subst nat_eq_iff, simp)
168.173
168.174 lemma one_less_nat_eq [simp]: "(Suc 0 < nat z) = (1 < z)"
168.175 apply (insert zless_nat_conj [of 1 z])
168.176 @@ -860,31 +876,10 @@
168.177 if d < 0 then 0 else nat d)"
168.178 by (simp add: Let_def nat_diff_distrib [symmetric])
168.179
168.180 -(* nat_diff_distrib has too-strong premises *)
168.181 -lemma nat_diff_distrib': "\<lbrakk>0 \<le> x; 0 \<le> y\<rbrakk> \<Longrightarrow> nat (x - y) = nat x - nat y"
168.182 -apply (rule int_int_eq [THEN iffD1], clarsimp)
168.183 -apply (subst of_nat_diff)
168.184 -apply (rule nat_mono, simp_all)
168.185 -done
168.186 -
168.187 -lemma nat_numeral [simp]:
168.188 - "nat (numeral k) = numeral k"
168.189 - by (simp add: nat_eq_iff)
168.190 -
168.191 -lemma nat_neg_numeral [simp]:
168.192 - "nat (neg_numeral k) = 0"
168.193 - by simp
168.194 -
168.195 -lemma diff_nat_numeral [simp]:
168.196 - "(numeral v :: nat) - numeral v' = nat (numeral v - numeral v')"
168.197 - by (simp only: nat_diff_distrib' zero_le_numeral nat_numeral)
168.198 -
168.199 lemma nat_numeral_diff_1 [simp]:
168.200 "numeral v - (1::nat) = nat (numeral v - 1)"
168.201 using diff_nat_numeral [of v Num.One] by simp
168.202
168.203 -lemmas nat_arith = diff_nat_numeral
168.204 -
168.205
168.206 subsection "Induction principles for int"
168.207
168.208 @@ -1074,8 +1069,6 @@
168.209 by auto
168.210 qed
168.211
168.212 -ML_val {* @{const_name neg_numeral} *}
168.213 -
168.214 lemma pos_zmult_eq_1_iff_lemma: "(m * n = 1) ==> m = (1::int) | m = -1"
168.215 by (insert abs_zmult_eq_1 [of m n], arith)
168.216
168.217 @@ -1131,62 +1124,30 @@
168.218 inverse_eq_divide [of "numeral w"] for w
168.219
168.220 lemmas inverse_eq_divide_neg_numeral [simp] =
168.221 - inverse_eq_divide [of "neg_numeral w"] for w
168.222 + inverse_eq_divide [of "- numeral w"] for w
168.223
168.224 text {*These laws simplify inequalities, moving unary minus from a term
168.225 into the literal.*}
168.226
168.227 -lemmas le_minus_iff_numeral [simp, no_atp] =
168.228 - le_minus_iff [of "numeral v"]
168.229 - le_minus_iff [of "neg_numeral v"] for v
168.230 +lemmas equation_minus_iff_numeral [no_atp] =
168.231 + equation_minus_iff [of "numeral v"] for v
168.232
168.233 -lemmas equation_minus_iff_numeral [simp, no_atp] =
168.234 - equation_minus_iff [of "numeral v"]
168.235 - equation_minus_iff [of "neg_numeral v"] for v
168.236 +lemmas minus_equation_iff_numeral [no_atp] =
168.237 + minus_equation_iff [of _ "numeral v"] for v
168.238
168.239 -lemmas minus_less_iff_numeral [simp, no_atp] =
168.240 - minus_less_iff [of _ "numeral v"]
168.241 - minus_less_iff [of _ "neg_numeral v"] for v
168.242 +lemmas le_minus_iff_numeral [no_atp] =
168.243 + le_minus_iff [of "numeral v"] for v
168.244
168.245 -lemmas minus_le_iff_numeral [simp, no_atp] =
168.246 - minus_le_iff [of _ "numeral v"]
168.247 - minus_le_iff [of _ "neg_numeral v"] for v
168.248 +lemmas minus_le_iff_numeral [no_atp] =
168.249 + minus_le_iff [of _ "numeral v"] for v
168.250
168.251 -lemmas minus_equation_iff_numeral [simp, no_atp] =
168.252 - minus_equation_iff [of _ "numeral v"]
168.253 - minus_equation_iff [of _ "neg_numeral v"] for v
168.254 +lemmas less_minus_iff_numeral [no_atp] =
168.255 + less_minus_iff [of "numeral v"] for v
168.256
168.257 -text{*To Simplify Inequalities Where One Side is the Constant 1*}
168.258 +lemmas minus_less_iff_numeral [no_atp] =
168.259 + minus_less_iff [of _ "numeral v"] for v
168.260
168.261 -lemma less_minus_iff_1 [simp,no_atp]:
168.262 - fixes b::"'b::linordered_idom"
168.263 - shows "(1 < - b) = (b < -1)"
168.264 -by auto
168.265 -
168.266 -lemma le_minus_iff_1 [simp,no_atp]:
168.267 - fixes b::"'b::linordered_idom"
168.268 - shows "(1 \<le> - b) = (b \<le> -1)"
168.269 -by auto
168.270 -
168.271 -lemma equation_minus_iff_1 [simp,no_atp]:
168.272 - fixes b::"'b::ring_1"
168.273 - shows "(1 = - b) = (b = -1)"
168.274 -by (subst equation_minus_iff, auto)
168.275 -
168.276 -lemma minus_less_iff_1 [simp,no_atp]:
168.277 - fixes a::"'b::linordered_idom"
168.278 - shows "(- a < 1) = (-1 < a)"
168.279 -by auto
168.280 -
168.281 -lemma minus_le_iff_1 [simp,no_atp]:
168.282 - fixes a::"'b::linordered_idom"
168.283 - shows "(- a \<le> 1) = (-1 \<le> a)"
168.284 -by auto
168.285 -
168.286 -lemma minus_equation_iff_1 [simp,no_atp]:
168.287 - fixes a::"'b::ring_1"
168.288 - shows "(- a = 1) = (a = -1)"
168.289 -by (subst minus_equation_iff, auto)
168.290 +-- {* FIXME maybe simproc *}
168.291
168.292
168.293 text {*Cancellation of constant factors in comparisons (@{text "<"} and @{text "\<le>"}) *}
168.294 @@ -1201,27 +1162,28 @@
168.295
168.296 lemmas le_divide_eq_numeral1 [simp] =
168.297 pos_le_divide_eq [of "numeral w", OF zero_less_numeral]
168.298 - neg_le_divide_eq [of "neg_numeral w", OF neg_numeral_less_zero] for w
168.299 + neg_le_divide_eq [of "- numeral w", OF neg_numeral_less_zero] for w
168.300
168.301 lemmas divide_le_eq_numeral1 [simp] =
168.302 pos_divide_le_eq [of "numeral w", OF zero_less_numeral]
168.303 - neg_divide_le_eq [of "neg_numeral w", OF neg_numeral_less_zero] for w
168.304 + neg_divide_le_eq [of "- numeral w", OF neg_numeral_less_zero] for w
168.305
168.306 lemmas less_divide_eq_numeral1 [simp] =
168.307 pos_less_divide_eq [of "numeral w", OF zero_less_numeral]
168.308 - neg_less_divide_eq [of "neg_numeral w", OF neg_numeral_less_zero] for w
168.309 + neg_less_divide_eq [of "- numeral w", OF neg_numeral_less_zero] for w
168.310
168.311 lemmas divide_less_eq_numeral1 [simp] =
168.312 pos_divide_less_eq [of "numeral w", OF zero_less_numeral]
168.313 - neg_divide_less_eq [of "neg_numeral w", OF neg_numeral_less_zero] for w
168.314 + neg_divide_less_eq [of "- numeral w", OF neg_numeral_less_zero] for w
168.315
168.316 lemmas eq_divide_eq_numeral1 [simp] =
168.317 eq_divide_eq [of _ _ "numeral w"]
168.318 - eq_divide_eq [of _ _ "neg_numeral w"] for w
168.319 + eq_divide_eq [of _ _ "- numeral w"] for w
168.320
168.321 lemmas divide_eq_eq_numeral1 [simp] =
168.322 divide_eq_eq [of _ "numeral w"]
168.323 - divide_eq_eq [of _ "neg_numeral w"] for w
168.324 + divide_eq_eq [of _ "- numeral w"] for w
168.325 +
168.326
168.327 subsubsection{*Optional Simplification Rules Involving Constants*}
168.328
168.329 @@ -1229,27 +1191,27 @@
168.330
168.331 lemmas le_divide_eq_numeral =
168.332 le_divide_eq [of "numeral w"]
168.333 - le_divide_eq [of "neg_numeral w"] for w
168.334 + le_divide_eq [of "- numeral w"] for w
168.335
168.336 lemmas divide_le_eq_numeral =
168.337 divide_le_eq [of _ _ "numeral w"]
168.338 - divide_le_eq [of _ _ "neg_numeral w"] for w
168.339 + divide_le_eq [of _ _ "- numeral w"] for w
168.340
168.341 lemmas less_divide_eq_numeral =
168.342 less_divide_eq [of "numeral w"]
168.343 - less_divide_eq [of "neg_numeral w"] for w
168.344 + less_divide_eq [of "- numeral w"] for w
168.345
168.346 lemmas divide_less_eq_numeral =
168.347 divide_less_eq [of _ _ "numeral w"]
168.348 - divide_less_eq [of _ _ "neg_numeral w"] for w
168.349 + divide_less_eq [of _ _ "- numeral w"] for w
168.350
168.351 lemmas eq_divide_eq_numeral =
168.352 eq_divide_eq [of "numeral w"]
168.353 - eq_divide_eq [of "neg_numeral w"] for w
168.354 + eq_divide_eq [of "- numeral w"] for w
168.355
168.356 lemmas divide_eq_eq_numeral =
168.357 divide_eq_eq [of _ _ "numeral w"]
168.358 - divide_eq_eq [of _ _ "neg_numeral w"] for w
168.359 + divide_eq_eq [of _ _ "- numeral w"] for w
168.360
168.361
168.362 text{*Not good as automatic simprules because they cause case splits.*}
168.363 @@ -1261,21 +1223,20 @@
168.364 text{*Division By @{text "-1"}*}
168.365
168.366 lemma divide_minus1 [simp]: "(x::'a::field) / -1 = - x"
168.367 - unfolding minus_one [symmetric]
168.368 unfolding nonzero_minus_divide_right [OF one_neq_zero, symmetric]
168.369 by simp
168.370
168.371 lemma minus1_divide [simp]: "-1 / (x::'a::field) = - (1 / x)"
168.372 - unfolding minus_one [symmetric] by (rule divide_minus_left)
168.373 + by (fact divide_minus_left)
168.374
168.375 lemma half_gt_zero_iff:
168.376 - "(0 < r/2) = (0 < (r::'a::linordered_field_inverse_zero))"
168.377 -by auto
168.378 + "(0 < r/2) = (0 < (r::'a::linordered_field_inverse_zero))"
168.379 + by auto
168.380
168.381 lemmas half_gt_zero [simp] = half_gt_zero_iff [THEN iffD2]
168.382
168.383 lemma divide_Numeral1: "(x::'a::field) / Numeral1 = x"
168.384 - by simp
168.385 + by (fact divide_numeral_1)
168.386
168.387
168.388 subsection {* The divides relation *}
168.389 @@ -1479,7 +1440,7 @@
168.390 [simp, code_abbrev]: "Pos = numeral"
168.391
168.392 definition Neg :: "num \<Rightarrow> int" where
168.393 - [simp, code_abbrev]: "Neg = neg_numeral"
168.394 + [simp, code_abbrev]: "Neg n = - (Pos n)"
168.395
168.396 code_datatype "0::int" Pos Neg
168.397
168.398 @@ -1493,7 +1454,7 @@
168.399 "dup 0 = 0"
168.400 "dup (Pos n) = Pos (Num.Bit0 n)"
168.401 "dup (Neg n) = Neg (Num.Bit0 n)"
168.402 - unfolding Pos_def Neg_def neg_numeral_def
168.403 + unfolding Pos_def Neg_def
168.404 by (simp_all add: numeral_Bit0)
168.405
168.406 definition sub :: "num \<Rightarrow> num \<Rightarrow> int" where
168.407 @@ -1509,10 +1470,11 @@
168.408 "sub (Num.Bit1 m) (Num.Bit1 n) = dup (sub m n)"
168.409 "sub (Num.Bit1 m) (Num.Bit0 n) = dup (sub m n) + 1"
168.410 "sub (Num.Bit0 m) (Num.Bit1 n) = dup (sub m n) - 1"
168.411 - unfolding sub_def dup_def numeral.simps Pos_def Neg_def
168.412 - neg_numeral_def numeral_BitM
168.413 - by (simp_all only: algebra_simps)
168.414 -
168.415 + apply (simp_all only: sub_def dup_def numeral.simps Pos_def Neg_def numeral_BitM)
168.416 + apply (simp_all only: algebra_simps minus_diff_eq)
168.417 + apply (simp_all only: add.commute [of _ "- (numeral n + numeral n)"])
168.418 + apply (simp_all only: minus_add add.assoc left_minus)
168.419 + done
168.420
168.421 text {* Implementations *}
168.422
168.423 @@ -1607,10 +1569,10 @@
168.424 "nat (Int.Neg k) = 0"
168.425 "nat 0 = 0"
168.426 "nat (Int.Pos k) = nat_of_num k"
168.427 - by (simp_all add: nat_of_num_numeral nat_numeral)
168.428 + by (simp_all add: nat_of_num_numeral)
168.429
168.430 lemma (in ring_1) of_int_code [code]:
168.431 - "of_int (Int.Neg k) = neg_numeral k"
168.432 + "of_int (Int.Neg k) = - numeral k"
168.433 "of_int 0 = 0"
168.434 "of_int (Int.Pos k) = numeral k"
168.435 by simp_all
168.436 @@ -1654,7 +1616,7 @@
168.437
168.438 lemma int_power:
168.439 "int (m ^ n) = int m ^ n"
168.440 - by (rule of_nat_power)
168.441 + by (fact of_nat_power)
168.442
168.443 lemmas zpower_int = int_power [symmetric]
168.444
169.1 --- a/src/HOL/Lattices.thy Thu Dec 05 17:52:12 2013 +0100
169.2 +++ b/src/HOL/Lattices.thy Thu Dec 05 17:58:03 2013 +0100
169.3 @@ -5,7 +5,7 @@
169.4 header {* Abstract lattices *}
169.5
169.6 theory Lattices
169.7 -imports Orderings Groups
169.8 +imports Groups
169.9 begin
169.10
169.11 subsection {* Abstract semilattice *}
170.1 --- a/src/HOL/Library/Abstract_Rat.thy Thu Dec 05 17:52:12 2013 +0100
170.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
170.3 @@ -1,521 +0,0 @@
170.4 -(* Title: HOL/Library/Abstract_Rat.thy
170.5 - Author: Amine Chaieb
170.6 -*)
170.7 -
170.8 -header {* Abstract rational numbers *}
170.9 -
170.10 -theory Abstract_Rat
170.11 -imports Complex_Main
170.12 -begin
170.13 -
170.14 -type_synonym Num = "int \<times> int"
170.15 -
170.16 -abbreviation Num0_syn :: Num ("0\<^sub>N")
170.17 - where "0\<^sub>N \<equiv> (0, 0)"
170.18 -
170.19 -abbreviation Numi_syn :: "int \<Rightarrow> Num" ("'((_)')\<^sub>N")
170.20 - where "(i)\<^sub>N \<equiv> (i, 1)"
170.21 -
170.22 -definition isnormNum :: "Num \<Rightarrow> bool" where
170.23 - "isnormNum = (\<lambda>(a,b). (if a = 0 then b = 0 else b > 0 \<and> gcd a b = 1))"
170.24 -
170.25 -definition normNum :: "Num \<Rightarrow> Num" where
170.26 - "normNum = (\<lambda>(a,b).
170.27 - (if a=0 \<or> b = 0 then (0,0) else
170.28 - (let g = gcd a b
170.29 - in if b > 0 then (a div g, b div g) else (- (a div g), - (b div g)))))"
170.30 -
170.31 -declare gcd_dvd1_int[presburger] gcd_dvd2_int[presburger]
170.32 -
170.33 -lemma normNum_isnormNum [simp]: "isnormNum (normNum x)"
170.34 -proof -
170.35 - obtain a b where x: "x = (a, b)" by (cases x)
170.36 - { assume "a=0 \<or> b = 0" hence ?thesis by (simp add: x normNum_def isnormNum_def) }
170.37 - moreover
170.38 - { assume anz: "a \<noteq> 0" and bnz: "b \<noteq> 0"
170.39 - let ?g = "gcd a b"
170.40 - let ?a' = "a div ?g"
170.41 - let ?b' = "b div ?g"
170.42 - let ?g' = "gcd ?a' ?b'"
170.43 - from anz bnz have "?g \<noteq> 0" by simp with gcd_ge_0_int[of a b]
170.44 - have gpos: "?g > 0" by arith
170.45 - have gdvd: "?g dvd a" "?g dvd b" by arith+
170.46 - from dvd_mult_div_cancel[OF gdvd(1)] dvd_mult_div_cancel[OF gdvd(2)] anz bnz
170.47 - have nz': "?a' \<noteq> 0" "?b' \<noteq> 0" by - (rule notI, simp)+
170.48 - from anz bnz have stupid: "a \<noteq> 0 \<or> b \<noteq> 0" by arith
170.49 - from div_gcd_coprime_int[OF stupid] have gp1: "?g' = 1" .
170.50 - from bnz have "b < 0 \<or> b > 0" by arith
170.51 - moreover
170.52 - { assume b: "b > 0"
170.53 - from b have "?b' \<ge> 0"
170.54 - by (presburger add: pos_imp_zdiv_nonneg_iff[OF gpos])
170.55 - with nz' have b': "?b' > 0" by arith
170.56 - from b b' anz bnz nz' gp1 have ?thesis
170.57 - by (simp add: x isnormNum_def normNum_def Let_def split_def) }
170.58 - moreover {
170.59 - assume b: "b < 0"
170.60 - { assume b': "?b' \<ge> 0"
170.61 - from gpos have th: "?g \<ge> 0" by arith
170.62 - from mult_nonneg_nonneg[OF th b'] dvd_mult_div_cancel[OF gdvd(2)]
170.63 - have False using b by arith }
170.64 - hence b': "?b' < 0" by (presburger add: linorder_not_le[symmetric])
170.65 - from anz bnz nz' b b' gp1 have ?thesis
170.66 - by (simp add: x isnormNum_def normNum_def Let_def split_def) }
170.67 - ultimately have ?thesis by blast
170.68 - }
170.69 - ultimately show ?thesis by blast
170.70 -qed
170.71 -
170.72 -text {* Arithmetic over Num *}
170.73 -
170.74 -definition Nadd :: "Num \<Rightarrow> Num \<Rightarrow> Num" (infixl "+\<^sub>N" 60) where
170.75 - "Nadd = (\<lambda>(a,b) (a',b'). if a = 0 \<or> b = 0 then normNum(a',b')
170.76 - else if a'=0 \<or> b' = 0 then normNum(a,b)
170.77 - else normNum(a*b' + b*a', b*b'))"
170.78 -
170.79 -definition Nmul :: "Num \<Rightarrow> Num \<Rightarrow> Num" (infixl "*\<^sub>N" 60) where
170.80 - "Nmul = (\<lambda>(a,b) (a',b'). let g = gcd (a*a') (b*b')
170.81 - in (a*a' div g, b*b' div g))"
170.82 -
170.83 -definition Nneg :: "Num \<Rightarrow> Num" ("~\<^sub>N")
170.84 - where "Nneg \<equiv> (\<lambda>(a,b). (-a,b))"
170.85 -
170.86 -definition Nsub :: "Num \<Rightarrow> Num \<Rightarrow> Num" (infixl "-\<^sub>N" 60)
170.87 - where "Nsub = (\<lambda>a b. a +\<^sub>N ~\<^sub>N b)"
170.88 -
170.89 -definition Ninv :: "Num \<Rightarrow> Num"
170.90 - where "Ninv = (\<lambda>(a,b). if a < 0 then (-b, \<bar>a\<bar>) else (b,a))"
170.91 -
170.92 -definition Ndiv :: "Num \<Rightarrow> Num \<Rightarrow> Num" (infixl "\<div>\<^sub>N" 60)
170.93 - where "Ndiv = (\<lambda>a b. a *\<^sub>N Ninv b)"
170.94 -
170.95 -lemma Nneg_normN[simp]: "isnormNum x \<Longrightarrow> isnormNum (~\<^sub>N x)"
170.96 - by (simp add: isnormNum_def Nneg_def split_def)
170.97 -
170.98 -lemma Nadd_normN[simp]: "isnormNum (x +\<^sub>N y)"
170.99 - by (simp add: Nadd_def split_def)
170.100 -
170.101 -lemma Nsub_normN[simp]: "\<lbrakk> isnormNum y\<rbrakk> \<Longrightarrow> isnormNum (x -\<^sub>N y)"
170.102 - by (simp add: Nsub_def split_def)
170.103 -
170.104 -lemma Nmul_normN[simp]:
170.105 - assumes xn: "isnormNum x" and yn: "isnormNum y"
170.106 - shows "isnormNum (x *\<^sub>N y)"
170.107 -proof -
170.108 - obtain a b where x: "x = (a, b)" by (cases x)
170.109 - obtain a' b' where y: "y = (a', b')" by (cases y)
170.110 - { assume "a = 0"
170.111 - hence ?thesis using xn x y
170.112 - by (simp add: isnormNum_def Let_def Nmul_def split_def) }
170.113 - moreover
170.114 - { assume "a' = 0"
170.115 - hence ?thesis using yn x y
170.116 - by (simp add: isnormNum_def Let_def Nmul_def split_def) }
170.117 - moreover
170.118 - { assume a: "a \<noteq>0" and a': "a'\<noteq>0"
170.119 - hence bp: "b > 0" "b' > 0" using xn yn x y by (simp_all add: isnormNum_def)
170.120 - from mult_pos_pos[OF bp] have "x *\<^sub>N y = normNum (a * a', b * b')"
170.121 - using x y a a' bp by (simp add: Nmul_def Let_def split_def normNum_def)
170.122 - hence ?thesis by simp }
170.123 - ultimately show ?thesis by blast
170.124 -qed
170.125 -
170.126 -lemma Ninv_normN[simp]: "isnormNum x \<Longrightarrow> isnormNum (Ninv x)"
170.127 - by (simp add: Ninv_def isnormNum_def split_def)
170.128 - (cases "fst x = 0", auto simp add: gcd_commute_int)
170.129 -
170.130 -lemma isnormNum_int[simp]:
170.131 - "isnormNum 0\<^sub>N" "isnormNum ((1::int)\<^sub>N)" "i \<noteq> 0 \<Longrightarrow> isnormNum (i)\<^sub>N"
170.132 - by (simp_all add: isnormNum_def)
170.133 -
170.134 -
170.135 -text {* Relations over Num *}
170.136 -
170.137 -definition Nlt0:: "Num \<Rightarrow> bool" ("0>\<^sub>N")
170.138 - where "Nlt0 = (\<lambda>(a,b). a < 0)"
170.139 -
170.140 -definition Nle0:: "Num \<Rightarrow> bool" ("0\<ge>\<^sub>N")
170.141 - where "Nle0 = (\<lambda>(a,b). a \<le> 0)"
170.142 -
170.143 -definition Ngt0:: "Num \<Rightarrow> bool" ("0<\<^sub>N")
170.144 - where "Ngt0 = (\<lambda>(a,b). a > 0)"
170.145 -
170.146 -definition Nge0:: "Num \<Rightarrow> bool" ("0\<le>\<^sub>N")
170.147 - where "Nge0 = (\<lambda>(a,b). a \<ge> 0)"
170.148 -
170.149 -definition Nlt :: "Num \<Rightarrow> Num \<Rightarrow> bool" (infix "<\<^sub>N" 55)
170.150 - where "Nlt = (\<lambda>a b. 0>\<^sub>N (a -\<^sub>N b))"
170.151 -
170.152 -definition Nle :: "Num \<Rightarrow> Num \<Rightarrow> bool" (infix "\<le>\<^sub>N" 55)
170.153 - where "Nle = (\<lambda>a b. 0\<ge>\<^sub>N (a -\<^sub>N b))"
170.154 -
170.155 -definition "INum = (\<lambda>(a,b). of_int a / of_int b)"
170.156 -
170.157 -lemma INum_int [simp]: "INum (i)\<^sub>N = ((of_int i) ::'a::field)" "INum 0\<^sub>N = (0::'a::field)"
170.158 - by (simp_all add: INum_def)
170.159 -
170.160 -lemma isnormNum_unique[simp]:
170.161 - assumes na: "isnormNum x" and nb: "isnormNum y"
170.162 - shows "((INum x ::'a::{field_char_0, field_inverse_zero}) = INum y) = (x = y)" (is "?lhs = ?rhs")
170.163 -proof
170.164 - obtain a b where x: "x = (a, b)" by (cases x)
170.165 - obtain a' b' where y: "y = (a', b')" by (cases y)
170.166 - assume H: ?lhs
170.167 - { assume "a = 0 \<or> b = 0 \<or> a' = 0 \<or> b' = 0"
170.168 - hence ?rhs using na nb H
170.169 - by (simp add: x y INum_def split_def isnormNum_def split: split_if_asm) }
170.170 - moreover
170.171 - { assume az: "a \<noteq> 0" and bz: "b \<noteq> 0" and a'z: "a'\<noteq>0" and b'z: "b'\<noteq>0"
170.172 - from az bz a'z b'z na nb have pos: "b > 0" "b' > 0" by (simp_all add: x y isnormNum_def)
170.173 - from H bz b'z have eq: "a * b' = a'*b"
170.174 - by (simp add: x y INum_def eq_divide_eq divide_eq_eq of_int_mult[symmetric] del: of_int_mult)
170.175 - from az a'z na nb have gcd1: "gcd a b = 1" "gcd b a = 1" "gcd a' b' = 1" "gcd b' a' = 1"
170.176 - by (simp_all add: x y isnormNum_def add: gcd_commute_int)
170.177 - from eq have raw_dvd: "a dvd a' * b" "b dvd b' * a" "a' dvd a * b'" "b' dvd b * a'"
170.178 - apply -
170.179 - apply algebra
170.180 - apply algebra
170.181 - apply simp
170.182 - apply algebra
170.183 - done
170.184 - from zdvd_antisym_abs[OF coprime_dvd_mult_int[OF gcd1(2) raw_dvd(2)]
170.185 - coprime_dvd_mult_int[OF gcd1(4) raw_dvd(4)]]
170.186 - have eq1: "b = b'" using pos by arith
170.187 - with eq have "a = a'" using pos by simp
170.188 - with eq1 have ?rhs by (simp add: x y) }
170.189 - ultimately show ?rhs by blast
170.190 -next
170.191 - assume ?rhs thus ?lhs by simp
170.192 -qed
170.193 -
170.194 -
170.195 -lemma isnormNum0[simp]:
170.196 - "isnormNum x \<Longrightarrow> (INum x = (0::'a::{field_char_0, field_inverse_zero})) = (x = 0\<^sub>N)"
170.197 - unfolding INum_int(2)[symmetric]
170.198 - by (rule isnormNum_unique) simp_all
170.199 -
170.200 -lemma of_int_div_aux: "d ~= 0 ==> ((of_int x)::'a::field_char_0) / (of_int d) =
170.201 - of_int (x div d) + (of_int (x mod d)) / ((of_int d)::'a)"
170.202 -proof -
170.203 - assume "d ~= 0"
170.204 - let ?t = "of_int (x div d) * ((of_int d)::'a) + of_int(x mod d)"
170.205 - let ?f = "\<lambda>x. x / of_int d"
170.206 - have "x = (x div d) * d + x mod d"
170.207 - by auto
170.208 - then have eq: "of_int x = ?t"
170.209 - by (simp only: of_int_mult[symmetric] of_int_add [symmetric])
170.210 - then have "of_int x / of_int d = ?t / of_int d"
170.211 - using cong[OF refl[of ?f] eq] by simp
170.212 - then show ?thesis by (simp add: add_divide_distrib algebra_simps `d ~= 0`)
170.213 -qed
170.214 -
170.215 -lemma of_int_div: "(d::int) ~= 0 ==> d dvd n ==>
170.216 - (of_int(n div d)::'a::field_char_0) = of_int n / of_int d"
170.217 - apply (frule of_int_div_aux [of d n, where ?'a = 'a])
170.218 - apply simp
170.219 - apply (simp add: dvd_eq_mod_eq_0)
170.220 - done
170.221 -
170.222 -
170.223 -lemma normNum[simp]: "INum (normNum x) = (INum x :: 'a::{field_char_0, field_inverse_zero})"
170.224 -proof -
170.225 - obtain a b where x: "x = (a, b)" by (cases x)
170.226 - { assume "a = 0 \<or> b = 0"
170.227 - hence ?thesis by (simp add: x INum_def normNum_def split_def Let_def) }
170.228 - moreover
170.229 - { assume a: "a \<noteq> 0" and b: "b \<noteq> 0"
170.230 - let ?g = "gcd a b"
170.231 - from a b have g: "?g \<noteq> 0"by simp
170.232 - from of_int_div[OF g, where ?'a = 'a]
170.233 - have ?thesis by (auto simp add: x INum_def normNum_def split_def Let_def) }
170.234 - ultimately show ?thesis by blast
170.235 -qed
170.236 -
170.237 -lemma INum_normNum_iff:
170.238 - "(INum x ::'a::{field_char_0, field_inverse_zero}) = INum y \<longleftrightarrow> normNum x = normNum y"
170.239 - (is "?lhs = ?rhs")
170.240 -proof -
170.241 - have "normNum x = normNum y \<longleftrightarrow> (INum (normNum x) :: 'a) = INum (normNum y)"
170.242 - by (simp del: normNum)
170.243 - also have "\<dots> = ?lhs" by simp
170.244 - finally show ?thesis by simp
170.245 -qed
170.246 -
170.247 -lemma Nadd[simp]: "INum (x +\<^sub>N y) = INum x + (INum y :: 'a :: {field_char_0, field_inverse_zero})"
170.248 -proof -
170.249 - let ?z = "0:: 'a"
170.250 - obtain a b where x: "x = (a, b)" by (cases x)
170.251 - obtain a' b' where y: "y = (a', b')" by (cases y)
170.252 - { assume "a=0 \<or> a'= 0 \<or> b =0 \<or> b' = 0"
170.253 - hence ?thesis
170.254 - apply (cases "a=0", simp_all add: x y Nadd_def)
170.255 - apply (cases "b= 0", simp_all add: INum_def)
170.256 - apply (cases "a'= 0", simp_all)
170.257 - apply (cases "b'= 0", simp_all)
170.258 - done }
170.259 - moreover
170.260 - { assume aa': "a \<noteq> 0" "a'\<noteq> 0" and bb': "b \<noteq> 0" "b' \<noteq> 0"
170.261 - { assume z: "a * b' + b * a' = 0"
170.262 - hence "of_int (a*b' + b*a') / (of_int b* of_int b') = ?z" by simp
170.263 - hence "of_int b' * of_int a / (of_int b * of_int b') +
170.264 - of_int b * of_int a' / (of_int b * of_int b') = ?z"
170.265 - by (simp add:add_divide_distrib)
170.266 - hence th: "of_int a / of_int b + of_int a' / of_int b' = ?z" using bb' aa'
170.267 - by simp
170.268 - from z aa' bb' have ?thesis
170.269 - by (simp add: x y th Nadd_def normNum_def INum_def split_def) }
170.270 - moreover {
170.271 - assume z: "a * b' + b * a' \<noteq> 0"
170.272 - let ?g = "gcd (a * b' + b * a') (b*b')"
170.273 - have gz: "?g \<noteq> 0" using z by simp
170.274 - have ?thesis using aa' bb' z gz
170.275 - of_int_div[where ?'a = 'a, OF gz gcd_dvd1_int[where x="a * b' + b * a'" and y="b*b'"]]
170.276 - of_int_div[where ?'a = 'a, OF gz gcd_dvd2_int[where x="a * b' + b * a'" and y="b*b'"]]
170.277 - by (simp add: x y Nadd_def INum_def normNum_def Let_def add_divide_distrib) }
170.278 - ultimately have ?thesis using aa' bb'
170.279 - by (simp add: x y Nadd_def INum_def normNum_def Let_def) }
170.280 - ultimately show ?thesis by blast
170.281 -qed
170.282 -
170.283 -lemma Nmul[simp]: "INum (x *\<^sub>N y) = INum x * (INum y:: 'a :: {field_char_0, field_inverse_zero})"
170.284 -proof -
170.285 - let ?z = "0::'a"
170.286 - obtain a b where x: "x = (a, b)" by (cases x)
170.287 - obtain a' b' where y: "y = (a', b')" by (cases y)
170.288 - { assume "a=0 \<or> a'= 0 \<or> b = 0 \<or> b' = 0"
170.289 - hence ?thesis
170.290 - apply (cases "a=0", simp_all add: x y Nmul_def INum_def Let_def)
170.291 - apply (cases "b=0", simp_all)
170.292 - apply (cases "a'=0", simp_all)
170.293 - done }
170.294 - moreover
170.295 - { assume z: "a \<noteq> 0" "a' \<noteq> 0" "b \<noteq> 0" "b' \<noteq> 0"
170.296 - let ?g="gcd (a*a') (b*b')"
170.297 - have gz: "?g \<noteq> 0" using z by simp
170.298 - from z of_int_div[where ?'a = 'a, OF gz gcd_dvd1_int[where x="a*a'" and y="b*b'"]]
170.299 - of_int_div[where ?'a = 'a , OF gz gcd_dvd2_int[where x="a*a'" and y="b*b'"]]
170.300 - have ?thesis by (simp add: Nmul_def x y Let_def INum_def) }
170.301 - ultimately show ?thesis by blast
170.302 -qed
170.303 -
170.304 -lemma Nneg[simp]: "INum (~\<^sub>N x) = - (INum x ::'a:: field)"
170.305 - by (simp add: Nneg_def split_def INum_def)
170.306 -
170.307 -lemma Nsub[simp]: "INum (x -\<^sub>N y) = INum x - (INum y:: 'a :: {field_char_0, field_inverse_zero})"
170.308 - by (simp add: Nsub_def split_def)
170.309 -
170.310 -lemma Ninv[simp]: "INum (Ninv x) = (1::'a :: field_inverse_zero) / (INum x)"
170.311 - by (simp add: Ninv_def INum_def split_def)
170.312 -
170.313 -lemma Ndiv[simp]: "INum (x \<div>\<^sub>N y) = INum x / (INum y ::'a :: {field_char_0, field_inverse_zero})"
170.314 - by (simp add: Ndiv_def)
170.315 -
170.316 -lemma Nlt0_iff[simp]:
170.317 - assumes nx: "isnormNum x"
170.318 - shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero})< 0) = 0>\<^sub>N x"
170.319 -proof -
170.320 - obtain a b where x: "x = (a, b)" by (cases x)
170.321 - { assume "a = 0" hence ?thesis by (simp add: x Nlt0_def INum_def) }
170.322 - moreover
170.323 - { assume a: "a \<noteq> 0" hence b: "(of_int b::'a) > 0"
170.324 - using nx by (simp add: x isnormNum_def)
170.325 - from pos_divide_less_eq[OF b, where b="of_int a" and a="0::'a"]
170.326 - have ?thesis by (simp add: x Nlt0_def INum_def) }
170.327 - ultimately show ?thesis by blast
170.328 -qed
170.329 -
170.330 -lemma Nle0_iff[simp]:
170.331 - assumes nx: "isnormNum x"
170.332 - shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero}) \<le> 0) = 0\<ge>\<^sub>N x"
170.333 -proof -
170.334 - obtain a b where x: "x = (a, b)" by (cases x)
170.335 - { assume "a = 0" hence ?thesis by (simp add: x Nle0_def INum_def) }
170.336 - moreover
170.337 - { assume a: "a \<noteq> 0" hence b: "(of_int b :: 'a) > 0"
170.338 - using nx by (simp add: x isnormNum_def)
170.339 - from pos_divide_le_eq[OF b, where b="of_int a" and a="0::'a"]
170.340 - have ?thesis by (simp add: x Nle0_def INum_def) }
170.341 - ultimately show ?thesis by blast
170.342 -qed
170.343 -
170.344 -lemma Ngt0_iff[simp]:
170.345 - assumes nx: "isnormNum x"
170.346 - shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero})> 0) = 0<\<^sub>N x"
170.347 -proof -
170.348 - obtain a b where x: "x = (a, b)" by (cases x)
170.349 - { assume "a = 0" hence ?thesis by (simp add: x Ngt0_def INum_def) }
170.350 - moreover
170.351 - { assume a: "a \<noteq> 0" hence b: "(of_int b::'a) > 0" using nx
170.352 - by (simp add: x isnormNum_def)
170.353 - from pos_less_divide_eq[OF b, where b="of_int a" and a="0::'a"]
170.354 - have ?thesis by (simp add: x Ngt0_def INum_def) }
170.355 - ultimately show ?thesis by blast
170.356 -qed
170.357 -
170.358 -lemma Nge0_iff[simp]:
170.359 - assumes nx: "isnormNum x"
170.360 - shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero}) \<ge> 0) = 0\<le>\<^sub>N x"
170.361 -proof -
170.362 - obtain a b where x: "x = (a, b)" by (cases x)
170.363 - { assume "a = 0" hence ?thesis by (simp add: x Nge0_def INum_def) }
170.364 - moreover
170.365 - { assume "a \<noteq> 0" hence b: "(of_int b::'a) > 0" using nx
170.366 - by (simp add: x isnormNum_def)
170.367 - from pos_le_divide_eq[OF b, where b="of_int a" and a="0::'a"]
170.368 - have ?thesis by (simp add: x Nge0_def INum_def) }
170.369 - ultimately show ?thesis by blast
170.370 -qed
170.371 -
170.372 -lemma Nlt_iff[simp]:
170.373 - assumes nx: "isnormNum x" and ny: "isnormNum y"
170.374 - shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero}) < INum y) = (x <\<^sub>N y)"
170.375 -proof -
170.376 - let ?z = "0::'a"
170.377 - have "((INum x ::'a) < INum y) = (INum (x -\<^sub>N y) < ?z)"
170.378 - using nx ny by simp
170.379 - also have "\<dots> = (0>\<^sub>N (x -\<^sub>N y))"
170.380 - using Nlt0_iff[OF Nsub_normN[OF ny]] by simp
170.381 - finally show ?thesis by (simp add: Nlt_def)
170.382 -qed
170.383 -
170.384 -lemma Nle_iff[simp]:
170.385 - assumes nx: "isnormNum x" and ny: "isnormNum y"
170.386 - shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero})\<le> INum y) = (x \<le>\<^sub>N y)"
170.387 -proof -
170.388 - have "((INum x ::'a) \<le> INum y) = (INum (x -\<^sub>N y) \<le> (0::'a))"
170.389 - using nx ny by simp
170.390 - also have "\<dots> = (0\<ge>\<^sub>N (x -\<^sub>N y))"
170.391 - using Nle0_iff[OF Nsub_normN[OF ny]] by simp
170.392 - finally show ?thesis by (simp add: Nle_def)
170.393 -qed
170.394 -
170.395 -lemma Nadd_commute:
170.396 - assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
170.397 - shows "x +\<^sub>N y = y +\<^sub>N x"
170.398 -proof -
170.399 - have n: "isnormNum (x +\<^sub>N y)" "isnormNum (y +\<^sub>N x)" by simp_all
170.400 - have "(INum (x +\<^sub>N y)::'a) = INum (y +\<^sub>N x)" by simp
170.401 - with isnormNum_unique[OF n] show ?thesis by simp
170.402 -qed
170.403 -
170.404 -lemma [simp]:
170.405 - assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
170.406 - shows "(0, b) +\<^sub>N y = normNum y"
170.407 - and "(a, 0) +\<^sub>N y = normNum y"
170.408 - and "x +\<^sub>N (0, b) = normNum x"
170.409 - and "x +\<^sub>N (a, 0) = normNum x"
170.410 - apply (simp add: Nadd_def split_def)
170.411 - apply (simp add: Nadd_def split_def)
170.412 - apply (subst Nadd_commute, simp add: Nadd_def split_def)
170.413 - apply (subst Nadd_commute, simp add: Nadd_def split_def)
170.414 - done
170.415 -
170.416 -lemma normNum_nilpotent_aux[simp]:
170.417 - assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
170.418 - assumes nx: "isnormNum x"
170.419 - shows "normNum x = x"
170.420 -proof -
170.421 - let ?a = "normNum x"
170.422 - have n: "isnormNum ?a" by simp
170.423 - have th: "INum ?a = (INum x ::'a)" by simp
170.424 - with isnormNum_unique[OF n nx] show ?thesis by simp
170.425 -qed
170.426 -
170.427 -lemma normNum_nilpotent[simp]:
170.428 - assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
170.429 - shows "normNum (normNum x) = normNum x"
170.430 - by simp
170.431 -
170.432 -lemma normNum0[simp]: "normNum (0,b) = 0\<^sub>N" "normNum (a,0) = 0\<^sub>N"
170.433 - by (simp_all add: normNum_def)
170.434 -
170.435 -lemma normNum_Nadd:
170.436 - assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
170.437 - shows "normNum (x +\<^sub>N y) = x +\<^sub>N y" by simp
170.438 -
170.439 -lemma Nadd_normNum1[simp]:
170.440 - assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
170.441 - shows "normNum x +\<^sub>N y = x +\<^sub>N y"
170.442 -proof -
170.443 - have n: "isnormNum (normNum x +\<^sub>N y)" "isnormNum (x +\<^sub>N y)" by simp_all
170.444 - have "INum (normNum x +\<^sub>N y) = INum x + (INum y :: 'a)" by simp
170.445 - also have "\<dots> = INum (x +\<^sub>N y)" by simp
170.446 - finally show ?thesis using isnormNum_unique[OF n] by simp
170.447 -qed
170.448 -
170.449 -lemma Nadd_normNum2[simp]:
170.450 - assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
170.451 - shows "x +\<^sub>N normNum y = x +\<^sub>N y"
170.452 -proof -
170.453 - have n: "isnormNum (x +\<^sub>N normNum y)" "isnormNum (x +\<^sub>N y)" by simp_all
170.454 - have "INum (x +\<^sub>N normNum y) = INum x + (INum y :: 'a)" by simp
170.455 - also have "\<dots> = INum (x +\<^sub>N y)" by simp
170.456 - finally show ?thesis using isnormNum_unique[OF n] by simp
170.457 -qed
170.458 -
170.459 -lemma Nadd_assoc:
170.460 - assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
170.461 - shows "x +\<^sub>N y +\<^sub>N z = x +\<^sub>N (y +\<^sub>N z)"
170.462 -proof -
170.463 - have n: "isnormNum (x +\<^sub>N y +\<^sub>N z)" "isnormNum (x +\<^sub>N (y +\<^sub>N z))" by simp_all
170.464 - have "INum (x +\<^sub>N y +\<^sub>N z) = (INum (x +\<^sub>N (y +\<^sub>N z)) :: 'a)" by simp
170.465 - with isnormNum_unique[OF n] show ?thesis by simp
170.466 -qed
170.467 -
170.468 -lemma Nmul_commute: "isnormNum x \<Longrightarrow> isnormNum y \<Longrightarrow> x *\<^sub>N y = y *\<^sub>N x"
170.469 - by (simp add: Nmul_def split_def Let_def gcd_commute_int mult_commute)
170.470 -
170.471 -lemma Nmul_assoc:
170.472 - assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
170.473 - assumes nx: "isnormNum x" and ny: "isnormNum y" and nz: "isnormNum z"
170.474 - shows "x *\<^sub>N y *\<^sub>N z = x *\<^sub>N (y *\<^sub>N z)"
170.475 -proof -
170.476 - from nx ny nz have n: "isnormNum (x *\<^sub>N y *\<^sub>N z)" "isnormNum (x *\<^sub>N (y *\<^sub>N z))"
170.477 - by simp_all
170.478 - have "INum (x +\<^sub>N y +\<^sub>N z) = (INum (x +\<^sub>N (y +\<^sub>N z)) :: 'a)" by simp
170.479 - with isnormNum_unique[OF n] show ?thesis by simp
170.480 -qed
170.481 -
170.482 -lemma Nsub0:
170.483 - assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
170.484 - assumes x: "isnormNum x" and y: "isnormNum y"
170.485 - shows "x -\<^sub>N y = 0\<^sub>N \<longleftrightarrow> x = y"
170.486 -proof -
170.487 - fix h :: 'a
170.488 - from isnormNum_unique[where 'a = 'a, OF Nsub_normN[OF y], where y="0\<^sub>N"]
170.489 - have "(x -\<^sub>N y = 0\<^sub>N) = (INum (x -\<^sub>N y) = (INum 0\<^sub>N :: 'a)) " by simp
170.490 - also have "\<dots> = (INum x = (INum y :: 'a))" by simp
170.491 - also have "\<dots> = (x = y)" using x y by simp
170.492 - finally show ?thesis .
170.493 -qed
170.494 -
170.495 -lemma Nmul0[simp]: "c *\<^sub>N 0\<^sub>N = 0\<^sub>N" " 0\<^sub>N *\<^sub>N c = 0\<^sub>N"
170.496 - by (simp_all add: Nmul_def Let_def split_def)
170.497 -
170.498 -lemma Nmul_eq0[simp]:
170.499 - assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
170.500 - assumes nx: "isnormNum x" and ny: "isnormNum y"
170.501 - shows "x*\<^sub>N y = 0\<^sub>N \<longleftrightarrow> x = 0\<^sub>N \<or> y = 0\<^sub>N"
170.502 -proof -
170.503 - fix h :: 'a
170.504 - obtain a b where x: "x = (a, b)" by (cases x)
170.505 - obtain a' b' where y: "y = (a', b')" by (cases y)
170.506 - have n0: "isnormNum 0\<^sub>N" by simp
170.507 - show ?thesis using nx ny
170.508 - apply (simp only: isnormNum_unique[where ?'a = 'a, OF Nmul_normN[OF nx ny] n0, symmetric]
170.509 - Nmul[where ?'a = 'a])
170.510 - apply (simp add: x y INum_def split_def isnormNum_def split: split_if_asm)
170.511 - done
170.512 -qed
170.513 -
170.514 -lemma Nneg_Nneg[simp]: "~\<^sub>N (~\<^sub>N c) = c"
170.515 - by (simp add: Nneg_def split_def)
170.516 -
170.517 -lemma Nmul1[simp]:
170.518 - "isnormNum c \<Longrightarrow> (1)\<^sub>N *\<^sub>N c = c"
170.519 - "isnormNum c \<Longrightarrow> c *\<^sub>N (1)\<^sub>N = c"
170.520 - apply (simp_all add: Nmul_def Let_def split_def isnormNum_def)
170.521 - apply (cases "fst c = 0", simp_all, cases c, simp_all)+
170.522 - done
170.523 -
170.524 -end
171.1 --- a/src/HOL/Library/BigO.thy Thu Dec 05 17:52:12 2013 +0100
171.2 +++ b/src/HOL/Library/BigO.thy Thu Dec 05 17:58:03 2013 +0100
171.3 @@ -215,7 +215,7 @@
171.4 f : lb +o O(g)"
171.5 apply (rule set_minus_imp_plus)
171.6 apply (rule bigo_bounded)
171.7 - apply (auto simp add: diff_minus fun_Compl_def func_plus)
171.8 + apply (auto simp add: fun_Compl_def func_plus)
171.9 apply (drule_tac x = x in spec)+
171.10 apply force
171.11 apply (drule_tac x = x in spec)+
171.12 @@ -390,7 +390,7 @@
171.13 apply (rule set_minus_imp_plus)
171.14 apply (drule set_plus_imp_minus)
171.15 apply (drule bigo_minus)
171.16 - apply (simp add: diff_minus)
171.17 + apply simp
171.18 done
171.19
171.20 lemma bigo_minus3: "O(-f) = O(f)"
171.21 @@ -446,7 +446,7 @@
171.22 apply (rule bigo_minus)
171.23 apply (subst set_minus_plus)
171.24 apply assumption
171.25 - apply (simp add: diff_minus add_ac)
171.26 + apply (simp add: add_ac)
171.27 done
171.28
171.29 lemma bigo_add_commute: "(f : g +o O(h)) = (g : f +o O(h))"
171.30 @@ -545,10 +545,9 @@
171.31
171.32 lemma bigo_compose2: "f =o g +o O(h) ==> (%x. f(k x)) =o (%x. g(k x)) +o
171.33 O(%x. h(k x))"
171.34 - apply (simp only: set_minus_plus [symmetric] diff_minus fun_Compl_def
171.35 - func_plus)
171.36 - apply (erule bigo_compose1)
171.37 -done
171.38 + apply (simp only: set_minus_plus [symmetric] fun_Compl_def func_plus)
171.39 + apply (drule bigo_compose1) apply (simp add: fun_diff_def)
171.40 + done
171.41
171.42
171.43 subsection {* Setsum *}
171.44 @@ -779,7 +778,7 @@
171.45 apply (subst abs_of_nonneg)
171.46 apply (drule_tac x = x in spec) back
171.47 apply (simp add: algebra_simps)
171.48 - apply (subst diff_minus)+
171.49 + apply (subst diff_conv_add_uminus)+
171.50 apply (rule add_right_mono)
171.51 apply (erule spec)
171.52 apply (rule order_trans)
171.53 @@ -803,7 +802,7 @@
171.54 apply (subst abs_of_nonneg)
171.55 apply (drule_tac x = x in spec) back
171.56 apply (simp add: algebra_simps)
171.57 - apply (subst diff_minus)+
171.58 + apply (subst diff_conv_add_uminus)+
171.59 apply (rule add_left_mono)
171.60 apply (rule le_imp_neg_le)
171.61 apply (erule spec)
172.1 --- a/src/HOL/Library/Binomial.thy Thu Dec 05 17:52:12 2013 +0100
172.2 +++ b/src/HOL/Library/Binomial.thy Thu Dec 05 17:58:03 2013 +0100
172.3 @@ -26,6 +26,11 @@
172.4 lemma binomial_Suc_Suc [simp]: "(Suc n choose Suc k) = (n choose k) + (n choose Suc k)"
172.5 by simp
172.6
172.7 +lemma choose_reduce_nat:
172.8 + "0 < (n::nat) \<Longrightarrow> 0 < k \<Longrightarrow>
172.9 + (n choose k) = ((n - 1) choose k) + ((n - 1) choose (k - 1))"
172.10 + by (metis Suc_diff_1 binomial.simps(2) nat_add_commute neq0_conv)
172.11 +
172.12 lemma binomial_eq_0: "n < k \<Longrightarrow> n choose k = 0"
172.13 by (induct n arbitrary: k) auto
172.14
172.15 @@ -44,10 +49,7 @@
172.16 by (induct n k rule: diff_induct) simp_all
172.17
172.18 lemma binomial_eq_0_iff: "n choose k = 0 \<longleftrightarrow> n < k"
172.19 - apply (safe intro!: binomial_eq_0)
172.20 - apply (erule contrapos_pp)
172.21 - apply (simp add: zero_less_binomial)
172.22 - done
172.23 + by (metis binomial_eq_0 less_numeral_extra(3) not_less zero_less_binomial)
172.24
172.25 lemma zero_less_binomial_iff: "n choose k > 0 \<longleftrightarrow> k \<le> n"
172.26 by (simp add: linorder_not_less binomial_eq_0_iff neq0_conv[symmetric] del: neq0_conv)
172.27 @@ -89,29 +91,14 @@
172.28 {s. s \<subseteq> M \<and> card s = Suc k} \<union> {s. \<exists>t. t \<subseteq> M \<and> card t = k \<and> s = insert x t}"
172.29 apply safe
172.30 apply (auto intro: finite_subset [THEN card_insert_disjoint])
172.31 - apply (drule_tac x = "xa - {x}" in spec)
172.32 - apply (subgoal_tac "x \<notin> xa")
172.33 - apply auto
172.34 - apply (erule rev_mp, subst card_Diff_singleton)
172.35 - apply (auto intro: finite_subset)
172.36 - done
172.37 -(*
172.38 -lemma "finite(UN y. {x. P x y})"
172.39 -apply simp
172.40 -lemma Collect_ex_eq
172.41 -
172.42 -lemma "{x. \<exists>y. P x y} = (UN y. {x. P x y})"
172.43 -apply blast
172.44 -*)
172.45 + by (metis (full_types) Diff_insert_absorb Set.set_insert Zero_neq_Suc card_Diff_singleton_if
172.46 + card_eq_0_iff diff_Suc_1 in_mono subset_insert_iff)
172.47
172.48 lemma finite_bex_subset [simp]:
172.49 assumes "finite B"
172.50 and "\<And>A. A \<subseteq> B \<Longrightarrow> finite {x. P x A}"
172.51 shows "finite {x. \<exists>A \<subseteq> B. P x A}"
172.52 -proof -
172.53 - have "{x. \<exists>A\<subseteq>B. P x A} = (\<Union>A \<in> Pow B. {x. P x A})" by blast
172.54 - with assms show ?thesis by simp
172.55 -qed
172.56 + by (metis (no_types) assms finite_Collect_bounded_ex finite_Collect_subsets)
172.57
172.58 text{*There are as many subsets of @{term A} having cardinality @{term k}
172.59 as there are sets obtained from the former by inserting a fixed element
172.60 @@ -120,71 +107,75 @@
172.61 "finite A \<Longrightarrow> x \<notin> A \<Longrightarrow>
172.62 card {B. \<exists>C. C \<subseteq> A \<and> card C = k \<and> B = insert x C} =
172.63 card {B. B \<subseteq> A & card(B) = k}"
172.64 - apply (rule_tac f = "\<lambda>s. s - {x}" and g = "insert x" in card_bij_eq)
172.65 - apply (auto elim!: equalityE simp add: inj_on_def)
172.66 - apply (subst Diff_insert0)
172.67 - apply auto
172.68 + apply (rule card_bij_eq [where f = "\<lambda>s. s - {x}" and g = "insert x"])
172.69 + apply (auto elim!: equalityE simp add: inj_on_def)
172.70 + apply (metis card_Diff_singleton_if finite_subset in_mono)
172.71 done
172.72
172.73 text {*
172.74 Main theorem: combinatorial statement about number of subsets of a set.
172.75 *}
172.76
172.77 -lemma n_sub_lemma:
172.78 - "finite A \<Longrightarrow> card {B. B \<subseteq> A \<and> card B = k} = (card A choose k)"
172.79 - apply (induct k arbitrary: A)
172.80 - apply (simp add: card_s_0_eq_empty)
172.81 - apply atomize
172.82 - apply (rotate_tac -1)
172.83 - apply (erule finite_induct)
172.84 - apply (simp_all (no_asm_simp) cong add: conj_cong
172.85 - add: card_s_0_eq_empty choose_deconstruct)
172.86 - apply (subst card_Un_disjoint)
172.87 - prefer 4 apply (force simp add: constr_bij)
172.88 - prefer 3 apply force
172.89 - prefer 2 apply (blast intro: finite_Pow_iff [THEN iffD2]
172.90 - finite_subset [of _ "Pow (insert x F)", standard])
172.91 - apply (blast intro: finite_Pow_iff [THEN iffD2, THEN [2] finite_subset])
172.92 - done
172.93 -
172.94 theorem n_subsets: "finite A \<Longrightarrow> card {B. B \<subseteq> A \<and> card B = k} = (card A choose k)"
172.95 - by (simp add: n_sub_lemma)
172.96 +proof (induct k arbitrary: A)
172.97 + case 0 then show ?case by (simp add: card_s_0_eq_empty)
172.98 +next
172.99 + case (Suc k)
172.100 + show ?case using `finite A`
172.101 + proof (induct A)
172.102 + case empty show ?case by (simp add: card_s_0_eq_empty)
172.103 + next
172.104 + case (insert x A)
172.105 + then show ?case using Suc.hyps
172.106 + apply (simp add: card_s_0_eq_empty choose_deconstruct)
172.107 + apply (subst card_Un_disjoint)
172.108 + prefer 4 apply (force simp add: constr_bij)
172.109 + prefer 3 apply force
172.110 + prefer 2 apply (blast intro: finite_Pow_iff [THEN iffD2]
172.111 + finite_subset [of _ "Pow (insert x F)", standard])
172.112 + apply (blast intro: finite_Pow_iff [THEN iffD2, THEN [2] finite_subset])
172.113 + done
172.114 + qed
172.115 +qed
172.116
172.117
172.118 text{* The binomial theorem (courtesy of Tobias Nipkow): *}
172.119
172.120 -theorem binomial: "(a + b::nat)^n = (\<Sum>k=0..n. (n choose k) * a^k * b^(n - k))"
172.121 +(* Avigad's version, generalized to any commutative semiring *)
172.122 +theorem binomial: "(a+b::'a::{comm_ring_1,power})^n =
172.123 + (\<Sum>k=0..n. (of_nat (n choose k)) * a^k * b^(n-k))" (is "?P n")
172.124 proof (induct n)
172.125 - case 0
172.126 - then show ?case by simp
172.127 + case 0 then show "?P 0" by simp
172.128 next
172.129 case (Suc n)
172.130 - have decomp: "{0..n+1} = {0} \<union> {n+1} \<union> {1..n}"
172.131 - by (auto simp add:atLeastAtMost_def atLeast_def atMost_def)
172.132 - have decomp2: "{0..n} = {0} \<union> {1..n}"
172.133 - by (auto simp add:atLeastAtMost_def atLeast_def atMost_def)
172.134 - have "(a + b)^(n + 1) = (a + b) * (\<Sum>k=0..n. (n choose k) * a^k * b^(n - k))"
172.135 - using Suc by simp
172.136 - also have "\<dots> = a*(\<Sum>k=0..n. (n choose k) * a^k * b^(n-k)) +
172.137 - b*(\<Sum>k=0..n. (n choose k) * a^k * b^(n-k))"
172.138 - by (rule nat_distrib)
172.139 - also have "\<dots> = (\<Sum>k=0..n. (n choose k) * a^(k+1) * b^(n-k)) +
172.140 - (\<Sum>k=0..n. (n choose k) * a^k * b^(n-k+1))"
172.141 - by (simp add: setsum_right_distrib mult_ac)
172.142 - also have "\<dots> = (\<Sum>k=0..n. (n choose k) * a^k * b^(n+1-k)) +
172.143 - (\<Sum>k=1..n+1. (n choose (k - 1)) * a^k * b^(n+1-k))"
172.144 - by (simp add:setsum_shift_bounds_cl_Suc_ivl Suc_diff_le
172.145 - del:setsum_cl_ivl_Suc)
172.146 + have decomp: "{0..n+1} = {0} Un {n+1} Un {1..n}"
172.147 + by auto
172.148 + have decomp2: "{0..n} = {0} Un {1..n}"
172.149 + by auto
172.150 + have "(a+b)^(n+1) =
172.151 + (a+b) * (\<Sum>k=0..n. of_nat (n choose k) * a^k * b^(n-k))"
172.152 + using Suc.hyps by simp
172.153 + also have "\<dots> = a*(\<Sum>k=0..n. of_nat (n choose k) * a^k * b^(n-k)) +
172.154 + b*(\<Sum>k=0..n. of_nat (n choose k) * a^k * b^(n-k))"
172.155 + by (rule distrib)
172.156 + also have "\<dots> = (\<Sum>k=0..n. of_nat (n choose k) * a^(k+1) * b^(n-k)) +
172.157 + (\<Sum>k=0..n. of_nat (n choose k) * a^k * b^(n-k+1))"
172.158 + by (auto simp add: setsum_right_distrib mult_ac)
172.159 + also have "\<dots> = (\<Sum>k=0..n. of_nat (n choose k) * a^k * b^(n+1-k)) +
172.160 + (\<Sum>k=1..n+1. of_nat (n choose (k - 1)) * a^k * b^(n+1-k))"
172.161 + by (simp add:setsum_shift_bounds_cl_Suc_ivl Suc_diff_le field_simps
172.162 + del:setsum_cl_ivl_Suc)
172.163 also have "\<dots> = a^(n+1) + b^(n+1) +
172.164 - (\<Sum>k=1..n. (n choose (k - 1)) * a^k * b^(n+1-k)) +
172.165 - (\<Sum>k=1..n. (n choose k) * a^k * b^(n+1-k))"
172.166 + (\<Sum>k=1..n. of_nat (n choose (k - 1)) * a^k * b^(n+1-k)) +
172.167 + (\<Sum>k=1..n. of_nat (n choose k) * a^k * b^(n+1-k))"
172.168 by (simp add: decomp2)
172.169 also have
172.170 - "\<dots> = a^(n+1) + b^(n+1) + (\<Sum>k=1..n. (n+1 choose k) * a^k * b^(n+1-k))"
172.171 - by (simp add: nat_distrib setsum_addf binomial.simps)
172.172 - also have "\<dots> = (\<Sum>k=0..n+1. (n+1 choose k) * a^k * b^(n+1-k))"
172.173 - using decomp by simp
172.174 - finally show ?case by simp
172.175 + "\<dots> = a^(n+1) + b^(n+1) +
172.176 + (\<Sum>k=1..n. of_nat(n+1 choose k) * a^k * b^(n+1-k))"
172.177 + by (auto simp add: field_simps setsum_addf [symmetric] choose_reduce_nat)
172.178 + also have "\<dots> = (\<Sum>k=0..n+1. of_nat (n+1 choose k) * a^k * b^(n+1-k))"
172.179 + using decomp by (simp add: field_simps)
172.180 + finally show "?P (Suc n)" by simp
172.181 qed
172.182
172.183 subsection{* Pochhammer's symbol : generalized raising factorial*}
172.184 @@ -265,11 +256,8 @@
172.185 case False
172.186 from assms obtain h where "k = Suc h" by (cases k) auto
172.187 then show ?thesis
172.188 - apply (simp add: pochhammer_Suc_setprod)
172.189 - apply (rule_tac x="n" in bexI)
172.190 - using assms
172.191 - apply auto
172.192 - done
172.193 + by (simp add: pochhammer_Suc_setprod)
172.194 + (metis Suc_leI Suc_le_mono assms atLeastAtMost_iff less_eq_nat.simps(1))
172.195 qed
172.196
172.197 lemma pochhammer_of_nat_eq_0_lemma':
172.198 @@ -298,8 +286,7 @@
172.199 apply (auto simp add: pochhammer_of_nat_eq_0_iff)
172.200 apply (cases n)
172.201 apply (auto simp add: pochhammer_def algebra_simps group_add_class.eq_neg_iff_add_eq_0)
172.202 - apply (rule_tac x=x in exI)
172.203 - apply auto
172.204 + apply (metis leD not_less_eq)
172.205 done
172.206
172.207
172.208 @@ -370,7 +357,7 @@
172.209 by auto
172.210 from False show ?thesis
172.211 by (simp add: pochhammer_def gbinomial_def field_simps
172.212 - eq setprod_timesf[symmetric] del: minus_one)
172.213 + eq setprod_timesf[symmetric])
172.214 qed
172.215
172.216 lemma binomial_fact_lemma: "k \<le> n \<Longrightarrow> fact k * fact (n - k) * (n choose k) = fact n"
172.217 @@ -441,9 +428,9 @@
172.218 from eq[symmetric]
172.219 have ?thesis using kn
172.220 apply (simp add: binomial_fact[OF kn, where ?'a = 'a]
172.221 - gbinomial_pochhammer field_simps pochhammer_Suc_setprod del: minus_one)
172.222 + gbinomial_pochhammer field_simps pochhammer_Suc_setprod)
172.223 apply (simp add: pochhammer_Suc_setprod fact_altdef_nat h
172.224 - of_nat_setprod setprod_timesf[symmetric] eq' del: One_nat_def power_Suc del: minus_one)
172.225 + of_nat_setprod setprod_timesf[symmetric] eq' del: One_nat_def power_Suc)
172.226 unfolding setprod_Un_disjoint[OF th0, unfolded eq3, of "of_nat:: nat \<Rightarrow> 'a"] eq[unfolded h]
172.227 unfolding mult_assoc[symmetric]
172.228 unfolding setprod_timesf[symmetric]
173.1 --- a/src/HOL/Library/Bit.thy Thu Dec 05 17:52:12 2013 +0100
173.2 +++ b/src/HOL/Library/Bit.thy Thu Dec 05 17:58:03 2013 +0100
173.3 @@ -147,11 +147,11 @@
173.4
173.5 text {* All numerals reduce to either 0 or 1. *}
173.6
173.7 -lemma bit_minus1 [simp]: "-1 = (1 :: bit)"
173.8 - by (simp only: minus_one [symmetric] uminus_bit_def)
173.9 +lemma bit_minus1 [simp]: "- 1 = (1 :: bit)"
173.10 + by (simp only: uminus_bit_def)
173.11
173.12 -lemma bit_neg_numeral [simp]: "(neg_numeral w :: bit) = numeral w"
173.13 - by (simp only: neg_numeral_def uminus_bit_def)
173.14 +lemma bit_neg_numeral [simp]: "(- numeral w :: bit) = numeral w"
173.15 + by (simp only: uminus_bit_def)
173.16
173.17 lemma bit_numeral_even [simp]: "numeral (Num.Bit0 w) = (0 :: bit)"
173.18 by (simp only: numeral_Bit0 bit_add_self)
174.1 --- a/src/HOL/Library/Char_ord.thy Thu Dec 05 17:52:12 2013 +0100
174.2 +++ b/src/HOL/Library/Char_ord.thy Thu Dec 05 17:58:03 2013 +0100
174.3 @@ -94,6 +94,30 @@
174.4
174.5 end
174.6
174.7 +instantiation String.literal :: linorder
174.8 +begin
174.9 +
174.10 +lift_definition less_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool" is "ord.lexordp op <" .
174.11 +lift_definition less_eq_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool" is "ord.lexordp_eq op <" .
174.12 +
174.13 +instance
174.14 +proof -
174.15 + interpret linorder "ord.lexordp_eq op <" "ord.lexordp op < :: string \<Rightarrow> string \<Rightarrow> bool"
174.16 + by(rule linorder.lexordp_linorder[where less_eq="op \<le>"])(unfold_locales)
174.17 + show "PROP ?thesis"
174.18 + by(intro_classes)(transfer, simp add: less_le_not_le linear)+
174.19 +qed
174.20 +
174.21 +end
174.22 +
174.23 +lemma less_literal_code [code]:
174.24 + "op < = (\<lambda>xs ys. ord.lexordp op < (explode xs) (explode ys))"
174.25 +by(simp add: less_literal.rep_eq fun_eq_iff)
174.26 +
174.27 +lemma less_eq_literal_code [code]:
174.28 + "op \<le> = (\<lambda>xs ys. ord.lexordp_eq op < (explode xs) (explode ys))"
174.29 +by(simp add: less_eq_literal.rep_eq fun_eq_iff)
174.30 +
174.31 text {* Legacy aliasses *}
174.32
174.33 lemmas nibble_less_eq_def = less_eq_nibble_def
175.1 --- a/src/HOL/Library/Code_Char.thy Thu Dec 05 17:52:12 2013 +0100
175.2 +++ b/src/HOL/Library/Code_Char.thy Thu Dec 05 17:58:03 2013 +0100
175.3 @@ -97,6 +97,21 @@
175.4 and (Haskell) infix 4 "<"
175.5 and (Scala) infixl 4 "<"
175.6 and (Eval) infixl 6 "<"
175.7 +| constant "Orderings.less_eq :: String.literal \<Rightarrow> String.literal \<Rightarrow> bool" \<rightharpoonup>
175.8 + (SML) "!((_ : string) <= _)"
175.9 + and (OCaml) "!((_ : string) <= _)"
175.10 + -- {* Order operations for @{typ String.literal} work in Haskell only
175.11 + if no type class instance needs to be generated, because String = [Char] in Haskell
175.12 + and @{typ "char list"} need not have the same order as @{typ String.literal}. *}
175.13 + and (Haskell) infix 4 "<="
175.14 + and (Scala) infixl 4 "<="
175.15 + and (Eval) infixl 6 "<="
175.16 +| constant "Orderings.less :: String.literal \<Rightarrow> String.literal \<Rightarrow> bool" \<rightharpoonup>
175.17 + (SML) "!((_ : string) < _)"
175.18 + and (OCaml) "!((_ : string) < _)"
175.19 + and (Haskell) infix 4 "<"
175.20 + and (Scala) infixl 4 "<"
175.21 + and (Eval) infixl 6 "<"
175.22
175.23 end
175.24
176.1 --- a/src/HOL/Library/Code_Prolog.thy Thu Dec 05 17:52:12 2013 +0100
176.2 +++ b/src/HOL/Library/Code_Prolog.thy Thu Dec 05 17:58:03 2013 +0100
176.3 @@ -12,10 +12,8 @@
176.4
176.5 section {* Setup for Numerals *}
176.6
176.7 -setup {* Predicate_Compile_Data.ignore_consts
176.8 - [@{const_name numeral}, @{const_name neg_numeral}] *}
176.9 +setup {* Predicate_Compile_Data.ignore_consts [@{const_name numeral}] *}
176.10
176.11 -setup {* Predicate_Compile_Data.keep_functions
176.12 - [@{const_name numeral}, @{const_name neg_numeral}] *}
176.13 +setup {* Predicate_Compile_Data.keep_functions [@{const_name numeral}] *}
176.14
176.15 end
177.1 --- a/src/HOL/Library/Code_Real_Approx_By_Float.thy Thu Dec 05 17:52:12 2013 +0100
177.2 +++ b/src/HOL/Library/Code_Real_Approx_By_Float.thy Thu Dec 05 17:58:03 2013 +0100
177.3 @@ -169,7 +169,7 @@
177.4 by simp
177.5
177.6 lemma [code_unfold del]:
177.7 - "neg_numeral k \<equiv> (of_rat (neg_numeral k) :: real)"
177.8 + "- numeral k \<equiv> (of_rat (- numeral k) :: real)"
177.9 by simp
177.10
177.11 hide_const (open) real_of_int
178.1 --- a/src/HOL/Library/Code_Target_Int.thy Thu Dec 05 17:52:12 2013 +0100
178.2 +++ b/src/HOL/Library/Code_Target_Int.thy Thu Dec 05 17:58:03 2013 +0100
178.3 @@ -30,7 +30,7 @@
178.4 by transfer simp
178.5
178.6 lemma [code_abbrev]:
178.7 - "int_of_integer (neg_numeral k) = Int.Neg k"
178.8 + "int_of_integer (- numeral k) = Int.Neg k"
178.9 by transfer simp
178.10
178.11 lemma [code, symmetric, code_post]:
178.12 @@ -99,7 +99,7 @@
178.13 proof -
178.14 from mod_div_equality have *: "of_int k = of_int (k div 2 * 2 + k mod 2)" by simp
178.15 show ?thesis
178.16 - by (simp add: Let_def divmod_int_mod_div mod_2_not_eq_zero_eq_one_int
178.17 + by (simp add: Let_def divmod_int_mod_div not_mod_2_eq_0_eq_1
178.18 of_int_add [symmetric]) (simp add: * mult_commute)
178.19 qed
178.20
179.1 --- a/src/HOL/Library/ContNotDenum.thy Thu Dec 05 17:52:12 2013 +0100
179.2 +++ b/src/HOL/Library/ContNotDenum.thy Thu Dec 05 17:58:03 2013 +0100
179.3 @@ -131,17 +131,15 @@
179.4
179.5 -- "A denotes the set of all left-most points of all the intervals ..."
179.6 moreover obtain A where Adef: "A = ?g ` \<nat>" by simp
179.7 - ultimately have "\<exists>x. x\<in>A"
179.8 + ultimately have "A \<noteq> {}"
179.9 proof -
179.10 have "(0::nat) \<in> \<nat>" by simp
179.11 - moreover have "?g 0 = ?g 0" by simp
179.12 - ultimately have "?g 0 \<in> ?g ` \<nat>" by (rule rev_image_eqI)
179.13 - with Adef have "?g 0 \<in> A" by simp
179.14 - thus ?thesis ..
179.15 + with Adef show ?thesis
179.16 + by blast
179.17 qed
179.18
179.19 -- "Now show that A is bounded above ..."
179.20 - moreover have "\<exists>y. isUb (UNIV::real set) A y"
179.21 + moreover have "bdd_above A"
179.22 proof -
179.23 {
179.24 fix n
179.25 @@ -177,18 +175,11 @@
179.26 obtain a and b where "f 0 = closed_int a b" and alb: "a \<le> b" by blast
179.27 ultimately have "\<forall>n. ?g n \<in> closed_int a b" by auto
179.28 with alb have "\<forall>n. ?g n \<le> b" using closed_int_most by blast
179.29 - with Adef have "\<forall>y\<in>A. y\<le>b" by auto
179.30 - hence "A *<= b" by (unfold setle_def)
179.31 - moreover have "b \<in> (UNIV::real set)" by simp
179.32 - ultimately have "A *<= b \<and> b \<in> (UNIV::real set)" by simp
179.33 - hence "isUb (UNIV::real set) A b" by (unfold isUb_def)
179.34 - thus ?thesis by auto
179.35 + with Adef show "bdd_above A" by auto
179.36 qed
179.37 - -- "by the Axiom Of Completeness, A has a least upper bound ..."
179.38 - ultimately have "\<exists>t. isLub UNIV A t" by (rule reals_complete)
179.39
179.40 -- "denote this least upper bound as t ..."
179.41 - then obtain t where tdef: "isLub UNIV A t" ..
179.42 + def tdef: t == "Sup A"
179.43
179.44 -- "and finally show that this least upper bound is in all the intervals..."
179.45 have "\<forall>n. t \<in> f n"
179.46 @@ -229,82 +220,76 @@
179.47 with Adef have "(?g n) \<in> A" by auto
179.48 ultimately show ?thesis by simp
179.49 qed
179.50 - with tdef show "a \<le> t" by (rule isLubD2)
179.51 + with `bdd_above A` show "a \<le> t"
179.52 + unfolding tdef by (intro cSup_upper)
179.53 qed
179.54 moreover have "t \<le> b"
179.55 - proof -
179.56 - have "isUb UNIV A b"
179.57 - proof -
179.58 + unfolding tdef
179.59 + proof (rule cSup_least)
179.60 + {
179.61 + from alb int have
179.62 + ain: "b\<in>f n \<and> (\<forall>x\<in>f n. x \<le> b)" using closed_int_most by blast
179.63 +
179.64 + have subsetd: "\<forall>m. \<forall>n. f (n + m) \<subseteq> f n"
179.65 + proof (rule allI, induct_tac m)
179.66 + show "\<forall>n. f (n + 0) \<subseteq> f n" by simp
179.67 + next
179.68 + fix m n
179.69 + assume pp: "\<forall>p. f (p + n) \<subseteq> f p"
179.70 + {
179.71 + fix p
179.72 + from pp have "f (p + n) \<subseteq> f p" by simp
179.73 + moreover from subset have "f (Suc (p + n)) \<subseteq> f (p + n)" by auto
179.74 + hence "f (p + (Suc n)) \<subseteq> f (p + n)" by simp
179.75 + ultimately have "f (p + (Suc n)) \<subseteq> f p" by simp
179.76 + }
179.77 + thus "\<forall>p. f (p + Suc n) \<subseteq> f p" ..
179.78 + qed
179.79 + have subsetm: "\<forall>\<alpha> \<beta>. \<alpha> \<ge> \<beta> \<longrightarrow> (f \<alpha>) \<subseteq> (f \<beta>)"
179.80 + proof ((rule allI)+, rule impI)
179.81 + fix \<alpha>::nat and \<beta>::nat
179.82 + assume "\<beta> \<le> \<alpha>"
179.83 + hence "\<exists>k. \<alpha> = \<beta> + k" by (simp only: le_iff_add)
179.84 + then obtain k where "\<alpha> = \<beta> + k" ..
179.85 + moreover
179.86 + from subsetd have "f (\<beta> + k) \<subseteq> f \<beta>" by simp
179.87 + ultimately show "f \<alpha> \<subseteq> f \<beta>" by auto
179.88 + qed
179.89 +
179.90 + fix m
179.91 {
179.92 - from alb int have
179.93 - ain: "b\<in>f n \<and> (\<forall>x\<in>f n. x \<le> b)" using closed_int_most by blast
179.94 -
179.95 - have subsetd: "\<forall>m. \<forall>n. f (n + m) \<subseteq> f n"
179.96 - proof (rule allI, induct_tac m)
179.97 - show "\<forall>n. f (n + 0) \<subseteq> f n" by simp
179.98 - next
179.99 - fix m n
179.100 - assume pp: "\<forall>p. f (p + n) \<subseteq> f p"
179.101 - {
179.102 - fix p
179.103 - from pp have "f (p + n) \<subseteq> f p" by simp
179.104 - moreover from subset have "f (Suc (p + n)) \<subseteq> f (p + n)" by auto
179.105 - hence "f (p + (Suc n)) \<subseteq> f (p + n)" by simp
179.106 - ultimately have "f (p + (Suc n)) \<subseteq> f p" by simp
179.107 - }
179.108 - thus "\<forall>p. f (p + Suc n) \<subseteq> f p" ..
179.109 - qed
179.110 - have subsetm: "\<forall>\<alpha> \<beta>. \<alpha> \<ge> \<beta> \<longrightarrow> (f \<alpha>) \<subseteq> (f \<beta>)"
179.111 - proof ((rule allI)+, rule impI)
179.112 - fix \<alpha>::nat and \<beta>::nat
179.113 - assume "\<beta> \<le> \<alpha>"
179.114 - hence "\<exists>k. \<alpha> = \<beta> + k" by (simp only: le_iff_add)
179.115 - then obtain k where "\<alpha> = \<beta> + k" ..
179.116 - moreover
179.117 - from subsetd have "f (\<beta> + k) \<subseteq> f \<beta>" by simp
179.118 - ultimately show "f \<alpha> \<subseteq> f \<beta>" by auto
179.119 - qed
179.120 -
179.121 - fix m
179.122 - {
179.123 - assume "m \<ge> n"
179.124 - with subsetm have "f m \<subseteq> f n" by simp
179.125 - with ain have "\<forall>x\<in>f m. x \<le> b" by auto
179.126 - moreover
179.127 - from gdef have "?g m \<in> f m \<and> (\<forall>x\<in>f m. ?g m \<le> x)" by simp
179.128 - ultimately have "?g m \<le> b" by auto
179.129 - }
179.130 + assume "m \<ge> n"
179.131 + with subsetm have "f m \<subseteq> f n" by simp
179.132 + with ain have "\<forall>x\<in>f m. x \<le> b" by auto
179.133 moreover
179.134 - {
179.135 - assume "\<not>(m \<ge> n)"
179.136 - hence "m < n" by simp
179.137 - with subsetm have sub: "(f n) \<subseteq> (f m)" by simp
179.138 - from closed obtain ma and mb where
179.139 - "f m = closed_int ma mb \<and> ma \<le> mb" by blast
179.140 - hence one: "ma \<le> mb" and fm: "f m = closed_int ma mb" by auto
179.141 - from one alb sub fm int have "ma \<le> b" using closed_subset by blast
179.142 - moreover have "(?g m) = ma"
179.143 - proof -
179.144 - from gdef have "?g m \<in> f m \<and> (\<forall>x\<in>f m. ?g m \<le> x)" ..
179.145 - moreover from one have
179.146 - "ma \<in> closed_int ma mb \<and> (\<forall>x\<in>closed_int ma mb. ma \<le> x)"
179.147 - by (rule closed_int_least)
179.148 - with fm have "ma\<in>f m \<and> (\<forall>x\<in>f m. ma \<le> x)" by simp
179.149 - ultimately have "ma \<le> ?g m \<and> ?g m \<le> ma" by auto
179.150 - thus "?g m = ma" by auto
179.151 - qed
179.152 - ultimately have "?g m \<le> b" by simp
179.153 - }
179.154 - ultimately have "?g m \<le> b" by (rule case_split)
179.155 + from gdef have "?g m \<in> f m \<and> (\<forall>x\<in>f m. ?g m \<le> x)" by simp
179.156 + ultimately have "?g m \<le> b" by auto
179.157 }
179.158 - with Adef have "\<forall>y\<in>A. y\<le>b" by auto
179.159 - hence "A *<= b" by (unfold setle_def)
179.160 - moreover have "b \<in> (UNIV::real set)" by simp
179.161 - ultimately have "A *<= b \<and> b \<in> (UNIV::real set)" by simp
179.162 - thus "isUb (UNIV::real set) A b" by (unfold isUb_def)
179.163 - qed
179.164 - with tdef show "t \<le> b" by (rule isLub_le_isUb)
179.165 - qed
179.166 + moreover
179.167 + {
179.168 + assume "\<not>(m \<ge> n)"
179.169 + hence "m < n" by simp
179.170 + with subsetm have sub: "(f n) \<subseteq> (f m)" by simp
179.171 + from closed obtain ma and mb where
179.172 + "f m = closed_int ma mb \<and> ma \<le> mb" by blast
179.173 + hence one: "ma \<le> mb" and fm: "f m = closed_int ma mb" by auto
179.174 + from one alb sub fm int have "ma \<le> b" using closed_subset by blast
179.175 + moreover have "(?g m) = ma"
179.176 + proof -
179.177 + from gdef have "?g m \<in> f m \<and> (\<forall>x\<in>f m. ?g m \<le> x)" ..
179.178 + moreover from one have
179.179 + "ma \<in> closed_int ma mb \<and> (\<forall>x\<in>closed_int ma mb. ma \<le> x)"
179.180 + by (rule closed_int_least)
179.181 + with fm have "ma\<in>f m \<and> (\<forall>x\<in>f m. ma \<le> x)" by simp
179.182 + ultimately have "ma \<le> ?g m \<and> ?g m \<le> ma" by auto
179.183 + thus "?g m = ma" by auto
179.184 + qed
179.185 + ultimately have "?g m \<le> b" by simp
179.186 + }
179.187 + ultimately have "?g m \<le> b" by (rule case_split)
179.188 + }
179.189 + with Adef show "\<And>y. y \<in> A \<Longrightarrow> y \<le> b" by auto
179.190 + qed fact
179.191 ultimately have "t \<in> closed_int a b" by (rule closed_mem)
179.192 with int show "t \<in> f n" by simp
179.193 qed
180.1 --- a/src/HOL/Library/Continuity.thy Thu Dec 05 17:52:12 2013 +0100
180.2 +++ b/src/HOL/Library/Continuity.thy Thu Dec 05 17:58:03 2013 +0100
180.3 @@ -19,7 +19,8 @@
180.4 "continuous F \<longleftrightarrow> (\<forall>M. chain M \<longrightarrow> F (SUP i. M i) = (SUP i. F (M i)))"
180.5
180.6 lemma SUP_nat_conv:
180.7 - "(SUP n. M n) = sup (M 0) (SUP n. M(Suc n))"
180.8 + fixes M :: "nat \<Rightarrow> 'a::complete_lattice"
180.9 + shows "(SUP n. M n) = sup (M 0) (SUP n. M(Suc n))"
180.10 apply(rule order_antisym)
180.11 apply(rule SUP_least)
180.12 apply(case_tac n)
181.1 --- a/src/HOL/Library/Convex.thy Thu Dec 05 17:52:12 2013 +0100
181.2 +++ b/src/HOL/Library/Convex.thy Thu Dec 05 17:58:03 2013 +0100
181.3 @@ -362,7 +362,7 @@
181.4 shows "convex {x - y| x y. x \<in> s \<and> y \<in> t}"
181.5 proof -
181.6 have "{x - y| x y. x \<in> s \<and> y \<in> t} = {x + y |x y. x \<in> s \<and> y \<in> uminus ` t}"
181.7 - unfolding diff_def by auto
181.8 + by (auto simp add: diff_conv_add_uminus simp del: add_uminus_conv_diff)
181.9 then show ?thesis
181.10 using convex_sums[OF assms(1) convex_negations[OF assms(2)]] by auto
181.11 qed
182.1 --- a/src/HOL/Library/Countable_Set.thy Thu Dec 05 17:52:12 2013 +0100
182.2 +++ b/src/HOL/Library/Countable_Set.thy Thu Dec 05 17:58:03 2013 +0100
182.3 @@ -230,6 +230,27 @@
182.4 lemma countable_Collect[simp]: "countable A \<Longrightarrow> countable {a \<in> A. \<phi> a}"
182.5 by (metis Collect_conj_eq Int_absorb Int_commute Int_def countable_Int1)
182.6
182.7 +lemma countable_Image:
182.8 + assumes "\<And>y. y \<in> Y \<Longrightarrow> countable (X `` {y})"
182.9 + assumes "countable Y"
182.10 + shows "countable (X `` Y)"
182.11 +proof -
182.12 + have "countable (X `` (\<Union>y\<in>Y. {y}))"
182.13 + unfolding Image_UN by (intro countable_UN assms)
182.14 + then show ?thesis by simp
182.15 +qed
182.16 +
182.17 +lemma countable_relpow:
182.18 + fixes X :: "'a rel"
182.19 + assumes Image_X: "\<And>Y. countable Y \<Longrightarrow> countable (X `` Y)"
182.20 + assumes Y: "countable Y"
182.21 + shows "countable ((X ^^ i) `` Y)"
182.22 + using Y by (induct i arbitrary: Y) (auto simp: relcomp_Image Image_X)
182.23 +
182.24 +lemma countable_rtrancl:
182.25 + "(\<And>Y. countable Y \<Longrightarrow> countable (X `` Y)) \<Longrightarrow> countable Y \<Longrightarrow> countable (X^* `` Y)"
182.26 + unfolding rtrancl_is_UN_relpow UN_Image by (intro countable_UN countableI_type countable_relpow)
182.27 +
182.28 lemma countable_lists[intro, simp]:
182.29 assumes A: "countable A" shows "countable (lists A)"
182.30 proof -
183.1 --- a/src/HOL/Library/Extended.thy Thu Dec 05 17:52:12 2013 +0100
183.2 +++ b/src/HOL/Library/Extended.thy Thu Dec 05 17:58:03 2013 +0100
183.3 @@ -161,8 +161,8 @@
183.4 apply (simp only: numeral_inc one_extended_def plus_extended.simps(1)[symmetric])
183.5 done
183.6
183.7 -lemma Fin_neg_numeral: "Fin(neg_numeral w) = - numeral w"
183.8 -by (simp only: Fin_numeral minus_numeral[symmetric] uminus_extended.simps[symmetric])
183.9 +lemma Fin_neg_numeral: "Fin (- numeral w) = - numeral w"
183.10 +by (simp only: Fin_numeral uminus_extended.simps[symmetric])
183.11
183.12
183.13 instantiation extended :: (lattice)bounded_lattice
184.1 --- a/src/HOL/Library/Extended_Nat.thy Thu Dec 05 17:52:12 2013 +0100
184.2 +++ b/src/HOL/Library/Extended_Nat.thy Thu Dec 05 17:58:03 2013 +0100
184.3 @@ -6,7 +6,7 @@
184.4 header {* Extended natural numbers (i.e. with infinity) *}
184.5
184.6 theory Extended_Nat
184.7 -imports Main
184.8 +imports Main Countable
184.9 begin
184.10
184.11 class infinity =
184.12 @@ -26,7 +26,9 @@
184.13 *}
184.14
184.15 typedef enat = "UNIV :: nat option set" ..
184.16 -
184.17 +
184.18 +text {* TODO: introduce enat as coinductive datatype, enat is just @{const of_nat} *}
184.19 +
184.20 definition enat :: "nat \<Rightarrow> enat" where
184.21 "enat n = Abs_enat (Some n)"
184.22
184.23 @@ -35,6 +37,12 @@
184.24 definition "\<infinity> = Abs_enat None"
184.25 instance proof qed
184.26 end
184.27 +
184.28 +instance enat :: countable
184.29 +proof
184.30 + show "\<exists>to_nat::enat \<Rightarrow> nat. inj to_nat"
184.31 + by (rule exI[of _ "to_nat \<circ> Rep_enat"]) (simp add: inj_on_def Rep_enat_inject)
184.32 +qed
184.33
184.34 rep_datatype enat "\<infinity> :: enat"
184.35 proof -
184.36 @@ -52,10 +60,10 @@
184.37 lemmas enat2_cases = enat.exhaust[case_product enat.exhaust]
184.38 lemmas enat3_cases = enat.exhaust[case_product enat.exhaust enat.exhaust]
184.39
184.40 -lemma not_infinity_eq [iff]: "(x \<noteq> \<infinity>) = (EX i. x = enat i)"
184.41 +lemma not_infinity_eq [iff]: "(x \<noteq> \<infinity>) = (\<exists>i. x = enat i)"
184.42 by (cases x) auto
184.43
184.44 -lemma not_enat_eq [iff]: "(ALL y. x ~= enat y) = (x = \<infinity>)"
184.45 +lemma not_enat_eq [iff]: "(\<forall>y. x \<noteq> enat y) = (x = \<infinity>)"
184.46 by (cases x) auto
184.47
184.48 primrec the_enat :: "enat \<Rightarrow> nat"
184.49 @@ -86,6 +94,12 @@
184.50 lemma enat_1 [code_post]: "enat 1 = 1"
184.51 by (simp add: one_enat_def)
184.52
184.53 +lemma enat_0_iff: "enat x = 0 \<longleftrightarrow> x = 0" "0 = enat x \<longleftrightarrow> x = 0"
184.54 + by (auto simp add: zero_enat_def)
184.55 +
184.56 +lemma enat_1_iff: "enat x = 1 \<longleftrightarrow> x = 1" "1 = enat x \<longleftrightarrow> x = 1"
184.57 + by (auto simp add: one_enat_def)
184.58 +
184.59 lemma one_eSuc: "1 = eSuc 0"
184.60 by (simp add: zero_enat_def one_enat_def eSuc_def)
184.61
184.62 @@ -555,7 +569,6 @@
184.63
184.64 text {* TODO: add simprocs for combining and cancelling numerals *}
184.65
184.66 -
184.67 subsection {* Well-ordering *}
184.68
184.69 lemma less_enatE:
184.70 @@ -596,6 +609,8 @@
184.71
184.72 subsection {* Complete Lattice *}
184.73
184.74 +text {* TODO: enat as order topology? *}
184.75 +
184.76 instantiation enat :: complete_lattice
184.77 begin
184.78
185.1 --- a/src/HOL/Library/Extended_Real.thy Thu Dec 05 17:52:12 2013 +0100
185.2 +++ b/src/HOL/Library/Extended_Real.thy Thu Dec 05 17:58:03 2013 +0100
185.3 @@ -156,7 +156,7 @@
185.4
185.5 subsubsection "Addition"
185.6
185.7 -instantiation ereal :: "{one,comm_monoid_add}"
185.8 +instantiation ereal :: "{one,comm_monoid_add,zero_neq_one}"
185.9 begin
185.10
185.11 definition "0 = ereal 0"
185.12 @@ -188,6 +188,11 @@
185.13 "0 = ereal r \<longleftrightarrow> r = 0"
185.14 unfolding zero_ereal_def by simp_all
185.15
185.16 +lemma ereal_eq_1[simp]:
185.17 + "ereal r = 1 \<longleftrightarrow> r = 1"
185.18 + "1 = ereal r \<longleftrightarrow> r = 1"
185.19 + unfolding one_ereal_def by simp_all
185.20 +
185.21 instance
185.22 proof
185.23 fix a b c :: ereal
185.24 @@ -197,6 +202,8 @@
185.25 by (cases rule: ereal2_cases[of a b]) simp_all
185.26 show "a + b + c = a + (b + c)"
185.27 by (cases rule: ereal3_cases[of a b c]) simp_all
185.28 + show "0 \<noteq> (1::ereal)"
185.29 + by (simp add: one_ereal_def zero_ereal_def)
185.30 qed
185.31
185.32 end
185.33 @@ -286,9 +293,11 @@
185.34 lemma ereal_less[simp]:
185.35 "ereal r < 0 \<longleftrightarrow> (r < 0)"
185.36 "0 < ereal r \<longleftrightarrow> (0 < r)"
185.37 + "ereal r < 1 \<longleftrightarrow> (r < 1)"
185.38 + "1 < ereal r \<longleftrightarrow> (1 < r)"
185.39 "0 < (\<infinity>::ereal)"
185.40 "-(\<infinity>::ereal) < 0"
185.41 - by (simp_all add: zero_ereal_def)
185.42 + by (simp_all add: zero_ereal_def one_ereal_def)
185.43
185.44 lemma ereal_less_eq[simp]:
185.45 "x \<le> (\<infinity>::ereal)"
185.46 @@ -296,7 +305,9 @@
185.47 "ereal r \<le> ereal p \<longleftrightarrow> r \<le> p"
185.48 "ereal r \<le> 0 \<longleftrightarrow> r \<le> 0"
185.49 "0 \<le> ereal r \<longleftrightarrow> 0 \<le> r"
185.50 - by (auto simp add: less_eq_ereal_def zero_ereal_def)
185.51 + "ereal r \<le> 1 \<longleftrightarrow> r \<le> 1"
185.52 + "1 \<le> ereal r \<longleftrightarrow> 1 \<le> r"
185.53 + by (auto simp add: less_eq_ereal_def zero_ereal_def one_ereal_def)
185.54
185.55 lemma ereal_infty_less_eq2:
185.56 "a \<le> b \<Longrightarrow> a = \<infinity> \<Longrightarrow> b = (\<infinity>::ereal)"
185.57 @@ -456,6 +467,11 @@
185.58 shows "\<bar>a\<bar> \<noteq> \<infinity> \<Longrightarrow> c < b \<Longrightarrow> a + c < a + b"
185.59 by (cases rule: ereal2_cases[of b c]) auto
185.60
185.61 +lemma ereal_add_nonneg_eq_0_iff:
185.62 + fixes a b :: ereal
185.63 + shows "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a + b = 0 \<longleftrightarrow> a = 0 \<and> b = 0"
185.64 + by (cases a b rule: ereal2_cases) auto
185.65 +
185.66 lemma ereal_uminus_eq_reorder: "- a = b \<longleftrightarrow> a = (-b::ereal)"
185.67 by auto
185.68
185.69 @@ -514,8 +530,8 @@
185.70
185.71 lemma
185.72 fixes f :: "nat \<Rightarrow> ereal"
185.73 - shows incseq_uminus[simp]: "incseq (\<lambda>x. - f x) \<longleftrightarrow> decseq f"
185.74 - and decseq_uminus[simp]: "decseq (\<lambda>x. - f x) \<longleftrightarrow> incseq f"
185.75 + shows ereal_incseq_uminus[simp]: "incseq (\<lambda>x. - f x) \<longleftrightarrow> decseq f"
185.76 + and ereal_decseq_uminus[simp]: "decseq (\<lambda>x. - f x) \<longleftrightarrow> incseq f"
185.77 unfolding decseq_def incseq_def by auto
185.78
185.79 lemma incseq_ereal: "incseq f \<Longrightarrow> incseq (\<lambda>x. ereal (f x))"
185.80 @@ -618,14 +634,6 @@
185.81 lemma ereal_m1_less_0[simp]: "-(1::ereal) < 0"
185.82 by (simp add: zero_ereal_def one_ereal_def)
185.83
185.84 -lemma ereal_zero_m1[simp]: "1 \<noteq> (0::ereal)"
185.85 - by (simp add: zero_ereal_def one_ereal_def)
185.86 -
185.87 -lemma ereal_times_0[simp]:
185.88 - fixes x :: ereal
185.89 - shows "0 * x = 0"
185.90 - by (cases x) (auto simp: zero_ereal_def)
185.91 -
185.92 lemma ereal_times[simp]:
185.93 "1 \<noteq> (\<infinity>::ereal)" "(\<infinity>::ereal) \<noteq> 1"
185.94 "1 \<noteq> -(\<infinity>::ereal)" "-(\<infinity>::ereal) \<noteq> 1"
185.95 @@ -653,12 +661,12 @@
185.96 (a = \<infinity> \<and> b < 0) \<or> (a < 0 \<and> b = \<infinity>) \<or> (a = -\<infinity> \<and> b > 0) \<or> (a > 0 \<and> b = -\<infinity>)"
185.97 by (cases rule: ereal2_cases[of a b]) auto
185.98
185.99 +lemma ereal_abs_mult: "\<bar>x * y :: ereal\<bar> = \<bar>x\<bar> * \<bar>y\<bar>"
185.100 + by (cases x y rule: ereal2_cases) (auto simp: abs_mult)
185.101 +
185.102 lemma ereal_0_less_1[simp]: "0 < (1::ereal)"
185.103 by (simp_all add: zero_ereal_def one_ereal_def)
185.104
185.105 -lemma ereal_zero_one[simp]: "0 \<noteq> (1::ereal)"
185.106 - by (simp_all add: zero_ereal_def one_ereal_def)
185.107 -
185.108 lemma ereal_mult_minus_left[simp]:
185.109 fixes a b :: ereal
185.110 shows "-a * b = - (a * b)"
185.111 @@ -950,7 +958,7 @@
185.112 by simp
185.113 }
185.114 then show ?thesis
185.115 - by (auto intro!: image_eqI)
185.116 + by force
185.117 qed
185.118
185.119 lemma ereal_uminus_greaterThan[simp]: "uminus ` {(a::ereal)<..} = {..<-a}"
185.120 @@ -1265,7 +1273,7 @@
185.121 shows "z / x \<le> z / y"
185.122 using assms
185.123 by (cases x y z rule: ereal3_cases)
185.124 - (auto intro: divide_left_mono simp: field_simps sign_simps split: split_if_asm)
185.125 + (auto intro: divide_left_mono simp: field_simps zero_less_mult_iff mult_less_0_iff split: split_if_asm)
185.126
185.127 lemma ereal_divide_zero_left[simp]:
185.128 fixes a :: ereal
185.129 @@ -1275,7 +1283,7 @@
185.130 lemma ereal_times_divide_eq_left[simp]:
185.131 fixes a b c :: ereal
185.132 shows "b / c * a = b * a / c"
185.133 - by (cases a b c rule: ereal3_cases) (auto simp: field_simps sign_simps)
185.134 + by (cases a b c rule: ereal3_cases) (auto simp: field_simps zero_less_mult_iff mult_less_0_iff)
185.135
185.136
185.137 subsection "Complete lattice"
185.138 @@ -1378,7 +1386,7 @@
185.139 instance ereal :: linear_continuum
185.140 proof
185.141 show "\<exists>a b::ereal. a \<noteq> b"
185.142 - using ereal_zero_one by blast
185.143 + using zero_neq_one by blast
185.144 qed
185.145
185.146 lemma ereal_Sup_uminus_image_eq: "Sup (uminus ` S::ereal set) = - Inf S"
185.147 @@ -1392,6 +1400,18 @@
185.148 lemma ereal_Inf_uminus_image_eq: "Inf (uminus ` S::ereal set) = - Sup S"
185.149 using ereal_Sup_uminus_image_eq[of "uminus ` S"] by simp
185.150
185.151 +lemma ereal_SUP_not_infty:
185.152 + fixes f :: "_ \<Rightarrow> ereal"
185.153 + shows "A \<noteq> {} \<Longrightarrow> l \<noteq> -\<infinity> \<Longrightarrow> u \<noteq> \<infinity> \<Longrightarrow> \<forall>a\<in>A. l \<le> f a \<and> f a \<le> u \<Longrightarrow> \<bar>SUPR A f\<bar> \<noteq> \<infinity>"
185.154 + using SUP_upper2[of _ A l f] SUP_least[of A f u]
185.155 + by (cases "SUPR A f") auto
185.156 +
185.157 +lemma ereal_INF_not_infty:
185.158 + fixes f :: "_ \<Rightarrow> ereal"
185.159 + shows "A \<noteq> {} \<Longrightarrow> l \<noteq> -\<infinity> \<Longrightarrow> u \<noteq> \<infinity> \<Longrightarrow> \<forall>a\<in>A. l \<le> f a \<and> f a \<le> u \<Longrightarrow> \<bar>INFI A f\<bar> \<noteq> \<infinity>"
185.160 + using INF_lower2[of _ A f u] INF_greatest[of A l f]
185.161 + by (cases "INFI A f") auto
185.162 +
185.163 lemma ereal_SUPR_uminus:
185.164 fixes f :: "'a \<Rightarrow> ereal"
185.165 shows "(SUP i : R. -(f i)) = -(INF i : R. f i)"
185.166 @@ -1710,8 +1730,7 @@
185.167 next
185.168 case False
185.169 have "\<exists>x\<in>A. 0 \<le> x"
185.170 - by (metis Infty_neq_0 PInf complete_lattice_class.Sup_least
185.171 - ereal_infty_less_eq2 linorder_linear)
185.172 + by (metis Infty_neq_0(2) PInf complete_lattice_class.Sup_least ereal_infty_less_eq2(1) linorder_linear)
185.173 then obtain x where "x \<in> A" and "0 \<le> x"
185.174 by auto
185.175 have "\<forall>n::nat. \<exists>f. f \<in> A \<and> x + ereal (real n) \<le> f"
185.176 @@ -1843,7 +1862,6 @@
185.177 finally show ?thesis .
185.178 qed
185.179
185.180 -
185.181 subsection "Relation to @{typ enat}"
185.182
185.183 definition "ereal_of_enat n = (case n of enat n \<Rightarrow> ereal (real n) | \<infinity> \<Rightarrow> \<infinity>)"
185.184 @@ -2411,12 +2429,6 @@
185.185 (is "?lhs \<longleftrightarrow> ?rhs")
185.186 unfolding le_Liminf_iff eventually_sequentially ..
185.187
185.188 -lemma
185.189 - fixes X :: "nat \<Rightarrow> ereal"
185.190 - shows ereal_incseq_uminus[simp]: "incseq (\<lambda>i. - X i) = decseq X"
185.191 - and ereal_decseq_uminus[simp]: "decseq (\<lambda>i. - X i) = incseq X"
185.192 - unfolding incseq_def decseq_def by auto
185.193 -
185.194
185.195 subsubsection {* Tests for code generator *}
185.196
186.1 --- a/src/HOL/Library/FSet.thy Thu Dec 05 17:52:12 2013 +0100
186.2 +++ b/src/HOL/Library/FSet.thy Thu Dec 05 17:58:03 2013 +0100
186.3 @@ -101,19 +101,25 @@
186.4 lemma finite_Sup: "\<exists>z. finite z \<and> (\<forall>a. a \<in> X \<longrightarrow> a \<le> z) \<Longrightarrow> finite (Sup X)"
186.5 by (auto intro: finite_subset)
186.6
186.7 +lemma transfer_bdd_below[transfer_rule]: "(set_rel (pcr_fset op =) ===> op =) bdd_below bdd_below"
186.8 + by auto
186.9 +
186.10 instance
186.11 proof
186.12 fix x z :: "'a fset"
186.13 fix X :: "'a fset set"
186.14 {
186.15 - assume "x \<in> X" "(\<And>a. a \<in> X \<Longrightarrow> z |\<subseteq>| a)"
186.16 + assume "x \<in> X" "bdd_below X"
186.17 then show "Inf X |\<subseteq>| x" by transfer auto
186.18 next
186.19 assume "X \<noteq> {}" "(\<And>x. x \<in> X \<Longrightarrow> z |\<subseteq>| x)"
186.20 then show "z |\<subseteq>| Inf X" by transfer (clarsimp, blast)
186.21 next
186.22 - assume "x \<in> X" "(\<And>a. a \<in> X \<Longrightarrow> a |\<subseteq>| z)"
186.23 - then show "x |\<subseteq>| Sup X" by transfer (auto intro!: finite_Sup)
186.24 + assume "x \<in> X" "bdd_above X"
186.25 + then obtain z where "x \<in> X" "(\<And>x. x \<in> X \<Longrightarrow> x |\<subseteq>| z)"
186.26 + by (auto simp: bdd_above_def)
186.27 + then show "x |\<subseteq>| Sup X"
186.28 + by transfer (auto intro!: finite_Sup)
186.29 next
186.30 assume "X \<noteq> {}" "(\<And>x. x \<in> X \<Longrightarrow> x |\<subseteq>| z)"
186.31 then show "Sup X |\<subseteq>| z" by transfer (clarsimp, blast)
187.1 --- a/src/HOL/Library/Float.thy Thu Dec 05 17:52:12 2013 +0100
187.2 +++ b/src/HOL/Library/Float.thy Thu Dec 05 17:58:03 2013 +0100
187.3 @@ -45,7 +45,7 @@
187.4 lemma zero_float[simp]: "0 \<in> float" by (auto simp: float_def)
187.5 lemma one_float[simp]: "1 \<in> float" by (intro floatI[of 1 0]) simp
187.6 lemma numeral_float[simp]: "numeral i \<in> float" by (intro floatI[of "numeral i" 0]) simp
187.7 -lemma neg_numeral_float[simp]: "neg_numeral i \<in> float" by (intro floatI[of "neg_numeral i" 0]) simp
187.8 +lemma neg_numeral_float[simp]: "- numeral i \<in> float" by (intro floatI[of "- numeral i" 0]) simp
187.9 lemma real_of_int_float[simp]: "real (x :: int) \<in> float" by (intro floatI[of x 0]) simp
187.10 lemma real_of_nat_float[simp]: "real (x :: nat) \<in> float" by (intro floatI[of x 0]) simp
187.11 lemma two_powr_int_float[simp]: "2 powr (real (i::int)) \<in> float" by (intro floatI[of 1 i]) simp
187.12 @@ -53,7 +53,7 @@
187.13 lemma two_powr_minus_int_float[simp]: "2 powr - (real (i::int)) \<in> float" by (intro floatI[of 1 "-i"]) simp
187.14 lemma two_powr_minus_nat_float[simp]: "2 powr - (real (i::nat)) \<in> float" by (intro floatI[of 1 "-i"]) simp
187.15 lemma two_powr_numeral_float[simp]: "2 powr numeral i \<in> float" by (intro floatI[of 1 "numeral i"]) simp
187.16 -lemma two_powr_neg_numeral_float[simp]: "2 powr neg_numeral i \<in> float" by (intro floatI[of 1 "neg_numeral i"]) simp
187.17 +lemma two_powr_neg_numeral_float[simp]: "2 powr - numeral i \<in> float" by (intro floatI[of 1 "- numeral i"]) simp
187.18 lemma two_pow_float[simp]: "2 ^ n \<in> float" by (intro floatI[of 1 "n"]) (simp add: powr_realpow)
187.19 lemma real_of_float_float[simp]: "real (f::float) \<in> float" by (cases f) simp
187.20
187.21 @@ -88,7 +88,7 @@
187.22 done
187.23
187.24 lemma minus_float[simp]: "x \<in> float \<Longrightarrow> y \<in> float \<Longrightarrow> x - y \<in> float"
187.25 - unfolding ab_diff_minus by (intro uminus_float plus_float)
187.26 + using plus_float [of x "- y"] by simp
187.27
187.28 lemma abs_float[simp]: "x \<in> float \<Longrightarrow> abs x \<in> float"
187.29 by (cases x rule: linorder_cases[of 0]) auto
187.30 @@ -121,11 +121,11 @@
187.31 qed
187.32
187.33 lemma div_neg_numeral_Bit0_float[simp]:
187.34 - assumes x: "x / numeral n \<in> float" shows "x / (neg_numeral (Num.Bit0 n)) \<in> float"
187.35 + assumes x: "x / numeral n \<in> float" shows "x / (- numeral (Num.Bit0 n)) \<in> float"
187.36 proof -
187.37 have "- (x / numeral (Num.Bit0 n)) \<in> float" using x by simp
187.38 - also have "- (x / numeral (Num.Bit0 n)) = x / neg_numeral (Num.Bit0 n)"
187.39 - unfolding neg_numeral_def by (simp del: minus_numeral)
187.40 + also have "- (x / numeral (Num.Bit0 n)) = x / - numeral (Num.Bit0 n)"
187.41 + by simp
187.42 finally show ?thesis .
187.43 qed
187.44
187.45 @@ -197,7 +197,7 @@
187.46 then show "\<exists>c. a < c \<and> c < b"
187.47 apply (intro exI[of _ "(a + b) * Float 1 -1"])
187.48 apply transfer
187.49 - apply (simp add: powr_neg_numeral)
187.50 + apply (simp add: powr_minus)
187.51 done
187.52 qed
187.53
187.54 @@ -226,16 +226,16 @@
187.55 "fun_rel (op =) pcr_float (numeral :: _ \<Rightarrow> real) (numeral :: _ \<Rightarrow> float)"
187.56 unfolding fun_rel_def float.pcr_cr_eq cr_float_def by simp
187.57
187.58 -lemma float_neg_numeral[simp]: "real (neg_numeral x :: float) = neg_numeral x"
187.59 - by (simp add: minus_numeral[symmetric] del: minus_numeral)
187.60 +lemma float_neg_numeral[simp]: "real (- numeral x :: float) = - numeral x"
187.61 + by simp
187.62
187.63 lemma transfer_neg_numeral [transfer_rule]:
187.64 - "fun_rel (op =) pcr_float (neg_numeral :: _ \<Rightarrow> real) (neg_numeral :: _ \<Rightarrow> float)"
187.65 + "fun_rel (op =) pcr_float (- numeral :: _ \<Rightarrow> real) (- numeral :: _ \<Rightarrow> float)"
187.66 unfolding fun_rel_def float.pcr_cr_eq cr_float_def by simp
187.67
187.68 lemma
187.69 shows float_of_numeral[simp]: "numeral k = float_of (numeral k)"
187.70 - and float_of_neg_numeral[simp]: "neg_numeral k = float_of (neg_numeral k)"
187.71 + and float_of_neg_numeral[simp]: "- numeral k = float_of (- numeral k)"
187.72 unfolding real_of_float_eq by simp_all
187.73
187.74 subsection {* Represent floats as unique mantissa and exponent *}
187.75 @@ -439,7 +439,7 @@
187.76 by transfer simp
187.77 hide_fact (open) compute_float_numeral
187.78
187.79 -lemma compute_float_neg_numeral[code_abbrev]: "Float (neg_numeral k) 0 = neg_numeral k"
187.80 +lemma compute_float_neg_numeral[code_abbrev]: "Float (- numeral k) 0 = - numeral k"
187.81 by transfer simp
187.82 hide_fact (open) compute_float_neg_numeral
187.83
187.84 @@ -960,7 +960,7 @@
187.85 also have "... < (1 / 2) * 2 powr real (rat_precision n (int x) (int y))"
187.86 apply (rule mult_strict_right_mono) by (insert assms) auto
187.87 also have "\<dots> = 2 powr real (rat_precision n (int x) (int y) - 1)"
187.88 - by (simp add: powr_add diff_def powr_neg_numeral)
187.89 + using powr_add [of 2 _ "- 1", simplified add_uminus_conv_diff] by (simp add: powr_minus)
187.90 also have "\<dots> = 2 ^ nat (rat_precision n (int x) (int y) - 1)"
187.91 using rat_precision_pos[of x y n] assms by (simp add: powr_realpow[symmetric])
187.92 also have "\<dots> \<le> 2 ^ nat (rat_precision n (int x) (int y)) - 1"
188.1 --- a/src/HOL/Library/Formal_Power_Series.thy Thu Dec 05 17:52:12 2013 +0100
188.2 +++ b/src/HOL/Library/Formal_Power_Series.thy Thu Dec 05 17:58:03 2013 +0100
188.3 @@ -231,7 +231,7 @@
188.4 proof
188.5 fix a b :: "'a fps"
188.6 show "- a + a = 0" by (simp add: fps_ext)
188.7 - show "a - b = a + - b" by (simp add: fps_ext diff_minus)
188.8 + show "a + - b = a - b" by (simp add: fps_ext)
188.9 qed
188.10
188.11 instance fps :: (ab_group_add) ab_group_add
188.12 @@ -348,10 +348,10 @@
188.13 instance fps :: (ring) ring ..
188.14
188.15 instance fps :: (ring_1) ring_1
188.16 - by (intro_classes, auto simp add: diff_minus distrib_right)
188.17 + by (intro_classes, auto simp add: distrib_right)
188.18
188.19 instance fps :: (comm_ring_1) comm_ring_1
188.20 - by (intro_classes, auto simp add: diff_minus distrib_right)
188.21 + by (intro_classes, auto simp add: distrib_right)
188.22
188.23 instance fps :: (ring_no_zero_divisors) ring_no_zero_divisors
188.24 proof
188.25 @@ -384,8 +384,8 @@
188.26 by (induct k) (simp_all only: numeral.simps fps_const_1_eq_1
188.27 fps_const_add [symmetric])
188.28
188.29 -lemma neg_numeral_fps_const: "neg_numeral k = fps_const (neg_numeral k)"
188.30 - by (simp only: neg_numeral_def numeral_fps_const fps_const_neg)
188.31 +lemma neg_numeral_fps_const: "- numeral k = fps_const (- numeral k)"
188.32 + by (simp only: numeral_fps_const fps_const_neg)
188.33
188.34 subsection{* The eXtractor series X*}
188.35
188.36 @@ -415,7 +415,7 @@
188.37 lemma X_power_iff: "X^k = Abs_fps (\<lambda>n. if n = k then (1::'a::comm_ring_1) else 0)"
188.38 proof (induct k)
188.39 case 0
188.40 - thus ?case by (simp add: X_def fps_eq_iff)
188.41 + then show ?case by (simp add: X_def fps_eq_iff)
188.42 next
188.43 case (Suc k)
188.44 {
188.45 @@ -451,7 +451,7 @@
188.46
188.47 definition
188.48 dist_fps_def: "dist (a::'a fps) b =
188.49 - (if (\<exists>n. a$n \<noteq> b$n) then inverse (2 ^ The (leastP (\<lambda>n. a$n \<noteq> b$n))) else 0)"
188.50 + (if (\<exists>n. a$n \<noteq> b$n) then inverse (2 ^ (LEAST n. a$n \<noteq> b$n)) else 0)"
188.51
188.52 lemma dist_fps_ge0: "dist (a::'a fps) b \<ge> 0"
188.53 by (simp add: dist_fps_def)
188.54 @@ -467,34 +467,6 @@
188.55
188.56 end
188.57
188.58 -lemma fps_nonzero_least_unique:
188.59 - assumes a0: "a \<noteq> 0"
188.60 - shows "\<exists>!n. leastP (\<lambda>n. a$n \<noteq> 0) n"
188.61 -proof -
188.62 - from fps_nonzero_nth_minimal [of a] a0
188.63 - obtain n where "a$n \<noteq> 0" "\<forall>m < n. a$m = 0" by blast
188.64 - then have ln: "leastP (\<lambda>n. a$n \<noteq> 0) n"
188.65 - by (auto simp add: leastP_def setge_def not_le [symmetric])
188.66 - moreover
188.67 - {
188.68 - fix m
188.69 - assume "leastP (\<lambda>n. a $ n \<noteq> 0) m"
188.70 - then have "m = n" using ln
188.71 - apply (auto simp add: leastP_def setge_def)
188.72 - apply (erule allE[where x=n])
188.73 - apply (erule allE[where x=m])
188.74 - apply simp
188.75 - done
188.76 - }
188.77 - ultimately show ?thesis by blast
188.78 -qed
188.79 -
188.80 -lemma fps_eq_least_unique:
188.81 - assumes "(a::('a::ab_group_add) fps) \<noteq> b"
188.82 - shows "\<exists>! n. leastP (\<lambda>n. a$n \<noteq> b$n) n"
188.83 - using fps_nonzero_least_unique[of "a - b"] assms
188.84 - by auto
188.85 -
188.86 instantiation fps :: (comm_ring_1) metric_space
188.87 begin
188.88
188.89 @@ -540,31 +512,15 @@
188.90 moreover
188.91 {
188.92 assume ab: "a \<noteq> b" and ac: "a \<noteq> c" and bc: "b \<noteq> c"
188.93 - let ?P = "\<lambda>a b n. a$n \<noteq> b$n"
188.94 - from fps_eq_least_unique[OF ab] fps_eq_least_unique[OF ac]
188.95 - fps_eq_least_unique[OF bc]
188.96 - obtain nab nac nbc where nab: "leastP (?P a b) nab"
188.97 - and nac: "leastP (?P a c) nac"
188.98 - and nbc: "leastP (?P b c) nbc" by blast
188.99 - from nab have nab': "\<And>m. m < nab \<Longrightarrow> a$m = b$m" "a$nab \<noteq> b$nab"
188.100 - by (auto simp add: leastP_def setge_def)
188.101 - from nac have nac': "\<And>m. m < nac \<Longrightarrow> a$m = c$m" "a$nac \<noteq> c$nac"
188.102 - by (auto simp add: leastP_def setge_def)
188.103 - from nbc have nbc': "\<And>m. m < nbc \<Longrightarrow> b$m = c$m" "b$nbc \<noteq> c$nbc"
188.104 - by (auto simp add: leastP_def setge_def)
188.105 -
188.106 - have th0: "\<And>(a::'a fps) b. a \<noteq> b \<longleftrightarrow> (\<exists>n. a$n \<noteq> b$n)"
188.107 - by (simp add: fps_eq_iff)
188.108 - from ab ac bc nab nac nbc
188.109 - have dab: "dist a b = inverse (2 ^ nab)"
188.110 - and dac: "dist a c = inverse (2 ^ nac)"
188.111 - and dbc: "dist b c = inverse (2 ^ nbc)"
188.112 - unfolding th0
188.113 - apply (simp_all add: dist_fps_def)
188.114 - apply (erule the1_equality[OF fps_eq_least_unique[OF ab]])
188.115 - apply (erule the1_equality[OF fps_eq_least_unique[OF ac]])
188.116 - apply (erule the1_equality[OF fps_eq_least_unique[OF bc]])
188.117 - done
188.118 + def n \<equiv> "\<lambda>a b::'a fps. LEAST n. a$n \<noteq> b$n"
188.119 + then have n': "\<And>m a b. m < n a b \<Longrightarrow> a$m = b$m"
188.120 + by (auto dest: not_less_Least)
188.121 +
188.122 + from ab ac bc
188.123 + have dab: "dist a b = inverse (2 ^ n a b)"
188.124 + and dac: "dist a c = inverse (2 ^ n a c)"
188.125 + and dbc: "dist b c = inverse (2 ^ n b c)"
188.126 + by (simp_all add: dist_fps_def n_def fps_eq_iff)
188.127 from ab ac bc have nz: "dist a b \<noteq> 0" "dist a c \<noteq> 0" "dist b c \<noteq> 0"
188.128 unfolding th by simp_all
188.129 from nz have pos: "dist a b > 0" "dist a c > 0" "dist b c > 0"
188.130 @@ -575,11 +531,13 @@
188.131 assume h: "dist a b > dist a c + dist b c"
188.132 then have gt: "dist a b > dist a c" "dist a b > dist b c"
188.133 using pos by auto
188.134 - from gt have gtn: "nab < nbc" "nab < nac"
188.135 + from gt have gtn: "n a b < n b c" "n a b < n a c"
188.136 unfolding dab dbc dac by (auto simp add: th1)
188.137 - from nac'(1)[OF gtn(2)] nbc'(1)[OF gtn(1)]
188.138 - have "a $ nab = b $ nab" by simp
188.139 - with nab'(2) have False by simp
188.140 + from n'[OF gtn(2)] n'(1)[OF gtn(1)]
188.141 + have "a $ n a b = b $ n a b" by simp
188.142 + moreover have "a $ n a b \<noteq> b $ n a b"
188.143 + unfolding n_def by (rule LeastI_ex) (insert ab, simp add: fps_eq_iff)
188.144 + ultimately have False by contradiction
188.145 }
188.146 then have "dist a b \<le> dist a c + dist b c"
188.147 by (auto simp add: not_le[symmetric])
188.148 @@ -620,13 +578,13 @@
188.149 by (simp add: X_power_iff)
188.150
188.151
188.152 -lemma fps_sum_rep_nth: "(setsum (%i. fps_const(a$i)*X^i) {0..m})$n =
188.153 +lemma fps_sum_rep_nth: "(setsum (\<lambda>i. fps_const(a$i)*X^i) {0..m})$n =
188.154 (if n \<le> m then a$n else (0::'a::comm_ring_1))"
188.155 apply (auto simp add: fps_setsum_nth cond_value_iff cong del: if_weak_cong)
188.156 apply (simp add: setsum_delta')
188.157 done
188.158
188.159 -lemma fps_notation: "(%n. setsum (%i. fps_const(a$i) * X^i) {0..n}) ----> a"
188.160 +lemma fps_notation: "(\<lambda>n. setsum (\<lambda>i. fps_const(a$i) * X^i) {0..n}) ----> a"
188.161 (is "?s ----> a")
188.162 proof -
188.163 {
188.164 @@ -638,7 +596,7 @@
188.165 {
188.166 fix n::nat
188.167 assume nn0: "n \<ge> n0"
188.168 - then have thnn0: "(1/2)^n <= (1/2 :: real)^n0"
188.169 + then have thnn0: "(1/2)^n \<le> (1/2 :: real)^n0"
188.170 by (auto intro: power_decreasing)
188.171 {
188.172 assume "?s n = a"
188.173 @@ -649,20 +607,15 @@
188.174 moreover
188.175 {
188.176 assume neq: "?s n \<noteq> a"
188.177 - from fps_eq_least_unique[OF neq]
188.178 - obtain k where k: "leastP (\<lambda>i. ?s n $ i \<noteq> a$i) k" by blast
188.179 - have th0: "\<And>(a::'a fps) b. a \<noteq> b \<longleftrightarrow> (\<exists>n. a$n \<noteq> b$n)"
188.180 - by (simp add: fps_eq_iff)
188.181 + def k \<equiv> "LEAST i. ?s n $ i \<noteq> a $ i"
188.182 from neq have dth: "dist (?s n) a = (1/2)^k"
188.183 - unfolding th0 dist_fps_def
188.184 - unfolding the1_equality[OF fps_eq_least_unique[OF neq], OF k]
188.185 - by (auto simp add: inverse_eq_divide power_divide)
188.186 -
188.187 - from k have kn: "k > n"
188.188 - by (simp add: leastP_def setge_def fps_sum_rep_nth split:split_if_asm)
188.189 + by (auto simp add: dist_fps_def inverse_eq_divide power_divide k_def fps_eq_iff)
188.190 +
188.191 + from neq have kn: "k > n"
188.192 + by (auto simp: fps_sum_rep_nth not_le k_def fps_eq_iff split: split_if_asm intro: LeastI2_ex)
188.193 then have "dist (?s n) a < (1/2)^n" unfolding dth
188.194 by (auto intro: power_strict_decreasing)
188.195 - also have "\<dots> <= (1/2)^n0" using nn0
188.196 + also have "\<dots> \<le> (1/2)^n0" using nn0
188.197 by (auto intro: power_decreasing)
188.198 also have "\<dots> < r" using n0 by simp
188.199 finally have "dist (?s n) a < r" .
188.200 @@ -888,7 +841,7 @@
188.201 using fps_deriv_linear[of 1 f 1 g] by simp
188.202
188.203 lemma fps_deriv_sub[simp]: "fps_deriv ((f:: ('a::comm_ring_1) fps) - g) = fps_deriv f - fps_deriv g"
188.204 - unfolding diff_minus by simp
188.205 + using fps_deriv_add [of f "- g"] by simp
188.206
188.207 lemma fps_deriv_const[simp]: "fps_deriv (fps_const c) = 0"
188.208 by (simp add: fps_ext fps_deriv_def fps_const_def)
188.209 @@ -978,7 +931,7 @@
188.210
188.211 lemma fps_nth_deriv_sub[simp]:
188.212 "fps_nth_deriv n ((f:: ('a::comm_ring_1) fps) - g) = fps_nth_deriv n f - fps_nth_deriv n g"
188.213 - unfolding diff_minus fps_nth_deriv_add by simp
188.214 + using fps_nth_deriv_add [of n f "- g"] by simp
188.215
188.216 lemma fps_nth_deriv_0[simp]: "fps_nth_deriv n 0 = 0"
188.217 by (induct n) simp_all
188.218 @@ -1127,7 +1080,7 @@
188.219 {
188.220 assume a0: "a$0 = 0"
188.221 then have eq: "inverse a = 0" by (simp add: fps_inverse_def)
188.222 - { assume "n = 0" hence ?thesis by simp }
188.223 + { assume "n = 0" then have ?thesis by simp }
188.224 moreover
188.225 {
188.226 assume n: "n > 0"
188.227 @@ -1167,8 +1120,10 @@
188.228 proof-
188.229 from inverse_mult_eq_1[OF a0]
188.230 have "fps_deriv (inverse a * a) = 0" by simp
188.231 - hence "inverse a * fps_deriv a + fps_deriv (inverse a) * a = 0" by simp
188.232 - hence "inverse a * (inverse a * fps_deriv a + fps_deriv (inverse a) * a) = 0" by simp
188.233 + then have "inverse a * fps_deriv a + fps_deriv (inverse a) * a = 0"
188.234 + by simp
188.235 + then have "inverse a * (inverse a * fps_deriv a + fps_deriv (inverse a) * a) = 0"
188.236 + by simp
188.237 with inverse_mult_eq_1[OF a0]
188.238 have "(inverse a)\<^sup>2 * fps_deriv a + fps_deriv (inverse a) = 0"
188.239 unfolding power2_eq_square
188.240 @@ -1187,13 +1142,15 @@
188.241 shows "inverse (a * b) = inverse a * inverse b"
188.242 proof -
188.243 {
188.244 - assume a0: "a$0 = 0" hence ab0: "(a*b)$0 = 0" by (simp add: fps_mult_nth)
188.245 + assume a0: "a$0 = 0"
188.246 + then have ab0: "(a*b)$0 = 0" by (simp add: fps_mult_nth)
188.247 from a0 ab0 have th: "inverse a = 0" "inverse (a*b) = 0" by simp_all
188.248 have ?thesis unfolding th by simp
188.249 }
188.250 moreover
188.251 {
188.252 - assume b0: "b$0 = 0" hence ab0: "(a*b)$0 = 0" by (simp add: fps_mult_nth)
188.253 + assume b0: "b$0 = 0"
188.254 + then have ab0: "(a*b)$0 = 0" by (simp add: fps_mult_nth)
188.255 from b0 ab0 have th: "inverse b = 0" "inverse (a*b) = 0" by simp_all
188.256 have ?thesis unfolding th by simp
188.257 }
188.258 @@ -1245,7 +1202,7 @@
188.259 have eq: "(1 + X) * ?r = 1"
188.260 unfolding minus_one_power_iff
188.261 by (auto simp add: field_simps fps_eq_iff)
188.262 - show ?thesis by (auto simp add: eq intro: fps_inverse_unique simp del: minus_one)
188.263 + show ?thesis by (auto simp add: eq intro: fps_inverse_unique)
188.264 qed
188.265
188.266
188.267 @@ -1288,7 +1245,7 @@
188.268 lemma numeral_compose[simp]: "(numeral k::('a::{comm_ring_1}) fps) oo b = numeral k"
188.269 unfolding numeral_fps_const by simp
188.270
188.271 -lemma neg_numeral_compose[simp]: "(neg_numeral k::('a::{comm_ring_1}) fps) oo b = neg_numeral k"
188.272 +lemma neg_numeral_compose[simp]: "(- numeral k::('a::{comm_ring_1}) fps) oo b = - numeral k"
188.273 unfolding neg_numeral_fps_const by simp
188.274
188.275 lemma X_fps_compose_startby0[simp]: "a$0 = 0 \<Longrightarrow> X oo a = (a :: ('a :: comm_ring_1) fps)"
188.276 @@ -1311,7 +1268,7 @@
188.277 also have "\<dots> = ?rhs $ n"
188.278 proof (induct k)
188.279 case 0
188.280 - thus ?case by (simp add: fps_setsum_nth)
188.281 + then show ?case by (simp add: fps_setsum_nth)
188.282 next
188.283 case (Suc k)
188.284 note th = Suc.hyps[symmetric]
188.285 @@ -1382,7 +1339,7 @@
188.286 fix n:: nat
188.287 {
188.288 assume "n=0"
188.289 - hence "a$n = ((1 - ?X) * ?sa) $ n"
188.290 + then have "a$n = ((1 - ?X) * ?sa) $ n"
188.291 by (simp add: fps_mult_nth)
188.292 }
188.293 moreover
188.294 @@ -1438,16 +1395,19 @@
188.295 done
188.296
188.297 lemma append_natpermute_less_eq:
188.298 - assumes h: "xs@ys \<in> natpermute n k"
188.299 + assumes "xs @ ys \<in> natpermute n k"
188.300 shows "listsum xs \<le> n" and "listsum ys \<le> n"
188.301 proof -
188.302 - from h have "listsum (xs @ ys) = n" by (simp add: natpermute_def)
188.303 - hence "listsum xs + listsum ys = n" by simp
188.304 - then show "listsum xs \<le> n" and "listsum ys \<le> n" by simp_all
188.305 + from assms have "listsum (xs @ ys) = n"
188.306 + by (simp add: natpermute_def)
188.307 + then have "listsum xs + listsum ys = n"
188.308 + by simp
188.309 + then show "listsum xs \<le> n" and "listsum ys \<le> n"
188.310 + by simp_all
188.311 qed
188.312
188.313 lemma natpermute_split:
188.314 - assumes mn: "h \<le> k"
188.315 + assumes "h \<le> k"
188.316 shows "natpermute n k =
188.317 (\<Union>m \<in>{0..n}. {l1 @ l2 |l1 l2. l1 \<in> natpermute m h \<and> l2 \<in> natpermute (n - m) (k - h)})"
188.318 (is "?L = ?R" is "?L = (\<Union>m \<in>{0..n}. ?S m)")
188.319 @@ -1466,7 +1426,7 @@
188.320 have "l \<in> ?L" using leq xs ys h
188.321 apply (clarsimp simp add: natpermute_def)
188.322 unfolding xs' ys'
188.323 - using mn xs ys
188.324 + using assms xs ys
188.325 unfolding natpermute_def
188.326 apply simp
188.327 done
188.328 @@ -1480,12 +1440,12 @@
188.329 let ?m = "listsum ?xs"
188.330 from l have ls: "listsum (?xs @ ?ys) = n"
188.331 by (simp add: natpermute_def)
188.332 - have xs: "?xs \<in> natpermute ?m h" using l mn
188.333 + have xs: "?xs \<in> natpermute ?m h" using l assms
188.334 by (simp add: natpermute_def)
188.335 have l_take_drop: "listsum l = listsum (take h l @ drop h l)"
188.336 by simp
188.337 then have ys: "?ys \<in> natpermute (n - ?m) (k - h)"
188.338 - using l mn ls by (auto simp add: natpermute_def simp del: append_take_drop_id)
188.339 + using l assms ls by (auto simp add: natpermute_def simp del: append_take_drop_id)
188.340 from ls have m: "?m \<in> {0..n}"
188.341 by (simp add: l_take_drop del: append_take_drop_id)
188.342 from xs ys ls have "l \<in> ?R"
188.343 @@ -1591,7 +1551,7 @@
188.344 ultimately show ?thesis by auto
188.345 qed
188.346
188.347 - (* The general form *)
188.348 +text {* The general form *}
188.349 lemma fps_setprod_nth:
188.350 fixes m :: nat
188.351 and a :: "nat \<Rightarrow> ('a::comm_ring_1) fps"
188.352 @@ -1612,9 +1572,7 @@
188.353 case (Suc k)
188.354 then have km: "k < m" by arith
188.355 have u0: "{0 .. k} \<union> {m} = {0..m}"
188.356 - using Suc apply (simp add: set_eq_iff)
188.357 - apply presburger
188.358 - done
188.359 + using Suc by (simp add: set_eq_iff) presburger
188.360 have f0: "finite {0 .. k}" "finite {m}" by auto
188.361 have d0: "{0 .. k} \<inter> {m} = {}" using Suc by auto
188.362 have "(setprod a {0 .. m}) $ n = (setprod a {0 .. k} * a m) $ n"
188.363 @@ -1653,18 +1611,21 @@
188.364 and a :: "('a::comm_ring_1) fps"
188.365 shows "(a ^ Suc m)$n = setsum (\<lambda>v. setprod (\<lambda>j. a $ (v!j)) {0..m}) (natpermute n (m+1))"
188.366 proof -
188.367 - have th0: "a^Suc m = setprod (\<lambda>i. a) {0..m}" by (simp add: setprod_constant)
188.368 + have th0: "a^Suc m = setprod (\<lambda>i. a) {0..m}"
188.369 + by (simp add: setprod_constant)
188.370 show ?thesis unfolding th0 fps_setprod_nth ..
188.371 qed
188.372
188.373 lemma fps_power_nth:
188.374 - fixes m :: nat and a :: "('a::comm_ring_1) fps"
188.375 + fixes m :: nat
188.376 + and a :: "('a::comm_ring_1) fps"
188.377 shows "(a ^m)$n =
188.378 (if m=0 then 1$n else setsum (\<lambda>v. setprod (\<lambda>j. a $ (v!j)) {0..m - 1}) (natpermute n m))"
188.379 by (cases m) (simp_all add: fps_power_nth_Suc del: power_Suc)
188.380
188.381 lemma fps_nth_power_0:
188.382 - fixes m :: nat and a :: "('a::{comm_ring_1}) fps"
188.383 + fixes m :: nat
188.384 + and a :: "('a::{comm_ring_1}) fps"
188.385 shows "(a ^m)$0 = (a$0) ^ m"
188.386 proof (cases m)
188.387 case 0
188.388 @@ -1697,7 +1658,7 @@
188.389 {
188.390 assume n0: "n=0"
188.391 from h have "(b oo a)$n = (c oo a)$n" by simp
188.392 - hence "b$n = c$n" using n0 by (simp add: fps_compose_nth)
188.393 + then have "b$n = c$n" using n0 by (simp add: fps_compose_nth)
188.394 }
188.395 moreover
188.396 {
188.397 @@ -1814,7 +1775,7 @@
188.398 qed
188.399
188.400 lemma natpermute_max_card:
188.401 - assumes n0: "n\<noteq>0"
188.402 + assumes n0: "n \<noteq> 0"
188.403 shows "card {xs \<in> natpermute n (k+1). n \<in> set xs} = k + 1"
188.404 unfolding natpermute_contain_maximal
188.405 proof -
188.406 @@ -1840,7 +1801,8 @@
188.407 then show "{replicate (k + 1) 0[i := n]} \<inter> {replicate (k + 1) 0[j := n]} = {}"
188.408 by auto
188.409 qed
188.410 - from card_UN_disjoint[OF fK fAK d] show "card (\<Union>i\<in>{0..k}. {replicate (k + 1) 0[i := n]}) = k+1"
188.411 + from card_UN_disjoint[OF fK fAK d]
188.412 + show "card (\<Union>i\<in>{0..k}. {replicate (k + 1) 0[i := n]}) = k + 1"
188.413 by simp
188.414 qed
188.415
188.416 @@ -1848,7 +1810,7 @@
188.417 fixes a:: "'a::field_char_0 fps"
188.418 assumes a0: "a$0 \<noteq> 0"
188.419 shows "(r (Suc k) (a$0)) ^ Suc k = a$0 \<longleftrightarrow> (fps_radical r (Suc k) a) ^ (Suc k) = a"
188.420 -proof-
188.421 +proof -
188.422 let ?r = "fps_radical r (Suc k) a"
188.423 {
188.424 assume r0: "(r (Suc k) (a$0)) ^ Suc k = a$0"
188.425 @@ -1861,7 +1823,7 @@
188.426 assume H: "\<forall>m<n. ?r ^ Suc k $ m = a$m"
188.427 {
188.428 assume "n = 0"
188.429 - hence "?r ^ Suc k $ n = a $n"
188.430 + then have "?r ^ Suc k $ n = a $n"
188.431 using fps_radical_power_nth[of r "Suc k" a, OF r0] by simp
188.432 }
188.433 moreover
188.434 @@ -1912,7 +1874,7 @@
188.435 moreover
188.436 {
188.437 assume h: "(fps_radical r (Suc k) a) ^ (Suc k) = a"
188.438 - hence "((fps_radical r (Suc k) a) ^ (Suc k))$0 = a$0" by simp
188.439 + then have "((fps_radical r (Suc k) a) ^ (Suc k))$0 = a$0" by simp
188.440 then have "(r (Suc k) (a$0)) ^ Suc k = a$0"
188.441 unfolding fps_power_nth_Suc
188.442 by (simp add: setprod_constant del: replicate.simps)
188.443 @@ -1931,7 +1893,7 @@
188.444 {fix z have "?r ^ Suc k $ z = a$z"
188.445 proof(induct z rule: nat_less_induct)
188.446 fix n assume H: "\<forall>m<n. ?r ^ Suc k $ m = a$m"
188.447 - {assume "n = 0" hence "?r ^ Suc k $ n = a $n"
188.448 + {assume "n = 0" then have "?r ^ Suc k $ n = a $n"
188.449 using fps_radical_power_nth[of r "Suc k" a, OF r0] by simp}
188.450 moreover
188.451 {fix n1 assume n1: "n = Suc n1"
188.452 @@ -1975,13 +1937,13 @@
188.453
188.454 *)
188.455 lemma eq_divide_imp':
188.456 - assumes c0: "(c::'a::field) ~= 0"
188.457 + assumes c0: "(c::'a::field) \<noteq> 0"
188.458 and eq: "a * c = b"
188.459 shows "a = b / c"
188.460 proof -
188.461 from eq have "a * c * inverse c = b * inverse c"
188.462 by simp
188.463 - hence "a * (inverse c * c) = b/c"
188.464 + then have "a * (inverse c * c) = b/c"
188.465 by (simp only: field_simps divide_inverse)
188.466 then show "a = b/c"
188.467 unfolding field_inverse[OF c0] by simp
188.468 @@ -2013,7 +1975,7 @@
188.469 assume h: "\<forall>m<n. a$m = ?r $m"
188.470 {
188.471 assume "n = 0"
188.472 - hence "a$n = ?r $n" using a0 by simp
188.473 + then have "a$n = ?r $n" using a0 by simp
188.474 }
188.475 moreover
188.476 {
188.477 @@ -2041,7 +2003,8 @@
188.478 by (auto simp del: replicate.simps)
188.479 have "(\<Prod>j\<in>{0..k}. a $ v ! j) = (\<Prod>j\<in>{0..k}. if j = i then a $ n else r (Suc k) (b$0))"
188.480 apply (rule setprod_cong, simp)
188.481 - using i a0 apply (simp del: replicate.simps)
188.482 + using i a0
188.483 + apply (simp del: replicate.simps)
188.484 done
188.485 also have "\<dots> = a $ n * (?r $ 0)^k"
188.486 using i by (simp add: setprod_gen_delta)
188.487 @@ -2147,11 +2110,11 @@
188.488 from iffD1[OF power_radical[of a r], OF a0 r0]
188.489 have "fps_deriv (?r ^ Suc k) = fps_deriv a"
188.490 by simp
188.491 - hence "fps_deriv ?r * ?w = fps_deriv a"
188.492 + then have "fps_deriv ?r * ?w = fps_deriv a"
188.493 by (simp add: fps_deriv_power mult_ac del: power_Suc)
188.494 - hence "?iw * fps_deriv ?r * ?w = ?iw * fps_deriv a"
188.495 + then have "?iw * fps_deriv ?r * ?w = ?iw * fps_deriv a"
188.496 by simp
188.497 - hence "fps_deriv ?r * (?iw * ?w) = fps_deriv a / ?w"
188.498 + then have "fps_deriv ?r * (?iw * ?w) = fps_deriv a / ?w"
188.499 by (simp add: fps_divide_def)
188.500 then show ?thesis unfolding th0 by simp
188.501 qed
188.502 @@ -2172,7 +2135,7 @@
188.503 by (simp add: fps_mult_nth ra0 rb0 power_mult_distrib)
188.504 {
188.505 assume "k = 0"
188.506 - hence ?thesis using r0' by simp
188.507 + then have ?thesis using r0' by simp
188.508 }
188.509 moreover
188.510 {
188.511 @@ -2192,7 +2155,7 @@
188.512 moreover
188.513 {
188.514 assume h: "fps_radical r k (a*b) = fps_radical r k a * fps_radical r k b"
188.515 - hence "(fps_radical r k (a*b))$0 = (fps_radical r k a * fps_radical r k b)$0"
188.516 + then have "(fps_radical r k (a*b))$0 = (fps_radical r k a * fps_radical r k b)$0"
188.517 by simp
188.518 then have "r k ((a * b) $ 0) = r k (a $ 0) * r k (b $ 0)"
188.519 using k by (simp add: fps_mult_nth)
188.520 @@ -2213,7 +2176,7 @@
188.521 proof-
188.522 from r0' have r0: "(r (k) ((a*b)$0)) ^ k = (a*b)$0"
188.523 by (simp add: fps_mult_nth ra0 rb0 power_mult_distrib)
188.524 - {assume "k=0" hence ?thesis by simp}
188.525 + {assume "k=0" then have ?thesis by simp}
188.526 moreover
188.527 {fix h assume k: "k = Suc h"
188.528 let ?ra = "fps_radical r (Suc h) a"
188.529 @@ -2400,7 +2363,7 @@
188.530 next
188.531 case (Suc n1)
188.532 have "?i $ n = setsum (\<lambda>i. (fps_inv a $ i) * (a^i)$n) {0 .. n1} + fps_inv a $ Suc n1 * (a $ 1)^ Suc n1"
188.533 - by (simp add: fps_compose_nth Suc startsby_zero_power_nth_same[OF a0] del: power_Suc)
188.534 + by (simp only: fps_compose_nth) (simp add: Suc startsby_zero_power_nth_same [OF a0] del: power_Suc)
188.535 also have "\<dots> = setsum (\<lambda>i. (fps_inv a $ i) * (a^i)$n) {0 .. n1} +
188.536 (X$ Suc n1 - setsum (\<lambda>i. (fps_inv a $ i) * (a^i)$n) {0 .. n1})"
188.537 using a0 a1 Suc by (simp add: fps_inv_def)
188.538 @@ -2441,7 +2404,7 @@
188.539 next
188.540 case (Suc n1)
188.541 have "?i $ n = setsum (\<lambda>i. (fps_ginv b a $ i) * (a^i)$n) {0 .. n1} + fps_ginv b a $ Suc n1 * (a $ 1)^ Suc n1"
188.542 - by (simp add: fps_compose_nth Suc startsby_zero_power_nth_same[OF a0] del: power_Suc)
188.543 + by (simp only: fps_compose_nth) (simp add: Suc startsby_zero_power_nth_same [OF a0] del: power_Suc)
188.544 also have "\<dots> = setsum (\<lambda>i. (fps_ginv b a $ i) * (a^i)$n) {0 .. n1} +
188.545 (b$ Suc n1 - setsum (\<lambda>i. (fps_ginv b a $ i) * (a^i)$n) {0 .. n1})"
188.546 using a0 a1 Suc by (simp add: fps_ginv_def)
188.547 @@ -2494,7 +2457,8 @@
188.548 qed
188.549
188.550 lemma convolution_eq:
188.551 - "setsum (%i. a (i :: nat) * b (n - i)) {0 .. n} = setsum (%(i,j). a i * b j) {(i,j). i <= n \<and> j \<le> n \<and> i + j = n}"
188.552 + "setsum (\<lambda>i. a (i :: nat) * b (n - i)) {0 .. n} =
188.553 + setsum (\<lambda>(i,j). a i * b j) {(i,j). i \<le> n \<and> j \<le> n \<and> i + j = n}"
188.554 apply (rule setsum_reindex_cong[where f=fst])
188.555 apply (clarsimp simp add: inj_on_def)
188.556 apply (auto simp add: set_eq_iff image_iff)
188.557 @@ -2508,7 +2472,7 @@
188.558 assumes c0: "c$0 = (0::'a::idom)"
188.559 and d0: "d$0 = 0"
188.560 shows "((a oo c) * (b oo d))$n =
188.561 - setsum (%(k,m). a$k * b$m * (c^k * d^m) $ n) {(k,m). k + m \<le> n}" (is "?l = ?r")
188.562 + setsum (\<lambda>(k,m). a$k * b$m * (c^k * d^m) $ n) {(k,m). k + m \<le> n}" (is "?l = ?r")
188.563 proof -
188.564 let ?S = "{(k\<Colon>nat, m\<Colon>nat). k + m \<le> n}"
188.565 have s: "?S \<subseteq> {0..n} <*> {0..n}" by (auto simp add: subset_eq)
188.566 @@ -2516,7 +2480,7 @@
188.567 apply (rule finite_subset[OF s])
188.568 apply auto
188.569 done
188.570 - have "?r = setsum (%i. setsum (%(k,m). a$k * (c^k)$i * b$m * (d^m) $ (n - i)) {(k,m). k + m \<le> n}) {0..n}"
188.571 + have "?r = setsum (\<lambda>i. setsum (\<lambda>(k,m). a$k * (c^k)$i * b$m * (d^m) $ (n - i)) {(k,m). k + m \<le> n}) {0..n}"
188.572 apply (simp add: fps_mult_nth setsum_right_distrib)
188.573 apply (subst setsum_commute)
188.574 apply (rule setsum_cong2)
188.575 @@ -2527,7 +2491,8 @@
188.576 apply (rule setsum_cong2)
188.577 apply (simp add: setsum_cartesian_product mult_assoc)
188.578 apply (rule setsum_mono_zero_right[OF f])
188.579 - apply (simp add: subset_eq) apply presburger
188.580 + apply (simp add: subset_eq)
188.581 + apply presburger
188.582 apply clarsimp
188.583 apply (rule ccontr)
188.584 apply (clarsimp simp add: not_le)
188.585 @@ -2546,7 +2511,7 @@
188.586 assumes c0: "c$0 = (0::'a::idom)"
188.587 and d0: "d$0 = 0"
188.588 shows "((a oo c) * (b oo d))$n =
188.589 - setsum (%k. setsum (%m. a$k * b$m * (c^k * d^m) $ n) {0..n}) {0..n}" (is "?l = ?r")
188.590 + setsum (\<lambda>k. setsum (\<lambda>m. a$k * b$m * (c^k * d^m) $ n) {0..n}) {0..n}" (is "?l = ?r")
188.591 unfolding product_composition_lemma[OF c0 d0]
188.592 unfolding setsum_cartesian_product
188.593 apply (rule setsum_mono_zero_left)
188.594 @@ -2570,12 +2535,12 @@
188.595
188.596
188.597 lemma setsum_pair_less_iff:
188.598 - "setsum (%((k::nat),m). a k * b m * c (k + m)) {(k,m). k + m \<le> n} =
188.599 - setsum (%s. setsum (%i. a i * b (s - i) * c s) {0..s}) {0..n}"
188.600 + "setsum (\<lambda>((k::nat),m). a k * b m * c (k + m)) {(k,m). k + m \<le> n} =
188.601 + setsum (\<lambda>s. setsum (\<lambda>i. a i * b (s - i) * c s) {0..s}) {0..n}"
188.602 (is "?l = ?r")
188.603 proof -
188.604 let ?KM = "{(k,m). k + m \<le> n}"
188.605 - let ?f = "%s. UNION {(0::nat)..s} (%i. {(i,s - i)})"
188.606 + let ?f = "\<lambda>s. UNION {(0::nat)..s} (\<lambda>i. {(i,s - i)})"
188.607 have th0: "?KM = UNION {0..n} ?f"
188.608 apply (simp add: set_eq_iff)
188.609 apply presburger (* FIXME: slow! *)
188.610 @@ -2592,22 +2557,22 @@
188.611 lemma fps_compose_mult_distrib_lemma:
188.612 assumes c0: "c$0 = (0::'a::idom)"
188.613 shows "((a oo c) * (b oo c))$n =
188.614 - setsum (%s. setsum (%i. a$i * b$(s - i) * (c^s) $ n) {0..s}) {0..n}"
188.615 + setsum (\<lambda>s. setsum (\<lambda>i. a$i * b$(s - i) * (c^s) $ n) {0..s}) {0..n}"
188.616 (is "?l = ?r")
188.617 unfolding product_composition_lemma[OF c0 c0] power_add[symmetric]
188.618 - unfolding setsum_pair_less_iff[where a = "%k. a$k" and b="%m. b$m" and c="%s. (c ^ s)$n" and n = n] ..
188.619 + unfolding setsum_pair_less_iff[where a = "\<lambda>k. a$k" and b="\<lambda>m. b$m" and c="\<lambda>s. (c ^ s)$n" and n = n] ..
188.620
188.621
188.622 lemma fps_compose_mult_distrib:
188.623 - assumes c0: "c$0 = (0::'a::idom)"
188.624 - shows "(a * b) oo c = (a oo c) * (b oo c)" (is "?l = ?r")
188.625 - apply (simp add: fps_eq_iff fps_compose_mult_distrib_lemma[OF c0])
188.626 + assumes c0: "c $ 0 = (0::'a::idom)"
188.627 + shows "(a * b) oo c = (a oo c) * (b oo c)"
188.628 + apply (simp add: fps_eq_iff fps_compose_mult_distrib_lemma [OF c0])
188.629 apply (simp add: fps_compose_nth fps_mult_nth setsum_left_distrib)
188.630 done
188.631
188.632 lemma fps_compose_setprod_distrib:
188.633 assumes c0: "c$0 = (0::'a::idom)"
188.634 - shows "(setprod a S) oo c = setprod (%k. a k oo c) S" (is "?l = ?r")
188.635 + shows "setprod a S oo c = setprod (\<lambda>k. a k oo c) S"
188.636 apply (cases "finite S")
188.637 apply simp_all
188.638 apply (induct S rule: finite_induct)
188.639 @@ -2624,7 +2589,7 @@
188.640 then show ?thesis by simp
188.641 next
188.642 case (Suc m)
188.643 - have th0: "a^n = setprod (%k. a) {0..m}" "(a oo c) ^ n = setprod (%k. a oo c) {0..m}"
188.644 + have th0: "a^n = setprod (\<lambda>k. a) {0..m}" "(a oo c) ^ n = setprod (\<lambda>k. a oo c) {0..m}"
188.645 by (simp_all add: setprod_constant Suc)
188.646 then show ?thesis
188.647 by (simp add: fps_compose_setprod_distrib[OF c0])
188.648 @@ -2634,7 +2599,7 @@
188.649 by (simp add: fps_eq_iff fps_compose_nth field_simps setsum_negf[symmetric])
188.650
188.651 lemma fps_compose_sub_distrib: "(a - b) oo (c::'a::ring_1 fps) = (a oo c) - (b oo c)"
188.652 - unfolding diff_minus fps_compose_uminus fps_compose_add_distrib ..
188.653 + using fps_compose_add_distrib [of a "- b" c] by (simp add: fps_compose_uminus)
188.654
188.655 lemma X_fps_compose: "X oo a = Abs_fps (\<lambda>n. if n = 0 then (0::'a::comm_ring_1) else a$n)"
188.656 by (simp add: fps_eq_iff fps_compose_nth mult_delta_left setsum_delta)
188.657 @@ -2654,7 +2619,7 @@
188.658 unfolding fps_compose_mult_distrib[OF b0, symmetric]
188.659 unfolding inverse_mult_eq_1[OF a0]
188.660 fps_compose_1 ..
188.661 -
188.662 +
188.663 then have "(?ia oo b) * (a oo b) * ?iab = 1 * ?iab" by simp
188.664 then have "(?ia oo b) * (?iab * (a oo b)) = ?iab" by simp
188.665 then show ?thesis unfolding inverse_mult_eq_1[OF ab0] by simp
188.666 @@ -2676,8 +2641,8 @@
188.667 have th0: "(1 - X) $ 0 \<noteq> (0::'a)" by simp
188.668 from fps_inverse_gp[where ?'a = 'a]
188.669 have "inverse ?one = 1 - X" by (simp add: fps_eq_iff)
188.670 - hence "inverse (inverse ?one) = inverse (1 - X)" by simp
188.671 - hence th: "?one = 1/(1 - X)" unfolding fps_inverse_idempotent[OF o0]
188.672 + then have "inverse (inverse ?one) = inverse (1 - X)" by simp
188.673 + then have th: "?one = 1/(1 - X)" unfolding fps_inverse_idempotent[OF o0]
188.674 by (simp add: fps_divide_def)
188.675 show ?thesis
188.676 unfolding th
188.677 @@ -2753,13 +2718,13 @@
188.678 fix n
188.679 {
188.680 assume kn: "k>n"
188.681 - hence "?l $ n = ?r $n" using a0 startsby_zero_power_prefix[OF a0] Suc
188.682 + then have "?l $ n = ?r $n" using a0 startsby_zero_power_prefix[OF a0] Suc
188.683 by (simp add: fps_compose_nth del: power_Suc)
188.684 }
188.685 moreover
188.686 {
188.687 assume kn: "k \<le> n"
188.688 - hence "?l$n = ?r$n"
188.689 + then have "?l$n = ?r$n"
188.690 by (simp add: fps_compose_nth mult_delta_left setsum_delta)
188.691 }
188.692 moreover have "k >n \<or> k\<le> n" by arith
188.693 @@ -2798,7 +2763,7 @@
188.694 have th0: "?d$0 \<noteq> 0" using a1 by (simp add: fps_compose_nth)
188.695 from fps_inv_right[OF a0 a1] have "?d * ?dia = 1"
188.696 by (simp add: fps_compose_deriv[OF ia0, of a, symmetric] )
188.697 - hence "inverse ?d * ?d * ?dia = inverse ?d * 1" by simp
188.698 + then have "inverse ?d * ?d * ?dia = inverse ?d * 1" by simp
188.699 with inverse_mult_eq_1 [OF th0]
188.700 show "?dia = inverse ?d" by simp
188.701 qed
188.702 @@ -2976,7 +2941,7 @@
188.703 (is "inverse ?l = ?r")
188.704 proof -
188.705 have th: "?l * ?r = 1"
188.706 - by (auto simp add: field_simps fps_eq_iff minus_one_power_iff simp del: minus_one)
188.707 + by (auto simp add: field_simps fps_eq_iff minus_one_power_iff)
188.708 have th': "?l $ 0 \<noteq> 0" by (simp add: )
188.709 from fps_inverse_unique[OF th' th] show ?thesis .
188.710 qed
188.711 @@ -3035,7 +3000,7 @@
188.712 subsubsection{* Logarithmic series *}
188.713
188.714 lemma Abs_fps_if_0:
188.715 - "Abs_fps(%n. if n=0 then (v::'a::ring_1) else f n) = fps_const v + X * Abs_fps (%n. f (Suc n))"
188.716 + "Abs_fps(\<lambda>n. if n=0 then (v::'a::ring_1) else f n) = fps_const v + X * Abs_fps (\<lambda>n. f (Suc n))"
188.717 by (auto simp add: fps_eq_iff)
188.718
188.719 definition L :: "'a::field_char_0 \<Rightarrow> 'a fps"
188.720 @@ -3051,8 +3016,9 @@
188.721 lemma L_0[simp]: "L c $ 0 = 0" by (simp add: L_def)
188.722
188.723 lemma L_E_inv:
188.724 - assumes a: "a\<noteq> (0::'a::{field_char_0})"
188.725 - shows "L a = fps_inv (E a - 1)" (is "?l = ?r")
188.726 + fixes a :: "'a::field_char_0"
188.727 + assumes a: "a \<noteq> 0"
188.728 + shows "L a = fps_inv (E a - 1)" (is "?l = ?r")
188.729 proof -
188.730 let ?b = "E a - 1"
188.731 have b0: "?b $ 0 = 0" by simp
188.732 @@ -3069,7 +3035,7 @@
188.733 have "fps_deriv (fps_inv ?b) = fps_const (inverse a) / (X + 1)"
188.734 using a
188.735 by (simp add: fps_const_inverse eq fps_divide_def fps_inverse_mult)
188.736 - hence "fps_deriv ?l = fps_deriv ?r"
188.737 + then have "fps_deriv ?l = fps_deriv ?r"
188.738 by (simp add: fps_deriv_L add_commute fps_divide_def divide_inverse)
188.739 then show ?thesis unfolding fps_deriv_eq_iff
188.740 by (simp add: L_nth fps_inv_def)
188.741 @@ -3132,10 +3098,10 @@
188.742 have "a$n = (c gchoose n) * a$0"
188.743 proof (induct n)
188.744 case 0
188.745 - thus ?case by simp
188.746 + then show ?case by simp
188.747 next
188.748 case (Suc m)
188.749 - thus ?case unfolding th0
188.750 + then show ?case unfolding th0
188.751 apply (simp add: field_simps del: of_nat_Suc)
188.752 unfolding mult_assoc[symmetric] gbinomial_mult_1
188.753 apply (simp add: field_simps)
188.754 @@ -3189,7 +3155,7 @@
188.755 have "?P = fps_const (?P$0) * ?b (c + d)"
188.756 unfolding fps_binomial_ODE_unique[symmetric]
188.757 using th0 by simp
188.758 - hence "?P = 0" by (simp add: fps_mult_nth)
188.759 + then have "?P = 0" by (simp add: fps_mult_nth)
188.760 then show ?thesis by simp
188.761 qed
188.762
188.763 @@ -3199,7 +3165,7 @@
188.764 have th: "?r$0 \<noteq> 0" by simp
188.765 have th': "fps_deriv (inverse ?r) = fps_const (- 1) * inverse ?r / (1 + X)"
188.766 by (simp add: fps_inverse_deriv[OF th] fps_divide_def
188.767 - power2_eq_square mult_commute fps_const_neg[symmetric] del: fps_const_neg minus_one)
188.768 + power2_eq_square mult_commute fps_const_neg[symmetric] del: fps_const_neg)
188.769 have eq: "inverse ?r $ 0 = 1"
188.770 by (simp add: fps_inverse_def)
188.771 from iffD1[OF fps_binomial_ODE_unique[of "inverse (1 + X)" "- 1"] th'] eq
188.772 @@ -3236,14 +3202,14 @@
188.773 lemma Vandermonde_pochhammer_lemma:
188.774 fixes a :: "'a::field_char_0"
188.775 assumes b: "\<forall> j\<in>{0 ..<n}. b \<noteq> of_nat j"
188.776 - shows "setsum (%k. (pochhammer (- a) k * pochhammer (- (of_nat n)) k) /
188.777 + shows "setsum (\<lambda>k. (pochhammer (- a) k * pochhammer (- (of_nat n)) k) /
188.778 (of_nat (fact k) * pochhammer (b - of_nat n + 1) k)) {0..n} =
188.779 - pochhammer (- (a+ b)) n / pochhammer (- b) n"
188.780 + pochhammer (- (a + b)) n / pochhammer (- b) n"
188.781 (is "?l = ?r")
188.782 proof -
188.783 - let ?m1 = "%m. (- 1 :: 'a) ^ m"
188.784 - let ?f = "%m. of_nat (fact m)"
188.785 - let ?p = "%(x::'a). pochhammer (- x)"
188.786 + let ?m1 = "\<lambda>m. (- 1 :: 'a) ^ m"
188.787 + let ?f = "\<lambda>m. of_nat (fact m)"
188.788 + let ?p = "\<lambda>(x::'a). pochhammer (- x)"
188.789 from b have bn0: "?p b n \<noteq> 0" unfolding pochhammer_eq_0_iff by simp
188.790 {
188.791 fix k
188.792 @@ -3288,7 +3254,7 @@
188.793 moreover
188.794 {
188.795 assume nk: "k \<noteq> n"
188.796 - have m1nk: "?m1 n = setprod (%i. - 1) {0..m}" "?m1 k = setprod (%i. - 1) {0..h}"
188.797 + have m1nk: "?m1 n = setprod (\<lambda>i. - 1) {0..m}" "?m1 k = setprod (\<lambda>i. - 1) {0..h}"
188.798 by (simp_all add: setprod_constant m h)
188.799 from kn nk have kn': "k < n" by simp
188.800 have bnz0: "pochhammer (b - of_nat n + 1) k \<noteq> 0"
188.801 @@ -3298,9 +3264,9 @@
188.802 apply (erule_tac x= "n - ka - 1" in allE)
188.803 apply (auto simp add: algebra_simps of_nat_diff)
188.804 done
188.805 - have eq1: "setprod (%k. (1::'a) + of_nat m - of_nat k) {0 .. h} =
188.806 + have eq1: "setprod (\<lambda>k. (1::'a) + of_nat m - of_nat k) {0 .. h} =
188.807 setprod of_nat {Suc (m - h) .. Suc m}"
188.808 - apply (rule strong_setprod_reindex_cong[where f="%k. Suc m - k "])
188.809 + apply (rule strong_setprod_reindex_cong[where f="\<lambda>k. Suc m - k "])
188.810 using kn' h m
188.811 apply (auto simp add: inj_on_def image_def)
188.812 apply (rule_tac x="Suc m - x" in bexI)
188.813 @@ -3310,7 +3276,7 @@
188.814 have th1: "(?m1 k * ?p (of_nat n) k) / ?f n = 1 / of_nat(fact (n - k))"
188.815 unfolding m1nk
188.816 unfolding m h pochhammer_Suc_setprod
188.817 - apply (simp add: field_simps del: fact_Suc minus_one)
188.818 + apply (simp add: field_simps del: fact_Suc)
188.819 unfolding fact_altdef_nat id_def
188.820 unfolding of_nat_setprod
188.821 unfolding setprod_timesf[symmetric]
188.822 @@ -3321,17 +3287,17 @@
188.823 apply (rule setprod_cong)
188.824 apply auto
188.825 done
188.826 - have th20: "?m1 n * ?p b n = setprod (%i. b - of_nat i) {0..m}"
188.827 + have th20: "?m1 n * ?p b n = setprod (\<lambda>i. b - of_nat i) {0..m}"
188.828 unfolding m1nk
188.829 unfolding m h pochhammer_Suc_setprod
188.830 unfolding setprod_timesf[symmetric]
188.831 apply (rule setprod_cong)
188.832 apply auto
188.833 done
188.834 - have th21:"pochhammer (b - of_nat n + 1) k = setprod (%i. b - of_nat i) {n - k .. n - 1}"
188.835 + have th21:"pochhammer (b - of_nat n + 1) k = setprod (\<lambda>i. b - of_nat i) {n - k .. n - 1}"
188.836 unfolding h m
188.837 unfolding pochhammer_Suc_setprod
188.838 - apply (rule strong_setprod_reindex_cong[where f="%k. n - 1 - k"])
188.839 + apply (rule strong_setprod_reindex_cong[where f="\<lambda>k. n - 1 - k"])
188.840 using kn
188.841 apply (auto simp add: inj_on_def m h image_def)
188.842 apply (rule_tac x= "m - x" in bexI)
188.843 @@ -3339,7 +3305,7 @@
188.844 done
188.845
188.846 have "?m1 n * ?p b n =
188.847 - pochhammer (b - of_nat n + 1) k * setprod (%i. b - of_nat i) {0.. n - k - 1}"
188.848 + pochhammer (b - of_nat n + 1) k * setprod (\<lambda>i. b - of_nat i) {0.. n - k - 1}"
188.849 unfolding th20 th21
188.850 unfolding h m
188.851 apply (subst setprod_Un_disjoint[symmetric])
188.852 @@ -3349,7 +3315,7 @@
188.853 apply auto
188.854 done
188.855 then have th2: "(?m1 n * ?p b n)/pochhammer (b - of_nat n + 1) k =
188.856 - setprod (%i. b - of_nat i) {0.. n - k - 1}"
188.857 + setprod (\<lambda>i. b - of_nat i) {0.. n - k - 1}"
188.858 using nz' by (simp add: field_simps)
188.859 have "(?m1 n * ?p b n * ?m1 k * ?p (of_nat n) k) / (?f n * pochhammer (b - of_nat n + 1) k) =
188.860 ((?m1 k * ?p (of_nat n) k) / ?f n) * ((?m1 n * ?p b n)/pochhammer (b - of_nat n + 1) k)"
188.861 @@ -3396,8 +3362,8 @@
188.862
188.863 lemma Vandermonde_pochhammer:
188.864 fixes a :: "'a::field_char_0"
188.865 - assumes c: "ALL i : {0..< n}. c \<noteq> - of_nat i"
188.866 - shows "setsum (%k. (pochhammer a k * pochhammer (- (of_nat n)) k) /
188.867 + assumes c: "\<forall>i \<in> {0..< n}. c \<noteq> - of_nat i"
188.868 + shows "setsum (\<lambda>k. (pochhammer a k * pochhammer (- (of_nat n)) k) /
188.869 (of_nat (fact k) * pochhammer c k)) {0..n} = pochhammer (c - a) n / pochhammer c n"
188.870 proof -
188.871 let ?a = "- a"
188.872 @@ -3627,7 +3593,7 @@
188.873 unfolding even_mult_two_ex by blast
188.874
188.875 have "?l $n = ?r$n"
188.876 - by (simp add: m fps_sin_def fps_cos_def power_mult_distrib power_mult power_minus)
188.877 + by (simp add: m fps_sin_def fps_cos_def power_mult_distrib power_mult power_minus [of "c ^ 2"])
188.878 }
188.879 moreover
188.880 {
188.881 @@ -3636,7 +3602,7 @@
188.882 unfolding odd_nat_equiv_def2 by (auto simp add: mult_2)
188.883 have "?l $n = ?r$n"
188.884 by (simp add: m fps_sin_def fps_cos_def power_mult_distrib
188.885 - power_mult power_minus)
188.886 + power_mult power_minus [of "c ^ 2"])
188.887 }
188.888 ultimately have "?l $n = ?r$n" by blast
188.889 } then show ?thesis by (simp add: fps_eq_iff)
188.890 @@ -3684,8 +3650,8 @@
188.891 subsection {* Hypergeometric series *}
188.892
188.893 definition "F as bs (c::'a::{field_char_0, field_inverse_zero}) =
188.894 - Abs_fps (%n. (foldl (%r a. r* pochhammer a n) 1 as * c^n) /
188.895 - (foldl (%r b. r * pochhammer b n) 1 bs * of_nat (fact n)))"
188.896 + Abs_fps (\<lambda>n. (foldl (\<lambda>r a. r* pochhammer a n) 1 as * c^n) /
188.897 + (foldl (\<lambda>r b. r * pochhammer b n) 1 bs * of_nat (fact n)))"
188.898
188.899 lemma F_nth[simp]: "F as bs c $ n =
188.900 (foldl (\<lambda>r a. r* pochhammer a n) 1 as * c^n) /
188.901 @@ -3693,11 +3659,13 @@
188.902 by (simp add: F_def)
188.903
188.904 lemma foldl_mult_start:
188.905 - "foldl (%r x. r * f x) (v::'a::comm_ring_1) as * x = foldl (%r x. r * f x) (v * x) as "
188.906 + fixes v :: "'a::comm_ring_1"
188.907 + shows "foldl (\<lambda>r x. r * f x) v as * x = foldl (\<lambda>r x. r * f x) (v * x) as "
188.908 by (induct as arbitrary: x v) (auto simp add: algebra_simps)
188.909
188.910 lemma foldr_mult_foldl:
188.911 - "foldr (%x r. r * f x) as v = foldl (%r x. r * f x) (v :: 'a::comm_ring_1) as"
188.912 + fixes v :: "'a::comm_ring_1"
188.913 + shows "foldr (\<lambda>x r. r * f x) as v = foldl (\<lambda>r x. r * f x) v as"
188.914 by (induct as arbitrary: v) (auto simp add: foldl_mult_start)
188.915
188.916 lemma F_nth_alt:
188.917 @@ -3722,28 +3690,28 @@
188.918
188.919 lemma F_0[simp]: "F as bs c $0 = 1"
188.920 apply simp
188.921 - apply (subgoal_tac "ALL as. foldl (%(r::'a) (a::'a). r) 1 as = 1")
188.922 + apply (subgoal_tac "\<forall>as. foldl (\<lambda>(r::'a) (a::'a). r) 1 as = 1")
188.923 apply auto
188.924 apply (induct_tac as)
188.925 apply auto
188.926 done
188.927
188.928 lemma foldl_prod_prod:
188.929 - "foldl (%(r::'b::comm_ring_1) (x::'a::comm_ring_1). r * f x) v as * foldl (%r x. r * g x) w as =
188.930 - foldl (%r x. r * f x * g x) (v*w) as"
188.931 + "foldl (\<lambda>(r::'b::comm_ring_1) (x::'a::comm_ring_1). r * f x) v as * foldl (\<lambda>r x. r * g x) w as =
188.932 + foldl (\<lambda>r x. r * f x * g x) (v * w) as"
188.933 by (induct as arbitrary: v w) (auto simp add: algebra_simps)
188.934
188.935
188.936 lemma F_rec:
188.937 - "F as bs c $ Suc n = ((foldl (%r a. r* (a + of_nat n)) c as) /
188.938 - (foldl (%r b. r * (b + of_nat n)) (of_nat (Suc n)) bs )) * F as bs c $ n"
188.939 + "F as bs c $ Suc n = ((foldl (\<lambda>r a. r* (a + of_nat n)) c as) /
188.940 + (foldl (\<lambda>r b. r * (b + of_nat n)) (of_nat (Suc n)) bs )) * F as bs c $ n"
188.941 apply (simp del: of_nat_Suc of_nat_add fact_Suc)
188.942 apply (simp add: foldl_mult_start del: fact_Suc of_nat_Suc)
188.943 unfolding foldl_prod_prod[unfolded foldl_mult_start] pochhammer_Suc
188.944 apply (simp add: algebra_simps of_nat_mult)
188.945 done
188.946
188.947 -lemma XD_nth[simp]: "XD a $ n = (if n=0 then 0 else of_nat n * a$n)"
188.948 +lemma XD_nth[simp]: "XD a $ n = (if n = 0 then 0 else of_nat n * a$n)"
188.949 by (simp add: XD_def)
188.950
188.951 lemma XD_0th[simp]: "XD a $ 0 = 0" by simp
188.952 @@ -3765,11 +3733,11 @@
188.953
188.954 lemma F_minus_nat:
188.955 "F [- of_nat n] [- of_nat (n + m)] (c::'a::{field_char_0, field_inverse_zero}) $ k =
188.956 - (if k <= n then
188.957 + (if k \<le> n then
188.958 pochhammer (- of_nat n) k * c ^ k / (pochhammer (- of_nat (n + m)) k * of_nat (fact k))
188.959 else 0)"
188.960 "F [- of_nat m] [- of_nat (m + n)] (c::'a::{field_char_0, field_inverse_zero}) $ k =
188.961 - (if k <= m then
188.962 + (if k \<le> m then
188.963 pochhammer (- of_nat m) k * c ^ k / (pochhammer (- of_nat (m + n)) k * of_nat (fact k))
188.964 else 0)"
188.965 by (auto simp add: pochhammer_eq_0_iff)
188.966 @@ -3783,34 +3751,28 @@
188.967 lemma pochhammer_rec_if: "pochhammer a n = (if n = 0 then 1 else a * pochhammer (a + 1) (n - 1))"
188.968 by (cases n) (simp_all add: pochhammer_rec)
188.969
188.970 -lemma XDp_foldr_nth [simp]: "foldr (%c r. XDp c o r) cs (%c. XDp c a) c0 $ n =
188.971 - foldr (%c r. (c + of_nat n) * r) cs (c0 + of_nat n) * a$n"
188.972 +lemma XDp_foldr_nth [simp]: "foldr (\<lambda>c r. XDp c o r) cs (\<lambda>c. XDp c a) c0 $ n =
188.973 + foldr (\<lambda>c r. (c + of_nat n) * r) cs (c0 + of_nat n) * a$n"
188.974 by (induct cs arbitrary: c0) (auto simp add: algebra_simps)
188.975
188.976 lemma genric_XDp_foldr_nth:
188.977 - assumes f: "ALL n c a. f c a $ n = (of_nat n + k c) * a$n"
188.978 - shows "foldr (%c r. f c o r) cs (%c. g c a) c0 $ n =
188.979 - foldr (%c r. (k c + of_nat n) * r) cs (g c0 a $ n)"
188.980 + assumes f: "\<forall>n c a. f c a $ n = (of_nat n + k c) * a$n"
188.981 + shows "foldr (\<lambda>c r. f c o r) cs (\<lambda>c. g c a) c0 $ n =
188.982 + foldr (\<lambda>c r. (k c + of_nat n) * r) cs (g c0 a $ n)"
188.983 by (induct cs arbitrary: c0) (auto simp add: algebra_simps f)
188.984
188.985 lemma dist_less_imp_nth_equal:
188.986 assumes "dist f g < inverse (2 ^ i)"
188.987 and"j \<le> i"
188.988 shows "f $ j = g $ j"
188.989 -proof (cases "f = g")
188.990 - case False
188.991 - hence "\<exists>n. f $ n \<noteq> g $ n" by (simp add: fps_eq_iff)
188.992 - with assms have "i < The (leastP (\<lambda>n. f $ n \<noteq> g $ n))"
188.993 +proof (rule ccontr)
188.994 + assume "f $ j \<noteq> g $ j"
188.995 + then have "\<exists>n. f $ n \<noteq> g $ n" by auto
188.996 + with assms have "i < (LEAST n. f $ n \<noteq> g $ n)"
188.997 by (simp add: split_if_asm dist_fps_def)
188.998 - moreover
188.999 - from fps_eq_least_unique[OF `f \<noteq> g`]
188.1000 - obtain n where n: "leastP (\<lambda>n. f$n \<noteq> g$n) n" "The (leastP (\<lambda>n. f $ n \<noteq> g $ n)) = n" by blast
188.1001 - moreover from n have "\<And>m. m < n \<Longrightarrow> f$m = g$m" "f$n \<noteq> g$n"
188.1002 - by (auto simp add: leastP_def setge_def)
188.1003 - ultimately show ?thesis using `j \<le> i` by simp
188.1004 -next
188.1005 - case True
188.1006 - then show ?thesis by simp
188.1007 + also have "\<dots> \<le> j"
188.1008 + using `f $ j \<noteq> g $ j` by (auto intro: Least_le)
188.1009 + finally show False using `j \<le> i` by simp
188.1010 qed
188.1011
188.1012 lemma nth_equal_imp_dist_less:
188.1013 @@ -3818,19 +3780,14 @@
188.1014 shows "dist f g < inverse (2 ^ i)"
188.1015 proof (cases "f = g")
188.1016 case False
188.1017 - hence "\<exists>n. f $ n \<noteq> g $ n" by (simp add: fps_eq_iff)
188.1018 - with assms have "dist f g = inverse (2 ^ (The (leastP (\<lambda>n. f $ n \<noteq> g $ n))))"
188.1019 + then have "\<exists>n. f $ n \<noteq> g $ n" by (simp add: fps_eq_iff)
188.1020 + with assms have "dist f g = inverse (2 ^ (LEAST n. f $ n \<noteq> g $ n))"
188.1021 by (simp add: split_if_asm dist_fps_def)
188.1022 moreover
188.1023 - from fps_eq_least_unique[OF `f \<noteq> g`]
188.1024 - obtain n where "leastP (\<lambda>n. f$n \<noteq> g$n) n" "The (leastP (\<lambda>n. f $ n \<noteq> g $ n)) = n" by blast
188.1025 - with assms have "i < The (leastP (\<lambda>n. f $ n \<noteq> g $ n))"
188.1026 - by (metis (full_types) leastPD1 not_le)
188.1027 + from assms `\<exists>n. f $ n \<noteq> g $ n` have "i < (LEAST n. f $ n \<noteq> g $ n)"
188.1028 + by (metis (mono_tags) LeastI not_less)
188.1029 ultimately show ?thesis by simp
188.1030 -next
188.1031 - case True
188.1032 - then show ?thesis by simp
188.1033 -qed
188.1034 +qed simp
188.1035
188.1036 lemma dist_less_eq_nth_equal: "dist f g < inverse (2 ^ i) \<longleftrightarrow> (\<forall>j \<le> i. f $ j = g $ j)"
188.1037 using dist_less_imp_nth_equal nth_equal_imp_dist_less by blast
188.1038 @@ -3846,7 +3803,7 @@
188.1039 have "\<exists>M. \<forall>m \<ge> M. \<forall>j\<le>i. X M $ j = X m $ j" by blast
188.1040 }
188.1041 then obtain M where M: "\<forall>i. \<forall>m \<ge> M i. \<forall>j \<le> i. X (M i) $ j = X m $ j" by metis
188.1042 - hence "\<forall>i. \<forall>m \<ge> M i. \<forall>j \<le> i. X (M i) $ j = X m $ j" by metis
188.1043 + then have "\<forall>i. \<forall>m \<ge> M i. \<forall>j \<le> i. X (M i) $ j = X m $ j" by metis
188.1044 show "convergent X"
188.1045 proof (rule convergentI)
188.1046 show "X ----> Abs_fps (\<lambda>i. X (M i) $ i)"
188.1047 @@ -3861,7 +3818,7 @@
188.1048 done
188.1049 then obtain i where "inverse (2 ^ i) < e" by (auto simp: eventually_sequentially)
188.1050 have "eventually (\<lambda>x. M i \<le> x) sequentially" by (auto simp: eventually_sequentially)
188.1051 - thus "eventually (\<lambda>x. dist (X x) (Abs_fps (\<lambda>i. X (M i) $ i)) < e) sequentially"
188.1052 + then show "eventually (\<lambda>x. dist (X x) (Abs_fps (\<lambda>i. X (M i) $ i)) < e) sequentially"
188.1053 proof eventually_elim
188.1054 fix x
188.1055 assume "M i \<le> x"
189.1 --- a/src/HOL/Library/Fraction_Field.thy Thu Dec 05 17:52:12 2013 +0100
189.2 +++ b/src/HOL/Library/Fraction_Field.thy Thu Dec 05 17:58:03 2013 +0100
189.3 @@ -41,14 +41,14 @@
189.4 ultimately have "a * b'' = a'' * b" by simp
189.5 with A B show "((a, b), (a'', b'')) \<in> fractrel" by auto
189.6 qed
189.7 -
189.8 +
189.9 lemma equiv_fractrel: "equiv {x. snd x \<noteq> 0} fractrel"
189.10 by (rule equivI [OF refl_fractrel sym_fractrel trans_fractrel])
189.11
189.12 lemmas UN_fractrel = UN_equiv_class [OF equiv_fractrel]
189.13 lemmas UN_fractrel2 = UN_equiv_class2 [OF equiv_fractrel equiv_fractrel]
189.14
189.15 -lemma equiv_fractrel_iff [iff]:
189.16 +lemma equiv_fractrel_iff [iff]:
189.17 assumes "snd x \<noteq> 0" and "snd y \<noteq> 0"
189.18 shows "fractrel `` {x} = fractrel `` {y} \<longleftrightarrow> (x, y) \<in> fractrel"
189.19 by (rule eq_equiv_class_iff, rule equiv_fractrel) (auto simp add: assms)
189.20 @@ -59,7 +59,8 @@
189.21 unfolding fract_def
189.22 proof
189.23 have "(0::'a, 1::'a) \<in> {x. snd x \<noteq> 0}" by simp
189.24 - then show "fractrel `` {(0::'a, 1)} \<in> {x. snd x \<noteq> 0} // fractrel" by (rule quotientI)
189.25 + then show "fractrel `` {(0::'a, 1)} \<in> {x. snd x \<noteq> 0} // fractrel"
189.26 + by (rule quotientI)
189.27 qed
189.28
189.29 lemma fractrel_in_fract [simp]: "snd x \<noteq> 0 \<Longrightarrow> fractrel `` {x} \<in> fract"
189.30 @@ -70,8 +71,8 @@
189.31
189.32 subsubsection {* Representation and basic operations *}
189.33
189.34 -definition Fract :: "'a::idom \<Rightarrow> 'a \<Rightarrow> 'a fract" where
189.35 - "Fract a b = Abs_fract (fractrel `` {if b = 0 then (0, 1) else (a, b)})"
189.36 +definition Fract :: "'a::idom \<Rightarrow> 'a \<Rightarrow> 'a fract"
189.37 + where "Fract a b = Abs_fract (fractrel `` {if b = 0 then (0, 1) else (a, b)})"
189.38
189.39 code_datatype Fract
189.40
189.41 @@ -80,7 +81,7 @@
189.42 by (cases q) (clarsimp simp add: Fract_def fract_def quotient_def)
189.43
189.44 lemma Fract_induct [case_names Fract, induct type: fract]:
189.45 - shows "(\<And>a b. b \<noteq> 0 \<Longrightarrow> P (Fract a b)) \<Longrightarrow> P q"
189.46 + "(\<And>a b. b \<noteq> 0 \<Longrightarrow> P (Fract a b)) \<Longrightarrow> P q"
189.47 by (cases q) simp
189.48
189.49 lemma eq_fract:
189.50 @@ -105,19 +106,17 @@
189.51 and "d \<noteq> 0"
189.52 shows "Fract a b + Fract c d = Fract (a * d + c * b) (b * d)"
189.53 proof -
189.54 - have "(\<lambda>x y. fractrel``{(fst x * snd y + fst y * snd x, snd x * snd y :: 'a)})
189.55 - respects2 fractrel"
189.56 - apply (rule equiv_fractrel [THEN congruent2_commuteI])
189.57 - apply (auto simp add: algebra_simps)
189.58 - unfolding mult_assoc[symmetric]
189.59 - done
189.60 + have "(\<lambda>x y. fractrel``{(fst x * snd y + fst y * snd x, snd x * snd y :: 'a)}) respects2 fractrel"
189.61 + by (rule equiv_fractrel [THEN congruent2_commuteI]) (simp_all add: algebra_simps)
189.62 with assms show ?thesis by (simp add: Fract_def add_fract_def UN_fractrel2)
189.63 qed
189.64
189.65 definition minus_fract_def:
189.66 "- q = Abs_fract (\<Union>x \<in> Rep_fract q. fractrel `` {(- fst x, snd x)})"
189.67
189.68 -lemma minus_fract [simp, code]: "- Fract a b = Fract (- a) (b::'a::idom)"
189.69 +lemma minus_fract [simp, code]:
189.70 + fixes a b :: "'a::idom"
189.71 + shows "- Fract a b = Fract (- a) b"
189.72 proof -
189.73 have "(\<lambda>x. fractrel `` {(- fst x, snd x :: 'a)}) respects fractrel"
189.74 by (simp add: congruent_def split_paired_all)
189.75 @@ -130,9 +129,10 @@
189.76 definition diff_fract_def: "q - r = q + - (r::'a fract)"
189.77
189.78 lemma diff_fract [simp]:
189.79 - assumes "b \<noteq> 0" and "d \<noteq> 0"
189.80 + assumes "b \<noteq> 0"
189.81 + and "d \<noteq> 0"
189.82 shows "Fract a b - Fract c d = Fract (a * d - c * b) (b * d)"
189.83 - using assms by (simp add: diff_fract_def diff_minus)
189.84 + using assms by (simp add: diff_fract_def)
189.85
189.86 definition mult_fract_def:
189.87 "q * r = Abs_fract (\<Union>x \<in> Rep_fract q. \<Union>y \<in> Rep_fract r.
189.88 @@ -141,9 +141,7 @@
189.89 lemma mult_fract [simp]: "Fract (a::'a::idom) b * Fract c d = Fract (a * c) (b * d)"
189.90 proof -
189.91 have "(\<lambda>x y. fractrel `` {(fst x * fst y, snd x * snd y :: 'a)}) respects2 fractrel"
189.92 - apply (rule equiv_fractrel [THEN congruent2_commuteI])
189.93 - apply (auto simp add: algebra_simps)
189.94 - done
189.95 + by (rule equiv_fractrel [THEN congruent2_commuteI]) (simp_all add: algebra_simps)
189.96 then show ?thesis by (simp add: Fract_def mult_fract_def UN_fractrel2)
189.97 qed
189.98
189.99 @@ -151,14 +149,16 @@
189.100 assumes "c \<noteq> (0::'a)"
189.101 shows "Fract (c * a) (c * b) = Fract a b"
189.102 proof -
189.103 - from assms have "Fract c c = Fract 1 1" by (simp add: Fract_def)
189.104 - then show ?thesis by (simp add: mult_fract [symmetric])
189.105 + from assms have "Fract c c = Fract 1 1"
189.106 + by (simp add: Fract_def)
189.107 + then show ?thesis
189.108 + by (simp add: mult_fract [symmetric])
189.109 qed
189.110
189.111 instance
189.112 proof
189.113 fix q r s :: "'a fract"
189.114 - show "(q * r) * s = q * (r * s)"
189.115 + show "(q * r) * s = q * (r * s)"
189.116 by (cases q, cases r, cases s) (simp add: eq_fract algebra_simps)
189.117 show "q * r = r * q"
189.118 by (cases q, cases r) (simp add: eq_fract algebra_simps)
189.119 @@ -201,7 +201,7 @@
189.120 by (simp_all add: fract_collapse)
189.121
189.122 lemma Fract_cases_nonzero:
189.123 - obtains (Fract) a b where "q = Fract a b" "b \<noteq> 0" "a \<noteq> 0"
189.124 + obtains (Fract) a b where "q = Fract a b" and "b \<noteq> 0" and "a \<noteq> 0"
189.125 | (0) "q = 0"
189.126 proof (cases "q = 0")
189.127 case True
189.128 @@ -213,7 +213,7 @@
189.129 with `b \<noteq> 0` have "a \<noteq> 0" by (simp add: Zero_fract_def eq_fract)
189.130 with Fract `q = Fract a b` `b \<noteq> 0` show thesis by auto
189.131 qed
189.132 -
189.133 +
189.134
189.135 subsubsection {* The field of rational numbers *}
189.136
189.137 @@ -233,10 +233,12 @@
189.138
189.139 lemma inverse_fract [simp]: "inverse (Fract a b) = Fract (b::'a::idom) a"
189.140 proof -
189.141 - have *: "\<And>x. (0::'a) = x \<longleftrightarrow> x = 0" by auto
189.142 + have *: "\<And>x. (0::'a) = x \<longleftrightarrow> x = 0"
189.143 + by auto
189.144 have "(\<lambda>x. fractrel `` {if fst x = 0 then (0, 1) else (snd x, fst x :: 'a)}) respects fractrel"
189.145 by (auto simp add: congruent_def * algebra_simps)
189.146 - then show ?thesis by (simp add: Fract_def inverse_fract_def UN_fractrel)
189.147 + then show ?thesis
189.148 + by (simp add: Fract_def inverse_fract_def UN_fractrel)
189.149 qed
189.150
189.151 definition divide_fract_def: "q / r = q * inverse (r:: 'a fract)"
189.152 @@ -276,10 +278,12 @@
189.153
189.154 let ?le = "\<lambda>a b c d. ((a * d) * (b * d) \<le> (c * b) * (b * d))"
189.155 {
189.156 - fix a b c d x :: 'a assume x: "x \<noteq> 0"
189.157 + fix a b c d x :: 'a
189.158 + assume x: "x \<noteq> 0"
189.159 have "?le a b c d = ?le (a * x) (b * x) c d"
189.160 proof -
189.161 - from x have "0 < x * x" by (auto simp add: zero_less_mult_iff)
189.162 + from x have "0 < x * x"
189.163 + by (auto simp add: zero_less_mult_iff)
189.164 then have "?le a b c d =
189.165 ((a * d) * (b * d) * (x * x) \<le> (c * b) * (b * d) * (x * x))"
189.166 by (simp add: mult_le_cancel_right)
189.167 @@ -315,23 +319,27 @@
189.168 definition less_fract_def: "z < (w::'a fract) \<longleftrightarrow> z \<le> w \<and> \<not> w \<le> z"
189.169
189.170 lemma le_fract [simp]:
189.171 - assumes "b \<noteq> 0" and "d \<noteq> 0"
189.172 + assumes "b \<noteq> 0"
189.173 + and "d \<noteq> 0"
189.174 shows "Fract a b \<le> Fract c d \<longleftrightarrow> (a * d) * (b * d) \<le> (c * b) * (b * d)"
189.175 by (simp add: Fract_def le_fract_def le_congruent2 UN_fractrel2 assms)
189.176
189.177 lemma less_fract [simp]:
189.178 - assumes "b \<noteq> 0" and "d \<noteq> 0"
189.179 + assumes "b \<noteq> 0"
189.180 + and "d \<noteq> 0"
189.181 shows "Fract a b < Fract c d \<longleftrightarrow> (a * d) * (b * d) < (c * b) * (b * d)"
189.182 by (simp add: less_fract_def less_le_not_le mult_ac assms)
189.183
189.184 instance
189.185 proof
189.186 fix q r s :: "'a fract"
189.187 - assume "q \<le> r" and "r \<le> s" thus "q \<le> s"
189.188 + assume "q \<le> r" and "r \<le> s"
189.189 + then show "q \<le> s"
189.190 proof (induct q, induct r, induct s)
189.191 fix a b c d e f :: 'a
189.192 - assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
189.193 - assume 1: "Fract a b \<le> Fract c d" and 2: "Fract c d \<le> Fract e f"
189.194 + assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
189.195 + assume 1: "Fract a b \<le> Fract c d"
189.196 + assume 2: "Fract c d \<le> Fract e f"
189.197 show "Fract a b \<le> Fract e f"
189.198 proof -
189.199 from neq obtain bb: "0 < b * b" and dd: "0 < d * d" and ff: "0 < f * f"
189.200 @@ -359,11 +367,13 @@
189.201 qed
189.202 next
189.203 fix q r :: "'a fract"
189.204 - assume "q \<le> r" and "r \<le> q" thus "q = r"
189.205 + assume "q \<le> r" and "r \<le> q"
189.206 + then show "q = r"
189.207 proof (induct q, induct r)
189.208 fix a b c d :: 'a
189.209 - assume neq: "b \<noteq> 0" "d \<noteq> 0"
189.210 - assume 1: "Fract a b \<le> Fract c d" and 2: "Fract c d \<le> Fract a b"
189.211 + assume neq: "b \<noteq> 0" "d \<noteq> 0"
189.212 + assume 1: "Fract a b \<le> Fract c d"
189.213 + assume 2: "Fract c d \<le> Fract a b"
189.214 show "Fract a b = Fract c d"
189.215 proof -
189.216 from neq 1 have "(a * d) * (b * d) \<le> (c * b) * (b * d)"
189.217 @@ -372,7 +382,7 @@
189.218 proof -
189.219 from neq 2 have "(c * b) * (d * b) \<le> (a * d) * (d * b)"
189.220 by simp
189.221 - thus ?thesis by (simp only: mult_ac)
189.222 + then show ?thesis by (simp only: mult_ac)
189.223 qed
189.224 finally have "(a * d) * (b * d) = (c * b) * (b * d)" .
189.225 moreover from neq have "b * d \<noteq> 0" by simp
189.226 @@ -393,13 +403,13 @@
189.227
189.228 end
189.229
189.230 -instantiation fract :: (linordered_idom) "{distrib_lattice, abs_if, sgn_if}"
189.231 +instantiation fract :: (linordered_idom) "{distrib_lattice,abs_if,sgn_if}"
189.232 begin
189.233
189.234 definition abs_fract_def: "\<bar>q\<bar> = (if q < 0 then -q else (q::'a fract))"
189.235
189.236 definition sgn_fract_def:
189.237 - "sgn (q::'a fract) = (if q=0 then 0 else if 0<q then 1 else - 1)"
189.238 + "sgn (q::'a fract) = (if q = 0 then 0 else if 0 < q then 1 else - 1)"
189.239
189.240 theorem abs_fract [simp]: "\<bar>Fract a b\<bar> = Fract \<bar>a\<bar> \<bar>b\<bar>"
189.241 by (auto simp add: abs_fract_def Zero_fract_def le_less
189.242 @@ -444,7 +454,7 @@
189.243 then show "s * q < s * r"
189.244 proof (induct q, induct r, induct s)
189.245 fix a b c d e f :: 'a
189.246 - assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
189.247 + assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
189.248 assume le: "Fract a b < Fract c d"
189.249 assume gt: "0 < Fract e f"
189.250 show "Fract e f * Fract a b < Fract e f * Fract c d"
189.251 @@ -469,16 +479,21 @@
189.252 assumes step: "\<And>a b. 0 < b \<Longrightarrow> P (Fract a b)"
189.253 shows "P q"
189.254 proof (cases q)
189.255 - have step': "\<And>a b. b < 0 \<Longrightarrow> P (Fract a b)"
189.256 - proof -
189.257 - fix a::'a and b::'a
189.258 + case (Fract a b)
189.259 + {
189.260 + fix a b :: 'a
189.261 assume b: "b < 0"
189.262 - then have "0 < -b" by simp
189.263 - then have "P (Fract (-a) (-b))" by (rule step)
189.264 - thus "P (Fract a b)" by (simp add: order_less_imp_not_eq [OF b])
189.265 - qed
189.266 - case (Fract a b)
189.267 - thus "P q" by (force simp add: linorder_neq_iff step step')
189.268 + have "P (Fract a b)"
189.269 + proof -
189.270 + from b have "0 < - b" by simp
189.271 + then have "P (Fract (- a) (- b))"
189.272 + by (rule step)
189.273 + then show "P (Fract a b)"
189.274 + by (simp add: order_less_imp_not_eq [OF b])
189.275 + qed
189.276 + }
189.277 + with Fract show "P q"
189.278 + by (auto simp add: linorder_neq_iff step)
189.279 qed
189.280
189.281 lemma zero_less_Fract_iff: "0 < b \<Longrightarrow> 0 < Fract a b \<longleftrightarrow> 0 < a"
190.1 --- a/src/HOL/Library/FuncSet.thy Thu Dec 05 17:52:12 2013 +0100
190.2 +++ b/src/HOL/Library/FuncSet.thy Thu Dec 05 17:58:03 2013 +0100
190.3 @@ -183,18 +183,20 @@
190.4
190.5 subsection{*Bounded Abstraction: @{term restrict}*}
190.6
190.7 -lemma restrict_in_funcset: "(!!x. x \<in> A ==> f x \<in> B) ==> (\<lambda>x\<in>A. f x) \<in> A -> B"
190.8 +lemma restrict_in_funcset: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> (\<lambda>x\<in>A. f x) \<in> A \<rightarrow> B"
190.9 by (simp add: Pi_def restrict_def)
190.10
190.11 -lemma restrictI[intro!]: "(!!x. x \<in> A ==> f x \<in> B x) ==> (\<lambda>x\<in>A. f x) \<in> Pi A B"
190.12 +lemma restrictI[intro!]: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> B x) \<Longrightarrow> (\<lambda>x\<in>A. f x) \<in> Pi A B"
190.13 by (simp add: Pi_def restrict_def)
190.14
190.15 -lemma restrict_apply [simp]:
190.16 - "(\<lambda>y\<in>A. f y) x = (if x \<in> A then f x else undefined)"
190.17 +lemma restrict_apply[simp]: "(\<lambda>y\<in>A. f y) x = (if x \<in> A then f x else undefined)"
190.18 by (simp add: restrict_def)
190.19
190.20 +lemma restrict_apply': "x \<in> A \<Longrightarrow> (\<lambda>y\<in>A. f y) x = f x"
190.21 + by simp
190.22 +
190.23 lemma restrict_ext:
190.24 - "(!!x. x \<in> A ==> f x = g x) ==> (\<lambda>x\<in>A. f x) = (\<lambda>x\<in>A. g x)"
190.25 + "(\<And>x. x \<in> A \<Longrightarrow> f x = g x) \<Longrightarrow> (\<lambda>x\<in>A. f x) = (\<lambda>x\<in>A. g x)"
190.26 by (simp add: fun_eq_iff Pi_def restrict_def)
190.27
190.28 lemma inj_on_restrict_eq [simp]: "inj_on (restrict f A) A = inj_on f A"
190.29 @@ -364,6 +366,9 @@
190.30 lemma PiE_empty_domain[simp]: "PiE {} T = {%x. undefined}"
190.31 unfolding PiE_def by simp
190.32
190.33 +lemma PiE_UNIV_domain: "PiE UNIV T = Pi UNIV T"
190.34 + unfolding PiE_def by simp
190.35 +
190.36 lemma PiE_empty_range[simp]: "i \<in> I \<Longrightarrow> F i = {} \<Longrightarrow> (PIE i:I. F i) = {}"
190.37 unfolding PiE_def by auto
190.38
191.1 --- a/src/HOL/Library/Function_Algebras.thy Thu Dec 05 17:52:12 2013 +0100
191.2 +++ b/src/HOL/Library/Function_Algebras.thy Thu Dec 05 17:58:03 2013 +0100
191.3 @@ -83,10 +83,10 @@
191.4
191.5 instance "fun" :: (type, group_add) group_add
191.6 by default
191.7 - (simp_all add: fun_eq_iff diff_minus)
191.8 + (simp_all add: fun_eq_iff)
191.9
191.10 instance "fun" :: (type, ab_group_add) ab_group_add
191.11 - by default (simp_all add: diff_minus)
191.12 + by default simp_all
191.13
191.14
191.15 text {* Multiplicative structures *}
192.1 --- a/src/HOL/Library/Fundamental_Theorem_Algebra.thy Thu Dec 05 17:52:12 2013 +0100
192.2 +++ b/src/HOL/Library/Fundamental_Theorem_Algebra.thy Thu Dec 05 17:58:03 2013 +0100
192.3 @@ -156,28 +156,11 @@
192.4 text{* An alternative useful formulation of completeness of the reals *}
192.5 lemma real_sup_exists: assumes ex: "\<exists>x. P x" and bz: "\<exists>z. \<forall>x. P x \<longrightarrow> x < z"
192.6 shows "\<exists>(s::real). \<forall>y. (\<exists>x. P x \<and> y < x) \<longleftrightarrow> y < s"
192.7 -proof-
192.8 - from ex bz obtain x Y where x: "P x" and Y: "\<And>x. P x \<Longrightarrow> x < Y" by blast
192.9 - from ex have thx:"\<exists>x. x \<in> Collect P" by blast
192.10 - from bz have thY: "\<exists>Y. isUb UNIV (Collect P) Y"
192.11 - by(auto simp add: isUb_def isLub_def setge_def setle_def leastP_def Ball_def order_le_less)
192.12 - from reals_complete[OF thx thY] obtain L where L: "isLub UNIV (Collect P) L"
192.13 - by blast
192.14 - from Y[OF x] have xY: "x < Y" .
192.15 - 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)
192.16 - from Y have Y': "\<forall>x. P x \<longrightarrow> x \<le> Y"
192.17 - apply (clarsimp, atomize (full)) by auto
192.18 - from L Y' have "L \<le> Y" by (auto simp add: isUb_def isLub_def setge_def setle_def leastP_def Ball_def)
192.19 - {fix y
192.20 - {fix z assume z: "P z" "y < z"
192.21 - from L' z have "y < L" by auto }
192.22 - moreover
192.23 - {assume yL: "y < L" "\<forall>z. P z \<longrightarrow> \<not> y < z"
192.24 - hence nox: "\<forall>z. P z \<longrightarrow> y \<ge> z" by auto
192.25 - from nox L have "y \<ge> L" by (auto simp add: isUb_def isLub_def setge_def setle_def leastP_def Ball_def)
192.26 - with yL(1) have False by arith}
192.27 - ultimately have "(\<exists>x. P x \<and> y < x) \<longleftrightarrow> y < L" by blast}
192.28 - thus ?thesis by blast
192.29 +proof
192.30 + from bz have "bdd_above (Collect P)"
192.31 + by (force intro: less_imp_le)
192.32 + then show "\<forall>y. (\<exists>x. P x \<and> y < x) \<longleftrightarrow> y < Sup (Collect P)"
192.33 + using ex bz by (subst less_cSup_iff) auto
192.34 qed
192.35
192.36 subsection {* Fundamental theorem of algebra *}
192.37 @@ -224,12 +207,14 @@
192.38 from unimodular_reduce_norm[OF th0] o
192.39 have "\<exists>v. cmod (complex_of_real (cmod b) / b + v^n) < 1"
192.40 apply (cases "cmod (complex_of_real (cmod b) / b + 1) < 1", rule_tac x="1" in exI, simp)
192.41 - apply (cases "cmod (complex_of_real (cmod b) / b - 1) < 1", rule_tac x="-1" in exI, simp add: diff_minus)
192.42 + apply (cases "cmod (complex_of_real (cmod b) / b - 1) < 1", rule_tac x="-1" in exI, simp)
192.43 apply (cases "cmod (complex_of_real (cmod b) / b + ii) < 1")
192.44 apply (cases "even m", rule_tac x="ii" in exI, simp add: m power_mult)
192.45 apply (rule_tac x="- ii" in exI, simp add: m power_mult)
192.46 - apply (cases "even m", rule_tac x="- ii" in exI, simp add: m power_mult diff_minus)
192.47 - apply (rule_tac x="ii" in exI, simp add: m power_mult diff_minus)
192.48 + apply (cases "even m", rule_tac x="- ii" in exI, simp add: m power_mult)
192.49 + apply (auto simp add: m power_mult)
192.50 + apply (rule_tac x="ii" in exI)
192.51 + apply (auto simp add: m power_mult)
192.52 done
192.53 then obtain v where v: "cmod (complex_of_real (cmod b) / b + v^n) < 1" by blast
192.54 let ?w = "v / complex_of_real (root n (cmod b))"
192.55 @@ -954,7 +939,7 @@
192.56
192.57 lemma mpoly_sub_conv:
192.58 "poly p (x::complex) - poly q x \<equiv> poly p x + -1 * poly q x"
192.59 - by (simp add: diff_minus)
192.60 + by simp
192.61
192.62 lemma poly_pad_rule: "poly p x = 0 ==> poly (pCons 0 p) x = (0::complex)" by simp
192.63
193.1 --- a/src/HOL/Library/Glbs.thy Thu Dec 05 17:52:12 2013 +0100
193.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
193.3 @@ -1,79 +0,0 @@
193.4 -(* Author: Amine Chaieb, University of Cambridge *)
193.5 -
193.6 -header {* Definitions of Lower Bounds and Greatest Lower Bounds, analogous to Lubs *}
193.7 -
193.8 -theory Glbs
193.9 -imports Lubs
193.10 -begin
193.11 -
193.12 -definition greatestP :: "('a \<Rightarrow> bool) \<Rightarrow> 'a::ord \<Rightarrow> bool"
193.13 - where "greatestP P x = (P x \<and> Collect P *<= x)"
193.14 -
193.15 -definition isLb :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
193.16 - where "isLb R S x = (x <=* S \<and> x: R)"
193.17 -
193.18 -definition isGlb :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
193.19 - where "isGlb R S x = greatestP (isLb R S) x"
193.20 -
193.21 -definition lbs :: "'a set \<Rightarrow> 'a::ord set \<Rightarrow> 'a set"
193.22 - where "lbs R S = Collect (isLb R S)"
193.23 -
193.24 -
193.25 -subsection {* Rules about the Operators @{term greatestP}, @{term isLb}
193.26 - and @{term isGlb} *}
193.27 -
193.28 -lemma leastPD1: "greatestP P x \<Longrightarrow> P x"
193.29 - by (simp add: greatestP_def)
193.30 -
193.31 -lemma greatestPD2: "greatestP P x \<Longrightarrow> Collect P *<= x"
193.32 - by (simp add: greatestP_def)
193.33 -
193.34 -lemma greatestPD3: "greatestP P x \<Longrightarrow> y: Collect P \<Longrightarrow> x \<ge> y"
193.35 - by (blast dest!: greatestPD2 setleD)
193.36 -
193.37 -lemma isGlbD1: "isGlb R S x \<Longrightarrow> x <=* S"
193.38 - by (simp add: isGlb_def isLb_def greatestP_def)
193.39 -
193.40 -lemma isGlbD1a: "isGlb R S x \<Longrightarrow> x: R"
193.41 - by (simp add: isGlb_def isLb_def greatestP_def)
193.42 -
193.43 -lemma isGlb_isLb: "isGlb R S x \<Longrightarrow> isLb R S x"
193.44 - unfolding isLb_def by (blast dest: isGlbD1 isGlbD1a)
193.45 -
193.46 -lemma isGlbD2: "isGlb R S x \<Longrightarrow> y : S \<Longrightarrow> y \<ge> x"
193.47 - by (blast dest!: isGlbD1 setgeD)
193.48 -
193.49 -lemma isGlbD3: "isGlb R S x \<Longrightarrow> greatestP (isLb R S) x"
193.50 - by (simp add: isGlb_def)
193.51 -
193.52 -lemma isGlbI1: "greatestP (isLb R S) x \<Longrightarrow> isGlb R S x"
193.53 - by (simp add: isGlb_def)
193.54 -
193.55 -lemma isGlbI2: "isLb R S x \<Longrightarrow> Collect (isLb R S) *<= x \<Longrightarrow> isGlb R S x"
193.56 - by (simp add: isGlb_def greatestP_def)
193.57 -
193.58 -lemma isLbD: "isLb R S x \<Longrightarrow> y : S \<Longrightarrow> y \<ge> x"
193.59 - by (simp add: isLb_def setge_def)
193.60 -
193.61 -lemma isLbD2: "isLb R S x \<Longrightarrow> x <=* S "
193.62 - by (simp add: isLb_def)
193.63 -
193.64 -lemma isLbD2a: "isLb R S x \<Longrightarrow> x: R"
193.65 - by (simp add: isLb_def)
193.66 -
193.67 -lemma isLbI: "x <=* S \<Longrightarrow> x: R \<Longrightarrow> isLb R S x"
193.68 - by (simp add: isLb_def)
193.69 -
193.70 -lemma isGlb_le_isLb: "isGlb R S x \<Longrightarrow> isLb R S y \<Longrightarrow> x \<ge> y"
193.71 - unfolding isGlb_def by (blast intro!: greatestPD3)
193.72 -
193.73 -lemma isGlb_ubs: "isGlb R S x \<Longrightarrow> lbs R S *<= x"
193.74 - unfolding lbs_def isGlb_def by (rule greatestPD2)
193.75 -
193.76 -lemma isGlb_unique: "[| isGlb R S x; isGlb R S y |] ==> x = (y::'a::linorder)"
193.77 - apply (frule isGlb_isLb)
193.78 - apply (frule_tac x = y in isGlb_isLb)
193.79 - apply (blast intro!: order_antisym dest!: isGlb_le_isLb)
193.80 - done
193.81 -
193.82 -end
194.1 --- a/src/HOL/Library/IArray.thy Thu Dec 05 17:52:12 2013 +0100
194.2 +++ b/src/HOL/Library/IArray.thy Thu Dec 05 17:58:03 2013 +0100
194.3 @@ -31,6 +31,14 @@
194.4 [simp]: "length as = List.length (IArray.list_of as)"
194.5 hide_const (open) length
194.6
194.7 +fun all :: "('a \<Rightarrow> bool) \<Rightarrow> 'a iarray \<Rightarrow> bool" where
194.8 +"all p (IArray as) = (ALL a : set as. p a)"
194.9 +hide_const (open) all
194.10 +
194.11 +fun exists :: "('a \<Rightarrow> bool) \<Rightarrow> 'a iarray \<Rightarrow> bool" where
194.12 +"exists p (IArray as) = (EX a : set as. p a)"
194.13 +hide_const (open) exists
194.14 +
194.15 lemma list_of_code [code]:
194.16 "IArray.list_of as = map (\<lambda>n. as !! n) [0 ..< IArray.length as]"
194.17 by (cases as) (simp add: map_nth)
194.18 @@ -43,6 +51,8 @@
194.19 code_printing
194.20 type_constructor iarray \<rightharpoonup> (SML) "_ Vector.vector"
194.21 | constant IArray \<rightharpoonup> (SML) "Vector.fromList"
194.22 +| constant IArray.all \<rightharpoonup> (SML) "Vector.all"
194.23 +| constant IArray.exists \<rightharpoonup> (SML) "Vector.exists"
194.24
194.25 lemma [code]:
194.26 "size (as :: 'a iarray) = 0"
195.1 --- a/src/HOL/Library/Indicator_Function.thy Thu Dec 05 17:52:12 2013 +0100
195.2 +++ b/src/HOL/Library/Indicator_Function.thy Thu Dec 05 17:58:03 2013 +0100
195.3 @@ -22,6 +22,12 @@
195.4 lemma indicator_abs_le_1: "\<bar>indicator S x\<bar> \<le> (1::'a::linordered_idom)"
195.5 unfolding indicator_def by auto
195.6
195.7 +lemma indicator_eq_0_iff: "indicator A x = (0::_::zero_neq_one) \<longleftrightarrow> x \<notin> A"
195.8 + by (auto simp: indicator_def)
195.9 +
195.10 +lemma indicator_eq_1_iff: "indicator A x = (1::_::zero_neq_one) \<longleftrightarrow> x \<in> A"
195.11 + by (auto simp: indicator_def)
195.12 +
195.13 lemma split_indicator:
195.14 "P (indicator S x) \<longleftrightarrow> ((x \<in> S \<longrightarrow> P 1) \<and> (x \<notin> S \<longrightarrow> P 0))"
195.15 unfolding indicator_def by auto
196.1 --- a/src/HOL/Library/Infinite_Set.thy Thu Dec 05 17:52:12 2013 +0100
196.2 +++ b/src/HOL/Library/Infinite_Set.thy Thu Dec 05 17:58:03 2013 +0100
196.3 @@ -11,7 +11,7 @@
196.4 subsection "Infinite Sets"
196.5
196.6 text {*
196.7 - Some elementary facts about infinite sets, mostly by Stefan Merz.
196.8 + Some elementary facts about infinite sets, mostly by Stephan Merz.
196.9 Beware! Because "infinite" merely abbreviates a negation, these
196.10 lemmas may not work well with @{text "blast"}.
196.11 *}
196.12 @@ -193,19 +193,9 @@
196.13 by (auto simp add: infinite_nat_iff_unbounded)
196.14 qed
196.15
196.16 -(* duplicates Finite_Set.infinite_UNIV_nat *)
196.17 -lemma nat_infinite: "infinite (UNIV :: nat set)"
196.18 - by (auto simp add: infinite_nat_iff_unbounded)
196.19 -
196.20 lemma nat_not_finite: "finite (UNIV::nat set) \<Longrightarrow> R"
196.21 by simp
196.22
196.23 -text {*
196.24 - Every infinite set contains a countable subset. More precisely we
196.25 - show that a set @{text S} is infinite if and only if there exists an
196.26 - injective function from the naturals into @{text S}.
196.27 -*}
196.28 -
196.29 lemma range_inj_infinite:
196.30 "inj (f::nat \<Rightarrow> 'a) \<Longrightarrow> infinite (range f)"
196.31 proof
196.32 @@ -215,118 +205,6 @@
196.33 then show False by simp
196.34 qed
196.35
196.36 -lemma int_infinite [simp]: "infinite (UNIV::int set)"
196.37 -proof -
196.38 - from inj_int have "infinite (range int)"
196.39 - by (rule range_inj_infinite)
196.40 - moreover
196.41 - have "range int \<subseteq> (UNIV::int set)" by simp
196.42 - ultimately show "infinite (UNIV::int set)"
196.43 - by (simp add: infinite_super)
196.44 -qed
196.45 -
196.46 -text {*
196.47 - The ``only if'' direction is harder because it requires the
196.48 - construction of a sequence of pairwise different elements of an
196.49 - infinite set @{text S}. The idea is to construct a sequence of
196.50 - non-empty and infinite subsets of @{text S} obtained by successively
196.51 - removing elements of @{text S}.
196.52 -*}
196.53 -
196.54 -lemma linorder_injI:
196.55 - assumes hyp: "\<And>x y. x < (y::'a::linorder) \<Longrightarrow> f x \<noteq> f y"
196.56 - shows "inj f"
196.57 -proof (rule inj_onI)
196.58 - fix x y
196.59 - assume f_eq: "f x = f y"
196.60 - show "x = y"
196.61 - proof (rule linorder_cases)
196.62 - assume "x < y"
196.63 - with hyp have "f x \<noteq> f y" by blast
196.64 - with f_eq show ?thesis by simp
196.65 - next
196.66 - assume "x = y"
196.67 - then show ?thesis .
196.68 - next
196.69 - assume "y < x"
196.70 - with hyp have "f y \<noteq> f x" by blast
196.71 - with f_eq show ?thesis by simp
196.72 - qed
196.73 -qed
196.74 -
196.75 -lemma infinite_countable_subset:
196.76 - assumes inf: "infinite (S::'a set)"
196.77 - shows "\<exists>f. inj (f::nat \<Rightarrow> 'a) \<and> range f \<subseteq> S"
196.78 -proof -
196.79 - def Sseq \<equiv> "nat_rec S (\<lambda>n T. T - {SOME e. e \<in> T})"
196.80 - def pick \<equiv> "\<lambda>n. (SOME e. e \<in> Sseq n)"
196.81 - have Sseq_inf: "\<And>n. infinite (Sseq n)"
196.82 - proof -
196.83 - fix n
196.84 - show "infinite (Sseq n)"
196.85 - proof (induct n)
196.86 - from inf show "infinite (Sseq 0)"
196.87 - by (simp add: Sseq_def)
196.88 - next
196.89 - fix n
196.90 - assume "infinite (Sseq n)" then show "infinite (Sseq (Suc n))"
196.91 - by (simp add: Sseq_def infinite_remove)
196.92 - qed
196.93 - qed
196.94 - have Sseq_S: "\<And>n. Sseq n \<subseteq> S"
196.95 - proof -
196.96 - fix n
196.97 - show "Sseq n \<subseteq> S"
196.98 - by (induct n) (auto simp add: Sseq_def)
196.99 - qed
196.100 - have Sseq_pick: "\<And>n. pick n \<in> Sseq n"
196.101 - proof -
196.102 - fix n
196.103 - show "pick n \<in> Sseq n"
196.104 - unfolding pick_def
196.105 - proof (rule someI_ex)
196.106 - from Sseq_inf have "infinite (Sseq n)" .
196.107 - then have "Sseq n \<noteq> {}" by auto
196.108 - then show "\<exists>x. x \<in> Sseq n" by auto
196.109 - qed
196.110 - qed
196.111 - with Sseq_S have rng: "range pick \<subseteq> S"
196.112 - by auto
196.113 - have pick_Sseq_gt: "\<And>n m. pick n \<notin> Sseq (n + Suc m)"
196.114 - proof -
196.115 - fix n m
196.116 - show "pick n \<notin> Sseq (n + Suc m)"
196.117 - by (induct m) (auto simp add: Sseq_def pick_def)
196.118 - qed
196.119 - have pick_pick: "\<And>n m. pick n \<noteq> pick (n + Suc m)"
196.120 - proof -
196.121 - fix n m
196.122 - from Sseq_pick have "pick (n + Suc m) \<in> Sseq (n + Suc m)" .
196.123 - moreover from pick_Sseq_gt
196.124 - have "pick n \<notin> Sseq (n + Suc m)" .
196.125 - ultimately show "pick n \<noteq> pick (n + Suc m)"
196.126 - by auto
196.127 - qed
196.128 - have inj: "inj pick"
196.129 - proof (rule linorder_injI)
196.130 - fix i j :: nat
196.131 - assume "i < j"
196.132 - show "pick i \<noteq> pick j"
196.133 - proof
196.134 - assume eq: "pick i = pick j"
196.135 - from `i < j` obtain k where "j = i + Suc k"
196.136 - by (auto simp add: less_iff_Suc_add)
196.137 - with pick_pick have "pick i \<noteq> pick j" by simp
196.138 - with eq show False by simp
196.139 - qed
196.140 - qed
196.141 - from rng inj show ?thesis by auto
196.142 -qed
196.143 -
196.144 -lemma infinite_iff_countable_subset:
196.145 - "infinite S \<longleftrightarrow> (\<exists>f. inj (f::nat \<Rightarrow> 'a) \<and> range f \<subseteq> S)"
196.146 - by (auto simp add: infinite_countable_subset range_inj_infinite infinite_super)
196.147 -
196.148 text {*
196.149 For any function with infinite domain and finite range there is some
196.150 element that is the image of infinitely many domain elements. In
197.1 --- a/src/HOL/Library/Inner_Product.thy Thu Dec 05 17:52:12 2013 +0100
197.2 +++ b/src/HOL/Library/Inner_Product.thy Thu Dec 05 17:58:03 2013 +0100
197.3 @@ -41,7 +41,7 @@
197.4 using inner_add_left [of x "- x" y] by simp
197.5
197.6 lemma inner_diff_left: "inner (x - y) z = inner x z - inner y z"
197.7 - by (simp add: diff_minus inner_add_left)
197.8 + using inner_add_left [of x "- y" z] by simp
197.9
197.10 lemma inner_setsum_left: "inner (\<Sum>x\<in>A. f x) y = (\<Sum>x\<in>A. inner (f x) y)"
197.11 by (cases "finite A", induct set: finite, simp_all add: inner_add_left)
198.1 --- a/src/HOL/Library/Lattice_Algebras.thy Thu Dec 05 17:52:12 2013 +0100
198.2 +++ b/src/HOL/Library/Lattice_Algebras.thy Thu Dec 05 17:58:03 2013 +0100
198.3 @@ -13,9 +13,7 @@
198.4 apply (rule antisym)
198.5 apply (simp_all add: le_infI)
198.6 apply (rule add_le_imp_le_left [of "uminus a"])
198.7 - apply (simp only: add_assoc [symmetric], simp)
198.8 - apply rule
198.9 - apply (rule add_le_imp_le_left[of "a"], simp only: add_assoc[symmetric], simp)+
198.10 + apply (simp only: add_assoc [symmetric], simp add: diff_le_eq add.commute)
198.11 done
198.12
198.13 lemma add_inf_distrib_right: "inf a b + c = inf (a + c) (b + c)"
198.14 @@ -33,11 +31,10 @@
198.15 lemma add_sup_distrib_left: "a + sup b c = sup (a + b) (a + c)"
198.16 apply (rule antisym)
198.17 apply (rule add_le_imp_le_left [of "uminus a"])
198.18 - apply (simp only: add_assoc[symmetric], simp)
198.19 - apply rule
198.20 + apply (simp only: add_assoc [symmetric], simp)
198.21 + apply (simp add: le_diff_eq add.commute)
198.22 + apply (rule le_supI)
198.23 apply (rule add_le_imp_le_left [of "a"], simp only: add_assoc[symmetric], simp)+
198.24 - apply (rule le_supI)
198.25 - apply (simp_all)
198.26 done
198.27
198.28 lemma add_sup_distrib_right: "sup a b + c = sup (a+c) (b+c)"
198.29 @@ -87,9 +84,15 @@
198.30 lemma neg_inf_eq_sup: "- inf a b = sup (-a) (-b)"
198.31 by (simp add: inf_eq_neg_sup)
198.32
198.33 +lemma diff_inf_eq_sup: "a - inf b c = a + sup (- b) (- c)"
198.34 + using neg_inf_eq_sup [of b c, symmetric] by simp
198.35 +
198.36 lemma neg_sup_eq_inf: "- sup a b = inf (-a) (-b)"
198.37 by (simp add: sup_eq_neg_inf)
198.38
198.39 +lemma diff_sup_eq_inf: "a - sup b c = a + inf (- b) (- c)"
198.40 + using neg_sup_eq_inf [of b c, symmetric] by simp
198.41 +
198.42 lemma add_eq_inf_sup: "a + b = sup a b + inf a b"
198.43 proof -
198.44 have "0 = - inf 0 (a-b) + inf (a-b) 0"
198.45 @@ -97,8 +100,8 @@
198.46 hence "0 = sup 0 (b-a) + inf (a-b) 0"
198.47 by (simp add: inf_eq_neg_sup)
198.48 hence "0 = (-a + sup a b) + (inf a b + (-b))"
198.49 - by (simp add: add_sup_distrib_left add_inf_distrib_right) (simp add: algebra_simps)
198.50 - thus ?thesis by (simp add: algebra_simps)
198.51 + by (simp only: add_sup_distrib_left add_inf_distrib_right) simp
198.52 + then show ?thesis by (simp add: algebra_simps)
198.53 qed
198.54
198.55
198.56 @@ -251,7 +254,7 @@
198.57 apply assumption
198.58 apply (rule notI)
198.59 unfolding double_zero [symmetric, of a]
198.60 - apply simp
198.61 + apply blast
198.62 done
198.63 qed
198.64
198.65 @@ -259,7 +262,8 @@
198.66 "a + a \<le> 0 \<longleftrightarrow> a \<le> 0"
198.67 proof -
198.68 have "a + a \<le> 0 \<longleftrightarrow> 0 \<le> - (a + a)" by (subst le_minus_iff, simp)
198.69 - moreover have "\<dots> \<longleftrightarrow> a \<le> 0" by simp
198.70 + moreover have "\<dots> \<longleftrightarrow> a \<le> 0"
198.71 + by (simp only: minus_add_distrib zero_le_double_add_iff_zero_le_single_add) simp
198.72 ultimately show ?thesis by blast
198.73 qed
198.74
198.75 @@ -267,11 +271,12 @@
198.76 "a + a < 0 \<longleftrightarrow> a < 0"
198.77 proof -
198.78 have "a + a < 0 \<longleftrightarrow> 0 < - (a + a)" by (subst less_minus_iff, simp)
198.79 - moreover have "\<dots> \<longleftrightarrow> a < 0" by simp
198.80 + moreover have "\<dots> \<longleftrightarrow> a < 0"
198.81 + by (simp only: minus_add_distrib zero_less_double_add_iff_zero_less_single_add) simp
198.82 ultimately show ?thesis by blast
198.83 qed
198.84
198.85 -declare neg_inf_eq_sup [simp] neg_sup_eq_inf [simp]
198.86 +declare neg_inf_eq_sup [simp] neg_sup_eq_inf [simp] diff_inf_eq_sup [simp] diff_sup_eq_inf [simp]
198.87
198.88 lemma le_minus_self_iff: "a \<le> - a \<longleftrightarrow> a \<le> 0"
198.89 proof -
198.90 @@ -326,7 +331,7 @@
198.91 then have "0 \<le> sup a (- a)" unfolding abs_lattice .
198.92 then have "sup (sup a (- a)) 0 = sup a (- a)" by (rule sup_absorb1)
198.93 then show ?thesis
198.94 - by (simp add: add_sup_inf_distribs sup_aci pprt_def nprt_def diff_minus abs_lattice)
198.95 + by (simp add: add_sup_inf_distribs ac_simps pprt_def nprt_def abs_lattice)
198.96 qed
198.97
198.98 subclass ordered_ab_group_add_abs
198.99 @@ -355,16 +360,17 @@
198.100 show "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
198.101 proof -
198.102 have g:"abs a + abs b = sup (a+b) (sup (-a-b) (sup (-a+b) (a + (-b))))" (is "_=sup ?m ?n")
198.103 - by (simp add: abs_lattice add_sup_inf_distribs sup_aci diff_minus)
198.104 + by (simp add: abs_lattice add_sup_inf_distribs sup_aci ac_simps)
198.105 have a: "a + b <= sup ?m ?n" by simp
198.106 have b: "- a - b <= ?n" by simp
198.107 have c: "?n <= sup ?m ?n" by simp
198.108 from b c have d: "-a-b <= sup ?m ?n" by (rule order_trans)
198.109 - have e:"-a-b = -(a+b)" by (simp add: diff_minus)
198.110 + have e:"-a-b = -(a+b)" by simp
198.111 from a d e have "abs(a+b) <= sup ?m ?n"
198.112 apply -
198.113 apply (drule abs_leI)
198.114 - apply auto
198.115 + apply (simp_all only: algebra_simps ac_simps minus_add)
198.116 + apply (metis add_uminus_conv_diff d sup_commute uminus_add_conv_diff)
198.117 done
198.118 with g[symmetric] show ?thesis by simp
198.119 qed
198.120 @@ -421,14 +427,12 @@
198.121 }
198.122 note b = this[OF refl[of a] refl[of b]]
198.123 have xy: "- ?x <= ?y"
198.124 - apply (simp)
198.125 - apply (rule order_trans [OF add_nonpos_nonpos add_nonneg_nonneg])
198.126 - apply (simp_all add: mult_nonneg_nonneg mult_nonpos_nonpos)
198.127 + apply simp
198.128 + apply (metis (full_types) add_increasing add_uminus_conv_diff lattice_ab_group_add_class.minus_le_self_iff minus_add_distrib mult_nonneg_nonneg mult_nonpos_nonpos nprt_le_zero zero_le_pprt)
198.129 done
198.130 have yx: "?y <= ?x"
198.131 - apply (simp add:diff_minus)
198.132 - apply (rule order_trans [OF add_nonpos_nonpos add_nonneg_nonneg])
198.133 - apply (simp_all add: mult_nonneg_nonpos mult_nonpos_nonneg)
198.134 + apply simp
198.135 + apply (metis (full_types) add_nonpos_nonpos add_uminus_conv_diff lattice_ab_group_add_class.le_minus_self_iff minus_add_distrib mult_nonneg_nonpos mult_nonpos_nonneg nprt_le_zero zero_le_pprt)
198.136 done
198.137 have i1: "a*b <= abs a * abs b" by (simp only: a b yx)
198.138 have i2: "- (abs a * abs b) <= a*b" by (simp only: a b xy)
198.139 @@ -549,7 +553,7 @@
198.140 by simp
198.141 then have "-(- nprt a1 * pprt b2 + - nprt a2 * nprt b2 + - pprt a1 * pprt b1 + - pprt a2 * nprt b1) <= a * b"
198.142 by (simp only: minus_le_iff)
198.143 - then show ?thesis by simp
198.144 + then show ?thesis by (simp add: algebra_simps)
198.145 qed
198.146
198.147 instance int :: lattice_ring
198.148 @@ -567,3 +571,4 @@
198.149 qed
198.150
198.151 end
198.152 +
199.1 --- a/src/HOL/Library/Library.thy Thu Dec 05 17:52:12 2013 +0100
199.2 +++ b/src/HOL/Library/Library.thy Thu Dec 05 17:58:03 2013 +0100
199.3 @@ -1,7 +1,6 @@
199.4 (*<*)
199.5 theory Library
199.6 imports
199.7 - Abstract_Rat
199.8 AList
199.9 BigO
199.10 Binomial
199.11 @@ -42,7 +41,6 @@
199.12 Numeral_Type
199.13 OptionalSugar
199.14 Option_ord
199.15 - Order_Union
199.16 Parallel
199.17 Permutation
199.18 Permutations
199.19 @@ -65,7 +63,6 @@
199.20 Sublist
199.21 Sum_of_Squares
199.22 Transitive_Closure_Table
199.23 - Univ_Poly
199.24 Wfrec
199.25 While_Combinator
199.26 Zorn
200.1 --- a/src/HOL/Library/Liminf_Limsup.thy Thu Dec 05 17:52:12 2013 +0100
200.2 +++ b/src/HOL/Library/Liminf_Limsup.thy Thu Dec 05 17:58:03 2013 +0100
200.3 @@ -21,19 +21,21 @@
200.4 by (blast intro: less_imp_le less_trans le_less_trans dest: dense)
200.5
200.6 lemma SUPR_pair:
200.7 - "(SUP i : A. SUP j : B. f i j) = (SUP p : A \<times> B. f (fst p) (snd p))"
200.8 + fixes f :: "_ \<Rightarrow> _ \<Rightarrow> _ :: complete_lattice"
200.9 + shows "(SUP i : A. SUP j : B. f i j) = (SUP p : A \<times> B. f (fst p) (snd p))"
200.10 by (rule antisym) (auto intro!: SUP_least SUP_upper2)
200.11
200.12 lemma INFI_pair:
200.13 - "(INF i : A. INF j : B. f i j) = (INF p : A \<times> B. f (fst p) (snd p))"
200.14 + fixes f :: "_ \<Rightarrow> _ \<Rightarrow> _ :: complete_lattice"
200.15 + shows "(INF i : A. INF j : B. f i j) = (INF p : A \<times> B. f (fst p) (snd p))"
200.16 by (rule antisym) (auto intro!: INF_greatest INF_lower2)
200.17
200.18 subsubsection {* @{text Liminf} and @{text Limsup} *}
200.19
200.20 -definition
200.21 +definition Liminf :: "'a filter \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b :: complete_lattice" where
200.22 "Liminf F f = (SUP P:{P. eventually P F}. INF x:{x. P x}. f x)"
200.23
200.24 -definition
200.25 +definition Limsup :: "'a filter \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b :: complete_lattice" where
200.26 "Limsup F f = (INF P:{P. eventually P F}. SUP x:{x. P x}. f x)"
200.27
200.28 abbreviation "liminf \<equiv> Liminf sequentially"
200.29 @@ -50,21 +52,17 @@
200.30 (\<And>y. (\<And>P. eventually P F \<Longrightarrow> y \<le> SUPR (Collect P) f) \<Longrightarrow> y \<le> x) \<Longrightarrow> Limsup F f = x"
200.31 unfolding Limsup_def by (auto intro!: INF_eqI)
200.32
200.33 -lemma liminf_SUPR_INFI:
200.34 - fixes f :: "nat \<Rightarrow> 'a :: complete_lattice"
200.35 - shows "liminf f = (SUP n. INF m:{n..}. f m)"
200.36 +lemma liminf_SUPR_INFI: "liminf f = (SUP n. INF m:{n..}. f m)"
200.37 unfolding Liminf_def eventually_sequentially
200.38 by (rule SUPR_eq) (auto simp: atLeast_def intro!: INF_mono)
200.39
200.40 -lemma limsup_INFI_SUPR:
200.41 - fixes f :: "nat \<Rightarrow> 'a :: complete_lattice"
200.42 - shows "limsup f = (INF n. SUP m:{n..}. f m)"
200.43 +lemma limsup_INFI_SUPR: "limsup f = (INF n. SUP m:{n..}. f m)"
200.44 unfolding Limsup_def eventually_sequentially
200.45 by (rule INFI_eq) (auto simp: atLeast_def intro!: SUP_mono)
200.46
200.47 lemma Limsup_const:
200.48 assumes ntriv: "\<not> trivial_limit F"
200.49 - shows "Limsup F (\<lambda>x. c) = (c::'a::complete_lattice)"
200.50 + shows "Limsup F (\<lambda>x. c) = c"
200.51 proof -
200.52 have *: "\<And>P. Ex P \<longleftrightarrow> P \<noteq> (\<lambda>x. False)" by auto
200.53 have "\<And>P. eventually P F \<Longrightarrow> (SUP x : {x. P x}. c) = c"
200.54 @@ -77,7 +75,7 @@
200.55
200.56 lemma Liminf_const:
200.57 assumes ntriv: "\<not> trivial_limit F"
200.58 - shows "Liminf F (\<lambda>x. c) = (c::'a::complete_lattice)"
200.59 + shows "Liminf F (\<lambda>x. c) = c"
200.60 proof -
200.61 have *: "\<And>P. Ex P \<longleftrightarrow> P \<noteq> (\<lambda>x. False)" by auto
200.62 have "\<And>P. eventually P F \<Longrightarrow> (INF x : {x. P x}. c) = c"
200.63 @@ -89,7 +87,6 @@
200.64 qed
200.65
200.66 lemma Liminf_mono:
200.67 - fixes f g :: "'a => 'b :: complete_lattice"
200.68 assumes ev: "eventually (\<lambda>x. f x \<le> g x) F"
200.69 shows "Liminf F f \<le> Liminf F g"
200.70 unfolding Liminf_def
200.71 @@ -101,13 +98,11 @@
200.72 qed
200.73
200.74 lemma Liminf_eq:
200.75 - fixes f g :: "'a \<Rightarrow> 'b :: complete_lattice"
200.76 assumes "eventually (\<lambda>x. f x = g x) F"
200.77 shows "Liminf F f = Liminf F g"
200.78 by (intro antisym Liminf_mono eventually_mono[OF _ assms]) auto
200.79
200.80 lemma Limsup_mono:
200.81 - fixes f g :: "'a \<Rightarrow> 'b :: complete_lattice"
200.82 assumes ev: "eventually (\<lambda>x. f x \<le> g x) F"
200.83 shows "Limsup F f \<le> Limsup F g"
200.84 unfolding Limsup_def
200.85 @@ -119,18 +114,16 @@
200.86 qed
200.87
200.88 lemma Limsup_eq:
200.89 - fixes f g :: "'a \<Rightarrow> 'b :: complete_lattice"
200.90 assumes "eventually (\<lambda>x. f x = g x) net"
200.91 shows "Limsup net f = Limsup net g"
200.92 by (intro antisym Limsup_mono eventually_mono[OF _ assms]) auto
200.93
200.94 lemma Liminf_le_Limsup:
200.95 - fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
200.96 assumes ntriv: "\<not> trivial_limit F"
200.97 shows "Liminf F f \<le> Limsup F f"
200.98 unfolding Limsup_def Liminf_def
200.99 - apply (rule complete_lattice_class.SUP_least)
200.100 - apply (rule complete_lattice_class.INF_greatest)
200.101 + apply (rule SUP_least)
200.102 + apply (rule INF_greatest)
200.103 proof safe
200.104 fix P Q assume "eventually P F" "eventually Q F"
200.105 then have "eventually (\<lambda>x. P x \<and> Q x) F" (is "eventually ?C F") by (rule eventually_conj)
200.106 @@ -146,14 +139,12 @@
200.107 qed
200.108
200.109 lemma Liminf_bounded:
200.110 - fixes X Y :: "'a \<Rightarrow> 'b::complete_lattice"
200.111 assumes ntriv: "\<not> trivial_limit F"
200.112 assumes le: "eventually (\<lambda>n. C \<le> X n) F"
200.113 shows "C \<le> Liminf F X"
200.114 using Liminf_mono[OF le] Liminf_const[OF ntriv, of C] by simp
200.115
200.116 lemma Limsup_bounded:
200.117 - fixes X Y :: "'a \<Rightarrow> 'b::complete_lattice"
200.118 assumes ntriv: "\<not> trivial_limit F"
200.119 assumes le: "eventually (\<lambda>n. X n \<le> C) F"
200.120 shows "Limsup F X \<le> C"
201.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
201.2 +++ b/src/HOL/Library/Lubs_Glbs.thy Thu Dec 05 17:58:03 2013 +0100
201.3 @@ -0,0 +1,245 @@
201.4 +(* Title: HOL/Library/Lubs_Glbs.thy
201.5 + Author: Jacques D. Fleuriot, University of Cambridge
201.6 + Author: Amine Chaieb, University of Cambridge *)
201.7 +
201.8 +header {* Definitions of Least Upper Bounds and Greatest Lower Bounds *}
201.9 +
201.10 +theory Lubs_Glbs
201.11 +imports Complex_Main
201.12 +begin
201.13 +
201.14 +text {* Thanks to suggestions by James Margetson *}
201.15 +
201.16 +definition setle :: "'a set \<Rightarrow> 'a::ord \<Rightarrow> bool" (infixl "*<=" 70)
201.17 + where "S *<= x = (ALL y: S. y \<le> x)"
201.18 +
201.19 +definition setge :: "'a::ord \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "<=*" 70)
201.20 + where "x <=* S = (ALL y: S. x \<le> y)"
201.21 +
201.22 +
201.23 +subsection {* Rules for the Relations @{text "*<="} and @{text "<=*"} *}
201.24 +
201.25 +lemma setleI: "ALL y: S. y \<le> x \<Longrightarrow> S *<= x"
201.26 + by (simp add: setle_def)
201.27 +
201.28 +lemma setleD: "S *<= x \<Longrightarrow> y: S \<Longrightarrow> y \<le> x"
201.29 + by (simp add: setle_def)
201.30 +
201.31 +lemma setgeI: "ALL y: S. x \<le> y \<Longrightarrow> x <=* S"
201.32 + by (simp add: setge_def)
201.33 +
201.34 +lemma setgeD: "x <=* S \<Longrightarrow> y: S \<Longrightarrow> x \<le> y"
201.35 + by (simp add: setge_def)
201.36 +
201.37 +
201.38 +definition leastP :: "('a \<Rightarrow> bool) \<Rightarrow> 'a::ord \<Rightarrow> bool"
201.39 + where "leastP P x = (P x \<and> x <=* Collect P)"
201.40 +
201.41 +definition isUb :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
201.42 + where "isUb R S x = (S *<= x \<and> x: R)"
201.43 +
201.44 +definition isLub :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
201.45 + where "isLub R S x = leastP (isUb R S) x"
201.46 +
201.47 +definition ubs :: "'a set \<Rightarrow> 'a::ord set \<Rightarrow> 'a set"
201.48 + where "ubs R S = Collect (isUb R S)"
201.49 +
201.50 +
201.51 +subsection {* Rules about the Operators @{term leastP}, @{term ub} and @{term lub} *}
201.52 +
201.53 +lemma leastPD1: "leastP P x \<Longrightarrow> P x"
201.54 + by (simp add: leastP_def)
201.55 +
201.56 +lemma leastPD2: "leastP P x \<Longrightarrow> x <=* Collect P"
201.57 + by (simp add: leastP_def)
201.58 +
201.59 +lemma leastPD3: "leastP P x \<Longrightarrow> y: Collect P \<Longrightarrow> x \<le> y"
201.60 + by (blast dest!: leastPD2 setgeD)
201.61 +
201.62 +lemma isLubD1: "isLub R S x \<Longrightarrow> S *<= x"
201.63 + by (simp add: isLub_def isUb_def leastP_def)
201.64 +
201.65 +lemma isLubD1a: "isLub R S x \<Longrightarrow> x: R"
201.66 + by (simp add: isLub_def isUb_def leastP_def)
201.67 +
201.68 +lemma isLub_isUb: "isLub R S x \<Longrightarrow> isUb R S x"
201.69 + unfolding isUb_def by (blast dest: isLubD1 isLubD1a)
201.70 +
201.71 +lemma isLubD2: "isLub R S x \<Longrightarrow> y : S \<Longrightarrow> y \<le> x"
201.72 + by (blast dest!: isLubD1 setleD)
201.73 +
201.74 +lemma isLubD3: "isLub R S x \<Longrightarrow> leastP (isUb R S) x"
201.75 + by (simp add: isLub_def)
201.76 +
201.77 +lemma isLubI1: "leastP(isUb R S) x \<Longrightarrow> isLub R S x"
201.78 + by (simp add: isLub_def)
201.79 +
201.80 +lemma isLubI2: "isUb R S x \<Longrightarrow> x <=* Collect (isUb R S) \<Longrightarrow> isLub R S x"
201.81 + by (simp add: isLub_def leastP_def)
201.82 +
201.83 +lemma isUbD: "isUb R S x \<Longrightarrow> y : S \<Longrightarrow> y \<le> x"
201.84 + by (simp add: isUb_def setle_def)
201.85 +
201.86 +lemma isUbD2: "isUb R S x \<Longrightarrow> S *<= x"
201.87 + by (simp add: isUb_def)
201.88 +
201.89 +lemma isUbD2a: "isUb R S x \<Longrightarrow> x: R"
201.90 + by (simp add: isUb_def)
201.91 +
201.92 +lemma isUbI: "S *<= x \<Longrightarrow> x: R \<Longrightarrow> isUb R S x"
201.93 + by (simp add: isUb_def)
201.94 +
201.95 +lemma isLub_le_isUb: "isLub R S x \<Longrightarrow> isUb R S y \<Longrightarrow> x \<le> y"
201.96 + unfolding isLub_def by (blast intro!: leastPD3)
201.97 +
201.98 +lemma isLub_ubs: "isLub R S x \<Longrightarrow> x <=* ubs R S"
201.99 + unfolding ubs_def isLub_def by (rule leastPD2)
201.100 +
201.101 +lemma isLub_unique: "[| isLub R S x; isLub R S y |] ==> x = (y::'a::linorder)"
201.102 + apply (frule isLub_isUb)
201.103 + apply (frule_tac x = y in isLub_isUb)
201.104 + apply (blast intro!: order_antisym dest!: isLub_le_isUb)
201.105 + done
201.106 +
201.107 +lemma isUb_UNIV_I: "(\<And>y. y \<in> S \<Longrightarrow> y \<le> u) \<Longrightarrow> isUb UNIV S u"
201.108 + by (simp add: isUbI setleI)
201.109 +
201.110 +
201.111 +definition greatestP :: "('a \<Rightarrow> bool) \<Rightarrow> 'a::ord \<Rightarrow> bool"
201.112 + where "greatestP P x = (P x \<and> Collect P *<= x)"
201.113 +
201.114 +definition isLb :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
201.115 + where "isLb R S x = (x <=* S \<and> x: R)"
201.116 +
201.117 +definition isGlb :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
201.118 + where "isGlb R S x = greatestP (isLb R S) x"
201.119 +
201.120 +definition lbs :: "'a set \<Rightarrow> 'a::ord set \<Rightarrow> 'a set"
201.121 + where "lbs R S = Collect (isLb R S)"
201.122 +
201.123 +
201.124 +subsection {* Rules about the Operators @{term greatestP}, @{term isLb} and @{term isGlb} *}
201.125 +
201.126 +lemma greatestPD1: "greatestP P x \<Longrightarrow> P x"
201.127 + by (simp add: greatestP_def)
201.128 +
201.129 +lemma greatestPD2: "greatestP P x \<Longrightarrow> Collect P *<= x"
201.130 + by (simp add: greatestP_def)
201.131 +
201.132 +lemma greatestPD3: "greatestP P x \<Longrightarrow> y: Collect P \<Longrightarrow> x \<ge> y"
201.133 + by (blast dest!: greatestPD2 setleD)
201.134 +
201.135 +lemma isGlbD1: "isGlb R S x \<Longrightarrow> x <=* S"
201.136 + by (simp add: isGlb_def isLb_def greatestP_def)
201.137 +
201.138 +lemma isGlbD1a: "isGlb R S x \<Longrightarrow> x: R"
201.139 + by (simp add: isGlb_def isLb_def greatestP_def)
201.140 +
201.141 +lemma isGlb_isLb: "isGlb R S x \<Longrightarrow> isLb R S x"
201.142 + unfolding isLb_def by (blast dest: isGlbD1 isGlbD1a)
201.143 +
201.144 +lemma isGlbD2: "isGlb R S x \<Longrightarrow> y : S \<Longrightarrow> y \<ge> x"
201.145 + by (blast dest!: isGlbD1 setgeD)
201.146 +
201.147 +lemma isGlbD3: "isGlb R S x \<Longrightarrow> greatestP (isLb R S) x"
201.148 + by (simp add: isGlb_def)
201.149 +
201.150 +lemma isGlbI1: "greatestP (isLb R S) x \<Longrightarrow> isGlb R S x"
201.151 + by (simp add: isGlb_def)
201.152 +
201.153 +lemma isGlbI2: "isLb R S x \<Longrightarrow> Collect (isLb R S) *<= x \<Longrightarrow> isGlb R S x"
201.154 + by (simp add: isGlb_def greatestP_def)
201.155 +
201.156 +lemma isLbD: "isLb R S x \<Longrightarrow> y : S \<Longrightarrow> y \<ge> x"
201.157 + by (simp add: isLb_def setge_def)
201.158 +
201.159 +lemma isLbD2: "isLb R S x \<Longrightarrow> x <=* S "
201.160 + by (simp add: isLb_def)
201.161 +
201.162 +lemma isLbD2a: "isLb R S x \<Longrightarrow> x: R"
201.163 + by (simp add: isLb_def)
201.164 +
201.165 +lemma isLbI: "x <=* S \<Longrightarrow> x: R \<Longrightarrow> isLb R S x"
201.166 + by (simp add: isLb_def)
201.167 +
201.168 +lemma isGlb_le_isLb: "isGlb R S x \<Longrightarrow> isLb R S y \<Longrightarrow> x \<ge> y"
201.169 + unfolding isGlb_def by (blast intro!: greatestPD3)
201.170 +
201.171 +lemma isGlb_ubs: "isGlb R S x \<Longrightarrow> lbs R S *<= x"
201.172 + unfolding lbs_def isGlb_def by (rule greatestPD2)
201.173 +
201.174 +lemma isGlb_unique: "[| isGlb R S x; isGlb R S y |] ==> x = (y::'a::linorder)"
201.175 + apply (frule isGlb_isLb)
201.176 + apply (frule_tac x = y in isGlb_isLb)
201.177 + apply (blast intro!: order_antisym dest!: isGlb_le_isLb)
201.178 + done
201.179 +
201.180 +lemma bdd_above_setle: "bdd_above A \<longleftrightarrow> (\<exists>a. A *<= a)"
201.181 + by (auto simp: bdd_above_def setle_def)
201.182 +
201.183 +lemma bdd_below_setge: "bdd_below A \<longleftrightarrow> (\<exists>a. a <=* A)"
201.184 + by (auto simp: bdd_below_def setge_def)
201.185 +
201.186 +lemma isLub_cSup:
201.187 + "(S::'a :: conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> (\<exists>b. S *<= b) \<Longrightarrow> isLub UNIV S (Sup S)"
201.188 + by (auto simp add: isLub_def setle_def leastP_def isUb_def
201.189 + intro!: setgeI cSup_upper cSup_least)
201.190 +
201.191 +lemma isGlb_cInf:
201.192 + "(S::'a :: conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> (\<exists>b. b <=* S) \<Longrightarrow> isGlb UNIV S (Inf S)"
201.193 + by (auto simp add: isGlb_def setge_def greatestP_def isLb_def
201.194 + intro!: setleI cInf_lower cInf_greatest)
201.195 +
201.196 +lemma cSup_le: "(S::'a::conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> S *<= b \<Longrightarrow> Sup S \<le> b"
201.197 + by (metis cSup_least setle_def)
201.198 +
201.199 +lemma cInf_ge: "(S::'a :: conditionally_complete_lattice set) \<noteq> {} \<Longrightarrow> b <=* S \<Longrightarrow> Inf S \<ge> b"
201.200 + by (metis cInf_greatest setge_def)
201.201 +
201.202 +lemma cSup_bounds:
201.203 + fixes S :: "'a :: conditionally_complete_lattice set"
201.204 + shows "S \<noteq> {} \<Longrightarrow> a <=* S \<Longrightarrow> S *<= b \<Longrightarrow> a \<le> Sup S \<and> Sup S \<le> b"
201.205 + using cSup_least[of S b] cSup_upper2[of _ S a]
201.206 + by (auto simp: bdd_above_setle setge_def setle_def)
201.207 +
201.208 +lemma cSup_unique: "(S::'a :: {conditionally_complete_linorder, no_bot} set) *<= b \<Longrightarrow> (\<forall>b'<b. \<exists>x\<in>S. b' < x) \<Longrightarrow> Sup S = b"
201.209 + by (rule cSup_eq) (auto simp: not_le[symmetric] setle_def)
201.210 +
201.211 +lemma cInf_unique: "b <=* (S::'a :: {conditionally_complete_linorder, no_top} set) \<Longrightarrow> (\<forall>b'>b. \<exists>x\<in>S. b' > x) \<Longrightarrow> Inf S = b"
201.212 + by (rule cInf_eq) (auto simp: not_le[symmetric] setge_def)
201.213 +
201.214 +text{* Use completeness of reals (supremum property) to show that any bounded sequence has a least upper bound*}
201.215 +
201.216 +lemma reals_complete: "\<exists>X. X \<in> S \<Longrightarrow> \<exists>Y. isUb (UNIV::real set) S Y \<Longrightarrow> \<exists>t. isLub (UNIV :: real set) S t"
201.217 + by (intro exI[of _ "Sup S"] isLub_cSup) (auto simp: setle_def isUb_def intro!: cSup_upper)
201.218 +
201.219 +lemma Bseq_isUb: "\<And>X :: nat \<Rightarrow> real. Bseq X \<Longrightarrow> \<exists>U. isUb (UNIV::real set) {x. \<exists>n. X n = x} U"
201.220 + by (auto intro: isUbI setleI simp add: Bseq_def abs_le_iff)
201.221 +
201.222 +lemma Bseq_isLub: "\<And>X :: nat \<Rightarrow> real. Bseq X \<Longrightarrow> \<exists>U. isLub (UNIV::real set) {x. \<exists>n. X n = x} U"
201.223 + by (blast intro: reals_complete Bseq_isUb)
201.224 +
201.225 +lemma isLub_mono_imp_LIMSEQ:
201.226 + fixes X :: "nat \<Rightarrow> real"
201.227 + assumes u: "isLub UNIV {x. \<exists>n. X n = x} u" (* FIXME: use 'range X' *)
201.228 + assumes X: "\<forall>m n. m \<le> n \<longrightarrow> X m \<le> X n"
201.229 + shows "X ----> u"
201.230 +proof -
201.231 + have "X ----> (SUP i. X i)"
201.232 + using u[THEN isLubD1] X
201.233 + by (intro LIMSEQ_incseq_SUP) (auto simp: incseq_def image_def eq_commute bdd_above_setle)
201.234 + also have "(SUP i. X i) = u"
201.235 + using isLub_cSup[of "range X"] u[THEN isLubD1]
201.236 + by (intro isLub_unique[OF _ u]) (auto simp add: SUP_def image_def eq_commute)
201.237 + finally show ?thesis .
201.238 +qed
201.239 +
201.240 +lemmas real_isGlb_unique = isGlb_unique[where 'a=real]
201.241 +
201.242 +lemma real_le_inf_subset: "t \<noteq> {} \<Longrightarrow> t \<subseteq> s \<Longrightarrow> \<exists>b. b <=* s \<Longrightarrow> Inf s \<le> Inf (t::real set)"
201.243 + by (rule cInf_superset_mono) (auto simp: bdd_below_setge)
201.244 +
201.245 +lemma real_ge_sup_subset: "t \<noteq> {} \<Longrightarrow> t \<subseteq> s \<Longrightarrow> \<exists>b. s *<= b \<Longrightarrow> Sup s \<ge> Sup (t::real set)"
201.246 + by (rule cSup_subset_mono) (auto simp: bdd_above_setle)
201.247 +
201.248 +end
202.1 --- a/src/HOL/Library/Multiset.thy Thu Dec 05 17:52:12 2013 +0100
202.2 +++ b/src/HOL/Library/Multiset.thy Thu Dec 05 17:58:03 2013 +0100
202.3 @@ -1533,10 +1533,10 @@
202.4 qed
202.5 qed
202.6
202.7 -lemma all_accessible: "wf r ==> \<forall>M. M \<in> acc (mult1 r)"
202.8 +lemma all_accessible: "wf r ==> \<forall>M. M \<in> Wellfounded.acc (mult1 r)"
202.9 proof
202.10 let ?R = "mult1 r"
202.11 - let ?W = "acc ?R"
202.12 + let ?W = "Wellfounded.acc ?R"
202.13 {
202.14 fix M M0 a
202.15 assume M0: "M0 \<in> ?W"
203.1 --- a/src/HOL/Library/Order_Relation.thy Thu Dec 05 17:52:12 2013 +0100
203.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
203.3 @@ -1,116 +0,0 @@
203.4 -(* Author: Tobias Nipkow *)
203.5 -
203.6 -header {* Orders as Relations *}
203.7 -
203.8 -theory Order_Relation
203.9 -imports Main
203.10 -begin
203.11 -
203.12 -subsection{* Orders on a set *}
203.13 -
203.14 -definition "preorder_on A r \<equiv> refl_on A r \<and> trans r"
203.15 -
203.16 -definition "partial_order_on A r \<equiv> preorder_on A r \<and> antisym r"
203.17 -
203.18 -definition "linear_order_on A r \<equiv> partial_order_on A r \<and> total_on A r"
203.19 -
203.20 -definition "strict_linear_order_on A r \<equiv> trans r \<and> irrefl r \<and> total_on A r"
203.21 -
203.22 -definition "well_order_on A r \<equiv> linear_order_on A r \<and> wf(r - Id)"
203.23 -
203.24 -lemmas order_on_defs =
203.25 - preorder_on_def partial_order_on_def linear_order_on_def
203.26 - strict_linear_order_on_def well_order_on_def
203.27 -
203.28 -
203.29 -lemma preorder_on_empty[simp]: "preorder_on {} {}"
203.30 -by(simp add:preorder_on_def trans_def)
203.31 -
203.32 -lemma partial_order_on_empty[simp]: "partial_order_on {} {}"
203.33 -by(simp add:partial_order_on_def)
203.34 -
203.35 -lemma lnear_order_on_empty[simp]: "linear_order_on {} {}"
203.36 -by(simp add:linear_order_on_def)
203.37 -
203.38 -lemma well_order_on_empty[simp]: "well_order_on {} {}"
203.39 -by(simp add:well_order_on_def)
203.40 -
203.41 -
203.42 -lemma preorder_on_converse[simp]: "preorder_on A (r^-1) = preorder_on A r"
203.43 -by (simp add:preorder_on_def)
203.44 -
203.45 -lemma partial_order_on_converse[simp]:
203.46 - "partial_order_on A (r^-1) = partial_order_on A r"
203.47 -by (simp add: partial_order_on_def)
203.48 -
203.49 -lemma linear_order_on_converse[simp]:
203.50 - "linear_order_on A (r^-1) = linear_order_on A r"
203.51 -by (simp add: linear_order_on_def)
203.52 -
203.53 -
203.54 -lemma strict_linear_order_on_diff_Id:
203.55 - "linear_order_on A r \<Longrightarrow> strict_linear_order_on A (r-Id)"
203.56 -by(simp add: order_on_defs trans_diff_Id)
203.57 -
203.58 -
203.59 -subsection{* Orders on the field *}
203.60 -
203.61 -abbreviation "Refl r \<equiv> refl_on (Field r) r"
203.62 -
203.63 -abbreviation "Preorder r \<equiv> preorder_on (Field r) r"
203.64 -
203.65 -abbreviation "Partial_order r \<equiv> partial_order_on (Field r) r"
203.66 -
203.67 -abbreviation "Total r \<equiv> total_on (Field r) r"
203.68 -
203.69 -abbreviation "Linear_order r \<equiv> linear_order_on (Field r) r"
203.70 -
203.71 -abbreviation "Well_order r \<equiv> well_order_on (Field r) r"
203.72 -
203.73 -
203.74 -lemma subset_Image_Image_iff:
203.75 - "\<lbrakk> Preorder r; A \<subseteq> Field r; B \<subseteq> Field r\<rbrakk> \<Longrightarrow>
203.76 - r `` A \<subseteq> r `` B \<longleftrightarrow> (\<forall>a\<in>A.\<exists>b\<in>B. (b,a):r)"
203.77 -unfolding preorder_on_def refl_on_def Image_def
203.78 -apply (simp add: subset_eq)
203.79 -unfolding trans_def by fast
203.80 -
203.81 -lemma subset_Image1_Image1_iff:
203.82 - "\<lbrakk> Preorder r; a : Field r; b : Field r\<rbrakk> \<Longrightarrow> r `` {a} \<subseteq> r `` {b} \<longleftrightarrow> (b,a):r"
203.83 -by(simp add:subset_Image_Image_iff)
203.84 -
203.85 -lemma Refl_antisym_eq_Image1_Image1_iff:
203.86 - "\<lbrakk>Refl r; antisym r; a:Field r; b:Field r\<rbrakk> \<Longrightarrow> r `` {a} = r `` {b} \<longleftrightarrow> a=b"
203.87 -by(simp add: set_eq_iff antisym_def refl_on_def) metis
203.88 -
203.89 -lemma Partial_order_eq_Image1_Image1_iff:
203.90 - "\<lbrakk>Partial_order r; a:Field r; b:Field r\<rbrakk> \<Longrightarrow> r `` {a} = r `` {b} \<longleftrightarrow> a=b"
203.91 -by(auto simp:order_on_defs Refl_antisym_eq_Image1_Image1_iff)
203.92 -
203.93 -lemma Total_Id_Field:
203.94 -assumes TOT: "Total r" and NID: "\<not> (r <= Id)"
203.95 -shows "Field r = Field(r - Id)"
203.96 -using mono_Field[of "r - Id" r] Diff_subset[of r Id]
203.97 -proof(auto)
203.98 - have "r \<noteq> {}" using NID by fast
203.99 - then obtain b and c where "b \<noteq> c \<and> (b,c) \<in> r" using NID by fast
203.100 - hence 1: "b \<noteq> c \<and> {b,c} \<le> Field r" by (auto simp: Field_def)
203.101 - (* *)
203.102 - fix a assume *: "a \<in> Field r"
203.103 - obtain d where 2: "d \<in> Field r" and 3: "d \<noteq> a"
203.104 - using * 1 by auto
203.105 - hence "(a,d) \<in> r \<or> (d,a) \<in> r" using * TOT
203.106 - by (simp add: total_on_def)
203.107 - thus "a \<in> Field(r - Id)" using 3 unfolding Field_def by blast
203.108 -qed
203.109 -
203.110 -
203.111 -subsection{* Orders on a type *}
203.112 -
203.113 -abbreviation "strict_linear_order \<equiv> strict_linear_order_on UNIV"
203.114 -
203.115 -abbreviation "linear_order \<equiv> linear_order_on UNIV"
203.116 -
203.117 -abbreviation "well_order r \<equiv> well_order_on UNIV"
203.118 -
203.119 -end
204.1 --- a/src/HOL/Library/Order_Union.thy Thu Dec 05 17:52:12 2013 +0100
204.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
204.3 @@ -1,376 +0,0 @@
204.4 -(* Title: HOL/Library/Order_Union.thy
204.5 - Author: Andrei Popescu, TU Muenchen
204.6 -
204.7 -The ordinal-like sum of two orders with disjoint fields
204.8 -*)
204.9 -
204.10 -header {* Order Union *}
204.11 -
204.12 -theory Order_Union
204.13 -imports "~~/src/HOL/Cardinals/Wellfounded_More_Base"
204.14 -begin
204.15 -
204.16 -definition Osum :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" (infix "Osum" 60) where
204.17 - "r Osum r' = r \<union> r' \<union> {(a, a'). a \<in> Field r \<and> a' \<in> Field r'}"
204.18 -
204.19 -notation Osum (infix "\<union>o" 60)
204.20 -
204.21 -lemma Field_Osum: "Field (r \<union>o r') = Field r \<union> Field r'"
204.22 - unfolding Osum_def Field_def by blast
204.23 -
204.24 -lemma Osum_wf:
204.25 -assumes FLD: "Field r Int Field r' = {}" and
204.26 - WF: "wf r" and WF': "wf r'"
204.27 -shows "wf (r Osum r')"
204.28 -unfolding wf_eq_minimal2 unfolding Field_Osum
204.29 -proof(intro allI impI, elim conjE)
204.30 - fix A assume *: "A \<subseteq> Field r \<union> Field r'" and **: "A \<noteq> {}"
204.31 - obtain B where B_def: "B = A Int Field r" by blast
204.32 - show "\<exists>a\<in>A. \<forall>a'\<in>A. (a', a) \<notin> r \<union>o r'"
204.33 - proof(cases "B = {}")
204.34 - assume Case1: "B \<noteq> {}"
204.35 - hence "B \<noteq> {} \<and> B \<le> Field r" using B_def by auto
204.36 - then obtain a where 1: "a \<in> B" and 2: "\<forall>a1 \<in> B. (a1,a) \<notin> r"
204.37 - using WF unfolding wf_eq_minimal2 by blast
204.38 - hence 3: "a \<in> Field r \<and> a \<notin> Field r'" using B_def FLD by auto
204.39 - (* *)
204.40 - have "\<forall>a1 \<in> A. (a1,a) \<notin> r Osum r'"
204.41 - proof(intro ballI)
204.42 - fix a1 assume **: "a1 \<in> A"
204.43 - {assume Case11: "a1 \<in> Field r"
204.44 - hence "(a1,a) \<notin> r" using B_def ** 2 by auto
204.45 - moreover
204.46 - have "(a1,a) \<notin> r'" using 3 by (auto simp add: Field_def)
204.47 - ultimately have "(a1,a) \<notin> r Osum r'"
204.48 - using 3 unfolding Osum_def by auto
204.49 - }
204.50 - moreover
204.51 - {assume Case12: "a1 \<notin> Field r"
204.52 - hence "(a1,a) \<notin> r" unfolding Field_def by auto
204.53 - moreover
204.54 - have "(a1,a) \<notin> r'" using 3 unfolding Field_def by auto
204.55 - ultimately have "(a1,a) \<notin> r Osum r'"
204.56 - using 3 unfolding Osum_def by auto
204.57 - }
204.58 - ultimately show "(a1,a) \<notin> r Osum r'" by blast
204.59 - qed
204.60 - thus ?thesis using 1 B_def by auto
204.61 - next
204.62 - assume Case2: "B = {}"
204.63 - hence 1: "A \<noteq> {} \<and> A \<le> Field r'" using * ** B_def by auto
204.64 - then obtain a' where 2: "a' \<in> A" and 3: "\<forall>a1' \<in> A. (a1',a') \<notin> r'"
204.65 - using WF' unfolding wf_eq_minimal2 by blast
204.66 - hence 4: "a' \<in> Field r' \<and> a' \<notin> Field r" using 1 FLD by blast
204.67 - (* *)
204.68 - have "\<forall>a1' \<in> A. (a1',a') \<notin> r Osum r'"
204.69 - proof(unfold Osum_def, auto simp add: 3)
204.70 - fix a1' assume "(a1', a') \<in> r"
204.71 - thus False using 4 unfolding Field_def by blast
204.72 - next
204.73 - fix a1' assume "a1' \<in> A" and "a1' \<in> Field r"
204.74 - thus False using Case2 B_def by auto
204.75 - qed
204.76 - thus ?thesis using 2 by blast
204.77 - qed
204.78 -qed
204.79 -
204.80 -lemma Osum_Refl:
204.81 -assumes FLD: "Field r Int Field r' = {}" and
204.82 - REFL: "Refl r" and REFL': "Refl r'"
204.83 -shows "Refl (r Osum r')"
204.84 -using assms
204.85 -unfolding refl_on_def Field_Osum unfolding Osum_def by blast
204.86 -
204.87 -lemma Osum_trans:
204.88 -assumes FLD: "Field r Int Field r' = {}" and
204.89 - TRANS: "trans r" and TRANS': "trans r'"
204.90 -shows "trans (r Osum r')"
204.91 -proof(unfold trans_def, auto)
204.92 - fix x y z assume *: "(x, y) \<in> r \<union>o r'" and **: "(y, z) \<in> r \<union>o r'"
204.93 - show "(x, z) \<in> r \<union>o r'"
204.94 - proof-
204.95 - {assume Case1: "(x,y) \<in> r"
204.96 - hence 1: "x \<in> Field r \<and> y \<in> Field r" unfolding Field_def by auto
204.97 - have ?thesis
204.98 - proof-
204.99 - {assume Case11: "(y,z) \<in> r"
204.100 - hence "(x,z) \<in> r" using Case1 TRANS trans_def[of r] by blast
204.101 - hence ?thesis unfolding Osum_def by auto
204.102 - }
204.103 - moreover
204.104 - {assume Case12: "(y,z) \<in> r'"
204.105 - hence "y \<in> Field r'" unfolding Field_def by auto
204.106 - hence False using FLD 1 by auto
204.107 - }
204.108 - moreover
204.109 - {assume Case13: "z \<in> Field r'"
204.110 - hence ?thesis using 1 unfolding Osum_def by auto
204.111 - }
204.112 - ultimately show ?thesis using ** unfolding Osum_def by blast
204.113 - qed
204.114 - }
204.115 - moreover
204.116 - {assume Case2: "(x,y) \<in> r'"
204.117 - hence 2: "x \<in> Field r' \<and> y \<in> Field r'" unfolding Field_def by auto
204.118 - have ?thesis
204.119 - proof-
204.120 - {assume Case21: "(y,z) \<in> r"
204.121 - hence "y \<in> Field r" unfolding Field_def by auto
204.122 - hence False using FLD 2 by auto
204.123 - }
204.124 - moreover
204.125 - {assume Case22: "(y,z) \<in> r'"
204.126 - hence "(x,z) \<in> r'" using Case2 TRANS' trans_def[of r'] by blast
204.127 - hence ?thesis unfolding Osum_def by auto
204.128 - }
204.129 - moreover
204.130 - {assume Case23: "y \<in> Field r"
204.131 - hence False using FLD 2 by auto
204.132 - }
204.133 - ultimately show ?thesis using ** unfolding Osum_def by blast
204.134 - qed
204.135 - }
204.136 - moreover
204.137 - {assume Case3: "x \<in> Field r \<and> y \<in> Field r'"
204.138 - have ?thesis
204.139 - proof-
204.140 - {assume Case31: "(y,z) \<in> r"
204.141 - hence "y \<in> Field r" unfolding Field_def by auto
204.142 - hence False using FLD Case3 by auto
204.143 - }
204.144 - moreover
204.145 - {assume Case32: "(y,z) \<in> r'"
204.146 - hence "z \<in> Field r'" unfolding Field_def by blast
204.147 - hence ?thesis unfolding Osum_def using Case3 by auto
204.148 - }
204.149 - moreover
204.150 - {assume Case33: "y \<in> Field r"
204.151 - hence False using FLD Case3 by auto
204.152 - }
204.153 - ultimately show ?thesis using ** unfolding Osum_def by blast
204.154 - qed
204.155 - }
204.156 - ultimately show ?thesis using * unfolding Osum_def by blast
204.157 - qed
204.158 -qed
204.159 -
204.160 -lemma Osum_Preorder:
204.161 -"\<lbrakk>Field r Int Field r' = {}; Preorder r; Preorder r'\<rbrakk> \<Longrightarrow> Preorder (r Osum r')"
204.162 -unfolding preorder_on_def using Osum_Refl Osum_trans by blast
204.163 -
204.164 -lemma Osum_antisym:
204.165 -assumes FLD: "Field r Int Field r' = {}" and
204.166 - AN: "antisym r" and AN': "antisym r'"
204.167 -shows "antisym (r Osum r')"
204.168 -proof(unfold antisym_def, auto)
204.169 - fix x y assume *: "(x, y) \<in> r \<union>o r'" and **: "(y, x) \<in> r \<union>o r'"
204.170 - show "x = y"
204.171 - proof-
204.172 - {assume Case1: "(x,y) \<in> r"
204.173 - hence 1: "x \<in> Field r \<and> y \<in> Field r" unfolding Field_def by auto
204.174 - have ?thesis
204.175 - proof-
204.176 - have "(y,x) \<in> r \<Longrightarrow> ?thesis"
204.177 - using Case1 AN antisym_def[of r] by blast
204.178 - moreover
204.179 - {assume "(y,x) \<in> r'"
204.180 - hence "y \<in> Field r'" unfolding Field_def by auto
204.181 - hence False using FLD 1 by auto
204.182 - }
204.183 - moreover
204.184 - have "x \<in> Field r' \<Longrightarrow> False" using FLD 1 by auto
204.185 - ultimately show ?thesis using ** unfolding Osum_def by blast
204.186 - qed
204.187 - }
204.188 - moreover
204.189 - {assume Case2: "(x,y) \<in> r'"
204.190 - hence 2: "x \<in> Field r' \<and> y \<in> Field r'" unfolding Field_def by auto
204.191 - have ?thesis
204.192 - proof-
204.193 - {assume "(y,x) \<in> r"
204.194 - hence "y \<in> Field r" unfolding Field_def by auto
204.195 - hence False using FLD 2 by auto
204.196 - }
204.197 - moreover
204.198 - have "(y,x) \<in> r' \<Longrightarrow> ?thesis"
204.199 - using Case2 AN' antisym_def[of r'] by blast
204.200 - moreover
204.201 - {assume "y \<in> Field r"
204.202 - hence False using FLD 2 by auto
204.203 - }
204.204 - ultimately show ?thesis using ** unfolding Osum_def by blast
204.205 - qed
204.206 - }
204.207 - moreover
204.208 - {assume Case3: "x \<in> Field r \<and> y \<in> Field r'"
204.209 - have ?thesis
204.210 - proof-
204.211 - {assume "(y,x) \<in> r"
204.212 - hence "y \<in> Field r" unfolding Field_def by auto
204.213 - hence False using FLD Case3 by auto
204.214 - }
204.215 - moreover
204.216 - {assume Case32: "(y,x) \<in> r'"
204.217 - hence "x \<in> Field r'" unfolding Field_def by blast
204.218 - hence False using FLD Case3 by auto
204.219 - }
204.220 - moreover
204.221 - have "\<not> y \<in> Field r" using FLD Case3 by auto
204.222 - ultimately show ?thesis using ** unfolding Osum_def by blast
204.223 - qed
204.224 - }
204.225 - ultimately show ?thesis using * unfolding Osum_def by blast
204.226 - qed
204.227 -qed
204.228 -
204.229 -lemma Osum_Partial_order:
204.230 -"\<lbrakk>Field r Int Field r' = {}; Partial_order r; Partial_order r'\<rbrakk> \<Longrightarrow>
204.231 - Partial_order (r Osum r')"
204.232 -unfolding partial_order_on_def using Osum_Preorder Osum_antisym by blast
204.233 -
204.234 -lemma Osum_Total:
204.235 -assumes FLD: "Field r Int Field r' = {}" and
204.236 - TOT: "Total r" and TOT': "Total r'"
204.237 -shows "Total (r Osum r')"
204.238 -using assms
204.239 -unfolding total_on_def Field_Osum unfolding Osum_def by blast
204.240 -
204.241 -lemma Osum_Linear_order:
204.242 -"\<lbrakk>Field r Int Field r' = {}; Linear_order r; Linear_order r'\<rbrakk> \<Longrightarrow>
204.243 - Linear_order (r Osum r')"
204.244 -unfolding linear_order_on_def using Osum_Partial_order Osum_Total by blast
204.245 -
204.246 -lemma Osum_minus_Id1:
204.247 -assumes "r \<le> Id"
204.248 -shows "(r Osum r') - Id \<le> (r' - Id) \<union> (Field r \<times> Field r')"
204.249 -proof-
204.250 - let ?Left = "(r Osum r') - Id"
204.251 - let ?Right = "(r' - Id) \<union> (Field r \<times> Field r')"
204.252 - {fix a::'a and b assume *: "(a,b) \<notin> Id"
204.253 - {assume "(a,b) \<in> r"
204.254 - with * have False using assms by auto
204.255 - }
204.256 - moreover
204.257 - {assume "(a,b) \<in> r'"
204.258 - with * have "(a,b) \<in> r' - Id" by auto
204.259 - }
204.260 - ultimately
204.261 - have "(a,b) \<in> ?Left \<Longrightarrow> (a,b) \<in> ?Right"
204.262 - unfolding Osum_def by auto
204.263 - }
204.264 - thus ?thesis by auto
204.265 -qed
204.266 -
204.267 -lemma Osum_minus_Id2:
204.268 -assumes "r' \<le> Id"
204.269 -shows "(r Osum r') - Id \<le> (r - Id) \<union> (Field r \<times> Field r')"
204.270 -proof-
204.271 - let ?Left = "(r Osum r') - Id"
204.272 - let ?Right = "(r - Id) \<union> (Field r \<times> Field r')"
204.273 - {fix a::'a and b assume *: "(a,b) \<notin> Id"
204.274 - {assume "(a,b) \<in> r'"
204.275 - with * have False using assms by auto
204.276 - }
204.277 - moreover
204.278 - {assume "(a,b) \<in> r"
204.279 - with * have "(a,b) \<in> r - Id" by auto
204.280 - }
204.281 - ultimately
204.282 - have "(a,b) \<in> ?Left \<Longrightarrow> (a,b) \<in> ?Right"
204.283 - unfolding Osum_def by auto
204.284 - }
204.285 - thus ?thesis by auto
204.286 -qed
204.287 -
204.288 -lemma Osum_minus_Id:
204.289 -assumes TOT: "Total r" and TOT': "Total r'" and
204.290 - NID: "\<not> (r \<le> Id)" and NID': "\<not> (r' \<le> Id)"
204.291 -shows "(r Osum r') - Id \<le> (r - Id) Osum (r' - Id)"
204.292 -proof-
204.293 - {fix a a' assume *: "(a,a') \<in> (r Osum r')" and **: "a \<noteq> a'"
204.294 - have "(a,a') \<in> (r - Id) Osum (r' - Id)"
204.295 - proof-
204.296 - {assume "(a,a') \<in> r \<or> (a,a') \<in> r'"
204.297 - with ** have ?thesis unfolding Osum_def by auto
204.298 - }
204.299 - moreover
204.300 - {assume "a \<in> Field r \<and> a' \<in> Field r'"
204.301 - hence "a \<in> Field(r - Id) \<and> a' \<in> Field (r' - Id)"
204.302 - using assms Total_Id_Field by blast
204.303 - hence ?thesis unfolding Osum_def by auto
204.304 - }
204.305 - ultimately show ?thesis using * unfolding Osum_def by blast
204.306 - qed
204.307 - }
204.308 - thus ?thesis by(auto simp add: Osum_def)
204.309 -qed
204.310 -
204.311 -lemma wf_Int_Times:
204.312 -assumes "A Int B = {}"
204.313 -shows "wf(A \<times> B)"
204.314 -proof(unfold wf_def, auto)
204.315 - fix P x
204.316 - assume *: "\<forall>x. (\<forall>y. y \<in> A \<and> x \<in> B \<longrightarrow> P y) \<longrightarrow> P x"
204.317 - moreover have "\<forall>y \<in> A. P y" using assms * by blast
204.318 - ultimately show "P x" using * by (case_tac "x \<in> B", auto)
204.319 -qed
204.320 -
204.321 -lemma Osum_wf_Id:
204.322 -assumes TOT: "Total r" and TOT': "Total r'" and
204.323 - FLD: "Field r Int Field r' = {}" and
204.324 - WF: "wf(r - Id)" and WF': "wf(r' - Id)"
204.325 -shows "wf ((r Osum r') - Id)"
204.326 -proof(cases "r \<le> Id \<or> r' \<le> Id")
204.327 - assume Case1: "\<not>(r \<le> Id \<or> r' \<le> Id)"
204.328 - have "Field(r - Id) Int Field(r' - Id) = {}"
204.329 - using FLD mono_Field[of "r - Id" r] mono_Field[of "r' - Id" r']
204.330 - Diff_subset[of r Id] Diff_subset[of r' Id] by blast
204.331 - thus ?thesis
204.332 - using Case1 Osum_minus_Id[of r r'] assms Osum_wf[of "r - Id" "r' - Id"]
204.333 - wf_subset[of "(r - Id) \<union>o (r' - Id)" "(r Osum r') - Id"] by auto
204.334 -next
204.335 - have 1: "wf(Field r \<times> Field r')"
204.336 - using FLD by (auto simp add: wf_Int_Times)
204.337 - assume Case2: "r \<le> Id \<or> r' \<le> Id"
204.338 - moreover
204.339 - {assume Case21: "r \<le> Id"
204.340 - hence "(r Osum r') - Id \<le> (r' - Id) \<union> (Field r \<times> Field r')"
204.341 - using Osum_minus_Id1[of r r'] by simp
204.342 - moreover
204.343 - {have "Domain(Field r \<times> Field r') Int Range(r' - Id) = {}"
204.344 - using FLD unfolding Field_def by blast
204.345 - hence "wf((r' - Id) \<union> (Field r \<times> Field r'))"
204.346 - using 1 WF' wf_Un[of "Field r \<times> Field r'" "r' - Id"]
204.347 - by (auto simp add: Un_commute)
204.348 - }
204.349 - ultimately have ?thesis by (auto simp add: wf_subset)
204.350 - }
204.351 - moreover
204.352 - {assume Case22: "r' \<le> Id"
204.353 - hence "(r Osum r') - Id \<le> (r - Id) \<union> (Field r \<times> Field r')"
204.354 - using Osum_minus_Id2[of r' r] by simp
204.355 - moreover
204.356 - {have "Range(Field r \<times> Field r') Int Domain(r - Id) = {}"
204.357 - using FLD unfolding Field_def by blast
204.358 - hence "wf((r - Id) \<union> (Field r \<times> Field r'))"
204.359 - using 1 WF wf_Un[of "r - Id" "Field r \<times> Field r'"]
204.360 - by (auto simp add: Un_commute)
204.361 - }
204.362 - ultimately have ?thesis by (auto simp add: wf_subset)
204.363 - }
204.364 - ultimately show ?thesis by blast
204.365 -qed
204.366 -
204.367 -lemma Osum_Well_order:
204.368 -assumes FLD: "Field r Int Field r' = {}" and
204.369 - WELL: "Well_order r" and WELL': "Well_order r'"
204.370 -shows "Well_order (r Osum r')"
204.371 -proof-
204.372 - have "Total r \<and> Total r'" using WELL WELL'
204.373 - by (auto simp add: order_on_defs)
204.374 - thus ?thesis using assms unfolding well_order_on_def
204.375 - using Osum_Linear_order Osum_wf_Id by blast
204.376 -qed
204.377 -
204.378 -end
204.379 -
205.1 --- a/src/HOL/Library/Polynomial.thy Thu Dec 05 17:52:12 2013 +0100
205.2 +++ b/src/HOL/Library/Polynomial.thy Thu Dec 05 17:58:03 2013 +0100
205.3 @@ -667,7 +667,7 @@
205.4 show "- p + p = 0"
205.5 by (simp add: poly_eq_iff)
205.6 show "p - q = p + - q"
205.7 - by (simp add: poly_eq_iff diff_minus)
205.8 + by (simp add: poly_eq_iff)
205.9 qed
205.10
205.11 end
205.12 @@ -714,15 +714,15 @@
205.13
205.14 lemma degree_diff_le_max: "degree (p - q) \<le> max (degree p) (degree q)"
205.15 using degree_add_le [where p=p and q="-q"]
205.16 - by (simp add: diff_minus)
205.17 + by simp
205.18
205.19 lemma degree_diff_le:
205.20 "\<lbrakk>degree p \<le> n; degree q \<le> n\<rbrakk> \<Longrightarrow> degree (p - q) \<le> n"
205.21 - by (simp add: diff_minus degree_add_le)
205.22 + using degree_add_le [of p n "- q"] by simp
205.23
205.24 lemma degree_diff_less:
205.25 "\<lbrakk>degree p < n; degree q < n\<rbrakk> \<Longrightarrow> degree (p - q) < n"
205.26 - by (simp add: diff_minus degree_add_less)
205.27 + using degree_add_less [of p n "- q"] by simp
205.28
205.29 lemma add_monom: "monom a n + monom b n = monom (a + b) n"
205.30 by (rule poly_eqI) simp
205.31 @@ -793,7 +793,7 @@
205.32 lemma poly_diff [simp]:
205.33 fixes x :: "'a::comm_ring"
205.34 shows "poly (p - q) x = poly p x - poly q x"
205.35 - by (simp add: diff_minus)
205.36 + using poly_add [of p "- q" x] by simp
205.37
205.38 lemma poly_setsum: "poly (\<Sum>k\<in>A. p k) x = (\<Sum>k\<in>A. poly (p k) x)"
205.39 by (induct A rule: infinite_finite_induct) simp_all
205.40 @@ -1575,12 +1575,12 @@
205.41 lemma poly_div_minus_left [simp]:
205.42 fixes x y :: "'a::field poly"
205.43 shows "(- x) div y = - (x div y)"
205.44 - using div_smult_left [of "- 1::'a"] by (simp del: minus_one) (* FIXME *)
205.45 + using div_smult_left [of "- 1::'a"] by simp
205.46
205.47 lemma poly_mod_minus_left [simp]:
205.48 fixes x y :: "'a::field poly"
205.49 shows "(- x) mod y = - (x mod y)"
205.50 - using mod_smult_left [of "- 1::'a"] by (simp del: minus_one) (* FIXME *)
205.51 + using mod_smult_left [of "- 1::'a"] by simp
205.52
205.53 lemma pdivmod_rel_smult_right:
205.54 "\<lbrakk>a \<noteq> 0; pdivmod_rel x y q r\<rbrakk>
205.55 @@ -1597,13 +1597,12 @@
205.56 lemma poly_div_minus_right [simp]:
205.57 fixes x y :: "'a::field poly"
205.58 shows "x div (- y) = - (x div y)"
205.59 - using div_smult_right [of "- 1::'a"]
205.60 - by (simp add: nonzero_inverse_minus_eq del: minus_one) (* FIXME *)
205.61 + using div_smult_right [of "- 1::'a"] by (simp add: nonzero_inverse_minus_eq)
205.62
205.63 lemma poly_mod_minus_right [simp]:
205.64 fixes x y :: "'a::field poly"
205.65 shows "x mod (- y) = x mod y"
205.66 - using mod_smult_right [of "- 1::'a"] by (simp del: minus_one) (* FIXME *)
205.67 + using mod_smult_right [of "- 1::'a"] by simp
205.68
205.69 lemma pdivmod_rel_mult:
205.70 "\<lbrakk>pdivmod_rel x y q r; pdivmod_rel q z q' r'\<rbrakk>
206.1 --- a/src/HOL/Library/Predicate_Compile_Alternative_Defs.thy Thu Dec 05 17:52:12 2013 +0100
206.2 +++ b/src/HOL/Library/Predicate_Compile_Alternative_Defs.thy Thu Dec 05 17:58:03 2013 +0100
206.3 @@ -45,8 +45,8 @@
206.4
206.5 section {* Setup for Numerals *}
206.6
206.7 -setup {* Predicate_Compile_Data.ignore_consts [@{const_name numeral}, @{const_name neg_numeral}] *}
206.8 -setup {* Predicate_Compile_Data.keep_functions [@{const_name numeral}, @{const_name neg_numeral}] *}
206.9 +setup {* Predicate_Compile_Data.ignore_consts [@{const_name numeral}] *}
206.10 +setup {* Predicate_Compile_Data.keep_functions [@{const_name numeral}] *}
206.11
206.12 setup {* Predicate_Compile_Data.ignore_consts [@{const_name div}, @{const_name mod}, @{const_name times}] *}
206.13
207.1 --- a/src/HOL/Library/Prefix_Order.thy Thu Dec 05 17:52:12 2013 +0100
207.2 +++ b/src/HOL/Library/Prefix_Order.thy Thu Dec 05 17:58:03 2013 +0100
207.3 @@ -5,7 +5,7 @@
207.4 header {* Prefix order on lists as order class instance *}
207.5
207.6 theory Prefix_Order
207.7 -imports Sublist
207.8 +imports List_Prefix
207.9 begin
207.10
207.11 instantiation list :: (type) order
208.1 --- a/src/HOL/Library/Product_plus.thy Thu Dec 05 17:52:12 2013 +0100
208.2 +++ b/src/HOL/Library/Product_plus.thy Thu Dec 05 17:58:03 2013 +0100
208.3 @@ -104,7 +104,7 @@
208.4 (cancel_comm_monoid_add, cancel_comm_monoid_add) cancel_comm_monoid_add ..
208.5
208.6 instance prod :: (group_add, group_add) group_add
208.7 - by default (simp_all add: prod_eq_iff diff_minus)
208.8 + by default (simp_all add: prod_eq_iff)
208.9
208.10 instance prod :: (ab_group_add, ab_group_add) ab_group_add
208.11 by default (simp_all add: prod_eq_iff)
209.1 --- a/src/HOL/Library/RBT_Set.thy Thu Dec 05 17:52:12 2013 +0100
209.2 +++ b/src/HOL/Library/RBT_Set.thy Thu Dec 05 17:58:03 2013 +0100
209.3 @@ -756,7 +756,8 @@
209.4 declare Inf_Set_fold[folded Inf'_def, code]
209.5
209.6 lemma INFI_Set_fold [code]:
209.7 - "INFI (Set t) f = fold_keys (inf \<circ> f) t top"
209.8 + fixes f :: "_ \<Rightarrow> 'a::complete_lattice"
209.9 + shows "INFI (Set t) f = fold_keys (inf \<circ> f) t top"
209.10 proof -
209.11 have "comp_fun_commute ((inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a) \<circ> f)"
209.12 by default (auto simp add: fun_eq_iff ac_simps)
209.13 @@ -796,7 +797,8 @@
209.14 declare Sup_Set_fold[folded Sup'_def, code]
209.15
209.16 lemma SUPR_Set_fold [code]:
209.17 - "SUPR (Set t) f = fold_keys (sup \<circ> f) t bot"
209.18 + fixes f :: "_ \<Rightarrow> 'a::complete_lattice"
209.19 + shows "SUPR (Set t) f = fold_keys (sup \<circ> f) t bot"
209.20 proof -
209.21 have "comp_fun_commute ((sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a) \<circ> f)"
209.22 by default (auto simp add: fun_eq_iff ac_simps)
210.1 --- a/src/HOL/Library/Ramsey.thy Thu Dec 05 17:52:12 2013 +0100
210.2 +++ b/src/HOL/Library/Ramsey.thy Thu Dec 05 17:58:03 2013 +0100
210.3 @@ -247,7 +247,7 @@
210.4 then obtain s' and n'
210.5 where s': "s' = ?gt n'"
210.6 and infeqs': "infinite {n. ?gt n = s'}"
210.7 - by (rule inf_img_fin_domE) (auto simp add: vimage_def intro: nat_infinite)
210.8 + by (rule inf_img_fin_domE) (auto simp add: vimage_def intro: infinite_UNIV_nat)
210.9 with pg [of n'] have less': "s'<s" by (cases "g n'") auto
210.10 have inj_gy: "inj ?gy"
210.11 proof (rule linorder_injI)
210.12 @@ -410,7 +410,7 @@
210.13 have
210.14 "\<exists>K k. K \<subseteq> UNIV & infinite K & k < n &
210.15 (\<forall>i\<in>K. \<forall>j\<in>K. i\<noteq>j --> transition_idx s T {i,j} = k)"
210.16 - by (rule Ramsey2) (auto intro: trless nat_infinite)
210.17 + by (rule Ramsey2) (auto intro: trless infinite_UNIV_nat)
210.18 then obtain K and k
210.19 where infK: "infinite K" and less: "k < n" and
210.20 allk: "\<forall>i\<in>K. \<forall>j\<in>K. i\<noteq>j --> transition_idx s T {i,j} = k"
211.1 --- a/src/HOL/Library/Refute.thy Thu Dec 05 17:52:12 2013 +0100
211.2 +++ b/src/HOL/Library/Refute.thy Thu Dec 05 17:58:03 2013 +0100
211.3 @@ -8,7 +8,7 @@
211.4 header {* Refute *}
211.5
211.6 theory Refute
211.7 -imports Hilbert_Choice List Sledgehammer
211.8 +imports Main
211.9 keywords "refute" :: diag and "refute_params" :: thy_decl
211.10 begin
211.11
212.1 --- a/src/HOL/Library/Set_Algebras.thy Thu Dec 05 17:52:12 2013 +0100
212.2 +++ b/src/HOL/Library/Set_Algebras.thy Thu Dec 05 17:58:03 2013 +0100
212.3 @@ -190,12 +190,12 @@
212.4 done
212.5
212.6 lemma set_plus_imp_minus: "(a::'a::ab_group_add) : b +o C ==> (a - b) : C"
212.7 - by (auto simp add: elt_set_plus_def add_ac diff_minus)
212.8 + by (auto simp add: elt_set_plus_def add_ac)
212.9
212.10 lemma set_minus_imp_plus: "(a::'a::ab_group_add) - b : C ==> a : b +o C"
212.11 - apply (auto simp add: elt_set_plus_def add_ac diff_minus)
212.12 + apply (auto simp add: elt_set_plus_def add_ac)
212.13 apply (subgoal_tac "a = (a + - b) + b")
212.14 - apply (rule bexI, assumption, assumption)
212.15 + apply (rule bexI, assumption)
212.16 apply (auto simp add: add_ac)
212.17 done
212.18
213.1 --- a/src/HOL/Library/Sublist.thy Thu Dec 05 17:52:12 2013 +0100
213.2 +++ b/src/HOL/Library/Sublist.thy Thu Dec 05 17:58:03 2013 +0100
213.3 @@ -3,192 +3,12 @@
213.4 Author: Christian Sternagel, JAIST
213.5 *)
213.6
213.7 -header {* List prefixes, suffixes, and homeomorphic embedding *}
213.8 +header {* Parallel lists, list suffixes, and homeomorphic embedding *}
213.9
213.10 theory Sublist
213.11 imports Main
213.12 begin
213.13
213.14 -subsection {* Prefix order on lists *}
213.15 -
213.16 -definition prefixeq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
213.17 - where "prefixeq xs ys \<longleftrightarrow> (\<exists>zs. ys = xs @ zs)"
213.18 -
213.19 -definition prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
213.20 - where "prefix xs ys \<longleftrightarrow> prefixeq xs ys \<and> xs \<noteq> ys"
213.21 -
213.22 -interpretation prefix_order: order prefixeq prefix
213.23 - by default (auto simp: prefixeq_def prefix_def)
213.24 -
213.25 -interpretation prefix_bot: order_bot Nil prefixeq prefix
213.26 - by default (simp add: prefixeq_def)
213.27 -
213.28 -lemma prefixeqI [intro?]: "ys = xs @ zs \<Longrightarrow> prefixeq xs ys"
213.29 - unfolding prefixeq_def by blast
213.30 -
213.31 -lemma prefixeqE [elim?]:
213.32 - assumes "prefixeq xs ys"
213.33 - obtains zs where "ys = xs @ zs"
213.34 - using assms unfolding prefixeq_def by blast
213.35 -
213.36 -lemma prefixI' [intro?]: "ys = xs @ z # zs \<Longrightarrow> prefix xs ys"
213.37 - unfolding prefix_def prefixeq_def by blast
213.38 -
213.39 -lemma prefixE' [elim?]:
213.40 - assumes "prefix xs ys"
213.41 - obtains z zs where "ys = xs @ z # zs"
213.42 -proof -
213.43 - from `prefix xs ys` obtain us where "ys = xs @ us" and "xs \<noteq> ys"
213.44 - unfolding prefix_def prefixeq_def by blast
213.45 - with that show ?thesis by (auto simp add: neq_Nil_conv)
213.46 -qed
213.47 -
213.48 -lemma prefixI [intro?]: "prefixeq xs ys \<Longrightarrow> xs \<noteq> ys \<Longrightarrow> prefix xs ys"
213.49 - unfolding prefix_def by blast
213.50 -
213.51 -lemma prefixE [elim?]:
213.52 - fixes xs ys :: "'a list"
213.53 - assumes "prefix xs ys"
213.54 - obtains "prefixeq xs ys" and "xs \<noteq> ys"
213.55 - using assms unfolding prefix_def by blast
213.56 -
213.57 -
213.58 -subsection {* Basic properties of prefixes *}
213.59 -
213.60 -theorem Nil_prefixeq [iff]: "prefixeq [] xs"
213.61 - by (simp add: prefixeq_def)
213.62 -
213.63 -theorem prefixeq_Nil [simp]: "(prefixeq xs []) = (xs = [])"
213.64 - by (induct xs) (simp_all add: prefixeq_def)
213.65 -
213.66 -lemma prefixeq_snoc [simp]: "prefixeq xs (ys @ [y]) \<longleftrightarrow> xs = ys @ [y] \<or> prefixeq xs ys"
213.67 -proof
213.68 - assume "prefixeq xs (ys @ [y])"
213.69 - then obtain zs where zs: "ys @ [y] = xs @ zs" ..
213.70 - show "xs = ys @ [y] \<or> prefixeq xs ys"
213.71 - by (metis append_Nil2 butlast_append butlast_snoc prefixeqI zs)
213.72 -next
213.73 - assume "xs = ys @ [y] \<or> prefixeq xs ys"
213.74 - then show "prefixeq xs (ys @ [y])"
213.75 - by (metis prefix_order.eq_iff prefix_order.order_trans prefixeqI)
213.76 -qed
213.77 -
213.78 -lemma Cons_prefixeq_Cons [simp]: "prefixeq (x # xs) (y # ys) = (x = y \<and> prefixeq xs ys)"
213.79 - by (auto simp add: prefixeq_def)
213.80 -
213.81 -lemma prefixeq_code [code]:
213.82 - "prefixeq [] xs \<longleftrightarrow> True"
213.83 - "prefixeq (x # xs) [] \<longleftrightarrow> False"
213.84 - "prefixeq (x # xs) (y # ys) \<longleftrightarrow> x = y \<and> prefixeq xs ys"
213.85 - by simp_all
213.86 -
213.87 -lemma same_prefixeq_prefixeq [simp]: "prefixeq (xs @ ys) (xs @ zs) = prefixeq ys zs"
213.88 - by (induct xs) simp_all
213.89 -
213.90 -lemma same_prefixeq_nil [iff]: "prefixeq (xs @ ys) xs = (ys = [])"
213.91 - by (metis append_Nil2 append_self_conv prefix_order.eq_iff prefixeqI)
213.92 -
213.93 -lemma prefixeq_prefixeq [simp]: "prefixeq xs ys \<Longrightarrow> prefixeq xs (ys @ zs)"
213.94 - by (metis prefix_order.le_less_trans prefixeqI prefixE prefixI)
213.95 -
213.96 -lemma append_prefixeqD: "prefixeq (xs @ ys) zs \<Longrightarrow> prefixeq xs zs"
213.97 - by (auto simp add: prefixeq_def)
213.98 -
213.99 -theorem prefixeq_Cons: "prefixeq xs (y # ys) = (xs = [] \<or> (\<exists>zs. xs = y # zs \<and> prefixeq zs ys))"
213.100 - by (cases xs) (auto simp add: prefixeq_def)
213.101 -
213.102 -theorem prefixeq_append:
213.103 - "prefixeq xs (ys @ zs) = (prefixeq xs ys \<or> (\<exists>us. xs = ys @ us \<and> prefixeq us zs))"
213.104 - apply (induct zs rule: rev_induct)
213.105 - apply force
213.106 - apply (simp del: append_assoc add: append_assoc [symmetric])
213.107 - apply (metis append_eq_appendI)
213.108 - done
213.109 -
213.110 -lemma append_one_prefixeq:
213.111 - "prefixeq xs ys \<Longrightarrow> length xs < length ys \<Longrightarrow> prefixeq (xs @ [ys ! length xs]) ys"
213.112 - unfolding prefixeq_def
213.113 - by (metis Cons_eq_appendI append_eq_appendI append_eq_conv_conj
213.114 - eq_Nil_appendI nth_drop')
213.115 -
213.116 -theorem prefixeq_length_le: "prefixeq xs ys \<Longrightarrow> length xs \<le> length ys"
213.117 - by (auto simp add: prefixeq_def)
213.118 -
213.119 -lemma prefixeq_same_cases:
213.120 - "prefixeq (xs\<^sub>1::'a list) ys \<Longrightarrow> prefixeq xs\<^sub>2 ys \<Longrightarrow> prefixeq xs\<^sub>1 xs\<^sub>2 \<or> prefixeq xs\<^sub>2 xs\<^sub>1"
213.121 - unfolding prefixeq_def by (metis append_eq_append_conv2)
213.122 -
213.123 -lemma set_mono_prefixeq: "prefixeq xs ys \<Longrightarrow> set xs \<subseteq> set ys"
213.124 - by (auto simp add: prefixeq_def)
213.125 -
213.126 -lemma take_is_prefixeq: "prefixeq (take n xs) xs"
213.127 - unfolding prefixeq_def by (metis append_take_drop_id)
213.128 -
213.129 -lemma map_prefixeqI: "prefixeq xs ys \<Longrightarrow> prefixeq (map f xs) (map f ys)"
213.130 - by (auto simp: prefixeq_def)
213.131 -
213.132 -lemma prefixeq_length_less: "prefix xs ys \<Longrightarrow> length xs < length ys"
213.133 - by (auto simp: prefix_def prefixeq_def)
213.134 -
213.135 -lemma prefix_simps [simp, code]:
213.136 - "prefix xs [] \<longleftrightarrow> False"
213.137 - "prefix [] (x # xs) \<longleftrightarrow> True"
213.138 - "prefix (x # xs) (y # ys) \<longleftrightarrow> x = y \<and> prefix xs ys"
213.139 - by (simp_all add: prefix_def cong: conj_cong)
213.140 -
213.141 -lemma take_prefix: "prefix xs ys \<Longrightarrow> prefix (take n xs) ys"
213.142 - apply (induct n arbitrary: xs ys)
213.143 - apply (case_tac ys, simp_all)[1]
213.144 - apply (metis prefix_order.less_trans prefixI take_is_prefixeq)
213.145 - done
213.146 -
213.147 -lemma not_prefixeq_cases:
213.148 - assumes pfx: "\<not> prefixeq ps ls"
213.149 - obtains
213.150 - (c1) "ps \<noteq> []" and "ls = []"
213.151 - | (c2) a as x xs where "ps = a#as" and "ls = x#xs" and "x = a" and "\<not> prefixeq as xs"
213.152 - | (c3) a as x xs where "ps = a#as" and "ls = x#xs" and "x \<noteq> a"
213.153 -proof (cases ps)
213.154 - case Nil
213.155 - then show ?thesis using pfx by simp
213.156 -next
213.157 - case (Cons a as)
213.158 - note c = `ps = a#as`
213.159 - show ?thesis
213.160 - proof (cases ls)
213.161 - case Nil then show ?thesis by (metis append_Nil2 pfx c1 same_prefixeq_nil)
213.162 - next
213.163 - case (Cons x xs)
213.164 - show ?thesis
213.165 - proof (cases "x = a")
213.166 - case True
213.167 - have "\<not> prefixeq as xs" using pfx c Cons True by simp
213.168 - with c Cons True show ?thesis by (rule c2)
213.169 - next
213.170 - case False
213.171 - with c Cons show ?thesis by (rule c3)
213.172 - qed
213.173 - qed
213.174 -qed
213.175 -
213.176 -lemma not_prefixeq_induct [consumes 1, case_names Nil Neq Eq]:
213.177 - assumes np: "\<not> prefixeq ps ls"
213.178 - and base: "\<And>x xs. P (x#xs) []"
213.179 - and r1: "\<And>x xs y ys. x \<noteq> y \<Longrightarrow> P (x#xs) (y#ys)"
213.180 - and r2: "\<And>x xs y ys. \<lbrakk> x = y; \<not> prefixeq xs ys; P xs ys \<rbrakk> \<Longrightarrow> P (x#xs) (y#ys)"
213.181 - shows "P ps ls" using np
213.182 -proof (induct ls arbitrary: ps)
213.183 - case Nil then show ?case
213.184 - by (auto simp: neq_Nil_conv elim!: not_prefixeq_cases intro!: base)
213.185 -next
213.186 - case (Cons y ys)
213.187 - then have npfx: "\<not> prefixeq ps (y # ys)" by simp
213.188 - then obtain x xs where pv: "ps = x # xs"
213.189 - by (rule not_prefixeq_cases) auto
213.190 - show ?case by (metis Cons.hyps Cons_prefixeq_Cons npfx pv r1 r2)
213.191 -qed
213.192 -
213.193 -
213.194 subsection {* Parallel lists *}
213.195
213.196 definition parallel :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "\<parallel>" 50)
213.197 @@ -224,9 +44,9 @@
213.198 then show ?thesis by (metis append_Nil2 parallelE prefixeqI snoc.prems ys)
213.199 next
213.200 fix c cs assume ys': "ys' = c # cs"
213.201 - then show ?thesis
213.202 - by (metis Cons_eq_appendI eq_Nil_appendI parallelE prefixeqI
213.203 - same_prefixeq_prefixeq snoc.prems ys)
213.204 + have "x \<noteq> c" using snoc.prems ys ys' by fastforce
213.205 + thus "\<exists>as b bs c cs. b \<noteq> c \<and> xs @ [x] = as @ b # bs \<and> ys = as @ c # cs"
213.206 + using ys ys' by blast
213.207 qed
213.208 next
213.209 assume "prefix ys xs"
213.210 @@ -464,7 +284,7 @@
213.211 then show ?case by (metis append_Cons)
213.212 next
213.213 case (list_hembeq_Cons2 x y xs ys)
213.214 - then show ?case by (cases xs) (auto, blast+)
213.215 + then show ?case by blast
213.216 qed
213.217
213.218 lemma list_hembeq_appendD:
213.219 @@ -475,9 +295,14 @@
213.220 case Nil then show ?case by auto
213.221 next
213.222 case (Cons x xs)
213.223 - then obtain us v vs where "zs = us @ v # vs"
213.224 - and "P\<^sup>=\<^sup>= x v" and "list_hembeq P (xs @ ys) vs" by (auto dest: list_hembeq_ConsD)
213.225 - with Cons show ?case by (metis append_Cons append_assoc list_hembeq_Cons2 list_hembeq_append2)
213.226 + then obtain us v vs where
213.227 + zs: "zs = us @ v # vs" and p: "P\<^sup>=\<^sup>= x v" and lh: "list_hembeq P (xs @ ys) vs"
213.228 + by (auto dest: list_hembeq_ConsD)
213.229 + obtain sk\<^sub>0 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" and sk\<^sub>1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
213.230 + sk: "\<forall>x\<^sub>0 x\<^sub>1. \<not> list_hembeq P (xs @ x\<^sub>0) x\<^sub>1 \<or> sk\<^sub>0 x\<^sub>0 x\<^sub>1 @ sk\<^sub>1 x\<^sub>0 x\<^sub>1 = x\<^sub>1 \<and> list_hembeq P xs (sk\<^sub>0 x\<^sub>0 x\<^sub>1) \<and> list_hembeq P x\<^sub>0 (sk\<^sub>1 x\<^sub>0 x\<^sub>1)"
213.231 + using Cons(1) by (metis (no_types))
213.232 + hence "\<forall>x\<^sub>2. list_hembeq P (x # xs) (x\<^sub>2 @ v # sk\<^sub>0 ys vs)" using p lh by auto
213.233 + thus ?case using lh zs sk by (metis (no_types) append_Cons append_assoc)
213.234 qed
213.235
213.236 lemma list_hembeq_suffix:
213.237 @@ -550,7 +375,7 @@
213.238 by (simp_all)
213.239
213.240 lemma sublisteq_Cons': "sublisteq (x#xs) ys \<Longrightarrow> sublisteq xs ys"
213.241 - by (induct xs) (auto dest: list_hembeq_ConsD)
213.242 + by (induct xs, simp, blast dest: list_hembeq_ConsD)
213.243
213.244 lemma sublisteq_Cons2':
213.245 assumes "sublisteq (x#xs) (x#ys)" shows "sublisteq xs ys"
213.246 @@ -579,11 +404,11 @@
213.247 from list_hembeq_Nil2 [OF this] show ?case by simp
213.248 next
213.249 case list_hembeq_Cons2
213.250 - then show ?case by simp
213.251 + thus ?case by simp
213.252 next
213.253 case list_hembeq_Cons
213.254 - then show ?case
213.255 - by (metis sublisteq_Cons' list_hembeq_length Suc_length_conv Suc_n_not_le_n)
213.256 + hence False using sublisteq_Cons' by fastforce
213.257 + thus ?case ..
213.258 qed
213.259
213.260 lemma sublisteq_trans: "sublisteq xs ys \<Longrightarrow> sublisteq ys zs \<Longrightarrow> sublisteq xs zs"
213.261 @@ -650,7 +475,7 @@
213.262
213.263 lemma sublisteq_filter [simp]:
213.264 assumes "sublisteq xs ys" shows "sublisteq (filter P xs) (filter P ys)"
213.265 - using assms by (induct) auto
213.266 + using assms by induct auto
213.267
213.268 lemma "sublisteq xs ys \<longleftrightarrow> (\<exists>N. xs = sublist ys N)" (is "?L = ?R")
213.269 proof
214.1 --- a/src/HOL/Library/Sum_of_Squares/sum_of_squares.ML Thu Dec 05 17:52:12 2013 +0100
214.2 +++ b/src/HOL/Library/Sum_of_Squares/sum_of_squares.ML Thu Dec 05 17:58:03 2013 +0100
214.3 @@ -875,7 +875,6 @@
214.4 @{term "0::real"}, @{term "1::real"},
214.5 @{term "numeral :: num => nat"},
214.6 @{term "numeral :: num => real"},
214.7 - @{term "neg_numeral :: num => real"},
214.8 @{term "Num.Bit0"}, @{term "Num.Bit1"}, @{term "Num.One"}];
214.9
214.10 fun check_sos kcts ct =
215.1 --- a/src/HOL/Library/Univ_Poly.thy Thu Dec 05 17:52:12 2013 +0100
215.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
215.3 @@ -1,1053 +0,0 @@
215.4 -(* Title: HOL/Library/Univ_Poly.thy
215.5 - Author: Amine Chaieb
215.6 -*)
215.7 -
215.8 -header {* Univariate Polynomials *}
215.9 -
215.10 -theory Univ_Poly
215.11 -imports Main
215.12 -begin
215.13 -
215.14 -text{* Application of polynomial as a function. *}
215.15 -
215.16 -primrec (in semiring_0) poly :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a"
215.17 -where
215.18 - poly_Nil: "poly [] x = 0"
215.19 -| poly_Cons: "poly (h#t) x = h + x * poly t x"
215.20 -
215.21 -
215.22 -subsection{*Arithmetic Operations on Polynomials*}
215.23 -
215.24 -text{*addition*}
215.25 -
215.26 -primrec (in semiring_0) padd :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "+++" 65)
215.27 -where
215.28 - padd_Nil: "[] +++ l2 = l2"
215.29 -| padd_Cons: "(h#t) +++ l2 = (if l2 = [] then h#t else (h + hd l2)#(t +++ tl l2))"
215.30 -
215.31 -text{*Multiplication by a constant*}
215.32 -primrec (in semiring_0) cmult :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "%*" 70) where
215.33 - cmult_Nil: "c %* [] = []"
215.34 -| cmult_Cons: "c %* (h#t) = (c * h)#(c %* t)"
215.35 -
215.36 -text{*Multiplication by a polynomial*}
215.37 -primrec (in semiring_0) pmult :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixl "***" 70)
215.38 -where
215.39 - pmult_Nil: "[] *** l2 = []"
215.40 -| pmult_Cons: "(h#t) *** l2 = (if t = [] then h %* l2
215.41 - else (h %* l2) +++ ((0) # (t *** l2)))"
215.42 -
215.43 -text{*Repeated multiplication by a polynomial*}
215.44 -primrec (in semiring_0) mulexp :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
215.45 - mulexp_zero: "mulexp 0 p q = q"
215.46 -| mulexp_Suc: "mulexp (Suc n) p q = p *** mulexp n p q"
215.47 -
215.48 -text{*Exponential*}
215.49 -primrec (in semiring_1) pexp :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" (infixl "%^" 80) where
215.50 - pexp_0: "p %^ 0 = [1]"
215.51 -| pexp_Suc: "p %^ (Suc n) = p *** (p %^ n)"
215.52 -
215.53 -text{*Quotient related value of dividing a polynomial by x + a*}
215.54 -(* Useful for divisor properties in inductive proofs *)
215.55 -primrec (in field) "pquot" :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list"
215.56 -where
215.57 - pquot_Nil: "pquot [] a= []"
215.58 -| pquot_Cons: "pquot (h#t) a =
215.59 - (if t = [] then [h] else (inverse(a) * (h - hd( pquot t a)))#(pquot t a))"
215.60 -
215.61 -text{*normalization of polynomials (remove extra 0 coeff)*}
215.62 -primrec (in semiring_0) pnormalize :: "'a list \<Rightarrow> 'a list" where
215.63 - pnormalize_Nil: "pnormalize [] = []"
215.64 -| pnormalize_Cons: "pnormalize (h#p) =
215.65 - (if pnormalize p = [] then (if h = 0 then [] else [h]) else h # pnormalize p)"
215.66 -
215.67 -definition (in semiring_0) "pnormal p = ((pnormalize p = p) \<and> p \<noteq> [])"
215.68 -definition (in semiring_0) "nonconstant p = (pnormal p \<and> (\<forall>x. p \<noteq> [x]))"
215.69 -text{*Other definitions*}
215.70 -
215.71 -definition (in ring_1) poly_minus :: "'a list \<Rightarrow> 'a list" ("-- _" [80] 80)
215.72 - where "-- p = (- 1) %* p"
215.73 -
215.74 -definition (in semiring_0) divides :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "divides" 70)
215.75 - where "p1 divides p2 = (\<exists>q. poly p2 = poly(p1 *** q))"
215.76 -
215.77 -lemma (in semiring_0) dividesI:
215.78 - "poly p2 = poly (p1 *** q) \<Longrightarrow> p1 divides p2"
215.79 - by (auto simp add: divides_def)
215.80 -
215.81 -lemma (in semiring_0) dividesE:
215.82 - assumes "p1 divides p2"
215.83 - obtains q where "poly p2 = poly (p1 *** q)"
215.84 - using assms by (auto simp add: divides_def)
215.85 -
215.86 - --{*order of a polynomial*}
215.87 -definition (in ring_1) order :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
215.88 - "order a p = (SOME n. ([-a, 1] %^ n) divides p \<and> ~ (([-a, 1] %^ (Suc n)) divides p))"
215.89 -
215.90 - --{*degree of a polynomial*}
215.91 -definition (in semiring_0) degree :: "'a list \<Rightarrow> nat"
215.92 - where "degree p = length (pnormalize p) - 1"
215.93 -
215.94 - --{*squarefree polynomials --- NB with respect to real roots only.*}
215.95 -definition (in ring_1) rsquarefree :: "'a list \<Rightarrow> bool"
215.96 - where "rsquarefree p \<longleftrightarrow> poly p \<noteq> poly [] \<and> (\<forall>a. order a p = 0 \<or> order a p = 1)"
215.97 -
215.98 -context semiring_0
215.99 -begin
215.100 -
215.101 -lemma padd_Nil2[simp]: "p +++ [] = p"
215.102 - by (induct p) auto
215.103 -
215.104 -lemma padd_Cons_Cons: "(h1 # p1) +++ (h2 # p2) = (h1 + h2) # (p1 +++ p2)"
215.105 - by auto
215.106 -
215.107 -lemma pminus_Nil: "-- [] = []"
215.108 - by (simp add: poly_minus_def)
215.109 -
215.110 -lemma pmult_singleton: "[h1] *** p1 = h1 %* p1" by simp
215.111 -
215.112 -end
215.113 -
215.114 -lemma (in semiring_1) poly_ident_mult[simp]: "1 %* t = t" by (induct t) auto
215.115 -
215.116 -lemma (in semiring_0) poly_simple_add_Cons[simp]: "[a] +++ ((0)#t) = (a#t)"
215.117 - by simp
215.118 -
215.119 -text{*Handy general properties*}
215.120 -
215.121 -lemma (in comm_semiring_0) padd_commut: "b +++ a = a +++ b"
215.122 -proof (induct b arbitrary: a)
215.123 - case Nil
215.124 - thus ?case by auto
215.125 -next
215.126 - case (Cons b bs a)
215.127 - thus ?case by (cases a) (simp_all add: add_commute)
215.128 -qed
215.129 -
215.130 -lemma (in comm_semiring_0) padd_assoc: "\<forall>b c. (a +++ b) +++ c = a +++ (b +++ c)"
215.131 - apply (induct a)
215.132 - apply (simp, clarify)
215.133 - apply (case_tac b, simp_all add: add_ac)
215.134 - done
215.135 -
215.136 -lemma (in semiring_0) poly_cmult_distr: "a %* ( p +++ q) = (a %* p +++ a %* q)"
215.137 - apply (induct p arbitrary: q)
215.138 - apply simp
215.139 - apply (case_tac q, simp_all add: distrib_left)
215.140 - done
215.141 -
215.142 -lemma (in ring_1) pmult_by_x[simp]: "[0, 1] *** t = ((0)#t)"
215.143 - apply (induct t)
215.144 - apply simp
215.145 - apply (auto simp add: padd_commut)
215.146 - apply (case_tac t, auto)
215.147 - done
215.148 -
215.149 -text{*properties of evaluation of polynomials.*}
215.150 -
215.151 -lemma (in semiring_0) poly_add: "poly (p1 +++ p2) x = poly p1 x + poly p2 x"
215.152 -proof(induct p1 arbitrary: p2)
215.153 - case Nil
215.154 - thus ?case by simp
215.155 -next
215.156 - case (Cons a as p2)
215.157 - thus ?case
215.158 - by (cases p2) (simp_all add: add_ac distrib_left)
215.159 -qed
215.160 -
215.161 -lemma (in comm_semiring_0) poly_cmult: "poly (c %* p) x = c * poly p x"
215.162 - apply (induct p)
215.163 - apply (case_tac [2] "x = zero")
215.164 - apply (auto simp add: distrib_left mult_ac)
215.165 - done
215.166 -
215.167 -lemma (in comm_semiring_0) poly_cmult_map: "poly (map (op * c) p) x = c*poly p x"
215.168 - by (induct p) (auto simp add: distrib_left mult_ac)
215.169 -
215.170 -lemma (in comm_ring_1) poly_minus: "poly (-- p) x = - (poly p x)"
215.171 - apply (simp add: poly_minus_def)
215.172 - apply (auto simp add: poly_cmult)
215.173 - done
215.174 -
215.175 -lemma (in comm_semiring_0) poly_mult: "poly (p1 *** p2) x = poly p1 x * poly p2 x"
215.176 -proof (induct p1 arbitrary: p2)
215.177 - case Nil
215.178 - thus ?case by simp
215.179 -next
215.180 - case (Cons a as p2)
215.181 - thus ?case by (cases as)
215.182 - (simp_all add: poly_cmult poly_add distrib_right distrib_left mult_ac)
215.183 -qed
215.184 -
215.185 -class idom_char_0 = idom + ring_char_0
215.186 -
215.187 -lemma (in comm_ring_1) poly_exp: "poly (p %^ n) x = (poly p x) ^ n"
215.188 - by (induct n) (auto simp add: poly_cmult poly_mult)
215.189 -
215.190 -text{*More Polynomial Evaluation Lemmas*}
215.191 -
215.192 -lemma (in semiring_0) poly_add_rzero[simp]: "poly (a +++ []) x = poly a x"
215.193 - by simp
215.194 -
215.195 -lemma (in comm_semiring_0) poly_mult_assoc: "poly ((a *** b) *** c) x = poly (a *** (b *** c)) x"
215.196 - by (simp add: poly_mult mult_assoc)
215.197 -
215.198 -lemma (in semiring_0) poly_mult_Nil2[simp]: "poly (p *** []) x = 0"
215.199 - by (induct p) auto
215.200 -
215.201 -lemma (in comm_semiring_1) poly_exp_add: "poly (p %^ (n + d)) x = poly( p %^ n *** p %^ d) x"
215.202 - by (induct n) (auto simp add: poly_mult mult_assoc)
215.203 -
215.204 -subsection{*Key Property: if @{term "f(a) = 0"} then @{term "(x - a)"} divides
215.205 - @{term "p(x)"} *}
215.206 -
215.207 -lemma (in comm_ring_1) lemma_poly_linear_rem: "\<forall>h. \<exists>q r. h#t = [r] +++ [-a, 1] *** q"
215.208 -proof(induct t)
215.209 - case Nil
215.210 - { fix h have "[h] = [h] +++ [- a, 1] *** []" by simp }
215.211 - thus ?case by blast
215.212 -next
215.213 - case (Cons x xs)
215.214 - { fix h
215.215 - from Cons.hyps[rule_format, of x]
215.216 - obtain q r where qr: "x#xs = [r] +++ [- a, 1] *** q" by blast
215.217 - have "h#x#xs = [a*r + h] +++ [-a, 1] *** (r#q)"
215.218 - using qr by (cases q) (simp_all add: algebra_simps)
215.219 - hence "\<exists>q r. h#x#xs = [r] +++ [-a, 1] *** q" by blast}
215.220 - thus ?case by blast
215.221 -qed
215.222 -
215.223 -lemma (in comm_ring_1) poly_linear_rem: "\<exists>q r. h#t = [r] +++ [-a, 1] *** q"
215.224 - using lemma_poly_linear_rem [where t = t and a = a] by auto
215.225 -
215.226 -
215.227 -lemma (in comm_ring_1) poly_linear_divides: "(poly p a = 0) = ((p = []) | (\<exists>q. p = [-a, 1] *** q))"
215.228 -proof -
215.229 - { assume p: "p = []" hence ?thesis by simp }
215.230 - moreover
215.231 - {
215.232 - fix x xs assume p: "p = x#xs"
215.233 - {
215.234 - fix q assume "p = [-a, 1] *** q"
215.235 - hence "poly p a = 0" by (simp add: poly_add poly_cmult)
215.236 - }
215.237 - moreover
215.238 - { assume p0: "poly p a = 0"
215.239 - from poly_linear_rem[of x xs a] obtain q r
215.240 - where qr: "x#xs = [r] +++ [- a, 1] *** q" by blast
215.241 - have "r = 0" using p0 by (simp only: p qr poly_mult poly_add) simp
215.242 - hence "\<exists>q. p = [- a, 1] *** q"
215.243 - using p qr
215.244 - apply -
215.245 - apply (rule exI[where x=q])
215.246 - apply auto
215.247 - apply (cases q)
215.248 - apply auto
215.249 - done
215.250 - }
215.251 - ultimately have ?thesis using p by blast
215.252 - }
215.253 - ultimately show ?thesis by (cases p) auto
215.254 -qed
215.255 -
215.256 -lemma (in semiring_0) lemma_poly_length_mult[simp]: "\<forall>h k a. length (k %* p +++ (h # (a %* p))) = Suc (length p)"
215.257 - by (induct p) auto
215.258 -
215.259 -lemma (in semiring_0) lemma_poly_length_mult2[simp]: "\<forall>h k. length (k %* p +++ (h # p)) = Suc (length p)"
215.260 - by (induct p) auto
215.261 -
215.262 -lemma (in ring_1) poly_length_mult[simp]: "length([-a,1] *** q) = Suc (length q)"
215.263 - by auto
215.264 -
215.265 -subsection{*Polynomial length*}
215.266 -
215.267 -lemma (in semiring_0) poly_cmult_length[simp]: "length (a %* p) = length p"
215.268 - by (induct p) auto
215.269 -
215.270 -lemma (in semiring_0) poly_add_length: "length (p1 +++ p2) = max (length p1) (length p2)"
215.271 - by (induct p1 arbitrary: p2) (simp_all, arith)
215.272 -
215.273 -lemma (in semiring_0) poly_root_mult_length[simp]: "length([a,b] *** p) = Suc (length p)"
215.274 - by (simp add: poly_add_length)
215.275 -
215.276 -lemma (in idom) poly_mult_not_eq_poly_Nil[simp]:
215.277 - "poly (p *** q) x \<noteq> poly [] x \<longleftrightarrow> poly p x \<noteq> poly [] x \<and> poly q x \<noteq> poly [] x"
215.278 - by (auto simp add: poly_mult)
215.279 -
215.280 -lemma (in idom) poly_mult_eq_zero_disj: "poly (p *** q) x = 0 \<longleftrightarrow> poly p x = 0 \<or> poly q x = 0"
215.281 - by (auto simp add: poly_mult)
215.282 -
215.283 -text{*Normalisation Properties*}
215.284 -
215.285 -lemma (in semiring_0) poly_normalized_nil: "(pnormalize p = []) --> (poly p x = 0)"
215.286 - by (induct p) auto
215.287 -
215.288 -text{*A nontrivial polynomial of degree n has no more than n roots*}
215.289 -lemma (in idom) poly_roots_index_lemma:
215.290 - assumes p: "poly p x \<noteq> poly [] x" and n: "length p = n"
215.291 - shows "\<exists>i. \<forall>x. poly p x = 0 \<longrightarrow> (\<exists>m\<le>n. x = i m)"
215.292 - using p n
215.293 -proof (induct n arbitrary: p x)
215.294 - case 0
215.295 - thus ?case by simp
215.296 -next
215.297 - case (Suc n p x)
215.298 - {
215.299 - assume C: "\<And>i. \<exists>x. poly p x = 0 \<and> (\<forall>m\<le>Suc n. x \<noteq> i m)"
215.300 - from Suc.prems have p0: "poly p x \<noteq> 0" "p\<noteq> []" by auto
215.301 - from p0(1)[unfolded poly_linear_divides[of p x]]
215.302 - have "\<forall>q. p \<noteq> [- x, 1] *** q" by blast
215.303 - from C obtain a where a: "poly p a = 0" by blast
215.304 - from a[unfolded poly_linear_divides[of p a]] p0(2)
215.305 - obtain q where q: "p = [-a, 1] *** q" by blast
215.306 - have lg: "length q = n" using q Suc.prems(2) by simp
215.307 - from q p0 have qx: "poly q x \<noteq> poly [] x"
215.308 - by (auto simp add: poly_mult poly_add poly_cmult)
215.309 - from Suc.hyps[OF qx lg] obtain i where
215.310 - i: "\<forall>x. poly q x = 0 \<longrightarrow> (\<exists>m\<le>n. x = i m)" by blast
215.311 - let ?i = "\<lambda>m. if m = Suc n then a else i m"
215.312 - from C[of ?i] obtain y where y: "poly p y = 0" "\<forall>m\<le> Suc n. y \<noteq> ?i m"
215.313 - by blast
215.314 - from y have "y = a \<or> poly q y = 0"
215.315 - by (simp only: q poly_mult_eq_zero_disj poly_add) (simp add: algebra_simps)
215.316 - with i[rule_format, of y] y(1) y(2) have False
215.317 - apply auto
215.318 - apply (erule_tac x = "m" in allE)
215.319 - apply auto
215.320 - done
215.321 - }
215.322 - thus ?case by blast
215.323 -qed
215.324 -
215.325 -
215.326 -lemma (in idom) poly_roots_index_length:
215.327 - "poly p x \<noteq> poly [] x \<Longrightarrow> \<exists>i. \<forall>x. (poly p x = 0) \<longrightarrow> (\<exists>n. n \<le> length p \<and> x = i n)"
215.328 - by (blast intro: poly_roots_index_lemma)
215.329 -
215.330 -lemma (in idom) poly_roots_finite_lemma1:
215.331 - "poly p x \<noteq> poly [] x \<Longrightarrow> \<exists>N i. \<forall>x. (poly p x = 0) \<longrightarrow> (\<exists>n. (n::nat) < N \<and> x = i n)"
215.332 - apply (drule poly_roots_index_length, safe)
215.333 - apply (rule_tac x = "Suc (length p)" in exI)
215.334 - apply (rule_tac x = i in exI)
215.335 - apply (simp add: less_Suc_eq_le)
215.336 - done
215.337 -
215.338 -lemma (in idom) idom_finite_lemma:
215.339 - assumes P: "\<forall>x. P x --> (\<exists>n. n < length j \<and> x = j!n)"
215.340 - shows "finite {x. P x}"
215.341 -proof -
215.342 - let ?M = "{x. P x}"
215.343 - let ?N = "set j"
215.344 - have "?M \<subseteq> ?N" using P by auto
215.345 - thus ?thesis using finite_subset by auto
215.346 -qed
215.347 -
215.348 -lemma (in idom) poly_roots_finite_lemma2:
215.349 - "poly p x \<noteq> poly [] x \<Longrightarrow> \<exists>i. \<forall>x. poly p x = 0 \<longrightarrow> x \<in> set i"
215.350 - apply (drule poly_roots_index_length, safe)
215.351 - apply (rule_tac x="map (\<lambda>n. i n) [0 ..< Suc (length p)]" in exI)
215.352 - apply (auto simp add: image_iff)
215.353 - apply (erule_tac x="x" in allE, clarsimp)
215.354 - apply (case_tac "n = length p")
215.355 - apply (auto simp add: order_le_less)
215.356 - done
215.357 -
215.358 -lemma (in ring_char_0) UNIV_ring_char_0_infinte: "\<not> (finite (UNIV:: 'a set))"
215.359 -proof
215.360 - assume F: "finite (UNIV :: 'a set)"
215.361 - have "finite (UNIV :: nat set)"
215.362 - proof (rule finite_imageD)
215.363 - have "of_nat ` UNIV \<subseteq> UNIV" by simp
215.364 - then show "finite (of_nat ` UNIV :: 'a set)" using F by (rule finite_subset)
215.365 - show "inj (of_nat :: nat \<Rightarrow> 'a)" by (simp add: inj_on_def)
215.366 - qed
215.367 - with infinite_UNIV_nat show False ..
215.368 -qed
215.369 -
215.370 -lemma (in idom_char_0) poly_roots_finite: "poly p \<noteq> poly [] \<longleftrightarrow> finite {x. poly p x = 0}"
215.371 -proof
215.372 - assume H: "poly p \<noteq> poly []"
215.373 - show "finite {x. poly p x = (0::'a)}"
215.374 - using H
215.375 - apply -
215.376 - apply (erule contrapos_np, rule ext)
215.377 - apply (rule ccontr)
215.378 - apply (clarify dest!: poly_roots_finite_lemma2)
215.379 - using finite_subset
215.380 - proof -
215.381 - fix x i
215.382 - assume F: "\<not> finite {x. poly p x = (0\<Colon>'a)}"
215.383 - and P: "\<forall>x. poly p x = (0\<Colon>'a) \<longrightarrow> x \<in> set i"
215.384 - let ?M= "{x. poly p x = (0\<Colon>'a)}"
215.385 - from P have "?M \<subseteq> set i" by auto
215.386 - with finite_subset F show False by auto
215.387 - qed
215.388 -next
215.389 - assume F: "finite {x. poly p x = (0\<Colon>'a)}"
215.390 - show "poly p \<noteq> poly []" using F UNIV_ring_char_0_infinte by auto
215.391 -qed
215.392 -
215.393 -text{*Entirety and Cancellation for polynomials*}
215.394 -
215.395 -lemma (in idom_char_0) poly_entire_lemma2:
215.396 - assumes p0: "poly p \<noteq> poly []"
215.397 - and q0: "poly q \<noteq> poly []"
215.398 - shows "poly (p***q) \<noteq> poly []"
215.399 -proof -
215.400 - let ?S = "\<lambda>p. {x. poly p x = 0}"
215.401 - have "?S (p *** q) = ?S p \<union> ?S q" by (auto simp add: poly_mult)
215.402 - with p0 q0 show ?thesis unfolding poly_roots_finite by auto
215.403 -qed
215.404 -
215.405 -lemma (in idom_char_0) poly_entire:
215.406 - "poly (p *** q) = poly [] \<longleftrightarrow> poly p = poly [] \<or> poly q = poly []"
215.407 - using poly_entire_lemma2[of p q]
215.408 - by (auto simp add: fun_eq_iff poly_mult)
215.409 -
215.410 -lemma (in idom_char_0) poly_entire_neg:
215.411 - "poly (p *** q) \<noteq> poly [] \<longleftrightarrow> poly p \<noteq> poly [] \<and> poly q \<noteq> poly []"
215.412 - by (simp add: poly_entire)
215.413 -
215.414 -lemma fun_eq: "f = g \<longleftrightarrow> (\<forall>x. f x = g x)"
215.415 - by auto
215.416 -
215.417 -lemma (in comm_ring_1) poly_add_minus_zero_iff:
215.418 - "poly (p +++ -- q) = poly [] \<longleftrightarrow> poly p = poly q"
215.419 - by (auto simp add: algebra_simps poly_add poly_minus_def fun_eq poly_cmult)
215.420 -
215.421 -lemma (in comm_ring_1) poly_add_minus_mult_eq:
215.422 - "poly (p *** q +++ --(p *** r)) = poly (p *** (q +++ -- r))"
215.423 - by (auto simp add: poly_add poly_minus_def fun_eq poly_mult poly_cmult distrib_left)
215.424 -
215.425 -subclass (in idom_char_0) comm_ring_1 ..
215.426 -
215.427 -lemma (in idom_char_0) poly_mult_left_cancel:
215.428 - "poly (p *** q) = poly (p *** r) \<longleftrightarrow> poly p = poly [] \<or> poly q = poly r"
215.429 -proof -
215.430 - have "poly (p *** q) = poly (p *** r) \<longleftrightarrow> poly (p *** q +++ -- (p *** r)) = poly []"
215.431 - by (simp only: poly_add_minus_zero_iff)
215.432 - also have "\<dots> \<longleftrightarrow> poly p = poly [] \<or> poly q = poly r"
215.433 - by (auto intro: simp add: poly_add_minus_mult_eq poly_entire poly_add_minus_zero_iff)
215.434 - finally show ?thesis .
215.435 -qed
215.436 -
215.437 -lemma (in idom) poly_exp_eq_zero[simp]:
215.438 - "poly (p %^ n) = poly [] \<longleftrightarrow> poly p = poly [] \<and> n \<noteq> 0"
215.439 - apply (simp only: fun_eq add: HOL.all_simps [symmetric])
215.440 - apply (rule arg_cong [where f = All])
215.441 - apply (rule ext)
215.442 - apply (induct n)
215.443 - apply (auto simp add: poly_exp poly_mult)
215.444 - done
215.445 -
215.446 -lemma (in comm_ring_1) poly_prime_eq_zero[simp]: "poly [a,1] \<noteq> poly []"
215.447 - apply (simp add: fun_eq)
215.448 - apply (rule_tac x = "minus one a" in exI)
215.449 - apply (unfold diff_minus)
215.450 - apply (subst add_commute)
215.451 - apply (subst add_assoc)
215.452 - apply simp
215.453 - done
215.454 -
215.455 -lemma (in idom) poly_exp_prime_eq_zero: "poly ([a, 1] %^ n) \<noteq> poly []"
215.456 - by auto
215.457 -
215.458 -text{*A more constructive notion of polynomials being trivial*}
215.459 -
215.460 -lemma (in idom_char_0) poly_zero_lemma': "poly (h # t) = poly [] \<Longrightarrow> h = 0 \<and> poly t = poly []"
215.461 - apply (simp add: fun_eq)
215.462 - apply (case_tac "h = zero")
215.463 - apply (drule_tac [2] x = zero in spec, auto)
215.464 - apply (cases "poly t = poly []", simp)
215.465 -proof -
215.466 - fix x
215.467 - assume H: "\<forall>x. x = (0\<Colon>'a) \<or> poly t x = (0\<Colon>'a)"
215.468 - and pnz: "poly t \<noteq> poly []"
215.469 - let ?S = "{x. poly t x = 0}"
215.470 - from H have "\<forall>x. x \<noteq>0 \<longrightarrow> poly t x = 0" by blast
215.471 - hence th: "?S \<supseteq> UNIV - {0}" by auto
215.472 - from poly_roots_finite pnz have th': "finite ?S" by blast
215.473 - from finite_subset[OF th th'] UNIV_ring_char_0_infinte show "poly t x = (0\<Colon>'a)"
215.474 - by simp
215.475 -qed
215.476 -
215.477 -lemma (in idom_char_0) poly_zero: "(poly p = poly []) = list_all (%c. c = 0) p"
215.478 - apply (induct p)
215.479 - apply simp
215.480 - apply (rule iffI)
215.481 - apply (drule poly_zero_lemma', auto)
215.482 - done
215.483 -
215.484 -lemma (in idom_char_0) poly_0: "list_all (\<lambda>c. c = 0) p \<Longrightarrow> poly p x = 0"
215.485 - unfolding poly_zero[symmetric] by simp
215.486 -
215.487 -
215.488 -
215.489 -text{*Basics of divisibility.*}
215.490 -
215.491 -lemma (in idom) poly_primes:
215.492 - "[a, 1] divides (p *** q) \<longleftrightarrow> [a, 1] divides p \<or> [a, 1] divides q"
215.493 - apply (auto simp add: divides_def fun_eq poly_mult poly_add poly_cmult distrib_right [symmetric])
215.494 - apply (drule_tac x = "uminus a" in spec)
215.495 - apply (simp add: poly_linear_divides poly_add poly_cmult distrib_right [symmetric])
215.496 - apply (cases "p = []")
215.497 - apply (rule exI[where x="[]"])
215.498 - apply simp
215.499 - apply (cases "q = []")
215.500 - apply (erule allE[where x="[]"], simp)
215.501 -
215.502 - apply clarsimp
215.503 - apply (cases "\<exists>q\<Colon>'a list. p = a %* q +++ ((0\<Colon>'a) # q)")
215.504 - apply (clarsimp simp add: poly_add poly_cmult)
215.505 - apply (rule_tac x="qa" in exI)
215.506 - apply (simp add: distrib_right [symmetric])
215.507 - apply clarsimp
215.508 -
215.509 - apply (auto simp add: poly_linear_divides poly_add poly_cmult distrib_right [symmetric])
215.510 - apply (rule_tac x = "pmult qa q" in exI)
215.511 - apply (rule_tac [2] x = "pmult p qa" in exI)
215.512 - apply (auto simp add: poly_add poly_mult poly_cmult mult_ac)
215.513 - done
215.514 -
215.515 -lemma (in comm_semiring_1) poly_divides_refl[simp]: "p divides p"
215.516 - apply (simp add: divides_def)
215.517 - apply (rule_tac x = "[one]" in exI)
215.518 - apply (auto simp add: poly_mult fun_eq)
215.519 - done
215.520 -
215.521 -lemma (in comm_semiring_1) poly_divides_trans: "p divides q \<Longrightarrow> q divides r \<Longrightarrow> p divides r"
215.522 - apply (simp add: divides_def, safe)
215.523 - apply (rule_tac x = "pmult qa qaa" in exI)
215.524 - apply (auto simp add: poly_mult fun_eq mult_assoc)
215.525 - done
215.526 -
215.527 -lemma (in comm_semiring_1) poly_divides_exp: "m \<le> n \<Longrightarrow> (p %^ m) divides (p %^ n)"
215.528 - apply (auto simp add: le_iff_add)
215.529 - apply (induct_tac k)
215.530 - apply (rule_tac [2] poly_divides_trans)
215.531 - apply (auto simp add: divides_def)
215.532 - apply (rule_tac x = p in exI)
215.533 - apply (auto simp add: poly_mult fun_eq mult_ac)
215.534 - done
215.535 -
215.536 -lemma (in comm_semiring_1) poly_exp_divides:
215.537 - "(p %^ n) divides q \<Longrightarrow> m \<le> n \<Longrightarrow> (p %^ m) divides q"
215.538 - by (blast intro: poly_divides_exp poly_divides_trans)
215.539 -
215.540 -lemma (in comm_semiring_0) poly_divides_add:
215.541 - "p divides q \<Longrightarrow> p divides r \<Longrightarrow> p divides (q +++ r)"
215.542 - apply (simp add: divides_def, auto)
215.543 - apply (rule_tac x = "padd qa qaa" in exI)
215.544 - apply (auto simp add: poly_add fun_eq poly_mult distrib_left)
215.545 - done
215.546 -
215.547 -lemma (in comm_ring_1) poly_divides_diff:
215.548 - "p divides q \<Longrightarrow> p divides (q +++ r) \<Longrightarrow> p divides r"
215.549 - apply (simp add: divides_def, auto)
215.550 - apply (rule_tac x = "padd qaa (poly_minus qa)" in exI)
215.551 - apply (auto simp add: poly_add fun_eq poly_mult poly_minus algebra_simps)
215.552 - done
215.553 -
215.554 -lemma (in comm_ring_1) poly_divides_diff2:
215.555 - "p divides r \<Longrightarrow> p divides (q +++ r) \<Longrightarrow> p divides q"
215.556 - apply (erule poly_divides_diff)
215.557 - apply (auto simp add: poly_add fun_eq poly_mult divides_def add_ac)
215.558 - done
215.559 -
215.560 -lemma (in semiring_0) poly_divides_zero: "poly p = poly [] \<Longrightarrow> q divides p"
215.561 - apply (simp add: divides_def)
215.562 - apply (rule exI[where x="[]"])
215.563 - apply (auto simp add: fun_eq poly_mult)
215.564 - done
215.565 -
215.566 -lemma (in semiring_0) poly_divides_zero2 [simp]: "q divides []"
215.567 - apply (simp add: divides_def)
215.568 - apply (rule_tac x = "[]" in exI)
215.569 - apply (auto simp add: fun_eq)
215.570 - done
215.571 -
215.572 -text{*At last, we can consider the order of a root.*}
215.573 -
215.574 -lemma (in idom_char_0) poly_order_exists_lemma:
215.575 - assumes lp: "length p = d"
215.576 - and p: "poly p \<noteq> poly []"
215.577 - shows "\<exists>n q. p = mulexp n [-a, 1] q \<and> poly q a \<noteq> 0"
215.578 - using lp p
215.579 -proof (induct d arbitrary: p)
215.580 - case 0
215.581 - thus ?case by simp
215.582 -next
215.583 - case (Suc n p)
215.584 - show ?case
215.585 - proof (cases "poly p a = 0")
215.586 - case True
215.587 - from Suc.prems have h: "length p = Suc n" "poly p \<noteq> poly []" by auto
215.588 - hence pN: "p \<noteq> []" by auto
215.589 - from True[unfolded poly_linear_divides] pN obtain q where q: "p = [-a, 1] *** q"
215.590 - by blast
215.591 - from q h True have qh: "length q = n" "poly q \<noteq> poly []"
215.592 - apply -
215.593 - apply simp
215.594 - apply (simp only: fun_eq)
215.595 - apply (rule ccontr)
215.596 - apply (simp add: fun_eq poly_add poly_cmult)
215.597 - done
215.598 - from Suc.hyps[OF qh] obtain m r where mr: "q = mulexp m [-a,1] r" "poly r a \<noteq> 0"
215.599 - by blast
215.600 - from mr q have "p = mulexp (Suc m) [-a,1] r \<and> poly r a \<noteq> 0" by simp
215.601 - then show ?thesis by blast
215.602 - next
215.603 - case False
215.604 - then show ?thesis
215.605 - using Suc.prems
215.606 - apply simp
215.607 - apply (rule exI[where x="0::nat"])
215.608 - apply simp
215.609 - done
215.610 - qed
215.611 -qed
215.612 -
215.613 -
215.614 -lemma (in comm_semiring_1) poly_mulexp: "poly (mulexp n p q) x = (poly p x) ^ n * poly q x"
215.615 - by (induct n) (auto simp add: poly_mult mult_ac)
215.616 -
215.617 -lemma (in comm_semiring_1) divides_left_mult:
215.618 - assumes d:"(p***q) divides r" shows "p divides r \<and> q divides r"
215.619 -proof-
215.620 - from d obtain t where r:"poly r = poly (p***q *** t)"
215.621 - unfolding divides_def by blast
215.622 - hence "poly r = poly (p *** (q *** t))"
215.623 - "poly r = poly (q *** (p***t))" by(auto simp add: fun_eq poly_mult mult_ac)
215.624 - thus ?thesis unfolding divides_def by blast
215.625 -qed
215.626 -
215.627 -
215.628 -(* FIXME: Tidy up *)
215.629 -
215.630 -lemma (in semiring_1) zero_power_iff: "0 ^ n = (if n = 0 then 1 else 0)"
215.631 - by (induct n) simp_all
215.632 -
215.633 -lemma (in idom_char_0) poly_order_exists:
215.634 - assumes "length p = d" and "poly p \<noteq> poly []"
215.635 - shows "\<exists>n. [- a, 1] %^ n divides p \<and> \<not> [- a, 1] %^ Suc n divides p"
215.636 -proof -
215.637 - from assms have "\<exists>n q. p = mulexp n [- a, 1] q \<and> poly q a \<noteq> 0"
215.638 - by (rule poly_order_exists_lemma)
215.639 - then obtain n q where p: "p = mulexp n [- a, 1] q" and "poly q a \<noteq> 0" by blast
215.640 - have "[- a, 1] %^ n divides mulexp n [- a, 1] q"
215.641 - proof (rule dividesI)
215.642 - show "poly (mulexp n [- a, 1] q) = poly ([- a, 1] %^ n *** q)"
215.643 - by (induct n) (simp_all add: poly_add poly_cmult poly_mult distrib_left mult_ac)
215.644 - qed
215.645 - moreover have "\<not> [- a, 1] %^ Suc n divides mulexp n [- a, 1] q"
215.646 - proof
215.647 - assume "[- a, 1] %^ Suc n divides mulexp n [- a, 1] q"
215.648 - then obtain m where "poly (mulexp n [- a, 1] q) = poly ([- a, 1] %^ Suc n *** m)"
215.649 - by (rule dividesE)
215.650 - moreover have "poly (mulexp n [- a, 1] q) \<noteq> poly ([- a, 1] %^ Suc n *** m)"
215.651 - proof (induct n)
215.652 - case 0 show ?case
215.653 - proof (rule ccontr)
215.654 - assume "\<not> poly (mulexp 0 [- a, 1] q) \<noteq> poly ([- a, 1] %^ Suc 0 *** m)"
215.655 - then have "poly q a = 0"
215.656 - by (simp add: poly_add poly_cmult)
215.657 - with `poly q a \<noteq> 0` show False by simp
215.658 - qed
215.659 - next
215.660 - case (Suc n) show ?case
215.661 - by (rule pexp_Suc [THEN ssubst], rule ccontr)
215.662 - (simp add: poly_mult_left_cancel poly_mult_assoc Suc del: pmult_Cons pexp_Suc)
215.663 - qed
215.664 - ultimately show False by simp
215.665 - qed
215.666 - ultimately show ?thesis by (auto simp add: p)
215.667 -qed
215.668 -
215.669 -lemma (in semiring_1) poly_one_divides[simp]: "[1] divides p"
215.670 - by (auto simp add: divides_def)
215.671 -
215.672 -lemma (in idom_char_0) poly_order:
215.673 - "poly p \<noteq> poly [] \<Longrightarrow> \<exists>!n. ([-a, 1] %^ n) divides p \<and> \<not> (([-a, 1] %^ Suc n) divides p)"
215.674 - apply (auto intro: poly_order_exists simp add: less_linear simp del: pmult_Cons pexp_Suc)
215.675 - apply (cut_tac x = y and y = n in less_linear)
215.676 - apply (drule_tac m = n in poly_exp_divides)
215.677 - apply (auto dest: Suc_le_eq [THEN iffD2, THEN [2] poly_exp_divides]
215.678 - simp del: pmult_Cons pexp_Suc)
215.679 - done
215.680 -
215.681 -text{*Order*}
215.682 -
215.683 -lemma some1_equalityD: "n = (SOME n. P n) \<Longrightarrow> \<exists>!n. P n \<Longrightarrow> P n"
215.684 - by (blast intro: someI2)
215.685 -
215.686 -lemma (in idom_char_0) order:
215.687 - "(([-a, 1] %^ n) divides p \<and>
215.688 - ~(([-a, 1] %^ (Suc n)) divides p)) =
215.689 - ((n = order a p) \<and> ~(poly p = poly []))"
215.690 - apply (unfold order_def)
215.691 - apply (rule iffI)
215.692 - apply (blast dest: poly_divides_zero intro!: some1_equality [symmetric] poly_order)
215.693 - apply (blast intro!: poly_order [THEN [2] some1_equalityD])
215.694 - done
215.695 -
215.696 -lemma (in idom_char_0) order2:
215.697 - "poly p \<noteq> poly [] \<Longrightarrow>
215.698 - ([-a, 1] %^ (order a p)) divides p \<and> \<not> (([-a, 1] %^ (Suc (order a p))) divides p)"
215.699 - by (simp add: order del: pexp_Suc)
215.700 -
215.701 -lemma (in idom_char_0) order_unique:
215.702 - "poly p \<noteq> poly [] \<Longrightarrow> ([-a, 1] %^ n) divides p \<Longrightarrow> ~(([-a, 1] %^ (Suc n)) divides p) \<Longrightarrow>
215.703 - n = order a p"
215.704 - using order [of a n p] by auto
215.705 -
215.706 -lemma (in idom_char_0) order_unique_lemma:
215.707 - "poly p \<noteq> poly [] \<and> ([-a, 1] %^ n) divides p \<and> ~(([-a, 1] %^ (Suc n)) divides p) \<Longrightarrow>
215.708 - n = order a p"
215.709 - by (blast intro: order_unique)
215.710 -
215.711 -lemma (in ring_1) order_poly: "poly p = poly q \<Longrightarrow> order a p = order a q"
215.712 - by (auto simp add: fun_eq divides_def poly_mult order_def)
215.713 -
215.714 -lemma (in semiring_1) pexp_one[simp]: "p %^ (Suc 0) = p"
215.715 - by (induct "p") auto
215.716 -
215.717 -lemma (in comm_ring_1) lemma_order_root:
215.718 - "0 < n \<and> [- a, 1] %^ n divides p \<and> ~ [- a, 1] %^ (Suc n) divides p \<Longrightarrow> poly p a = 0"
215.719 - by (induct n arbitrary: a p) (auto simp add: divides_def poly_mult simp del: pmult_Cons)
215.720 -
215.721 -lemma (in idom_char_0) order_root:
215.722 - "poly p a = 0 \<longleftrightarrow> poly p = poly [] \<or> order a p \<noteq> 0"
215.723 - apply (cases "poly p = poly []")
215.724 - apply auto
215.725 - apply (simp add: poly_linear_divides del: pmult_Cons, safe)
215.726 - apply (drule_tac [!] a = a in order2)
215.727 - apply (rule ccontr)
215.728 - apply (simp add: divides_def poly_mult fun_eq del: pmult_Cons, blast)
215.729 - using neq0_conv
215.730 - apply (blast intro: lemma_order_root)
215.731 - done
215.732 -
215.733 -lemma (in idom_char_0) order_divides:
215.734 - "([-a, 1] %^ n) divides p \<longleftrightarrow> poly p = poly [] \<or> n \<le> order a p"
215.735 - apply (cases "poly p = poly []")
215.736 - apply auto
215.737 - apply (simp add: divides_def fun_eq poly_mult)
215.738 - apply (rule_tac x = "[]" in exI)
215.739 - apply (auto dest!: order2 [where a=a] intro: poly_exp_divides simp del: pexp_Suc)
215.740 - done
215.741 -
215.742 -lemma (in idom_char_0) order_decomp:
215.743 - "poly p \<noteq> poly [] \<Longrightarrow> \<exists>q. poly p = poly (([-a, 1] %^ (order a p)) *** q) \<and> ~([-a, 1] divides q)"
215.744 - apply (unfold divides_def)
215.745 - apply (drule order2 [where a = a])
215.746 - apply (simp add: divides_def del: pexp_Suc pmult_Cons, safe)
215.747 - apply (rule_tac x = q in exI, safe)
215.748 - apply (drule_tac x = qa in spec)
215.749 - apply (auto simp add: poly_mult fun_eq poly_exp mult_ac simp del: pmult_Cons)
215.750 - done
215.751 -
215.752 -text{*Important composition properties of orders.*}
215.753 -lemma order_mult:
215.754 - "poly (p *** q) \<noteq> poly [] \<Longrightarrow>
215.755 - order a (p *** q) = order a p + order (a::'a::{idom_char_0}) q"
215.756 - apply (cut_tac a = a and p = "p *** q" and n = "order a p + order a q" in order)
215.757 - apply (auto simp add: poly_entire simp del: pmult_Cons)
215.758 - apply (drule_tac a = a in order2)+
215.759 - apply safe
215.760 - apply (simp add: divides_def fun_eq poly_exp_add poly_mult del: pmult_Cons, safe)
215.761 - apply (rule_tac x = "qa *** qaa" in exI)
215.762 - apply (simp add: poly_mult mult_ac del: pmult_Cons)
215.763 - apply (drule_tac a = a in order_decomp)+
215.764 - apply safe
215.765 - apply (subgoal_tac "[-a,1] divides (qa *** qaa) ")
215.766 - apply (simp add: poly_primes del: pmult_Cons)
215.767 - apply (auto simp add: divides_def simp del: pmult_Cons)
215.768 - apply (rule_tac x = qb in exI)
215.769 - apply (subgoal_tac "poly ([-a, 1] %^ (order a p) *** (qa *** qaa)) = poly ([-a, 1] %^ (order a p) *** ([-a, 1] *** qb))")
215.770 - apply (drule poly_mult_left_cancel [THEN iffD1], force)
215.771 - apply (subgoal_tac "poly ([-a, 1] %^ (order a q) *** ([-a, 1] %^ (order a p) *** (qa *** qaa))) = poly ([-a, 1] %^ (order a q) *** ([-a, 1] %^ (order a p) *** ([-a, 1] *** qb))) ")
215.772 - apply (drule poly_mult_left_cancel [THEN iffD1], force)
215.773 - apply (simp add: fun_eq poly_exp_add poly_mult mult_ac del: pmult_Cons)
215.774 - done
215.775 -
215.776 -lemma (in idom_char_0) order_mult:
215.777 - assumes "poly (p *** q) \<noteq> poly []"
215.778 - shows "order a (p *** q) = order a p + order a q"
215.779 - using assms
215.780 - apply (cut_tac a = a and p = "pmult p q" and n = "order a p + order a q" in order)
215.781 - apply (auto simp add: poly_entire simp del: pmult_Cons)
215.782 - apply (drule_tac a = a in order2)+
215.783 - apply safe
215.784 - apply (simp add: divides_def fun_eq poly_exp_add poly_mult del: pmult_Cons, safe)
215.785 - apply (rule_tac x = "pmult qa qaa" in exI)
215.786 - apply (simp add: poly_mult mult_ac del: pmult_Cons)
215.787 - apply (drule_tac a = a in order_decomp)+
215.788 - apply safe
215.789 - apply (subgoal_tac "[uminus a, one] divides pmult qa qaa")
215.790 - apply (simp add: poly_primes del: pmult_Cons)
215.791 - apply (auto simp add: divides_def simp del: pmult_Cons)
215.792 - apply (rule_tac x = qb in exI)
215.793 - apply (subgoal_tac "poly (pmult (pexp [uminus a, one] (order a p)) (pmult qa qaa)) =
215.794 - poly (pmult (pexp [uminus a, one] (?order a p)) (pmult [uminus a, one] qb))")
215.795 - apply (drule poly_mult_left_cancel [THEN iffD1], force)
215.796 - apply (subgoal_tac "poly (pmult (pexp [uminus a, one] (order a q))
215.797 - (pmult (pexp [uminus a, one] (order a p)) (pmult qa qaa))) =
215.798 - poly (pmult (pexp [uminus a, one] (order a q))
215.799 - (pmult (pexp [uminus a, one] (order a p)) (pmult [uminus a, one] qb)))")
215.800 - apply (drule poly_mult_left_cancel [THEN iffD1], force)
215.801 - apply (simp add: fun_eq poly_exp_add poly_mult mult_ac del: pmult_Cons)
215.802 - done
215.803 -
215.804 -lemma (in idom_char_0) order_root2: "poly p \<noteq> poly [] \<Longrightarrow> poly p a = 0 \<longleftrightarrow> order a p \<noteq> 0"
215.805 - by (rule order_root [THEN ssubst]) auto
215.806 -
215.807 -lemma (in semiring_1) pmult_one[simp]: "[1] *** p = p" by auto
215.808 -
215.809 -lemma (in semiring_0) poly_Nil_zero: "poly [] = poly [0]"
215.810 - by (simp add: fun_eq)
215.811 -
215.812 -lemma (in idom_char_0) rsquarefree_decomp:
215.813 - "rsquarefree p \<Longrightarrow> poly p a = 0 \<Longrightarrow>
215.814 - \<exists>q. poly p = poly ([-a, 1] *** q) \<and> poly q a \<noteq> 0"
215.815 - apply (simp add: rsquarefree_def, safe)
215.816 - apply (frule_tac a = a in order_decomp)
215.817 - apply (drule_tac x = a in spec)
215.818 - apply (drule_tac a = a in order_root2 [symmetric])
215.819 - apply (auto simp del: pmult_Cons)
215.820 - apply (rule_tac x = q in exI, safe)
215.821 - apply (simp add: poly_mult fun_eq)
215.822 - apply (drule_tac p1 = q in poly_linear_divides [THEN iffD1])
215.823 - apply (simp add: divides_def del: pmult_Cons, safe)
215.824 - apply (drule_tac x = "[]" in spec)
215.825 - apply (auto simp add: fun_eq)
215.826 - done
215.827 -
215.828 -
215.829 -text{*Normalization of a polynomial.*}
215.830 -
215.831 -lemma (in semiring_0) poly_normalize[simp]: "poly (pnormalize p) = poly p"
215.832 - by (induct p) (auto simp add: fun_eq)
215.833 -
215.834 -text{*The degree of a polynomial.*}
215.835 -
215.836 -lemma (in semiring_0) lemma_degree_zero: "list_all (%c. c = 0) p \<longleftrightarrow> pnormalize p = []"
215.837 - by (induct p) auto
215.838 -
215.839 -lemma (in idom_char_0) degree_zero:
215.840 - assumes "poly p = poly []"
215.841 - shows "degree p = 0"
215.842 - using assms
215.843 - by (cases "pnormalize p = []") (auto simp add: degree_def poly_zero lemma_degree_zero)
215.844 -
215.845 -lemma (in semiring_0) pnormalize_sing: "(pnormalize [x] = [x]) \<longleftrightarrow> x \<noteq> 0"
215.846 - by simp
215.847 -
215.848 -lemma (in semiring_0) pnormalize_pair: "y \<noteq> 0 \<longleftrightarrow> (pnormalize [x, y] = [x, y])"
215.849 - by simp
215.850 -
215.851 -lemma (in semiring_0) pnormal_cons: "pnormal p \<Longrightarrow> pnormal (c#p)"
215.852 - unfolding pnormal_def by simp
215.853 -
215.854 -lemma (in semiring_0) pnormal_tail: "p\<noteq>[] \<Longrightarrow> pnormal (c#p) \<Longrightarrow> pnormal p"
215.855 - unfolding pnormal_def by(auto split: split_if_asm)
215.856 -
215.857 -
215.858 -lemma (in semiring_0) pnormal_last_nonzero: "pnormal p \<Longrightarrow> last p \<noteq> 0"
215.859 - by (induct p) (simp_all add: pnormal_def split: split_if_asm)
215.860 -
215.861 -lemma (in semiring_0) pnormal_length: "pnormal p \<Longrightarrow> 0 < length p"
215.862 - unfolding pnormal_def length_greater_0_conv by blast
215.863 -
215.864 -lemma (in semiring_0) pnormal_last_length: "0 < length p \<Longrightarrow> last p \<noteq> 0 \<Longrightarrow> pnormal p"
215.865 - by (induct p) (auto simp: pnormal_def split: split_if_asm)
215.866 -
215.867 -
215.868 -lemma (in semiring_0) pnormal_id: "pnormal p \<longleftrightarrow> 0 < length p \<and> last p \<noteq> 0"
215.869 - using pnormal_last_length pnormal_length pnormal_last_nonzero by blast
215.870 -
215.871 -lemma (in idom_char_0) poly_Cons_eq:
215.872 - "poly (c # cs) = poly (d # ds) \<longleftrightarrow> c = d \<and> poly cs = poly ds"
215.873 - (is "?lhs \<longleftrightarrow> ?rhs")
215.874 -proof
215.875 - assume eq: ?lhs
215.876 - hence "\<And>x. poly ((c#cs) +++ -- (d#ds)) x = 0"
215.877 - by (simp only: poly_minus poly_add algebra_simps) simp
215.878 - hence "poly ((c#cs) +++ -- (d#ds)) = poly []" by(simp add: fun_eq_iff)
215.879 - hence "c = d \<and> list_all (\<lambda>x. x=0) ((cs +++ -- ds))"
215.880 - unfolding poly_zero by (simp add: poly_minus_def algebra_simps)
215.881 - hence "c = d \<and> (\<forall>x. poly (cs +++ -- ds) x = 0)"
215.882 - unfolding poly_zero[symmetric] by simp
215.883 - then show ?rhs by (simp add: poly_minus poly_add algebra_simps fun_eq_iff)
215.884 -next
215.885 - assume ?rhs
215.886 - then show ?lhs by(simp add:fun_eq_iff)
215.887 -qed
215.888 -
215.889 -lemma (in idom_char_0) pnormalize_unique: "poly p = poly q \<Longrightarrow> pnormalize p = pnormalize q"
215.890 -proof (induct q arbitrary: p)
215.891 - case Nil
215.892 - thus ?case by (simp only: poly_zero lemma_degree_zero) simp
215.893 -next
215.894 - case (Cons c cs p)
215.895 - thus ?case
215.896 - proof (induct p)
215.897 - case Nil
215.898 - hence "poly [] = poly (c#cs)" by blast
215.899 - then have "poly (c#cs) = poly [] " by simp
215.900 - thus ?case by (simp only: poly_zero lemma_degree_zero) simp
215.901 - next
215.902 - case (Cons d ds)
215.903 - hence eq: "poly (d # ds) = poly (c # cs)" by blast
215.904 - hence eq': "\<And>x. poly (d # ds) x = poly (c # cs) x" by simp
215.905 - hence "poly (d # ds) 0 = poly (c # cs) 0" by blast
215.906 - hence dc: "d = c" by auto
215.907 - with eq have "poly ds = poly cs"
215.908 - unfolding poly_Cons_eq by simp
215.909 - with Cons.prems have "pnormalize ds = pnormalize cs" by blast
215.910 - with dc show ?case by simp
215.911 - qed
215.912 -qed
215.913 -
215.914 -lemma (in idom_char_0) degree_unique:
215.915 - assumes pq: "poly p = poly q"
215.916 - shows "degree p = degree q"
215.917 - using pnormalize_unique[OF pq] unfolding degree_def by simp
215.918 -
215.919 -lemma (in semiring_0) pnormalize_length:
215.920 - "length (pnormalize p) \<le> length p" by (induct p) auto
215.921 -
215.922 -lemma (in semiring_0) last_linear_mul_lemma:
215.923 - "last ((a %* p) +++ (x#(b %* p))) = (if p = [] then x else b * last p)"
215.924 - apply (induct p arbitrary: a x b)
215.925 - apply auto
215.926 - apply (subgoal_tac "padd (cmult aa p) (times b a # cmult b p) \<noteq> []")
215.927 - apply simp
215.928 - apply (induct_tac p)
215.929 - apply auto
215.930 - done
215.931 -
215.932 -lemma (in semiring_1) last_linear_mul:
215.933 - assumes p: "p \<noteq> []"
215.934 - shows "last ([a,1] *** p) = last p"
215.935 -proof -
215.936 - from p obtain c cs where cs: "p = c#cs" by (cases p) auto
215.937 - from cs have eq: "[a,1] *** p = (a %* (c#cs)) +++ (0#(1 %* (c#cs)))"
215.938 - by (simp add: poly_cmult_distr)
215.939 - show ?thesis using cs
215.940 - unfolding eq last_linear_mul_lemma by simp
215.941 -qed
215.942 -
215.943 -lemma (in semiring_0) pnormalize_eq: "last p \<noteq> 0 \<Longrightarrow> pnormalize p = p"
215.944 - by (induct p) (auto split: split_if_asm)
215.945 -
215.946 -lemma (in semiring_0) last_pnormalize: "pnormalize p \<noteq> [] \<Longrightarrow> last (pnormalize p) \<noteq> 0"
215.947 - by (induct p) auto
215.948 -
215.949 -lemma (in semiring_0) pnormal_degree: "last p \<noteq> 0 \<Longrightarrow> degree p = length p - 1"
215.950 - using pnormalize_eq[of p] unfolding degree_def by simp
215.951 -
215.952 -lemma (in semiring_0) poly_Nil_ext: "poly [] = (\<lambda>x. 0)"
215.953 - by (rule ext) simp
215.954 -
215.955 -lemma (in idom_char_0) linear_mul_degree:
215.956 - assumes p: "poly p \<noteq> poly []"
215.957 - shows "degree ([a,1] *** p) = degree p + 1"
215.958 -proof -
215.959 - from p have pnz: "pnormalize p \<noteq> []"
215.960 - unfolding poly_zero lemma_degree_zero .
215.961 -
215.962 - from last_linear_mul[OF pnz, of a] last_pnormalize[OF pnz]
215.963 - have l0: "last ([a, 1] *** pnormalize p) \<noteq> 0" by simp
215.964 - from last_pnormalize[OF pnz] last_linear_mul[OF pnz, of a]
215.965 - pnormal_degree[OF l0] pnormal_degree[OF last_pnormalize[OF pnz]] pnz
215.966 -
215.967 - have th: "degree ([a,1] *** pnormalize p) = degree (pnormalize p) + 1"
215.968 - by simp
215.969 -
215.970 - have eqs: "poly ([a,1] *** pnormalize p) = poly ([a,1] *** p)"
215.971 - by (rule ext) (simp add: poly_mult poly_add poly_cmult)
215.972 - from degree_unique[OF eqs] th
215.973 - show ?thesis by (simp add: degree_unique[OF poly_normalize])
215.974 -qed
215.975 -
215.976 -lemma (in idom_char_0) linear_pow_mul_degree:
215.977 - "degree([a,1] %^n *** p) = (if poly p = poly [] then 0 else degree p + n)"
215.978 -proof (induct n arbitrary: a p)
215.979 - case (0 a p)
215.980 - show ?case
215.981 - proof (cases "poly p = poly []")
215.982 - case True
215.983 - then show ?thesis
215.984 - using degree_unique[OF True] by (simp add: degree_def)
215.985 - next
215.986 - case False
215.987 - then show ?thesis by (auto simp add: poly_Nil_ext)
215.988 - qed
215.989 -next
215.990 - case (Suc n a p)
215.991 - have eq: "poly ([a,1] %^(Suc n) *** p) = poly ([a,1] %^ n *** ([a,1] *** p))"
215.992 - apply (rule ext)
215.993 - apply (simp add: poly_mult poly_add poly_cmult)
215.994 - apply (simp add: mult_ac add_ac distrib_left)
215.995 - done
215.996 - note deq = degree_unique[OF eq]
215.997 - show ?case
215.998 - proof (cases "poly p = poly []")
215.999 - case True
215.1000 - with eq have eq': "poly ([a,1] %^(Suc n) *** p) = poly []"
215.1001 - apply -
215.1002 - apply (rule ext)
215.1003 - apply (simp add: poly_mult poly_cmult poly_add)
215.1004 - done
215.1005 - from degree_unique[OF eq'] True show ?thesis
215.1006 - by (simp add: degree_def)
215.1007 - next
215.1008 - case False
215.1009 - then have ap: "poly ([a,1] *** p) \<noteq> poly []"
215.1010 - using poly_mult_not_eq_poly_Nil unfolding poly_entire by auto
215.1011 - have eq: "poly ([a,1] %^(Suc n) *** p) = poly ([a,1]%^n *** ([a,1] *** p))"
215.1012 - by (rule ext, simp add: poly_mult poly_add poly_exp poly_cmult algebra_simps)
215.1013 - from ap have ap': "(poly ([a,1] *** p) = poly []) = False"
215.1014 - by blast
215.1015 - have th0: "degree ([a,1]%^n *** ([a,1] *** p)) = degree ([a,1] *** p) + n"
215.1016 - apply (simp only: Suc.hyps[of a "pmult [a,one] p"] ap')
215.1017 - apply simp
215.1018 - done
215.1019 - from degree_unique[OF eq] ap False th0 linear_mul_degree[OF False, of a]
215.1020 - show ?thesis by (auto simp del: poly.simps)
215.1021 - qed
215.1022 -qed
215.1023 -
215.1024 -lemma (in idom_char_0) order_degree:
215.1025 - assumes p0: "poly p \<noteq> poly []"
215.1026 - shows "order a p \<le> degree p"
215.1027 -proof -
215.1028 - from order2[OF p0, unfolded divides_def]
215.1029 - obtain q where q: "poly p = poly ([- a, 1]%^ (order a p) *** q)" by blast
215.1030 - {
215.1031 - assume "poly q = poly []"
215.1032 - with q p0 have False by (simp add: poly_mult poly_entire)
215.1033 - }
215.1034 - with degree_unique[OF q, unfolded linear_pow_mul_degree] show ?thesis
215.1035 - by auto
215.1036 -qed
215.1037 -
215.1038 -text{*Tidier versions of finiteness of roots.*}
215.1039 -
215.1040 -lemma (in idom_char_0) poly_roots_finite_set:
215.1041 - "poly p \<noteq> poly [] \<Longrightarrow> finite {x. poly p x = 0}"
215.1042 - unfolding poly_roots_finite .
215.1043 -
215.1044 -text{*bound for polynomial.*}
215.1045 -
215.1046 -lemma poly_mono: "abs(x) \<le> k \<Longrightarrow> abs(poly p (x::'a::{linordered_idom})) \<le> poly (map abs p) k"
215.1047 - apply (induct p)
215.1048 - apply auto
215.1049 - apply (rule_tac y = "abs a + abs (x * poly p x)" in order_trans)
215.1050 - apply (rule abs_triangle_ineq)
215.1051 - apply (auto intro!: mult_mono simp add: abs_mult)
215.1052 - done
215.1053 -
215.1054 -lemma (in semiring_0) poly_Sing: "poly [c] x = c" by simp
215.1055 -
215.1056 -end
216.1 --- a/src/HOL/Library/Wfrec.thy Thu Dec 05 17:52:12 2013 +0100
216.2 +++ b/src/HOL/Library/Wfrec.thy Thu Dec 05 17:58:03 2013 +0100
216.3 @@ -48,7 +48,7 @@
216.4 apply (fast dest!: theI')
216.5 apply (erule wfrec_rel.cases, simp)
216.6 apply (erule allE, erule allE, erule allE, erule mp)
216.7 -apply (fast intro: the_equality [symmetric])
216.8 +apply (blast intro: the_equality [symmetric])
216.9 done
216.10
216.11 lemma adm_lemma: "adm_wf R (%f x. F (cut f R x) x)"
217.1 --- a/src/HOL/Library/While_Combinator.thy Thu Dec 05 17:52:12 2013 +0100
217.2 +++ b/src/HOL/Library/While_Combinator.thy Thu Dec 05 17:58:03 2013 +0100
217.3 @@ -307,37 +307,44 @@
217.4 by Nipkow (the theories are in the AFP entry Flyspeck by Nipkow)
217.5 and the AFP article Executable Transitive Closures by René Thiemann. *}
217.6
217.7 -definition rtrancl_while :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a list) \<Rightarrow> 'a
217.8 - \<Rightarrow> ('a list * 'a set) option"
217.9 -where "rtrancl_while p f x =
217.10 - while_option (%(ws,_). ws \<noteq> [] \<and> p(hd ws))
217.11 - ((%(ws,Z).
217.12 - let x = hd ws; new = filter (\<lambda>y. y \<notin> Z) (f x)
217.13 - in (new @ tl ws, set new \<union> Z)))
217.14 - ([x],{x})"
217.15 +context
217.16 +fixes p :: "'a \<Rightarrow> bool"
217.17 +and f :: "'a \<Rightarrow> 'a list"
217.18 +and x :: 'a
217.19 +begin
217.20
217.21 -lemma rtrancl_while_Some: assumes "rtrancl_while p f x = Some(ws,Z)"
217.22 +fun rtrancl_while_test :: "'a list \<times> 'a set \<Rightarrow> bool"
217.23 +where "rtrancl_while_test (ws,_) = (ws \<noteq> [] \<and> p(hd ws))"
217.24 +
217.25 +fun rtrancl_while_step :: "'a list \<times> 'a set \<Rightarrow> 'a list \<times> 'a set"
217.26 +where "rtrancl_while_step (ws, Z) =
217.27 + (let x = hd ws; new = remdups (filter (\<lambda>y. y \<notin> Z) (f x))
217.28 + in (new @ tl ws, set new \<union> Z))"
217.29 +
217.30 +definition rtrancl_while :: "('a list * 'a set) option"
217.31 +where "rtrancl_while = while_option rtrancl_while_test rtrancl_while_step ([x],{x})"
217.32 +
217.33 +fun rtrancl_while_invariant :: "'a list \<times> 'a set \<Rightarrow> bool"
217.34 +where "rtrancl_while_invariant (ws, Z) =
217.35 + (x \<in> Z \<and> set ws \<subseteq> Z \<and> distinct ws \<and> {(x,y). y \<in> set(f x)} `` (Z - set ws) \<subseteq> Z \<and>
217.36 + Z \<subseteq> {(x,y). y \<in> set(f x)}^* `` {x} \<and> (\<forall>z\<in>Z - set ws. p z))"
217.37 +
217.38 +lemma rtrancl_while_invariant:
217.39 + assumes inv: "rtrancl_while_invariant st" and test: "rtrancl_while_test st"
217.40 + shows "rtrancl_while_invariant (rtrancl_while_step st)"
217.41 +proof (cases st)
217.42 + fix ws Z assume st: "st = (ws, Z)"
217.43 + with test obtain h t where "ws = h # t" "p h" by (cases ws) auto
217.44 + with inv st show ?thesis by (auto intro: rtrancl.rtrancl_into_rtrancl)
217.45 +qed
217.46 +
217.47 +lemma rtrancl_while_Some: assumes "rtrancl_while = Some(ws,Z)"
217.48 shows "if ws = []
217.49 then Z = {(x,y). y \<in> set(f x)}^* `` {x} \<and> (\<forall>z\<in>Z. p z)
217.50 else \<not>p(hd ws) \<and> hd ws \<in> {(x,y). y \<in> set(f x)}^* `` {x}"
217.51 -proof-
217.52 - let ?test = "(%(ws,_). ws \<noteq> [] \<and> p(hd ws))"
217.53 - let ?step = "(%(ws,Z).
217.54 - let x = hd ws; new = filter (\<lambda>y. y \<notin> Z) (f x)
217.55 - in (new @ tl ws, set new \<union> Z))"
217.56 - let ?R = "{(x,y). y \<in> set(f x)}"
217.57 - let ?Inv = "%(ws,Z). x \<in> Z \<and> set ws \<subseteq> Z \<and> ?R `` (Z - set ws) \<subseteq> Z \<and>
217.58 - Z \<subseteq> ?R^* `` {x} \<and> (\<forall>z\<in>Z - set ws. p z)"
217.59 - { fix ws Z assume 1: "?Inv(ws,Z)" and 2: "?test(ws,Z)"
217.60 - from 2 obtain v vs where [simp]: "ws = v#vs" by (auto simp: neq_Nil_conv)
217.61 - have "?Inv(?step (ws,Z))" using 1 2
217.62 - by (auto intro: rtrancl.rtrancl_into_rtrancl)
217.63 - } note inv = this
217.64 - hence "!!p. ?Inv p \<Longrightarrow> ?test p \<Longrightarrow> ?Inv(?step p)"
217.65 - apply(tactic {* split_all_tac @{context} 1 *})
217.66 - using inv by iprover
217.67 - moreover have "?Inv ([x],{x})" by (simp)
217.68 - ultimately have I: "?Inv (ws,Z)"
217.69 +proof -
217.70 + have "rtrancl_while_invariant ([x],{x})" by simp
217.71 + with rtrancl_while_invariant have I: "rtrancl_while_invariant (ws,Z)"
217.72 by (rule while_option_rule[OF _ assms[unfolded rtrancl_while_def]])
217.73 { assume "ws = []"
217.74 hence ?thesis using I
217.75 @@ -350,4 +357,41 @@
217.76 ultimately show ?thesis by simp
217.77 qed
217.78
217.79 +lemma rtrancl_while_finite_Some:
217.80 + assumes "finite ({(x, y). y \<in> set (f x)}\<^sup>* `` {x})" (is "finite ?Cl")
217.81 + shows "\<exists>y. rtrancl_while = Some y"
217.82 +proof -
217.83 + let ?R = "(\<lambda>(_, Z). card (?Cl - Z)) <*mlex*> (\<lambda>(ws, _). length ws) <*mlex*> {}"
217.84 + have "wf ?R" by (blast intro: wf_mlex)
217.85 + then show ?thesis unfolding rtrancl_while_def
217.86 + proof (rule wf_rel_while_option_Some[of ?R rtrancl_while_invariant])
217.87 + fix st assume *: "rtrancl_while_invariant st \<and> rtrancl_while_test st"
217.88 + hence I: "rtrancl_while_invariant (rtrancl_while_step st)"
217.89 + by (blast intro: rtrancl_while_invariant)
217.90 + show "(rtrancl_while_step st, st) \<in> ?R"
217.91 + proof (cases st)
217.92 + fix ws Z let ?ws = "fst (rtrancl_while_step st)" and ?Z = "snd (rtrancl_while_step st)"
217.93 + assume st: "st = (ws, Z)"
217.94 + with * obtain h t where ws: "ws = h # t" "p h" by (cases ws) auto
217.95 + { assume "remdups (filter (\<lambda>y. y \<notin> Z) (f h)) \<noteq> []"
217.96 + then obtain z where "z \<in> set (remdups (filter (\<lambda>y. y \<notin> Z) (f h)))" by fastforce
217.97 + with st ws I have "Z \<subset> ?Z" "Z \<subseteq> ?Cl" "?Z \<subseteq> ?Cl" by auto
217.98 + with assms have "card (?Cl - ?Z) < card (?Cl - Z)" by (blast intro: psubset_card_mono)
217.99 + with st ws have ?thesis unfolding mlex_prod_def by simp
217.100 + }
217.101 + moreover
217.102 + { assume "remdups (filter (\<lambda>y. y \<notin> Z) (f h)) = []"
217.103 + with st ws have "?Z = Z" "?ws = t" by (auto simp: filter_empty_conv)
217.104 + with st ws have ?thesis unfolding mlex_prod_def by simp
217.105 + }
217.106 + ultimately show ?thesis by blast
217.107 + qed
217.108 + qed (simp_all add: rtrancl_while_invariant)
217.109 +qed
217.110 +
217.111 end
217.112 +
217.113 +hide_const (open) rtrancl_while_test rtrancl_while_step rtrancl_while_invariant
217.114 +hide_fact (open) rtrancl_while_invariant
217.115 +
217.116 +end
218.1 --- a/src/HOL/Library/Zorn.thy Thu Dec 05 17:52:12 2013 +0100
218.2 +++ b/src/HOL/Library/Zorn.thy Thu Dec 05 17:58:03 2013 +0100
218.3 @@ -5,13 +5,12 @@
218.4
218.5 Zorn's Lemma (ported from Larry Paulson's Zorn.thy in ZF).
218.6 The well-ordering theorem.
218.7 -The extension of any well-founded relation to a well-order.
218.8 *)
218.9
218.10 header {* Zorn's Lemma *}
218.11
218.12 theory Zorn
218.13 -imports Order_Union
218.14 +imports Main
218.15 begin
218.16
218.17 subsection {* Zorn's Lemma for the Subset Relation *}
218.18 @@ -71,7 +70,7 @@
218.19
218.20 lemma suc_not_equals:
218.21 "chain C \<Longrightarrow> \<not> maxchain C \<Longrightarrow> suc C \<noteq> C"
218.22 - by (auto simp: suc_def) (metis less_irrefl not_maxchain_Some)
218.23 + by (auto simp: suc_def) (metis (no_types) less_irrefl not_maxchain_Some)
218.24
218.25 lemma subset_suc:
218.26 assumes "X \<subseteq> Y" shows "X \<subseteq> suc Y"
218.27 @@ -258,7 +257,7 @@
218.28 shows "chain X"
218.29 using assms
218.30 proof (induct)
218.31 - case (suc X) then show ?case by (simp add: suc_def) (metis not_maxchain_Some)
218.32 + case (suc X) then show ?case by (simp add: suc_def) (metis (no_types) not_maxchain_Some)
218.33 next
218.34 case (Union X)
218.35 then have "\<Union>X \<subseteq> A" by (auto dest: suc_Union_closed_in_carrier)
218.36 @@ -378,7 +377,7 @@
218.37 using `subset.maxchain A M` by (auto simp: subset.maxchain_def)
218.38 qed
218.39 qed
218.40 - ultimately show ?thesis by blast
218.41 + ultimately show ?thesis by metis
218.42 qed
218.43
218.44 text{*Alternative version of Zorn's lemma for the subset relation.*}
218.45 @@ -423,7 +422,7 @@
218.46 unfolding Chains_def by blast
218.47
218.48 lemma chain_subset_alt_def: "chain\<^sub>\<subseteq> C = subset.chain UNIV C"
218.49 - by (auto simp add: chain_subset_def subset.chain_def)
218.50 + unfolding chain_subset_def subset.chain_def by fast
218.51
218.52 lemma chains_alt_def: "chains A = {C. subset.chain A C}"
218.53 by (simp add: chains_def chain_subset_alt_def subset.chain_def)
218.54 @@ -487,7 +486,7 @@
218.55 fix a B assume aB: "B \<in> C" "a \<in> B"
218.56 with 1 obtain x where "x \<in> Field r" and "B = r\<inverse> `` {x}" by auto
218.57 thus "(a, u) \<in> r" using uA and aB and `Preorder r`
218.58 - by (auto simp add: preorder_on_def refl_on_def) (metis transD)
218.59 + unfolding preorder_on_def refl_on_def by simp (fast dest: transD)
218.60 qed
218.61 then have "\<exists>u\<in>Field r. ?P u" using `u \<in> Field r` by blast
218.62 }
218.63 @@ -524,8 +523,7 @@
218.64
218.65 lemma trans_init_seg_of:
218.66 "r initial_segment_of s \<Longrightarrow> s initial_segment_of t \<Longrightarrow> r initial_segment_of t"
218.67 - by (simp (no_asm_use) add: init_seg_of_def)
218.68 - (metis UnCI Un_absorb2 subset_trans)
218.69 + by (simp (no_asm_use) add: init_seg_of_def) blast
218.70
218.71 lemma antisym_init_seg_of:
218.72 "r initial_segment_of s \<Longrightarrow> s initial_segment_of r \<Longrightarrow> r = s"
218.73 @@ -539,14 +537,13 @@
218.74 "chain\<^sub>\<subseteq> R \<Longrightarrow> \<forall>r\<in>R. trans r \<Longrightarrow> trans (\<Union>R)"
218.75 apply (auto simp add: chain_subset_def)
218.76 apply (simp (no_asm_use) add: trans_def)
218.77 -apply (metis subsetD)
218.78 -done
218.79 +by (metis subsetD)
218.80
218.81 lemma chain_subset_antisym_Union:
218.82 "chain\<^sub>\<subseteq> R \<Longrightarrow> \<forall>r\<in>R. antisym r \<Longrightarrow> antisym (\<Union>R)"
218.83 -apply (auto simp add: chain_subset_def antisym_def)
218.84 -apply (metis subsetD)
218.85 -done
218.86 +unfolding chain_subset_def antisym_def
218.87 +apply simp
218.88 +by (metis (no_types) subsetD)
218.89
218.90 lemma chain_subset_Total_Union:
218.91 assumes "chain\<^sub>\<subseteq> R" and "\<forall>r\<in>R. Total r"
218.92 @@ -558,11 +555,11 @@
218.93 thus "(\<exists>r\<in>R. (a, b) \<in> r) \<or> (\<exists>r\<in>R. (b, a) \<in> r)"
218.94 proof
218.95 assume "r \<subseteq> s" hence "(a, b) \<in> s \<or> (b, a) \<in> s" using assms(2) A
218.96 - by (simp add: total_on_def) (metis mono_Field subsetD)
218.97 + by (simp add: total_on_def) (metis (no_types) mono_Field subsetD)
218.98 thus ?thesis using `s \<in> R` by blast
218.99 next
218.100 assume "s \<subseteq> r" hence "(a, b) \<in> r \<or> (b, a) \<in> r" using assms(2) A
218.101 - by (simp add: total_on_def) (metis mono_Field subsetD)
218.102 + by (simp add: total_on_def) (metis (no_types) mono_Field subsetD)
218.103 thus ?thesis using `r \<in> R` by blast
218.104 qed
218.105 qed
218.106 @@ -604,7 +601,7 @@
218.107 def I \<equiv> "init_seg_of \<inter> ?WO \<times> ?WO"
218.108 have I_init: "I \<subseteq> init_seg_of" by (auto simp: I_def)
218.109 hence subch: "\<And>R. R \<in> Chains I \<Longrightarrow> chain\<^sub>\<subseteq> R"
218.110 - by (auto simp: init_seg_of_def chain_subset_def Chains_def)
218.111 + unfolding init_seg_of_def chain_subset_def Chains_def by blast
218.112 have Chains_wo: "\<And>R r. R \<in> Chains I \<Longrightarrow> r \<in> R \<Longrightarrow> Well_order r"
218.113 by (simp add: Chains_def I_def) blast
218.114 have FI: "Field I = ?WO" by (auto simp add: I_def init_seg_of_def Field_def)
218.115 @@ -619,7 +616,7 @@
218.116 have "\<forall>r\<in>R. Refl r" and "\<forall>r\<in>R. trans r" and "\<forall>r\<in>R. antisym r"
218.117 and "\<forall>r\<in>R. Total r" and "\<forall>r\<in>R. wf (r - Id)"
218.118 using Chains_wo [OF `R \<in> Chains I`] by (simp_all add: order_on_defs)
218.119 - have "Refl (\<Union>R)" using `\<forall>r\<in>R. Refl r` by (auto simp: refl_on_def)
218.120 + have "Refl (\<Union>R)" using `\<forall>r\<in>R. Refl r` unfolding refl_on_def by fastforce
218.121 moreover have "trans (\<Union>R)"
218.122 by (rule chain_subset_trans_Union [OF subch `\<forall>r\<in>R. trans r`])
218.123 moreover have "antisym (\<Union>R)"
218.124 @@ -630,7 +627,7 @@
218.125 proof -
218.126 have "(\<Union>R) - Id = \<Union>{r - Id | r. r \<in> R}" by blast
218.127 with `\<forall>r\<in>R. wf (r - Id)` and wf_Union_wf_init_segs [OF Chains_inits_DiffI [OF Ris]]
218.128 - show ?thesis by (simp (no_asm_simp)) blast
218.129 + show ?thesis by fastforce
218.130 qed
218.131 ultimately have "Well_order (\<Union>R)" by(simp add:order_on_defs)
218.132 moreover have "\<forall>r \<in> R. r initial_segment_of \<Union>R" using Ris
218.133 @@ -643,7 +640,7 @@
218.134 --{*Zorn's Lemma yields a maximal well-order m:*}
218.135 then obtain m::"'a rel" where "Well_order m" and
218.136 max: "\<forall>r. Well_order r \<and> (m, r) \<in> I \<longrightarrow> r = m"
218.137 - using Zorns_po_lemma[OF 0 1] by (auto simp:FI)
218.138 + using Zorns_po_lemma[OF 0 1] unfolding FI by fastforce
218.139 --{*Now show by contradiction that m covers the whole type:*}
218.140 { fix x::'a assume "x \<notin> Field m"
218.141 --{*We assume that x is not covered and extend m at the top with x*}
218.142 @@ -666,7 +663,7 @@
218.143 have "Refl m" and "trans m" and "antisym m" and "Total m" and "wf (m - Id)"
218.144 using `Well_order m` by (simp_all add: order_on_defs)
218.145 --{*We show that the extension is a well-order*}
218.146 - have "Refl ?m" using `Refl m` Fm by (auto simp: refl_on_def)
218.147 + have "Refl ?m" using `Refl m` Fm unfolding refl_on_def by blast
218.148 moreover have "trans ?m" using `trans m` and `x \<notin> Field m`
218.149 unfolding trans_def Field_def by blast
218.150 moreover have "antisym ?m" using `antisym m` and `x \<notin> Field m`
218.151 @@ -678,7 +675,7 @@
218.152 by (auto simp add: wf_eq_minimal Field_def) metis
218.153 thus ?thesis using `wf (m - Id)` and `x \<notin> Field m`
218.154 wf_subset [OF `wf ?s` Diff_subset]
218.155 - by (fastforce intro!: wf_Un simp add: Un_Diff Field_def)
218.156 + unfolding Un_Diff Field_def by (auto intro: wf_Un)
218.157 qed
218.158 ultimately have "Well_order ?m" by (simp add: order_on_defs)
218.159 --{*We show that the extension is above m*}
218.160 @@ -709,208 +706,7 @@
218.161 moreover have "Total ?r" using `Total r` by (simp add:total_on_def 1 univ)
218.162 moreover have "wf (?r - Id)" by (rule wf_subset [OF `wf (r - Id)`]) blast
218.163 ultimately have "Well_order ?r" by (simp add: order_on_defs)
218.164 - with 1 show ?thesis by metis
218.165 -qed
218.166 -
218.167 -subsection {* Extending Well-founded Relations to Well-Orders *}
218.168 -
218.169 -text {*A \emph{downset} (also lower set, decreasing set, initial segment, or
218.170 -downward closed set) is closed w.r.t.\ smaller elements.*}
218.171 -definition downset_on where
218.172 - "downset_on A r = (\<forall>x y. (x, y) \<in> r \<and> y \<in> A \<longrightarrow> x \<in> A)"
218.173 -
218.174 -(*
218.175 -text {*Connection to order filters of the @{theory Cardinals} theory.*}
218.176 -lemma (in wo_rel) ofilter_downset_on_conv:
218.177 - "ofilter A \<longleftrightarrow> downset_on A r \<and> A \<subseteq> Field r"
218.178 - by (auto simp: downset_on_def ofilter_def under_def)
218.179 -*)
218.180 -
218.181 -lemma downset_onI:
218.182 - "(\<And>x y. (x, y) \<in> r \<Longrightarrow> y \<in> A \<Longrightarrow> x \<in> A) \<Longrightarrow> downset_on A r"
218.183 - by (auto simp: downset_on_def)
218.184 -
218.185 -lemma downset_onD:
218.186 - "downset_on A r \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> y \<in> A \<Longrightarrow> x \<in> A"
218.187 - by (auto simp: downset_on_def)
218.188 -
218.189 -text {*Extensions of relations w.r.t.\ a given set.*}
218.190 -definition extension_on where
218.191 - "extension_on A r s = (\<forall>x\<in>A. \<forall>y\<in>A. (x, y) \<in> s \<longrightarrow> (x, y) \<in> r)"
218.192 -
218.193 -lemma extension_onI:
218.194 - "(\<And>x y. \<lbrakk>x \<in> A; y \<in> A; (x, y) \<in> s\<rbrakk> \<Longrightarrow> (x, y) \<in> r) \<Longrightarrow> extension_on A r s"
218.195 - by (auto simp: extension_on_def)
218.196 -
218.197 -lemma extension_onD:
218.198 - "extension_on A r s \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> (x, y) \<in> s \<Longrightarrow> (x, y) \<in> r"
218.199 - by (auto simp: extension_on_def)
218.200 -
218.201 -lemma downset_on_Union:
218.202 - assumes "\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p"
218.203 - shows "downset_on (Field (\<Union>R)) p"
218.204 - using assms by (auto intro: downset_onI dest: downset_onD)
218.205 -
218.206 -lemma chain_subset_extension_on_Union:
218.207 - assumes "chain\<^sub>\<subseteq> R" and "\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p"
218.208 - shows "extension_on (Field (\<Union>R)) (\<Union>R) p"
218.209 - using assms
218.210 - by (simp add: chain_subset_def extension_on_def) (metis mono_Field set_mp)
218.211 -
218.212 -lemma downset_on_empty [simp]: "downset_on {} p"
218.213 - by (auto simp: downset_on_def)
218.214 -
218.215 -lemma extension_on_empty [simp]: "extension_on {} p q"
218.216 - by (auto simp: extension_on_def)
218.217 -
218.218 -text {*Every well-founded relation can be extended to a well-order.*}
218.219 -theorem well_order_extension:
218.220 - assumes "wf p"
218.221 - shows "\<exists>w. p \<subseteq> w \<and> Well_order w"
218.222 -proof -
218.223 - let ?K = "{r. Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p}"
218.224 - def I \<equiv> "init_seg_of \<inter> ?K \<times> ?K"
218.225 - have I_init: "I \<subseteq> init_seg_of" by (simp add: I_def)
218.226 - then have subch: "\<And>R. R \<in> Chains I \<Longrightarrow> chain\<^sub>\<subseteq> R"
218.227 - by (auto simp: init_seg_of_def chain_subset_def Chains_def)
218.228 - have Chains_wo: "\<And>R r. R \<in> Chains I \<Longrightarrow> r \<in> R \<Longrightarrow>
218.229 - Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p"
218.230 - by (simp add: Chains_def I_def) blast
218.231 - have FI: "Field I = ?K" by (auto simp: I_def init_seg_of_def Field_def)
218.232 - then have 0: "Partial_order I"
218.233 - by (auto simp: partial_order_on_def preorder_on_def antisym_def antisym_init_seg_of refl_on_def
218.234 - trans_def I_def elim: trans_init_seg_of)
218.235 - { fix R assume "R \<in> Chains I"
218.236 - then have Ris: "R \<in> Chains init_seg_of" using mono_Chains [OF I_init] by blast
218.237 - have subch: "chain\<^sub>\<subseteq> R" using `R \<in> Chains I` I_init
218.238 - by (auto simp: init_seg_of_def chain_subset_def Chains_def)
218.239 - have "\<forall>r\<in>R. Refl r" and "\<forall>r\<in>R. trans r" and "\<forall>r\<in>R. antisym r" and
218.240 - "\<forall>r\<in>R. Total r" and "\<forall>r\<in>R. wf (r - Id)" and
218.241 - "\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p" and
218.242 - "\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p"
218.243 - using Chains_wo [OF `R \<in> Chains I`] by (simp_all add: order_on_defs)
218.244 - have "Refl (\<Union>R)" using `\<forall>r\<in>R. Refl r` by (auto simp: refl_on_def)
218.245 - moreover have "trans (\<Union>R)"
218.246 - by (rule chain_subset_trans_Union [OF subch `\<forall>r\<in>R. trans r`])
218.247 - moreover have "antisym (\<Union>R)"
218.248 - by (rule chain_subset_antisym_Union [OF subch `\<forall>r\<in>R. antisym r`])
218.249 - moreover have "Total (\<Union>R)"
218.250 - by (rule chain_subset_Total_Union [OF subch `\<forall>r\<in>R. Total r`])
218.251 - moreover have "wf ((\<Union>R) - Id)"
218.252 - proof -
218.253 - have "(\<Union>R) - Id = \<Union>{r - Id | r. r \<in> R}" by blast
218.254 - with `\<forall>r\<in>R. wf (r - Id)` wf_Union_wf_init_segs [OF Chains_inits_DiffI [OF Ris]]
218.255 - show ?thesis by (simp (no_asm_simp)) blast
218.256 - qed
218.257 - ultimately have "Well_order (\<Union>R)" by (simp add: order_on_defs)
218.258 - moreover have "\<forall>r\<in>R. r initial_segment_of \<Union>R" using Ris
218.259 - by (simp add: Chains_init_seg_of_Union)
218.260 - moreover have "downset_on (Field (\<Union>R)) p"
218.261 - by (rule downset_on_Union [OF `\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p`])
218.262 - moreover have "extension_on (Field (\<Union>R)) (\<Union>R) p"
218.263 - by (rule chain_subset_extension_on_Union [OF subch `\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p`])
218.264 - ultimately have "\<Union>R \<in> ?K \<and> (\<forall>r\<in>R. (r,\<Union>R) \<in> I)"
218.265 - using mono_Chains [OF I_init] and `R \<in> Chains I`
218.266 - by (simp (no_asm) add: I_def del: Field_Union) (metis Chains_wo)
218.267 - }
218.268 - then have 1: "\<forall>R\<in>Chains I. \<exists>u\<in>Field I. \<forall>r\<in>R. (r, u) \<in> I" by (subst FI) blast
218.269 - txt {*Zorn's Lemma yields a maximal well-order m.*}
218.270 - from Zorns_po_lemma [OF 0 1] obtain m :: "('a \<times> 'a) set"
218.271 - where "Well_order m" and "downset_on (Field m) p" and "extension_on (Field m) m p" and
218.272 - max: "\<forall>r. Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p \<and>
218.273 - (m, r) \<in> I \<longrightarrow> r = m"
218.274 - by (auto simp: FI)
218.275 - have "Field p \<subseteq> Field m"
218.276 - proof (rule ccontr)
218.277 - let ?Q = "Field p - Field m"
218.278 - assume "\<not> (Field p \<subseteq> Field m)"
218.279 - with assms [unfolded wf_eq_minimal, THEN spec, of ?Q]
218.280 - obtain x where "x \<in> Field p" and "x \<notin> Field m" and
218.281 - min: "\<forall>y. (y, x) \<in> p \<longrightarrow> y \<notin> ?Q" by blast
218.282 - txt {*Add @{term x} as topmost element to @{term m}.*}
218.283 - let ?s = "{(y, x) | y. y \<in> Field m}"
218.284 - let ?m = "insert (x, x) m \<union> ?s"
218.285 - have Fm: "Field ?m = insert x (Field m)" by (auto simp: Field_def)
218.286 - have "Refl m" and "trans m" and "antisym m" and "Total m" and "wf (m - Id)"
218.287 - using `Well_order m` by (simp_all add: order_on_defs)
218.288 - txt {*We show that the extension is a well-order.*}
218.289 - have "Refl ?m" using `Refl m` Fm by (auto simp: refl_on_def)
218.290 - moreover have "trans ?m" using `trans m` `x \<notin> Field m`
218.291 - unfolding trans_def Field_def Domain_unfold Domain_converse [symmetric] by blast
218.292 - moreover have "antisym ?m" using `antisym m` `x \<notin> Field m`
218.293 - unfolding antisym_def Field_def Domain_unfold Domain_converse [symmetric] by blast
218.294 - moreover have "Total ?m" using `Total m` Fm by (auto simp: Relation.total_on_def)
218.295 - moreover have "wf (?m - Id)"
218.296 - proof -
218.297 - have "wf ?s" using `x \<notin> Field m`
218.298 - by (simp add: wf_eq_minimal Field_def Domain_unfold Domain_converse [symmetric]) metis
218.299 - thus ?thesis using `wf (m - Id)` `x \<notin> Field m`
218.300 - wf_subset [OF `wf ?s` Diff_subset]
218.301 - by (fastforce intro!: wf_Un simp add: Un_Diff Field_def)
218.302 - qed
218.303 - ultimately have "Well_order ?m" by (simp add: order_on_defs)
218.304 - moreover have "extension_on (Field ?m) ?m p"
218.305 - using `extension_on (Field m) m p` `downset_on (Field m) p`
218.306 - by (subst Fm) (auto simp: extension_on_def dest: downset_onD)
218.307 - moreover have "downset_on (Field ?m) p"
218.308 - using `downset_on (Field m) p` and min
218.309 - by (subst Fm, simp add: downset_on_def Field_def) (metis Domain_iff)
218.310 - moreover have "(m, ?m) \<in> I"
218.311 - using `Well_order m` and `Well_order ?m` and
218.312 - `downset_on (Field m) p` and `downset_on (Field ?m) p` and
218.313 - `extension_on (Field m) m p` and `extension_on (Field ?m) ?m p` and
218.314 - `Refl m` and `x \<notin> Field m`
218.315 - by (auto simp: I_def init_seg_of_def refl_on_def)
218.316 - ultimately
218.317 - --{*This contradicts maximality of m:*}
218.318 - show False using max and `x \<notin> Field m` unfolding Field_def by blast
218.319 - qed
218.320 - have "p \<subseteq> m"
218.321 - using `Field p \<subseteq> Field m` and `extension_on (Field m) m p`
218.322 - by (force simp: Field_def extension_on_def)
218.323 - with `Well_order m` show ?thesis by blast
218.324 -qed
218.325 -
218.326 -text {*Every well-founded relation can be extended to a total well-order.*}
218.327 -corollary total_well_order_extension:
218.328 - assumes "wf p"
218.329 - shows "\<exists>w. p \<subseteq> w \<and> Well_order w \<and> Field w = UNIV"
218.330 -proof -
218.331 - from well_order_extension [OF assms] obtain w
218.332 - where "p \<subseteq> w" and wo: "Well_order w" by blast
218.333 - let ?A = "UNIV - Field w"
218.334 - from well_order_on [of ?A] obtain w' where wo': "well_order_on ?A w'" ..
218.335 - have [simp]: "Field w' = ?A" using rel.well_order_on_Well_order [OF wo'] by simp
218.336 - have *: "Field w \<inter> Field w' = {}" by simp
218.337 - let ?w = "w \<union>o w'"
218.338 - have "p \<subseteq> ?w" using `p \<subseteq> w` by (auto simp: Osum_def)
218.339 - moreover have "Well_order ?w" using Osum_Well_order [OF * wo] and wo' by simp
218.340 - moreover have "Field ?w = UNIV" by (simp add: Field_Osum)
218.341 - ultimately show ?thesis by blast
218.342 -qed
218.343 -
218.344 -corollary well_order_on_extension:
218.345 - assumes "wf p" and "Field p \<subseteq> A"
218.346 - shows "\<exists>w. p \<subseteq> w \<and> well_order_on A w"
218.347 -proof -
218.348 - from total_well_order_extension [OF `wf p`] obtain r
218.349 - where "p \<subseteq> r" and wo: "Well_order r" and univ: "Field r = UNIV" by blast
218.350 - let ?r = "{(x, y). x \<in> A \<and> y \<in> A \<and> (x, y) \<in> r}"
218.351 - from `p \<subseteq> r` have "p \<subseteq> ?r" using `Field p \<subseteq> A` by (auto simp: Field_def)
218.352 - have 1: "Field ?r = A" using wo univ
218.353 - by (fastforce simp: Field_def order_on_defs refl_on_def)
218.354 - have "Refl r" "trans r" "antisym r" "Total r" "wf (r - Id)"
218.355 - using `Well_order r` by (simp_all add: order_on_defs)
218.356 - have "refl_on A ?r" using `Refl r` by (auto simp: refl_on_def univ)
218.357 - moreover have "trans ?r" using `trans r`
218.358 - unfolding trans_def by blast
218.359 - moreover have "antisym ?r" using `antisym r`
218.360 - unfolding antisym_def by blast
218.361 - moreover have "total_on A ?r" using `Total r` by (simp add: total_on_def univ)
218.362 - moreover have "wf (?r - Id)" by (rule wf_subset [OF `wf(r - Id)`]) blast
218.363 - ultimately have "well_order_on A ?r" by (simp add: order_on_defs)
218.364 - with `p \<subseteq> ?r` show ?thesis by blast
218.365 + with 1 show ?thesis by auto
218.366 qed
218.367
218.368 end
218.369 -
219.1 --- a/src/HOL/Library/refute.ML Thu Dec 05 17:52:12 2013 +0100
219.2 +++ b/src/HOL/Library/refute.ML Thu Dec 05 17:58:03 2013 +0100
219.3 @@ -392,7 +392,7 @@
219.4 (* TRANSLATION HOL -> PROPOSITIONAL LOGIC, BOOLEAN ASSIGNMENT -> MODEL *)
219.5 (* ------------------------------------------------------------------------- *)
219.6
219.7 -val typ_of_dtyp = ATP_Util.typ_of_dtyp
219.8 +val typ_of_dtyp = Nitpick_Util.typ_of_dtyp
219.9
219.10 (* ------------------------------------------------------------------------- *)
219.11 (* close_form: universal closure over schematic variables in 't' *)
220.1 --- a/src/HOL/Library/simps_case_conv.ML Thu Dec 05 17:52:12 2013 +0100
220.2 +++ b/src/HOL/Library/simps_case_conv.ML Thu Dec 05 17:58:03 2013 +0100
220.3 @@ -22,9 +22,9 @@
220.4 | collect_Tcons (TFree _) = []
220.5 | collect_Tcons (TVar _) = []
220.6
220.7 -fun get_split_ths thy = collect_Tcons
220.8 +fun get_split_ths ctxt = collect_Tcons
220.9 #> distinct (op =)
220.10 - #> map_filter (Datatype_Data.get_info thy)
220.11 + #> map_filter (Ctr_Sugar.ctr_sugar_of ctxt)
220.12 #> map #split
220.13
220.14 val strip_eq = prop_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq
220.15 @@ -80,7 +80,7 @@
220.16 val case_arg = HOLogic.mk_tuple (flat def_frees)
220.17 val cases = Case_Translation.make_case ctxt' Case_Translation.Warning Name.context
220.18 case_arg (pattern ~~ rhss)
220.19 - val split_thms = get_split_ths (Proof_Context.theory_of ctxt') (fastype_of case_arg)
220.20 + val split_thms = get_split_ths ctxt' (fastype_of case_arg)
220.21 val t = (list_comb (fun_t, def_pats), cases)
220.22 |> HOLogic.mk_eq
220.23 |> HOLogic.mk_Trueprop
220.24 @@ -194,7 +194,7 @@
220.25 fun to_simps ctxt thm =
220.26 let
220.27 val T = thm |> strip_eq |> fst |> strip_comb |> fst |> fastype_of
220.28 - val splitthms = get_split_ths (Proof_Context.theory_of ctxt) T
220.29 + val splitthms = get_split_ths ctxt T
220.30 in gen_to_simps ctxt splitthms thm end
220.31
220.32
221.1 --- a/src/HOL/Lifting_Set.thy Thu Dec 05 17:52:12 2013 +0100
221.2 +++ b/src/HOL/Lifting_Set.thy Thu Dec 05 17:58:03 2013 +0100
221.3 @@ -153,7 +153,7 @@
221.4 unfolding fun_rel_def set_rel_def by fast
221.5
221.6 lemma SUPR_parametric [transfer_rule]:
221.7 - "(set_rel R ===> (R ===> op =) ===> op =) SUPR SUPR"
221.8 + "(set_rel R ===> (R ===> op =) ===> op =) SUPR (SUPR :: _ \<Rightarrow> _ \<Rightarrow> _::complete_lattice)"
221.9 proof(rule fun_relI)+
221.10 fix A B f and g :: "'b \<Rightarrow> 'c"
221.11 assume AB: "set_rel R A B"
222.1 --- a/src/HOL/Limits.thy Thu Dec 05 17:52:12 2013 +0100
222.2 +++ b/src/HOL/Limits.thy Thu Dec 05 17:58:03 2013 +0100
222.3 @@ -138,6 +138,18 @@
222.4 lemma BseqI: "[| 0 < K; \<forall>n. norm (X n) \<le> K |] ==> Bseq X"
222.5 by (auto simp add: Bseq_def)
222.6
222.7 +lemma Bseq_bdd_above: "Bseq (X::nat \<Rightarrow> real) \<Longrightarrow> bdd_above (range X)"
222.8 +proof (elim BseqE, intro bdd_aboveI2)
222.9 + fix K n assume "0 < K" "\<forall>n. norm (X n) \<le> K" then show "X n \<le> K"
222.10 + by (auto elim!: allE[of _ n])
222.11 +qed
222.12 +
222.13 +lemma Bseq_bdd_below: "Bseq (X::nat \<Rightarrow> real) \<Longrightarrow> bdd_below (range X)"
222.14 +proof (elim BseqE, intro bdd_belowI2)
222.15 + fix K n assume "0 < K" "\<forall>n. norm (X n) \<le> K" then show "- K \<le> X n"
222.16 + by (auto elim!: allE[of _ n])
222.17 +qed
222.18 +
222.19 lemma lemma_NBseq_def:
222.20 "(\<exists>K > 0. \<forall>n. norm (X n) \<le> K) = (\<exists>N. \<forall>n. norm (X n) \<le> real(Suc N))"
222.21 proof safe
222.22 @@ -179,7 +191,7 @@
222.23 apply (rule_tac x = K in exI, simp)
222.24 apply (rule exI [where x = 0], auto)
222.25 apply (erule order_less_le_trans, simp)
222.26 -apply (drule_tac x=n in spec, fold diff_minus)
222.27 +apply (drule_tac x=n in spec)
222.28 apply (drule order_trans [OF norm_triangle_ineq2])
222.29 apply simp
222.30 done
222.31 @@ -192,9 +204,11 @@
222.32 then obtain K
222.33 where *: "0 < K" and **: "\<And>n. norm (X n) \<le> K" by (auto simp add: Bseq_def)
222.34 from * have "0 < K + norm (X 0)" by (rule order_less_le_trans) simp
222.35 - moreover from ** have "\<forall>n. norm (X n + - X 0) \<le> K + norm (X 0)"
222.36 - by (auto intro: order_trans norm_triangle_ineq)
222.37 - ultimately show ?Q by blast
222.38 + from ** have "\<forall>n. norm (X n - X 0) \<le> K + norm (X 0)"
222.39 + by (auto intro: order_trans norm_triangle_ineq4)
222.40 + then have "\<forall>n. norm (X n + - X 0) \<le> K + norm (X 0)"
222.41 + by simp
222.42 + with `0 < K + norm (X 0)` show ?Q by blast
222.43 next
222.44 assume ?Q then show ?P by (auto simp add: Bseq_iff2)
222.45 qed
222.46 @@ -205,20 +219,9 @@
222.47 apply (drule_tac x = n in spec, arith)
222.48 done
222.49
222.50 +
222.51 subsubsection{*Upper Bounds and Lubs of Bounded Sequences*}
222.52
222.53 -lemma Bseq_isUb:
222.54 - "!!(X::nat=>real). Bseq X ==> \<exists>U. isUb (UNIV::real set) {x. \<exists>n. X n = x} U"
222.55 -by (auto intro: isUbI setleI simp add: Bseq_def abs_le_iff)
222.56 -
222.57 -text{* Use completeness of reals (supremum property)
222.58 - to show that any bounded sequence has a least upper bound*}
222.59 -
222.60 -lemma Bseq_isLub:
222.61 - "!!(X::nat=>real). Bseq X ==>
222.62 - \<exists>U. isLub (UNIV::real set) {x. \<exists>n. X n = x} U"
222.63 -by (blast intro: reals_complete Bseq_isUb)
222.64 -
222.65 lemma Bseq_minus_iff: "Bseq (%n. -(X n) :: 'a :: real_normed_vector) = Bseq X"
222.66 by (simp add: Bseq_def)
222.67
222.68 @@ -342,7 +345,7 @@
222.69 unfolding Zfun_def by simp
222.70
222.71 lemma Zfun_diff: "\<lbrakk>Zfun f F; Zfun g F\<rbrakk> \<Longrightarrow> Zfun (\<lambda>x. f x - g x) F"
222.72 - by (simp only: diff_minus Zfun_add Zfun_minus)
222.73 + using Zfun_add [of f F "\<lambda>x. - g x"] by (simp add: Zfun_minus)
222.74
222.75 lemma (in bounded_linear) Zfun:
222.76 assumes g: "Zfun g F"
222.77 @@ -532,7 +535,7 @@
222.78 lemma tendsto_diff [tendsto_intros]:
222.79 fixes a b :: "'a::real_normed_vector"
222.80 shows "\<lbrakk>(f ---> a) F; (g ---> b) F\<rbrakk> \<Longrightarrow> ((\<lambda>x. f x - g x) ---> a - b) F"
222.81 - by (simp add: diff_minus tendsto_add tendsto_minus)
222.82 + using tendsto_add [of f a F "\<lambda>x. - g x" "- b"] by (simp add: tendsto_minus)
222.83
222.84 lemma continuous_diff [continuous_intros]:
222.85 fixes f g :: "'a::t2_space \<Rightarrow> 'b::real_normed_vector"
222.86 @@ -1355,40 +1358,29 @@
222.87
222.88 text {* A monotone sequence converges to its least upper bound. *}
222.89
222.90 -lemma isLub_mono_imp_LIMSEQ:
222.91 - fixes X :: "nat \<Rightarrow> real"
222.92 - assumes u: "isLub UNIV {x. \<exists>n. X n = x} u" (* FIXME: use 'range X' *)
222.93 - assumes X: "\<forall>m n. m \<le> n \<longrightarrow> X m \<le> X n"
222.94 - shows "X ----> u"
222.95 -proof (rule LIMSEQ_I)
222.96 - have 1: "\<forall>n. X n \<le> u"
222.97 - using isLubD2 [OF u] by auto
222.98 - have "\<forall>y. (\<forall>n. X n \<le> y) \<longrightarrow> u \<le> y"
222.99 - using isLub_le_isUb [OF u] by (auto simp add: isUb_def setle_def)
222.100 - hence 2: "\<forall>y<u. \<exists>n. y < X n"
222.101 - by (metis not_le)
222.102 - fix r :: real assume "0 < r"
222.103 - hence "u - r < u" by simp
222.104 - hence "\<exists>m. u - r < X m" using 2 by simp
222.105 - then obtain m where "u - r < X m" ..
222.106 - with X have "\<forall>n\<ge>m. u - r < X n"
222.107 - by (fast intro: less_le_trans)
222.108 - hence "\<exists>m. \<forall>n\<ge>m. u - r < X n" ..
222.109 - thus "\<exists>m. \<forall>n\<ge>m. norm (X n - u) < r"
222.110 - using 1 by (simp add: diff_less_eq add_commute)
222.111 -qed
222.112 +lemma LIMSEQ_incseq_SUP:
222.113 + fixes X :: "nat \<Rightarrow> 'a::{conditionally_complete_linorder, linorder_topology}"
222.114 + assumes u: "bdd_above (range X)"
222.115 + assumes X: "incseq X"
222.116 + shows "X ----> (SUP i. X i)"
222.117 + by (rule order_tendstoI)
222.118 + (auto simp: eventually_sequentially u less_cSUP_iff intro: X[THEN incseqD] less_le_trans cSUP_lessD[OF u])
222.119
222.120 -text{*A standard proof of the theorem for monotone increasing sequence*}
222.121 -
222.122 -lemma Bseq_mono_convergent:
222.123 - "Bseq X \<Longrightarrow> \<forall>m. \<forall>n \<ge> m. X m \<le> X n \<Longrightarrow> convergent (X::nat=>real)"
222.124 - by (metis Bseq_isLub isLub_mono_imp_LIMSEQ convergentI)
222.125 +lemma LIMSEQ_decseq_INF:
222.126 + fixes X :: "nat \<Rightarrow> 'a::{conditionally_complete_linorder, linorder_topology}"
222.127 + assumes u: "bdd_below (range X)"
222.128 + assumes X: "decseq X"
222.129 + shows "X ----> (INF i. X i)"
222.130 + by (rule order_tendstoI)
222.131 + (auto simp: eventually_sequentially u cINF_less_iff intro: X[THEN decseqD] le_less_trans less_cINF_D[OF u])
222.132
222.133 text{*Main monotonicity theorem*}
222.134
222.135 lemma Bseq_monoseq_convergent: "Bseq X \<Longrightarrow> monoseq X \<Longrightarrow> convergent (X::nat\<Rightarrow>real)"
222.136 - by (metis monoseq_iff incseq_def decseq_eq_incseq convergent_minus_iff Bseq_minus_iff
222.137 - Bseq_mono_convergent)
222.138 + by (auto simp: monoseq_iff convergent_def intro: LIMSEQ_decseq_INF LIMSEQ_incseq_SUP dest: Bseq_bdd_above Bseq_bdd_below)
222.139 +
222.140 +lemma Bseq_mono_convergent: "Bseq X \<Longrightarrow> (\<forall>m n. m \<le> n \<longrightarrow> X m \<le> X n) \<Longrightarrow> convergent (X::nat\<Rightarrow>real)"
222.141 + by (auto intro!: Bseq_monoseq_convergent incseq_imp_monoseq simp: incseq_def)
222.142
222.143 lemma Cauchy_iff:
222.144 fixes X :: "nat \<Rightarrow> 'a::real_normed_vector"
223.1 --- a/src/HOL/List.thy Thu Dec 05 17:52:12 2013 +0100
223.2 +++ b/src/HOL/List.thy Thu Dec 05 17:58:03 2013 +0100
223.3 @@ -5,7 +5,7 @@
223.4 header {* The datatype of finite lists *}
223.5
223.6 theory List
223.7 -imports Presburger Code_Numeral Quotient ATP Lifting_Set Lifting_Option Lifting_Product
223.8 +imports Presburger Code_Numeral Quotient Lifting_Set Lifting_Option Lifting_Product
223.9 begin
223.10
223.11 datatype 'a list =
223.12 @@ -542,7 +542,6 @@
223.13
223.14 fun simproc ctxt redex =
223.15 let
223.16 - val thy = Proof_Context.theory_of ctxt
223.17 val set_Nil_I = @{thm trans} OF [@{thm set.simps(1)}, @{thm empty_def}]
223.18 val set_singleton = @{lemma "set [a] = {x. x = a}" by simp}
223.19 val inst_Collect_mem_eq = @{lemma "set A = {x. x : set A}" by simp}
223.20 @@ -563,21 +562,22 @@
223.21 in
223.22 fold_index check cases (SOME NONE) |> the_default NONE
223.23 end
223.24 - (* returns (case_expr type index chosen_case) option *)
223.25 + (* returns (case_expr type index chosen_case constr_name) option *)
223.26 fun dest_case case_term =
223.27 let
223.28 val (case_const, args) = strip_comb case_term
223.29 in
223.30 (case try dest_Const case_const of
223.31 SOME (c, T) =>
223.32 - (case Datatype.info_of_case thy c of
223.33 - SOME _ =>
223.34 + (case Ctr_Sugar.ctr_sugar_of_case ctxt c of
223.35 + SOME {ctrs, ...} =>
223.36 (case possible_index_of_singleton_case (fst (split_last args)) of
223.37 SOME i =>
223.38 let
223.39 + val constr_names = map (fst o dest_Const) ctrs
223.40 val (Ts, _) = strip_type T
223.41 val T' = List.last Ts
223.42 - in SOME (List.last args, T', i, nth args i) end
223.43 + in SOME (List.last args, T', i, nth args i, nth constr_names i) end
223.44 | NONE => NONE)
223.45 | NONE => NONE)
223.46 | NONE => NONE)
223.47 @@ -605,12 +605,13 @@
223.48 THEN rtac set_Nil_I 1
223.49 | tac ctxt (Case (T, i) :: cont) =
223.50 let
223.51 - val info = Datatype.the_info thy (fst (dest_Type T))
223.52 + val SOME {injects, distincts, case_thms, split, ...} =
223.53 + Ctr_Sugar.ctr_sugar_of ctxt (fst (dest_Type T))
223.54 in
223.55 (* do case distinction *)
223.56 - Splitter.split_tac [#split info] 1
223.57 + Splitter.split_tac [split] 1
223.58 THEN EVERY (map_index (fn (i', _) =>
223.59 - (if i' < length (#case_rewrites info) - 1 then rtac @{thm conjI} 1 else all_tac)
223.60 + (if i' < length case_thms - 1 then rtac @{thm conjI} 1 else all_tac)
223.61 THEN REPEAT_DETERM (rtac @{thm allI} 1)
223.62 THEN rtac @{thm impI} 1
223.63 THEN (if i' = i then
223.64 @@ -619,7 +620,7 @@
223.65 CONVERSION (Thm.eta_conversion then_conv right_hand_set_comprehension_conv (K
223.66 ((HOLogic.conj_conv
223.67 (HOLogic.eq_conv Conv.all_conv (rewr_conv' (List.last prems)) then_conv
223.68 - (Conv.try_conv (Conv.rewrs_conv (map mk_meta_eq (#inject info)))))
223.69 + (Conv.try_conv (Conv.rewrs_conv (map mk_meta_eq injects))))
223.70 Conv.all_conv)
223.71 then_conv (Conv.try_conv (Conv.rewr_conv del_refl_eq))
223.72 then_conv conjunct_assoc_conv)) context
223.73 @@ -636,7 +637,7 @@
223.74 (HOLogic.conj_conv
223.75 ((HOLogic.eq_conv Conv.all_conv
223.76 (rewr_conv' (List.last prems))) then_conv
223.77 - (Conv.rewrs_conv (map (fn th => th RS @{thm Eq_FalseI}) (#distinct info))))
223.78 + (Conv.rewrs_conv (map (fn th => th RS @{thm Eq_FalseI}) distincts)))
223.79 Conv.all_conv then_conv
223.80 (rewr_conv' @{lemma "(False & P) = False" by simp}))) context then_conv
223.81 HOLogic.Trueprop_conv
223.82 @@ -646,16 +647,15 @@
223.83 (Conv.bottom_conv
223.84 (K (rewr_conv'
223.85 @{lemma "(EX x. P) = P" by simp})) ctxt)) context))) 1) ctxt 1
223.86 - THEN rtac set_Nil_I 1)) (#case_rewrites info))
223.87 + THEN rtac set_Nil_I 1)) case_thms)
223.88 end
223.89 fun make_inner_eqs bound_vs Tis eqs t =
223.90 (case dest_case t of
223.91 - SOME (x, T, i, cont) =>
223.92 + SOME (x, T, i, cont, constr_name) =>
223.93 let
223.94 val (vs, body) = strip_abs (Envir.eta_long (map snd bound_vs) cont)
223.95 val x' = incr_boundvars (length vs) x
223.96 val eqs' = map (incr_boundvars (length vs)) eqs
223.97 - val (constr_name, _) = nth (the (Datatype.get_constrs thy (fst (dest_Type T)))) i
223.98 val constr_t =
223.99 list_comb
223.100 (Const (constr_name, map snd vs ---> T), map Bound (((length vs) - 1) downto 0))
223.101 @@ -902,7 +902,7 @@
223.102 lemma self_append_conv [iff]: "(xs = xs @ ys) = (ys = [])"
223.103 by (induct xs) auto
223.104
223.105 -lemma append_eq_append_conv [simp, no_atp]:
223.106 +lemma append_eq_append_conv [simp]:
223.107 "length xs = length ys \<or> length us = length vs
223.108 ==> (xs@us = ys@vs) = (xs=ys \<and> us=vs)"
223.109 apply (induct xs arbitrary: ys)
223.110 @@ -934,7 +934,7 @@
223.111 lemma self_append_conv2 [iff]: "(ys = xs @ ys) = (xs = [])"
223.112 using append_same_eq [of "[]"] by auto
223.113
223.114 -lemma hd_Cons_tl [simp,no_atp]: "xs \<noteq> [] ==> hd xs # tl xs = xs"
223.115 +lemma hd_Cons_tl [simp]: "xs \<noteq> [] ==> hd xs # tl xs = xs"
223.116 by (induct xs) auto
223.117
223.118 lemma hd_append: "hd (xs @ ys) = (if xs = [] then hd ys else hd xs)"
223.119 @@ -1178,7 +1178,7 @@
223.120 lemma singleton_rev_conv [simp]: "([x] = rev xs) = (xs = [x])"
223.121 by (cases xs) auto
223.122
223.123 -lemma rev_is_rev_conv [iff, no_atp]: "(rev xs = rev ys) = (xs = ys)"
223.124 +lemma rev_is_rev_conv [iff]: "(rev xs = rev ys) = (xs = ys)"
223.125 apply (induct xs arbitrary: ys, force)
223.126 apply (case_tac ys, simp, force)
223.127 done
223.128 @@ -2988,6 +2988,9 @@
223.129 lemma map_Suc_upt: "map Suc [m..<n] = [Suc m..<Suc n]"
223.130 by (induct n) auto
223.131
223.132 +lemma map_add_upt: "map (\<lambda>i. i + n) [0..<m] = [n..<m + n]"
223.133 + by (induct m) simp_all
223.134 +
223.135 lemma nth_map_upt: "i < n-m ==> (map f [m..<n]) ! i = f(m+i)"
223.136 apply (induct n m arbitrary: i rule: diff_induct)
223.137 prefer 3 apply (subst map_Suc_upt[symmetric])
223.138 @@ -3072,9 +3075,9 @@
223.139
223.140 lemmas upto_rec_numeral [simp] =
223.141 upto.simps[of "numeral m" "numeral n"]
223.142 - upto.simps[of "numeral m" "neg_numeral n"]
223.143 - upto.simps[of "neg_numeral m" "numeral n"]
223.144 - upto.simps[of "neg_numeral m" "neg_numeral n"] for m n
223.145 + upto.simps[of "numeral m" "- numeral n"]
223.146 + upto.simps[of "- numeral m" "numeral n"]
223.147 + upto.simps[of "- numeral m" "- numeral n"] for m n
223.148
223.149 lemma upto_empty[simp]: "j < i \<Longrightarrow> [i..j] = []"
223.150 by(simp add: upto.simps)
223.151 @@ -5084,10 +5087,10 @@
223.152 for A :: "'a set"
223.153 where
223.154 Nil [intro!, simp]: "[]: lists A"
223.155 - | Cons [intro!, simp, no_atp]: "[| a: A; l: lists A|] ==> a#l : lists A"
223.156 -
223.157 -inductive_cases listsE [elim!,no_atp]: "x#l : lists A"
223.158 -inductive_cases listspE [elim!,no_atp]: "listsp A (x # l)"
223.159 + | Cons [intro!, simp]: "[| a: A; l: lists A|] ==> a#l : lists A"
223.160 +
223.161 +inductive_cases listsE [elim!]: "x#l : lists A"
223.162 +inductive_cases listspE [elim!]: "listsp A (x # l)"
223.163
223.164 inductive_simps listsp_simps[code]:
223.165 "listsp A []"
223.166 @@ -5129,15 +5132,15 @@
223.167
223.168 lemmas in_lists_conv_set [code_unfold] = in_listsp_conv_set [to_set]
223.169
223.170 -lemma in_listspD [dest!,no_atp]: "listsp A xs ==> \<forall>x\<in>set xs. A x"
223.171 +lemma in_listspD [dest!]: "listsp A xs ==> \<forall>x\<in>set xs. A x"
223.172 by (rule in_listsp_conv_set [THEN iffD1])
223.173
223.174 -lemmas in_listsD [dest!,no_atp] = in_listspD [to_set]
223.175 -
223.176 -lemma in_listspI [intro!,no_atp]: "\<forall>x\<in>set xs. A x ==> listsp A xs"
223.177 +lemmas in_listsD [dest!] = in_listspD [to_set]
223.178 +
223.179 +lemma in_listspI [intro!]: "\<forall>x\<in>set xs. A x ==> listsp A xs"
223.180 by (rule in_listsp_conv_set [THEN iffD2])
223.181
223.182 -lemmas in_listsI [intro!,no_atp] = in_listspI [to_set]
223.183 +lemmas in_listsI [intro!] = in_listspI [to_set]
223.184
223.185 lemma lists_eq_set: "lists A = {xs. set xs <= A}"
223.186 by auto
223.187 @@ -5387,6 +5390,175 @@
223.188 apply (rule allI, case_tac x, simp, simp)
223.189 by blast
223.190
223.191 +text {*
223.192 + Predicate version of lexicographic order integrated with Isabelle's order type classes.
223.193 + Author: Andreas Lochbihler
223.194 +*}
223.195 +
223.196 +context ord begin
223.197 +
223.198 +inductive lexordp :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
223.199 +where
223.200 + Nil: "lexordp [] (y # ys)"
223.201 +| Cons: "x < y \<Longrightarrow> lexordp (x # xs) (y # ys)"
223.202 +| Cons_eq:
223.203 + "\<lbrakk> \<not> x < y; \<not> y < x; lexordp xs ys \<rbrakk> \<Longrightarrow> lexordp (x # xs) (y # ys)"
223.204 +
223.205 +lemma lexordp_simps [simp]:
223.206 + "lexordp [] ys = (ys \<noteq> [])"
223.207 + "lexordp xs [] = False"
223.208 + "lexordp (x # xs) (y # ys) \<longleftrightarrow> x < y \<or> \<not> y < x \<and> lexordp xs ys"
223.209 +by(subst lexordp.simps, fastforce simp add: neq_Nil_conv)+
223.210 +
223.211 +inductive lexordp_eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
223.212 + Nil: "lexordp_eq [] ys"
223.213 +| Cons: "x < y \<Longrightarrow> lexordp_eq (x # xs) (y # ys)"
223.214 +| Cons_eq: "\<lbrakk> \<not> x < y; \<not> y < x; lexordp_eq xs ys \<rbrakk> \<Longrightarrow> lexordp_eq (x # xs) (y # ys)"
223.215 +
223.216 +lemma lexordp_eq_simps [simp]:
223.217 + "lexordp_eq [] ys = True"
223.218 + "lexordp_eq xs [] \<longleftrightarrow> xs = []"
223.219 + "lexordp_eq (x # xs) [] = False"
223.220 + "lexordp_eq (x # xs) (y # ys) \<longleftrightarrow> x < y \<or> \<not> y < x \<and> lexordp_eq xs ys"
223.221 +by(subst lexordp_eq.simps, fastforce)+
223.222 +
223.223 +lemma lexordp_append_rightI: "ys \<noteq> Nil \<Longrightarrow> lexordp xs (xs @ ys)"
223.224 +by(induct xs)(auto simp add: neq_Nil_conv)
223.225 +
223.226 +lemma lexordp_append_left_rightI: "x < y \<Longrightarrow> lexordp (us @ x # xs) (us @ y # ys)"
223.227 +by(induct us) auto
223.228 +
223.229 +lemma lexordp_eq_refl: "lexordp_eq xs xs"
223.230 +by(induct xs) simp_all
223.231 +
223.232 +lemma lexordp_append_leftI: "lexordp us vs \<Longrightarrow> lexordp (xs @ us) (xs @ vs)"
223.233 +by(induct xs) auto
223.234 +
223.235 +lemma lexordp_append_leftD: "\<lbrakk> lexordp (xs @ us) (xs @ vs); \<forall>a. \<not> a < a \<rbrakk> \<Longrightarrow> lexordp us vs"
223.236 +by(induct xs) auto
223.237 +
223.238 +lemma lexordp_irreflexive:
223.239 + assumes irrefl: "\<forall>x. \<not> x < x"
223.240 + shows "\<not> lexordp xs xs"
223.241 +proof
223.242 + assume "lexordp xs xs"
223.243 + thus False by(induct xs ys\<equiv>xs)(simp_all add: irrefl)
223.244 +qed
223.245 +
223.246 +lemma lexordp_into_lexordp_eq:
223.247 + assumes "lexordp xs ys"
223.248 + shows "lexordp_eq xs ys"
223.249 +using assms by induct simp_all
223.250 +
223.251 +end
223.252 +
223.253 +declare ord.lexordp_simps [simp, code]
223.254 +declare ord.lexordp_eq_simps [code, simp]
223.255 +
223.256 +lemma lexord_code [code, code_unfold]: "lexordp = ord.lexordp less"
223.257 +unfolding lexordp_def ord.lexordp_def ..
223.258 +
223.259 +context order begin
223.260 +
223.261 +lemma lexordp_antisym:
223.262 + assumes "lexordp xs ys" "lexordp ys xs"
223.263 + shows False
223.264 +using assms by induct auto
223.265 +
223.266 +lemma lexordp_irreflexive': "\<not> lexordp xs xs"
223.267 +by(rule lexordp_irreflexive) simp
223.268 +
223.269 +end
223.270 +
223.271 +context linorder begin
223.272 +
223.273 +lemma lexordp_cases [consumes 1, case_names Nil Cons Cons_eq, cases pred: lexordp]:
223.274 + assumes "lexordp xs ys"
223.275 + obtains (Nil) y ys' where "xs = []" "ys = y # ys'"
223.276 + | (Cons) x xs' y ys' where "xs = x # xs'" "ys = y # ys'" "x < y"
223.277 + | (Cons_eq) x xs' ys' where "xs = x # xs'" "ys = x # ys'" "lexordp xs' ys'"
223.278 +using assms by cases (fastforce simp add: not_less_iff_gr_or_eq)+
223.279 +
223.280 +lemma lexordp_induct [consumes 1, case_names Nil Cons Cons_eq, induct pred: lexordp]:
223.281 + assumes major: "lexordp xs ys"
223.282 + and Nil: "\<And>y ys. P [] (y # ys)"
223.283 + and Cons: "\<And>x xs y ys. x < y \<Longrightarrow> P (x # xs) (y # ys)"
223.284 + and Cons_eq: "\<And>x xs ys. \<lbrakk> lexordp xs ys; P xs ys \<rbrakk> \<Longrightarrow> P (x # xs) (x # ys)"
223.285 + shows "P xs ys"
223.286 +using major by induct (simp_all add: Nil Cons not_less_iff_gr_or_eq Cons_eq)
223.287 +
223.288 +lemma lexordp_iff:
223.289 + "lexordp xs ys \<longleftrightarrow> (\<exists>x vs. ys = xs @ x # vs) \<or> (\<exists>us a b vs ws. a < b \<and> xs = us @ a # vs \<and> ys = us @ b # ws)"
223.290 + (is "?lhs = ?rhs")
223.291 +proof
223.292 + assume ?lhs thus ?rhs
223.293 + proof induct
223.294 + case Cons_eq thus ?case by simp (metis append.simps(2))
223.295 + qed(fastforce intro: disjI2 del: disjCI intro: exI[where x="[]"])+
223.296 +next
223.297 + assume ?rhs thus ?lhs
223.298 + by(auto intro: lexordp_append_leftI[where us="[]", simplified] lexordp_append_leftI)
223.299 +qed
223.300 +
223.301 +lemma lexordp_conv_lexord:
223.302 + "lexordp xs ys \<longleftrightarrow> (xs, ys) \<in> lexord {(x, y). x < y}"
223.303 +by(simp add: lexordp_iff lexord_def)
223.304 +
223.305 +lemma lexordp_eq_antisym:
223.306 + assumes "lexordp_eq xs ys" "lexordp_eq ys xs"
223.307 + shows "xs = ys"
223.308 +using assms by induct simp_all
223.309 +
223.310 +lemma lexordp_eq_trans:
223.311 + assumes "lexordp_eq xs ys" and "lexordp_eq ys zs"
223.312 + shows "lexordp_eq xs zs"
223.313 +using assms
223.314 +apply(induct arbitrary: zs)
223.315 +apply(case_tac [2-3] zs)
223.316 +apply auto
223.317 +done
223.318 +
223.319 +lemma lexordp_trans:
223.320 + assumes "lexordp xs ys" "lexordp ys zs"
223.321 + shows "lexordp xs zs"
223.322 +using assms
223.323 +apply(induct arbitrary: zs)
223.324 +apply(case_tac [2-3] zs)
223.325 +apply auto
223.326 +done
223.327 +
223.328 +lemma lexordp_linear: "lexordp xs ys \<or> xs = ys \<or> lexordp ys xs"
223.329 +proof(induct xs arbitrary: ys)
223.330 + case Nil thus ?case by(cases ys) simp_all
223.331 +next
223.332 + case Cons thus ?case by(cases ys) auto
223.333 +qed
223.334 +
223.335 +lemma lexordp_conv_lexordp_eq: "lexordp xs ys \<longleftrightarrow> lexordp_eq xs ys \<and> \<not> lexordp_eq ys xs"
223.336 + (is "?lhs \<longleftrightarrow> ?rhs")
223.337 +proof
223.338 + assume ?lhs
223.339 + moreover hence "\<not> lexordp_eq ys xs" by induct simp_all
223.340 + ultimately show ?rhs by(simp add: lexordp_into_lexordp_eq)
223.341 +next
223.342 + assume ?rhs
223.343 + hence "lexordp_eq xs ys" "\<not> lexordp_eq ys xs" by simp_all
223.344 + thus ?lhs by induct simp_all
223.345 +qed
223.346 +
223.347 +lemma lexordp_eq_conv_lexord: "lexordp_eq xs ys \<longleftrightarrow> xs = ys \<or> lexordp xs ys"
223.348 +by(auto simp add: lexordp_conv_lexordp_eq lexordp_eq_refl dest: lexordp_eq_antisym)
223.349 +
223.350 +lemma lexordp_eq_linear: "lexordp_eq xs ys \<or> lexordp_eq ys xs"
223.351 +apply(induct xs arbitrary: ys)
223.352 +apply(case_tac [!] ys)
223.353 +apply auto
223.354 +done
223.355 +
223.356 +lemma lexordp_linorder: "class.linorder lexordp_eq lexordp"
223.357 +by unfold_locales(auto simp add: lexordp_conv_lexordp_eq lexordp_eq_refl lexordp_eq_antisym intro: lexordp_eq_trans del: disjCI intro: lexordp_eq_linear)
223.358 +
223.359 +end
223.360
223.361 subsubsection {* Lexicographic combination of measure functions *}
223.362
223.363 @@ -5514,15 +5686,15 @@
223.364 text{* Accessible part and wellfoundedness: *}
223.365
223.366 lemma Cons_acc_listrel1I [intro!]:
223.367 - "x \<in> acc r \<Longrightarrow> xs \<in> acc (listrel1 r) \<Longrightarrow> (x # xs) \<in> acc (listrel1 r)"
223.368 -apply (induct arbitrary: xs set: acc)
223.369 + "x \<in> Wellfounded.acc r \<Longrightarrow> xs \<in> Wellfounded.acc (listrel1 r) \<Longrightarrow> (x # xs) \<in> Wellfounded.acc (listrel1 r)"
223.370 +apply (induct arbitrary: xs set: Wellfounded.acc)
223.371 apply (erule thin_rl)
223.372 apply (erule acc_induct)
223.373 apply (rule accI)
223.374 apply (blast)
223.375 done
223.376
223.377 -lemma lists_accD: "xs \<in> lists (acc r) \<Longrightarrow> xs \<in> acc (listrel1 r)"
223.378 +lemma lists_accD: "xs \<in> lists (Wellfounded.acc r) \<Longrightarrow> xs \<in> Wellfounded.acc (listrel1 r)"
223.379 apply (induct set: lists)
223.380 apply (rule accI)
223.381 apply simp
223.382 @@ -5530,8 +5702,8 @@
223.383 apply (fast dest: acc_downward)
223.384 done
223.385
223.386 -lemma lists_accI: "xs \<in> acc (listrel1 r) \<Longrightarrow> xs \<in> lists (acc r)"
223.387 -apply (induct set: acc)
223.388 +lemma lists_accI: "xs \<in> Wellfounded.acc (listrel1 r) \<Longrightarrow> xs \<in> lists (Wellfounded.acc r)"
223.389 +apply (induct set: Wellfounded.acc)
223.390 apply clarify
223.391 apply (rule accI)
223.392 apply (fastforce dest!: in_set_conv_decomp[THEN iffD1] simp: listrel1_def)
224.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
224.2 +++ b/src/HOL/List_Prefix.thy Thu Dec 05 17:58:03 2013 +0100
224.3 @@ -0,0 +1,197 @@
224.4 +(* Title: HOL/List_Prefix.thy
224.5 + Author: Tobias Nipkow and Markus Wenzel, TU Muenchen
224.6 + Author: Christian Sternagel, JAIST
224.7 +*)
224.8 +
224.9 +header {* Parallel lists, list suffixes, and homeomorphic embedding *}
224.10 +
224.11 +theory List_Prefix
224.12 +imports List
224.13 +begin
224.14 +
224.15 +subsection {* Prefix order on lists *}
224.16 +
224.17 +definition prefixeq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
224.18 + where "prefixeq xs ys \<longleftrightarrow> (\<exists>zs. ys = xs @ zs)"
224.19 +
224.20 +definition prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
224.21 + where "prefix xs ys \<longleftrightarrow> prefixeq xs ys \<and> xs \<noteq> ys"
224.22 +
224.23 +interpretation prefix_order: order prefixeq prefix
224.24 + by default (auto simp: prefixeq_def prefix_def)
224.25 +
224.26 +interpretation prefix_bot: order_bot Nil prefixeq prefix
224.27 + by default (simp add: prefixeq_def)
224.28 +
224.29 +lemma prefixeqI [intro?]: "ys = xs @ zs \<Longrightarrow> prefixeq xs ys"
224.30 + unfolding prefixeq_def by blast
224.31 +
224.32 +lemma prefixeqE [elim?]:
224.33 + assumes "prefixeq xs ys"
224.34 + obtains zs where "ys = xs @ zs"
224.35 + using assms unfolding prefixeq_def by blast
224.36 +
224.37 +lemma prefixI' [intro?]: "ys = xs @ z # zs \<Longrightarrow> prefix xs ys"
224.38 + unfolding prefix_def prefixeq_def by blast
224.39 +
224.40 +lemma prefixE' [elim?]:
224.41 + assumes "prefix xs ys"
224.42 + obtains z zs where "ys = xs @ z # zs"
224.43 +proof -
224.44 + from `prefix xs ys` obtain us where "ys = xs @ us" and "xs \<noteq> ys"
224.45 + unfolding prefix_def prefixeq_def by blast
224.46 + with that show ?thesis by (auto simp add: neq_Nil_conv)
224.47 +qed
224.48 +
224.49 +lemma prefixI [intro?]: "prefixeq xs ys \<Longrightarrow> xs \<noteq> ys \<Longrightarrow> prefix xs ys"
224.50 + unfolding prefix_def by blast
224.51 +
224.52 +lemma prefixE [elim?]:
224.53 + fixes xs ys :: "'a list"
224.54 + assumes "prefix xs ys"
224.55 + obtains "prefixeq xs ys" and "xs \<noteq> ys"
224.56 + using assms unfolding prefix_def by blast
224.57 +
224.58 +
224.59 +subsection {* Basic properties of prefixes *}
224.60 +
224.61 +theorem Nil_prefixeq [iff]: "prefixeq [] xs"
224.62 + by (simp add: prefixeq_def)
224.63 +
224.64 +theorem prefixeq_Nil [simp]: "(prefixeq xs []) = (xs = [])"
224.65 + by (induct xs) (simp_all add: prefixeq_def)
224.66 +
224.67 +lemma prefixeq_snoc [simp]: "prefixeq xs (ys @ [y]) \<longleftrightarrow> xs = ys @ [y] \<or> prefixeq xs ys"
224.68 +proof
224.69 + assume "prefixeq xs (ys @ [y])"
224.70 + then obtain zs where zs: "ys @ [y] = xs @ zs" ..
224.71 + show "xs = ys @ [y] \<or> prefixeq xs ys"
224.72 + by (metis append_Nil2 butlast_append butlast_snoc prefixeqI zs)
224.73 +next
224.74 + assume "xs = ys @ [y] \<or> prefixeq xs ys"
224.75 + then show "prefixeq xs (ys @ [y])"
224.76 + by (metis prefix_order.eq_iff prefix_order.order_trans prefixeqI)
224.77 +qed
224.78 +
224.79 +lemma Cons_prefixeq_Cons [simp]: "prefixeq (x # xs) (y # ys) = (x = y \<and> prefixeq xs ys)"
224.80 + by (auto simp add: prefixeq_def)
224.81 +
224.82 +lemma prefixeq_code [code]:
224.83 + "prefixeq [] xs \<longleftrightarrow> True"
224.84 + "prefixeq (x # xs) [] \<longleftrightarrow> False"
224.85 + "prefixeq (x # xs) (y # ys) \<longleftrightarrow> x = y \<and> prefixeq xs ys"
224.86 + by simp_all
224.87 +
224.88 +lemma same_prefixeq_prefixeq [simp]: "prefixeq (xs @ ys) (xs @ zs) = prefixeq ys zs"
224.89 + by (induct xs) simp_all
224.90 +
224.91 +lemma same_prefixeq_nil [iff]: "prefixeq (xs @ ys) xs = (ys = [])"
224.92 + by (metis append_Nil2 append_self_conv prefix_order.eq_iff prefixeqI)
224.93 +
224.94 +lemma prefixeq_prefixeq [simp]: "prefixeq xs ys \<Longrightarrow> prefixeq xs (ys @ zs)"
224.95 + by (metis prefix_order.le_less_trans prefixeqI prefixE prefixI)
224.96 +
224.97 +lemma append_prefixeqD: "prefixeq (xs @ ys) zs \<Longrightarrow> prefixeq xs zs"
224.98 + by (auto simp add: prefixeq_def)
224.99 +
224.100 +theorem prefixeq_Cons: "prefixeq xs (y # ys) = (xs = [] \<or> (\<exists>zs. xs = y # zs \<and> prefixeq zs ys))"
224.101 + by (cases xs) (auto simp add: prefixeq_def)
224.102 +
224.103 +theorem prefixeq_append:
224.104 + "prefixeq xs (ys @ zs) = (prefixeq xs ys \<or> (\<exists>us. xs = ys @ us \<and> prefixeq us zs))"
224.105 + apply (induct zs rule: rev_induct)
224.106 + apply force
224.107 + apply (simp del: append_assoc add: append_assoc [symmetric])
224.108 + apply (metis append_eq_appendI)
224.109 + done
224.110 +
224.111 +lemma append_one_prefixeq:
224.112 + "prefixeq xs ys \<Longrightarrow> length xs < length ys \<Longrightarrow> prefixeq (xs @ [ys ! length xs]) ys"
224.113 + proof (unfold prefixeq_def)
224.114 + assume a1: "\<exists>zs. ys = xs @ zs"
224.115 + then obtain sk :: "'a list" where sk: "ys = xs @ sk" by fastforce
224.116 + assume a2: "length xs < length ys"
224.117 + have f1: "\<And>v. ([]\<Colon>'a list) @ v = v" using append_Nil2 by simp
224.118 + have "[] \<noteq> sk" using a1 a2 sk less_not_refl by force
224.119 + hence "\<exists>v. xs @ hd sk # v = ys" using sk by (metis hd_Cons_tl)
224.120 + thus "\<exists>zs. ys = (xs @ [ys ! length xs]) @ zs" using f1 by fastforce
224.121 + qed
224.122 +
224.123 +theorem prefixeq_length_le: "prefixeq xs ys \<Longrightarrow> length xs \<le> length ys"
224.124 + by (auto simp add: prefixeq_def)
224.125 +
224.126 +lemma prefixeq_same_cases:
224.127 + "prefixeq (xs\<^sub>1::'a list) ys \<Longrightarrow> prefixeq xs\<^sub>2 ys \<Longrightarrow> prefixeq xs\<^sub>1 xs\<^sub>2 \<or> prefixeq xs\<^sub>2 xs\<^sub>1"
224.128 + unfolding prefixeq_def by (force simp: append_eq_append_conv2)
224.129 +
224.130 +lemma set_mono_prefixeq: "prefixeq xs ys \<Longrightarrow> set xs \<subseteq> set ys"
224.131 + by (auto simp add: prefixeq_def)
224.132 +
224.133 +lemma take_is_prefixeq: "prefixeq (take n xs) xs"
224.134 + unfolding prefixeq_def by (metis append_take_drop_id)
224.135 +
224.136 +lemma map_prefixeqI: "prefixeq xs ys \<Longrightarrow> prefixeq (map f xs) (map f ys)"
224.137 + by (auto simp: prefixeq_def)
224.138 +
224.139 +lemma prefixeq_length_less: "prefix xs ys \<Longrightarrow> length xs < length ys"
224.140 + by (auto simp: prefix_def prefixeq_def)
224.141 +
224.142 +lemma prefix_simps [simp, code]:
224.143 + "prefix xs [] \<longleftrightarrow> False"
224.144 + "prefix [] (x # xs) \<longleftrightarrow> True"
224.145 + "prefix (x # xs) (y # ys) \<longleftrightarrow> x = y \<and> prefix xs ys"
224.146 + by (simp_all add: prefix_def cong: conj_cong)
224.147 +
224.148 +lemma take_prefix: "prefix xs ys \<Longrightarrow> prefix (take n xs) ys"
224.149 + apply (induct n arbitrary: xs ys)
224.150 + apply (case_tac ys, simp_all)[1]
224.151 + apply (metis prefix_order.less_trans prefixI take_is_prefixeq)
224.152 + done
224.153 +
224.154 +lemma not_prefixeq_cases:
224.155 + assumes pfx: "\<not> prefixeq ps ls"
224.156 + obtains
224.157 + (c1) "ps \<noteq> []" and "ls = []"
224.158 + | (c2) a as x xs where "ps = a#as" and "ls = x#xs" and "x = a" and "\<not> prefixeq as xs"
224.159 + | (c3) a as x xs where "ps = a#as" and "ls = x#xs" and "x \<noteq> a"
224.160 +proof (cases ps)
224.161 + case Nil
224.162 + then show ?thesis using pfx by simp
224.163 +next
224.164 + case (Cons a as)
224.165 + note c = `ps = a#as`
224.166 + show ?thesis
224.167 + proof (cases ls)
224.168 + case Nil then show ?thesis by (metis append_Nil2 pfx c1 same_prefixeq_nil)
224.169 + next
224.170 + case (Cons x xs)
224.171 + show ?thesis
224.172 + proof (cases "x = a")
224.173 + case True
224.174 + have "\<not> prefixeq as xs" using pfx c Cons True by simp
224.175 + with c Cons True show ?thesis by (rule c2)
224.176 + next
224.177 + case False
224.178 + with c Cons show ?thesis by (rule c3)
224.179 + qed
224.180 + qed
224.181 +qed
224.182 +
224.183 +lemma not_prefixeq_induct [consumes 1, case_names Nil Neq Eq]:
224.184 + assumes np: "\<not> prefixeq ps ls"
224.185 + and base: "\<And>x xs. P (x#xs) []"
224.186 + and r1: "\<And>x xs y ys. x \<noteq> y \<Longrightarrow> P (x#xs) (y#ys)"
224.187 + and r2: "\<And>x xs y ys. \<lbrakk> x = y; \<not> prefixeq xs ys; P xs ys \<rbrakk> \<Longrightarrow> P (x#xs) (y#ys)"
224.188 + shows "P ps ls" using np
224.189 +proof (induct ls arbitrary: ps)
224.190 + case Nil then show ?case
224.191 + by (auto simp: neq_Nil_conv elim!: not_prefixeq_cases intro!: base)
224.192 +next
224.193 + case (Cons y ys)
224.194 + then have npfx: "\<not> prefixeq ps (y # ys)" by simp
224.195 + then obtain x xs where pv: "ps = x # xs"
224.196 + by (rule not_prefixeq_cases) auto
224.197 + show ?case by (metis Cons.hyps Cons_prefixeq_Cons npfx pv r1 r2)
224.198 +qed
224.199 +
224.200 +end
225.1 --- a/src/HOL/Lubs.thy Thu Dec 05 17:52:12 2013 +0100
225.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
225.3 @@ -1,103 +0,0 @@
225.4 -(* Title: HOL/Lubs.thy
225.5 - Author: Jacques D. Fleuriot, University of Cambridge
225.6 -*)
225.7 -
225.8 -header {* Definitions of Upper Bounds and Least Upper Bounds *}
225.9 -
225.10 -theory Lubs
225.11 -imports Main
225.12 -begin
225.13 -
225.14 -text {* Thanks to suggestions by James Margetson *}
225.15 -
225.16 -definition setle :: "'a set \<Rightarrow> 'a::ord \<Rightarrow> bool" (infixl "*<=" 70)
225.17 - where "S *<= x = (ALL y: S. y \<le> x)"
225.18 -
225.19 -definition setge :: "'a::ord \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "<=*" 70)
225.20 - where "x <=* S = (ALL y: S. x \<le> y)"
225.21 -
225.22 -definition leastP :: "('a \<Rightarrow> bool) \<Rightarrow> 'a::ord \<Rightarrow> bool"
225.23 - where "leastP P x = (P x \<and> x <=* Collect P)"
225.24 -
225.25 -definition isUb :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
225.26 - where "isUb R S x = (S *<= x \<and> x: R)"
225.27 -
225.28 -definition isLub :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a::ord \<Rightarrow> bool"
225.29 - where "isLub R S x = leastP (isUb R S) x"
225.30 -
225.31 -definition ubs :: "'a set \<Rightarrow> 'a::ord set \<Rightarrow> 'a set"
225.32 - where "ubs R S = Collect (isUb R S)"
225.33 -
225.34 -
225.35 -subsection {* Rules for the Relations @{text "*<="} and @{text "<=*"} *}
225.36 -
225.37 -lemma setleI: "ALL y: S. y \<le> x \<Longrightarrow> S *<= x"
225.38 - by (simp add: setle_def)
225.39 -
225.40 -lemma setleD: "S *<= x \<Longrightarrow> y: S \<Longrightarrow> y \<le> x"
225.41 - by (simp add: setle_def)
225.42 -
225.43 -lemma setgeI: "ALL y: S. x \<le> y \<Longrightarrow> x <=* S"
225.44 - by (simp add: setge_def)
225.45 -
225.46 -lemma setgeD: "x <=* S \<Longrightarrow> y: S \<Longrightarrow> x \<le> y"
225.47 - by (simp add: setge_def)
225.48 -
225.49 -
225.50 -subsection {* Rules about the Operators @{term leastP}, @{term ub} and @{term lub} *}
225.51 -
225.52 -lemma leastPD1: "leastP P x \<Longrightarrow> P x"
225.53 - by (simp add: leastP_def)
225.54 -
225.55 -lemma leastPD2: "leastP P x \<Longrightarrow> x <=* Collect P"
225.56 - by (simp add: leastP_def)
225.57 -
225.58 -lemma leastPD3: "leastP P x \<Longrightarrow> y: Collect P \<Longrightarrow> x \<le> y"
225.59 - by (blast dest!: leastPD2 setgeD)
225.60 -
225.61 -lemma isLubD1: "isLub R S x \<Longrightarrow> S *<= x"
225.62 - by (simp add: isLub_def isUb_def leastP_def)
225.63 -
225.64 -lemma isLubD1a: "isLub R S x \<Longrightarrow> x: R"
225.65 - by (simp add: isLub_def isUb_def leastP_def)
225.66 -
225.67 -lemma isLub_isUb: "isLub R S x \<Longrightarrow> isUb R S x"
225.68 - unfolding isUb_def by (blast dest: isLubD1 isLubD1a)
225.69 -
225.70 -lemma isLubD2: "isLub R S x \<Longrightarrow> y : S \<Longrightarrow> y \<le> x"
225.71 - by (blast dest!: isLubD1 setleD)
225.72 -
225.73 -lemma isLubD3: "isLub R S x \<Longrightarrow> leastP (isUb R S) x"
225.74 - by (simp add: isLub_def)
225.75 -
225.76 -lemma isLubI1: "leastP(isUb R S) x \<Longrightarrow> isLub R S x"
225.77 - by (simp add: isLub_def)
225.78 -
225.79 -lemma isLubI2: "isUb R S x \<Longrightarrow> x <=* Collect (isUb R S) \<Longrightarrow> isLub R S x"
225.80 - by (simp add: isLub_def leastP_def)
225.81 -
225.82 -lemma isUbD: "isUb R S x \<Longrightarrow> y : S \<Longrightarrow> y \<le> x"
225.83 - by (simp add: isUb_def setle_def)
225.84 -
225.85 -lemma isUbD2: "isUb R S x \<Longrightarrow> S *<= x"
225.86 - by (simp add: isUb_def)
225.87 -
225.88 -lemma isUbD2a: "isUb R S x \<Longrightarrow> x: R"
225.89 - by (simp add: isUb_def)
225.90 -
225.91 -lemma isUbI: "S *<= x \<Longrightarrow> x: R \<Longrightarrow> isUb R S x"
225.92 - by (simp add: isUb_def)
225.93 -
225.94 -lemma isLub_le_isUb: "isLub R S x \<Longrightarrow> isUb R S y \<Longrightarrow> x \<le> y"
225.95 - unfolding isLub_def by (blast intro!: leastPD3)
225.96 -
225.97 -lemma isLub_ubs: "isLub R S x \<Longrightarrow> x <=* ubs R S"
225.98 - unfolding ubs_def isLub_def by (rule leastPD2)
225.99 -
225.100 -lemma isLub_unique: "[| isLub R S x; isLub R S y |] ==> x = (y::'a::linorder)"
225.101 - apply (frule isLub_isUb)
225.102 - apply (frule_tac x = y in isLub_isUb)
225.103 - apply (blast intro!: order_antisym dest!: isLub_le_isUb)
225.104 - done
225.105 -
225.106 -end
226.1 --- a/src/HOL/Main.thy Thu Dec 05 17:52:12 2013 +0100
226.2 +++ b/src/HOL/Main.thy Thu Dec 05 17:58:03 2013 +0100
226.3 @@ -1,7 +1,7 @@
226.4 header {* Main HOL *}
226.5
226.6 theory Main
226.7 -imports Predicate_Compile Nitpick Extraction Lifting_Sum
226.8 +imports Predicate_Compile Nitpick Extraction Lifting_Sum List_Prefix Coinduction Order_Relation
226.9 begin
226.10
226.11 text {*
227.1 --- a/src/HOL/Matrix_LP/ComputeFloat.thy Thu Dec 05 17:52:12 2013 +0100
227.2 +++ b/src/HOL/Matrix_LP/ComputeFloat.thy Thu Dec 05 17:58:03 2013 +0100
227.3 @@ -79,8 +79,8 @@
227.4 lemma real_is_int_numeral[simp]: "real_is_int (numeral x)"
227.5 by (auto simp: real_is_int_def intro!: exI[of _ "numeral x"])
227.6
227.7 -lemma real_is_int_neg_numeral[simp]: "real_is_int (neg_numeral x)"
227.8 - by (auto simp: real_is_int_def intro!: exI[of _ "neg_numeral x"])
227.9 +lemma real_is_int_neg_numeral[simp]: "real_is_int (- numeral x)"
227.10 + by (auto simp: real_is_int_def intro!: exI[of _ "- numeral x"])
227.11
227.12 lemma int_of_real_0[simp]: "int_of_real (0::real) = (0::int)"
227.13 by (simp add: int_of_real_def)
227.14 @@ -96,7 +96,7 @@
227.15 by (intro some_equality)
227.16 (auto simp add: real_of_int_inject[symmetric] simp del: real_of_int_inject)
227.17
227.18 -lemma int_of_real_neg_numeral[simp]: "int_of_real (neg_numeral b) = neg_numeral b"
227.19 +lemma int_of_real_neg_numeral[simp]: "int_of_real (- numeral b) = - numeral b"
227.20 unfolding int_of_real_def
227.21 by (intro some_equality)
227.22 (auto simp add: real_of_int_inject[symmetric] simp del: real_of_int_inject)
228.1 --- a/src/HOL/Matrix_LP/LP.thy Thu Dec 05 17:52:12 2013 +0100
228.2 +++ b/src/HOL/Matrix_LP/LP.thy Thu Dec 05 17:58:03 2013 +0100
228.3 @@ -72,8 +72,7 @@
228.4 proof -
228.5 have "0 <= A - A1"
228.6 proof -
228.7 - have 1: "A - A1 = A + (- A1)" by simp
228.8 - show ?thesis by (simp only: 1 add_right_mono[of A1 A "-A1", simplified, simplified assms])
228.9 + from assms add_right_mono [of A1 A "- A1"] show ?thesis by simp
228.10 qed
228.11 then have "abs (A-A1) = A-A1" by (rule abs_of_nonneg)
228.12 with assms show "abs (A-A1) <= (A2-A1)" by simp
228.13 @@ -147,9 +146,9 @@
228.14 then have "c * x <= y * b - (y * A - c) * x" by (simp add: le_diff_eq)
228.15 then have cx: "c * x <= y * b + (c - y * A) * x" by (simp add: algebra_simps)
228.16 have s2: "c - y * A <= c2 - y * A1"
228.17 - by (simp add: diff_minus assms add_mono mult_left_mono)
228.18 + by (simp add: assms add_mono mult_left_mono algebra_simps)
228.19 have s1: "c1 - y * A2 <= c - y * A"
228.20 - by (simp add: diff_minus assms add_mono mult_left_mono)
228.21 + by (simp add: assms add_mono mult_left_mono algebra_simps)
228.22 have prts: "(c - y * A) * x <= ?C"
228.23 apply (simp add: Let_def)
228.24 apply (rule mult_le_prts)
229.1 --- a/src/HOL/Matrix_LP/Matrix.thy Thu Dec 05 17:52:12 2013 +0100
229.2 +++ b/src/HOL/Matrix_LP/Matrix.thy Thu Dec 05 17:58:03 2013 +0100
229.3 @@ -1542,8 +1542,8 @@
229.4 fix A B :: "'a matrix"
229.5 show "- A + A = 0"
229.6 by (simp add: plus_matrix_def minus_matrix_def Rep_matrix_inject[symmetric] ext)
229.7 - show "A - B = A + - B"
229.8 - by (simp add: plus_matrix_def diff_matrix_def minus_matrix_def Rep_matrix_inject [symmetric] ext diff_minus)
229.9 + show "A + - B = A - B"
229.10 + by (simp add: plus_matrix_def diff_matrix_def minus_matrix_def Rep_matrix_inject [symmetric] ext)
229.11 qed
229.12
229.13 instance matrix :: (ab_group_add) ab_group_add
230.1 --- a/src/HOL/Meson.thy Thu Dec 05 17:52:12 2013 +0100
230.2 +++ b/src/HOL/Meson.thy Thu Dec 05 17:58:03 2013 +0100
230.3 @@ -8,7 +8,7 @@
230.4 header {* MESON Proof Method *}
230.5
230.6 theory Meson
230.7 -imports Datatype
230.8 +imports Nat
230.9 begin
230.10
230.11 subsection {* Negation Normal Form *}
230.12 @@ -132,45 +132,45 @@
230.13 text{* Combinator translation helpers *}
230.14
230.15 definition COMBI :: "'a \<Rightarrow> 'a" where
230.16 -[no_atp]: "COMBI P = P"
230.17 +"COMBI P = P"
230.18
230.19 definition COMBK :: "'a \<Rightarrow> 'b \<Rightarrow> 'a" where
230.20 -[no_atp]: "COMBK P Q = P"
230.21 +"COMBK P Q = P"
230.22
230.23 -definition COMBB :: "('b => 'c) \<Rightarrow> ('a => 'b) \<Rightarrow> 'a \<Rightarrow> 'c" where [no_atp]:
230.24 +definition COMBB :: "('b => 'c) \<Rightarrow> ('a => 'b) \<Rightarrow> 'a \<Rightarrow> 'c" where
230.25 "COMBB P Q R = P (Q R)"
230.26
230.27 definition COMBC :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'c" where
230.28 -[no_atp]: "COMBC P Q R = P R Q"
230.29 +"COMBC P Q R = P R Q"
230.30
230.31 definition COMBS :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" where
230.32 -[no_atp]: "COMBS P Q R = P R (Q R)"
230.33 +"COMBS P Q R = P R (Q R)"
230.34
230.35 -lemma abs_S [no_atp]: "\<lambda>x. (f x) (g x) \<equiv> COMBS f g"
230.36 +lemma abs_S: "\<lambda>x. (f x) (g x) \<equiv> COMBS f g"
230.37 apply (rule eq_reflection)
230.38 apply (rule ext)
230.39 apply (simp add: COMBS_def)
230.40 done
230.41
230.42 -lemma abs_I [no_atp]: "\<lambda>x. x \<equiv> COMBI"
230.43 +lemma abs_I: "\<lambda>x. x \<equiv> COMBI"
230.44 apply (rule eq_reflection)
230.45 apply (rule ext)
230.46 apply (simp add: COMBI_def)
230.47 done
230.48
230.49 -lemma abs_K [no_atp]: "\<lambda>x. y \<equiv> COMBK y"
230.50 +lemma abs_K: "\<lambda>x. y \<equiv> COMBK y"
230.51 apply (rule eq_reflection)
230.52 apply (rule ext)
230.53 apply (simp add: COMBK_def)
230.54 done
230.55
230.56 -lemma abs_B [no_atp]: "\<lambda>x. a (g x) \<equiv> COMBB a g"
230.57 +lemma abs_B: "\<lambda>x. a (g x) \<equiv> COMBB a g"
230.58 apply (rule eq_reflection)
230.59 apply (rule ext)
230.60 apply (simp add: COMBB_def)
230.61 done
230.62
230.63 -lemma abs_C [no_atp]: "\<lambda>x. (f x) b \<equiv> COMBC f b"
230.64 +lemma abs_C: "\<lambda>x. (f x) b \<equiv> COMBC f b"
230.65 apply (rule eq_reflection)
230.66 apply (rule ext)
230.67 apply (simp add: COMBC_def)
230.68 @@ -180,7 +180,7 @@
230.69 subsection {* Skolemization helpers *}
230.70
230.71 definition skolem :: "'a \<Rightarrow> 'a" where
230.72 -[no_atp]: "skolem = (\<lambda>x. x)"
230.73 +"skolem = (\<lambda>x. x)"
230.74
230.75 lemma skolem_COMBK_iff: "P \<longleftrightarrow> skolem (COMBK P (i\<Colon>nat))"
230.76 unfolding skolem_def COMBK_def by (rule refl)
231.1 --- a/src/HOL/Metis.thy Thu Dec 05 17:52:12 2013 +0100
231.2 +++ b/src/HOL/Metis.thy Thu Dec 05 17:58:03 2013 +0100
231.3 @@ -16,7 +16,7 @@
231.4 subsection {* Literal selection and lambda-lifting helpers *}
231.5
231.6 definition select :: "'a \<Rightarrow> 'a" where
231.7 -[no_atp]: "select = (\<lambda>x. x)"
231.8 +"select = (\<lambda>x. x)"
231.9
231.10 lemma not_atomize: "(\<not> A \<Longrightarrow> False) \<equiv> Trueprop A"
231.11 by (cut_tac atomize_not [of "\<not> A"]) simp
231.12 @@ -30,7 +30,7 @@
231.13 lemma select_FalseI: "False \<Longrightarrow> select False" by simp
231.14
231.15 definition lambda :: "'a \<Rightarrow> 'a" where
231.16 -[no_atp]: "lambda = (\<lambda>x. x)"
231.17 +"lambda = (\<lambda>x. x)"
231.18
231.19 lemma eq_lambdaI: "x \<equiv> y \<Longrightarrow> x \<equiv> lambda y"
231.20 unfolding lambda_def by assumption
232.1 --- a/src/HOL/Metis_Examples/Big_O.thy Thu Dec 05 17:52:12 2013 +0100
232.2 +++ b/src/HOL/Metis_Examples/Big_O.thy Thu Dec 05 17:58:03 2013 +0100
232.3 @@ -493,8 +493,10 @@
232.4
232.5 lemma bigo_compose2:
232.6 "f =o g +o O(h) \<Longrightarrow> (\<lambda>x. f(k x)) =o (\<lambda>x. g(k x)) +o O(\<lambda>x. h(k x))"
232.7 -apply (simp only: set_minus_plus [symmetric] diff_minus fun_Compl_def func_plus)
232.8 -by (erule bigo_compose1)
232.9 +apply (simp only: set_minus_plus [symmetric] fun_Compl_def func_plus)
232.10 +apply (drule bigo_compose1 [of "f - g" h k])
232.11 +apply (simp add: fun_diff_def)
232.12 +done
232.13
232.14 subsection {* Setsum *}
232.15
233.1 --- a/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML Thu Dec 05 17:52:12 2013 +0100
233.2 +++ b/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML Thu Dec 05 17:58:03 2013 +0100
233.3 @@ -374,8 +374,7 @@
233.4
233.5 fun get_prover ctxt name params goal all_facts =
233.6 let
233.7 - fun learn prover =
233.8 - Sledgehammer_MaSh.mash_learn_proof ctxt params prover (prop_of goal) all_facts
233.9 + val learn = Sledgehammer_MaSh.mash_learn_proof ctxt params (prop_of goal) all_facts
233.10 in
233.11 Sledgehammer_Minimize.get_minimizing_prover ctxt Sledgehammer_Provers.Normal
233.12 learn name
233.13 @@ -439,7 +438,7 @@
233.14 term_order |> the_default I)
233.15 #> (Option.map (Config.put ATP_Systems.force_sos)
233.16 force_sos |> the_default I))
233.17 - val params as {max_facts, slice, ...} =
233.18 + val params as {max_facts, ...} =
233.19 Sledgehammer_Isar.default_params ctxt
233.20 ([("verbose", "true"),
233.21 ("fact_filter", fact_filter),
233.22 @@ -454,8 +453,7 @@
233.23 |> sh_minimizeLST (*don't confuse the two minimization flags*)
233.24 |> max_new_mono_instancesLST
233.25 |> max_mono_itersLST)
233.26 - val default_max_facts =
233.27 - Sledgehammer_Provers.default_max_facts_of_prover ctxt slice prover_name
233.28 + val default_max_facts = Sledgehammer_Provers.default_max_facts_of_prover ctxt prover_name
233.29 val is_appropriate_prop =
233.30 Sledgehammer_Provers.is_appropriate_prop_of_prover ctxt prover_name
233.31 val (_, hyp_ts, concl_t) = ATP_Util.strip_subgoal goal i ctxt
233.32 @@ -494,7 +492,7 @@
233.33 |> Output.urgent_message)
233.34 val prover = get_prover ctxt prover_name params goal facts
233.35 val problem =
233.36 - {state = st', goal = goal, subgoal = i,
233.37 + {comment = "", state = st', goal = goal, subgoal = i,
233.38 subgoal_count = Sledgehammer_Util.subgoal_count st, factss = factss}
233.39 in prover params (K (K (K ""))) problem end)) ()
233.40 handle TimeLimit.TimeOut => failed ATP_Proof.TimedOut
233.41 @@ -584,6 +582,7 @@
233.42 ({pre=st, log, ...}: Mirabelle.run_args) =
233.43 let
233.44 val ctxt = Proof.context_of st
233.45 + val {goal, ...} = Proof.goal st
233.46 val n0 = length (these (!named_thms))
233.47 val prover_name = get_prover_name ctxt args
233.48 val type_enc = AList.lookup (op =) args type_encK |> the_default type_enc_default
233.49 @@ -609,11 +608,11 @@
233.50 |> max_new_mono_instancesLST
233.51 |> max_mono_itersLST)
233.52 val minimize =
233.53 - Sledgehammer_Minimize.minimize_facts (K (K ())) prover_name params
233.54 - true 1 (Sledgehammer_Util.subgoal_count st)
233.55 + Sledgehammer_Minimize.minimize_facts (K ()) prover_name params true 1
233.56 + (Sledgehammer_Util.subgoal_count st)
233.57 val _ = log separator
233.58 val (used_facts, (preplay, message, message_tail)) =
233.59 - minimize st NONE (these (!named_thms))
233.60 + minimize st goal NONE (these (!named_thms))
233.61 val msg = message (Lazy.force preplay) ^ message_tail
233.62 in
233.63 case used_facts of
233.64 @@ -665,7 +664,7 @@
233.65 SMT_Solver.smt_tac ctxt thms
233.66 else if full then
233.67 Metis_Tactic.metis_tac [ATP_Proof_Reconstruct.full_typesN]
233.68 - ATP_Proof_Reconstruct.metis_default_lam_trans ctxt thms
233.69 + ATP_Proof_Reconstruct.default_metis_lam_trans ctxt thms
233.70 else if String.isPrefix "metis (" (!reconstructor) then
233.71 let
233.72 val (type_encs, lam_trans) =
233.73 @@ -674,10 +673,10 @@
233.74 |> filter Token.is_proper |> tl
233.75 |> Metis_Tactic.parse_metis_options |> fst
233.76 |>> the_default [ATP_Proof_Reconstruct.partial_typesN]
233.77 - ||> the_default ATP_Proof_Reconstruct.metis_default_lam_trans
233.78 + ||> the_default ATP_Proof_Reconstruct.default_metis_lam_trans
233.79 in Metis_Tactic.metis_tac type_encs lam_trans ctxt thms end
233.80 else if !reconstructor = "metis" then
233.81 - Metis_Tactic.metis_tac [] ATP_Proof_Reconstruct.metis_default_lam_trans ctxt
233.82 + Metis_Tactic.metis_tac [] ATP_Proof_Reconstruct.default_metis_lam_trans ctxt
233.83 thms
233.84 else
233.85 K all_tac
234.1 --- a/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer_filter.ML Thu Dec 05 17:52:12 2013 +0100
234.2 +++ b/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer_filter.ML Thu Dec 05 17:58:03 2013 +0100
234.3 @@ -110,18 +110,14 @@
234.4 SOME proofs =>
234.5 let
234.6 val {context = ctxt, facts = chained_ths, goal} = Proof.goal pre
234.7 - val prover = AList.lookup (op =) args "prover"
234.8 - |> the_default default_prover
234.9 - val params as {max_facts, slice, ...} =
234.10 + val prover = AList.lookup (op =) args "prover" |> the_default default_prover
234.11 + val params as {max_facts, ...} =
234.12 Sledgehammer_Isar.default_params ctxt args
234.13 - val default_max_facts =
234.14 - Sledgehammer_Provers.default_max_facts_of_prover ctxt slice prover
234.15 + val default_max_facts = Sledgehammer_Provers.default_max_facts_of_prover ctxt prover
234.16 val is_appropriate_prop =
234.17 - Sledgehammer_Provers.is_appropriate_prop_of_prover ctxt
234.18 - default_prover
234.19 + Sledgehammer_Provers.is_appropriate_prop_of_prover ctxt default_prover
234.20 val relevance_fudge =
234.21 - extract_relevance_fudge args
234.22 - (Sledgehammer_Provers.relevance_fudge_of_prover ctxt prover)
234.23 + extract_relevance_fudge args Sledgehammer_MePo.default_relevance_fudge
234.24 val subgoal = 1
234.25 val (_, hyp_ts, concl_t) = ATP_Util.strip_subgoal goal subgoal ctxt
234.26 val ho_atp = Sledgehammer_Provers.is_ho_atp ctxt prover
234.27 @@ -132,9 +128,9 @@
234.28 Sledgehammer_Fact.no_fact_override reserved css_table chained_ths
234.29 hyp_ts concl_t
234.30 |> filter (is_appropriate_prop o prop_of o snd)
234.31 + |> Sledgehammer_Fact.drop_duplicate_facts
234.32 |> Sledgehammer_MePo.mepo_suggested_facts ctxt params
234.33 - default_prover (the_default default_max_facts max_facts)
234.34 - (SOME relevance_fudge) hyp_ts concl_t
234.35 + (the_default default_max_facts max_facts) (SOME relevance_fudge) hyp_ts concl_t
234.36 |> map (fst o fst)
234.37 val (found_facts, lost_facts) =
234.38 flat proofs |> sort_distinct string_ord
235.1 --- a/src/HOL/Multivariate_Analysis/Cartesian_Euclidean_Space.thy Thu Dec 05 17:52:12 2013 +0100
235.2 +++ b/src/HOL/Multivariate_Analysis/Cartesian_Euclidean_Space.thy Thu Dec 05 17:58:03 2013 +0100
235.3 @@ -228,7 +228,10 @@
235.4 then show ?case by vector
235.5 qed
235.6
235.7 -lemma one_index[simp]: "(1 :: 'a::one ^'n)$i = 1"
235.8 +lemma one_index [simp]: "(1 :: 'a :: one ^ 'n) $ i = 1"
235.9 + by vector
235.10 +
235.11 +lemma neg_one_index [simp]: "(- 1 :: 'a :: {one, uminus} ^ 'n) $ i = - 1"
235.12 by vector
235.13
235.14 instance vec :: (semiring_char_0, finite) semiring_char_0
235.15 @@ -244,8 +247,8 @@
235.16 lemma numeral_index [simp]: "numeral w $ i = numeral w"
235.17 by (induct w) (simp_all only: numeral.simps vector_add_component one_index)
235.18
235.19 -lemma neg_numeral_index [simp]: "neg_numeral w $ i = neg_numeral w"
235.20 - by (simp only: neg_numeral_def vector_uminus_component numeral_index)
235.21 +lemma neg_numeral_index [simp]: "- numeral w $ i = - numeral w"
235.22 + by (simp only: vector_uminus_component numeral_index)
235.23
235.24 instance vec :: (comm_ring_1, finite) comm_ring_1 ..
235.25 instance vec :: (ring_char_0, finite) ring_char_0 ..
235.26 @@ -1099,8 +1102,8 @@
235.27 shows "(\<lambda>x. m *s x + c) o (\<lambda>x. inverse(m) *s x + (-(inverse(m) *s c))) = id"
235.28 "(\<lambda>x. inverse(m) *s x + (-(inverse(m) *s c))) o (\<lambda>x. m *s x + c) = id"
235.29 using m0
235.30 - apply (auto simp add: fun_eq_iff vector_add_ldistrib)
235.31 - apply (simp_all add: vector_smult_lneg[symmetric] vector_smult_assoc vector_sneg_minus1[symmetric])
235.32 + apply (auto simp add: fun_eq_iff vector_add_ldistrib diff_conv_add_uminus simp del: add_uminus_conv_diff)
235.33 + apply (simp_all add: vector_smult_lneg[symmetric] vector_smult_assoc vector_sneg_minus1 [symmetric])
235.34 done
235.35
235.36 lemma vector_affinity_eq:
235.37 @@ -1114,7 +1117,7 @@
235.38 using m0 by (simp add: vector_smult_assoc vector_ssub_ldistrib)
235.39 next
235.40 assume h: "x = inverse m *s y + - (inverse m *s c)"
235.41 - show "m *s x + c = y" unfolding h diff_minus[symmetric]
235.42 + show "m *s x + c = y" unfolding h
235.43 using m0 by (simp add: vector_smult_assoc vector_ssub_ldistrib)
235.44 qed
235.45
236.1 --- a/src/HOL/Multivariate_Analysis/Convex_Euclidean_Space.thy Thu Dec 05 17:52:12 2013 +0100
236.2 +++ b/src/HOL/Multivariate_Analysis/Convex_Euclidean_Space.thy Thu Dec 05 17:58:03 2013 +0100
236.3 @@ -277,13 +277,13 @@
236.4 assumes "linear f" "inj f"
236.5 shows "f ` (closure S) = closure (f ` S)"
236.6 proof -
236.7 - obtain f' where f'_def: "linear f' \<and> f \<circ> f' = id \<and> f' \<circ> f = id"
236.8 + obtain f' where f': "linear f' \<and> f \<circ> f' = id \<and> f' \<circ> f = id"
236.9 using assms linear_injective_isomorphism[of f] isomorphism_expand by auto
236.10 then have "f' ` closure (f ` S) \<le> closure (S)"
236.11 using closure_linear_image[of f' "f ` S"] image_compose[of f' f] by auto
236.12 then have "f ` f' ` closure (f ` S) \<le> f ` closure S" by auto
236.13 then have "closure (f ` S) \<le> f ` closure S"
236.14 - using image_compose[of f f' "closure (f ` S)"] f'_def by auto
236.15 + using image_compose[of f f' "closure (f ` S)"] f' by auto
236.16 then show ?thesis using closure_linear_image[of f S] assms by auto
236.17 qed
236.18
236.19 @@ -304,7 +304,7 @@
236.20 lemma snd_linear: "linear snd"
236.21 unfolding linear_iff by (simp add: algebra_simps)
236.22
236.23 -lemma fst_snd_linear: "linear (%(x,y). x + y)"
236.24 +lemma fst_snd_linear: "linear (\<lambda>(x,y). x + y)"
236.25 unfolding linear_iff by (simp add: algebra_simps)
236.26
236.27 lemma scaleR_2:
236.28 @@ -858,9 +858,10 @@
236.29 assumes "affine_parallel A B"
236.30 shows "affine_parallel B A"
236.31 proof -
236.32 - from assms obtain a where "B = (\<lambda>x. a + x) ` A"
236.33 + from assms obtain a where B: "B = (\<lambda>x. a + x) ` A"
236.34 unfolding affine_parallel_def by auto
236.35 - then show ?thesis
236.36 + have [simp]: "(\<lambda>x. x - a) = plus (- a)" by (simp add: fun_eq_iff)
236.37 + from B show ?thesis
236.38 using translation_galois [of B a A]
236.39 unfolding affine_parallel_def by auto
236.40 qed
236.41 @@ -937,18 +938,19 @@
236.42 assume assm: "affine S \<and> 0 \<in> S"
236.43 {
236.44 fix c :: real
236.45 - fix x assume x_def: "x \<in> S"
236.46 + fix x
236.47 + assume x: "x \<in> S"
236.48 have "c *\<^sub>R x = (1-c) *\<^sub>R 0 + c *\<^sub>R x" by auto
236.49 moreover
236.50 have "(1 - c) *\<^sub>R 0 + c *\<^sub>R x \<in> S"
236.51 - using affine_alt[of S] assm x_def by auto
236.52 + using affine_alt[of S] assm x by auto
236.53 ultimately have "c *\<^sub>R x \<in> S" by auto
236.54 }
236.55 then have h1: "\<forall>c. \<forall>x \<in> S. c *\<^sub>R x \<in> S" by auto
236.56
236.57 {
236.58 fix x y
236.59 - assume xy_def: "x \<in> S" "y \<in> S"
236.60 + assume xy: "x \<in> S" "y \<in> S"
236.61 def u == "(1 :: real)/2"
236.62 have "(1/2) *\<^sub>R (x+y) = (1/2) *\<^sub>R (x+y)"
236.63 by auto
236.64 @@ -956,16 +958,16 @@
236.65 have "(1/2) *\<^sub>R (x+y)=(1/2) *\<^sub>R x + (1-(1/2)) *\<^sub>R y"
236.66 by (simp add: algebra_simps)
236.67 moreover
236.68 - have "(1-u) *\<^sub>R x + u *\<^sub>R y \<in> S"
236.69 - using affine_alt[of S] assm xy_def by auto
236.70 + have "(1 - u) *\<^sub>R x + u *\<^sub>R y \<in> S"
236.71 + using affine_alt[of S] assm xy by auto
236.72 ultimately
236.73 have "(1/2) *\<^sub>R (x+y) \<in> S"
236.74 using u_def by auto
236.75 moreover
236.76 - have "(x+y) = 2 *\<^sub>R ((1/2) *\<^sub>R (x+y))"
236.77 + have "x + y = 2 *\<^sub>R ((1/2) *\<^sub>R (x+y))"
236.78 by auto
236.79 ultimately
236.80 - have "(x+y) \<in> S"
236.81 + have "x + y \<in> S"
236.82 using h1[rule_format, of "(1/2) *\<^sub>R (x+y)" "2"] by auto
236.83 }
236.84 then have "\<forall>x \<in> S. \<forall>y \<in> S. x + y \<in> S"
236.85 @@ -980,6 +982,7 @@
236.86 assumes "affine S" "a \<in> S"
236.87 shows "subspace ((\<lambda>x. (-a)+x) ` S)"
236.88 proof -
236.89 + have [simp]: "(\<lambda>x. x - a) = plus (- a)" by (simp add: fun_eq_iff)
236.90 have "affine ((\<lambda>x. (-a)+x) ` S)"
236.91 using affine_translation assms by auto
236.92 moreover have "0 : ((\<lambda>x. (-a)+x) ` S)"
236.93 @@ -988,19 +991,17 @@
236.94 qed
236.95
236.96 lemma parallel_subspace_explicit:
236.97 - assumes "affine S" "a : S"
236.98 - assumes "L \<equiv> {y. \<exists>x \<in> S. (-a)+x=y}"
236.99 - shows "subspace L & affine_parallel S L"
236.100 -proof -
236.101 - have par: "affine_parallel S L"
236.102 - unfolding affine_parallel_def using assms by auto
236.103 + assumes "affine S"
236.104 + and "a \<in> S"
236.105 + assumes "L \<equiv> {y. \<exists>x \<in> S. (-a) + x = y}"
236.106 + shows "subspace L \<and> affine_parallel S L"
236.107 +proof -
236.108 + from assms have "L = plus (- a) ` S" by auto
236.109 + then have par: "affine_parallel S L"
236.110 + unfolding affine_parallel_def ..
236.111 then have "affine L" using assms parallel_is_affine by auto
236.112 moreover have "0 \<in> L"
236.113 - using assms
236.114 - apply auto
236.115 - using exI[of "(\<lambda>x. x:S \<and> -a+x=0)" a]
236.116 - apply auto
236.117 - done
236.118 + using assms by auto
236.119 ultimately show ?thesis
236.120 using subspace_affine par by auto
236.121 qed
236.122 @@ -1011,14 +1012,14 @@
236.123 and "affine_parallel A B"
236.124 shows "A \<supseteq> B"
236.125 proof -
236.126 - from assms obtain a where a_def: "\<forall>x. x \<in> A \<longleftrightarrow> a + x \<in> B"
236.127 + from assms obtain a where a: "\<forall>x. x \<in> A \<longleftrightarrow> a + x \<in> B"
236.128 using affine_parallel_expl[of A B] by auto
236.129 then have "-a \<in> A"
236.130 using assms subspace_0[of B] by auto
236.131 then have "a \<in> A"
236.132 using assms subspace_neg[of A "-a"] by auto
236.133 then show ?thesis
236.134 - using assms a_def unfolding subspace_def by auto
236.135 + using assms a unfolding subspace_def by auto
236.136 qed
236.137
236.138 lemma parallel_subspace:
236.139 @@ -1117,7 +1118,7 @@
236.140 then have "x \<in> (op *\<^sub>R c) ` S"
236.141 unfolding image_def
236.142 using `cone S` `c>0` mem_cone[of S x "1/c"]
236.143 - exI[of "(%t. t:S & x = c *\<^sub>R t)" "(1 / c) *\<^sub>R x"]
236.144 + exI[of "(\<lambda>t. t \<in> S \<and> x = c *\<^sub>R t)" "(1 / c) *\<^sub>R x"]
236.145 by auto
236.146 }
236.147 moreover
236.148 @@ -1170,17 +1171,17 @@
236.149 {
236.150 fix x
236.151 assume "x \<in> ?rhs"
236.152 - then obtain cx :: real and xx where x_def: "x = cx *\<^sub>R xx" "cx \<ge> 0" "xx \<in> S"
236.153 + then obtain cx :: real and xx where x: "x = cx *\<^sub>R xx" "cx \<ge> 0" "xx \<in> S"
236.154 by auto
236.155 fix c :: real
236.156 assume c: "c \<ge> 0"
236.157 then have "c *\<^sub>R x = (c * cx) *\<^sub>R xx"
236.158 - using x_def by (simp add: algebra_simps)
236.159 + using x by (simp add: algebra_simps)
236.160 moreover
236.161 have "c * cx \<ge> 0"
236.162 - using c x_def using mult_nonneg_nonneg by auto
236.163 + using c x using mult_nonneg_nonneg by auto
236.164 ultimately
236.165 - have "c *\<^sub>R x \<in> ?rhs" using x_def by auto
236.166 + have "c *\<^sub>R x \<in> ?rhs" using x by auto
236.167 }
236.168 then have "cone ?rhs"
236.169 unfolding cone_def by auto
236.170 @@ -1203,12 +1204,12 @@
236.171 {
236.172 fix x
236.173 assume "x \<in> ?rhs"
236.174 - then obtain cx :: real and xx where x_def: "x = cx *\<^sub>R xx" "cx \<ge> 0" "xx \<in> S"
236.175 + then obtain cx :: real and xx where x: "x = cx *\<^sub>R xx" "cx \<ge> 0" "xx \<in> S"
236.176 by auto
236.177 then have "xx \<in> cone hull S"
236.178 using hull_subset[of S] by auto
236.179 then have "x \<in> ?lhs"
236.180 - using x_def cone_cone_hull[of S] cone_def[of "cone hull S"] by auto
236.181 + using x cone_cone_hull[of S] cone_def[of "cone hull S"] by auto
236.182 }
236.183 ultimately show ?thesis by auto
236.184 qed
236.185 @@ -2390,7 +2391,7 @@
236.186 ultimately have h1: "affine hull ((\<lambda>x. a + x) ` S) \<subseteq> (\<lambda>x. a + x) ` (affine hull S)"
236.187 by (metis hull_minimal)
236.188 have "affine((\<lambda>x. -a + x) ` (affine hull ((\<lambda>x. a + x) ` S)))"
236.189 - using affine_translation affine_affine_hull by auto
236.190 + using affine_translation affine_affine_hull by (auto simp del: uminus_add_conv_diff)
236.191 moreover have "(\<lambda>x. -a + x) ` (\<lambda>x. a + x) ` S \<subseteq> (\<lambda>x. -a + x) ` (affine hull ((\<lambda>x. a + x) ` S))"
236.192 using hull_subset[of "(\<lambda>x. a + x) ` S"] by auto
236.193 moreover have "S = (\<lambda>x. -a + x) ` (\<lambda>x. a + x) ` S"
236.194 @@ -2399,27 +2400,27 @@
236.195 by (metis hull_minimal)
236.196 then have "affine hull ((\<lambda>x. a + x) ` S) >= (\<lambda>x. a + x) ` (affine hull S)"
236.197 by auto
236.198 - from this show ?thesis using h1 by auto
236.199 + then show ?thesis using h1 by auto
236.200 qed
236.201
236.202 lemma affine_dependent_translation:
236.203 assumes "affine_dependent S"
236.204 shows "affine_dependent ((\<lambda>x. a + x) ` S)"
236.205 proof -
236.206 - obtain x where x_def: "x \<in> S \<and> x \<in> affine hull (S - {x})"
236.207 + obtain x where x: "x \<in> S \<and> x \<in> affine hull (S - {x})"
236.208 using assms affine_dependent_def by auto
236.209 have "op + a ` (S - {x}) = op + a ` S - {a + x}"
236.210 by auto
236.211 then have "a + x \<in> affine hull ((\<lambda>x. a + x) ` S - {a + x})"
236.212 - using affine_hull_translation[of a "S - {x}"] x_def by auto
236.213 + using affine_hull_translation[of a "S - {x}"] x by auto
236.214 moreover have "a + x \<in> (\<lambda>x. a + x) ` S"
236.215 - using x_def by auto
236.216 + using x by auto
236.217 ultimately show ?thesis
236.218 unfolding affine_dependent_def by auto
236.219 qed
236.220
236.221 lemma affine_dependent_translation_eq:
236.222 - "affine_dependent S <-> affine_dependent ((\<lambda>x. a + x) ` S)"
236.223 + "affine_dependent S \<longleftrightarrow> affine_dependent ((\<lambda>x. a + x) ` S)"
236.224 proof -
236.225 {
236.226 assume "affine_dependent ((\<lambda>x. a + x) ` S)"
236.227 @@ -2435,12 +2436,12 @@
236.228 assumes "0 \<in> affine hull S"
236.229 shows "dependent S"
236.230 proof -
236.231 - obtain s u where s_u_def: "finite s \<and> s \<noteq> {} \<and> s \<subseteq> S \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = 0"
236.232 + obtain s u where s_u: "finite s \<and> s \<noteq> {} \<and> s \<subseteq> S \<and> setsum u s = 1 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = 0"
236.233 using assms affine_hull_explicit[of S] by auto
236.234 then have "\<exists>v\<in>s. u v \<noteq> 0"
236.235 using setsum_not_0[of "u" "s"] by auto
236.236 then have "finite s \<and> s \<subseteq> S \<and> (\<exists>v\<in>s. u v \<noteq> 0 \<and> (\<Sum>v\<in>s. u v *\<^sub>R v) = 0)"
236.237 - using s_u_def by auto
236.238 + using s_u by auto
236.239 then show ?thesis
236.240 unfolding dependent_explicit[of S] by auto
236.241 qed
236.242 @@ -2449,7 +2450,7 @@
236.243 assumes "affine_dependent (insert 0 S)"
236.244 shows "dependent S"
236.245 proof -
236.246 - obtain x where x_def: "x \<in> insert 0 S \<and> x \<in> affine hull (insert 0 S - {x})"
236.247 + obtain x where x: "x \<in> insert 0 S \<and> x \<in> affine hull (insert 0 S - {x})"
236.248 using affine_dependent_def[of "(insert 0 S)"] assms by blast
236.249 then have "x \<in> span (insert 0 S - {x})"
236.250 using affine_hull_subset_span by auto
236.251 @@ -2457,12 +2458,12 @@
236.252 using insert_Diff_if[of "0" S "{x}"] span_insert_0[of "S-{x}"] by auto
236.253 ultimately have "x \<in> span (S - {x})" by auto
236.254 then have "x \<noteq> 0 \<Longrightarrow> dependent S"
236.255 - using x_def dependent_def by auto
236.256 + using x dependent_def by auto
236.257 moreover
236.258 {
236.259 assume "x = 0"
236.260 then have "0 \<in> affine hull S"
236.261 - using x_def hull_mono[of "S - {0}" S] by auto
236.262 + using x hull_mono[of "S - {0}" S] by auto
236.263 then have "dependent S"
236.264 using affine_hull_0_dependent by auto
236.265 }
236.266 @@ -2478,7 +2479,7 @@
236.267 using affine_dependent_translation_eq[of "(insert a S)" "-a"]
236.268 affine_dependent_imp_dependent2 assms
236.269 dependent_imp_affine_dependent[of a S]
236.270 - by auto
236.271 + by (auto simp del: uminus_add_conv_diff)
236.272 qed
236.273
236.274 lemma affine_dependent_iff_dependent2:
236.275 @@ -2512,7 +2513,7 @@
236.276 then have "insert 0 ((\<lambda>x. -a+x) ` (s - {a})) = (\<lambda>x. -a+x) ` s"
236.277 by auto
236.278 then have "span ((\<lambda>x. -a+x) ` (s - {a}))=span ((\<lambda>x. -a+x) ` s)"
236.279 - using span_insert_0[of "op + (- a) ` (s - {a})"] by auto
236.280 + using span_insert_0[of "op + (- a) ` (s - {a})"] by (auto simp del: uminus_add_conv_diff)
236.281 moreover have "{x - a |x. x \<in> (s - {a})} = ((\<lambda>x. -a+x) ` (s - {a}))"
236.282 by auto
236.283 moreover have "insert a (s - {a}) = insert a s"
236.284 @@ -2550,11 +2551,11 @@
236.285 assumes "\<not> affine_dependent S" "S \<subseteq> V" "S \<noteq> {}"
236.286 shows "\<exists>T. \<not> affine_dependent T \<and> S \<subseteq> T \<and> T \<subseteq> V \<and> affine hull T = affine hull V"
236.287 proof -
236.288 - obtain a where a_def: "a \<in> S"
236.289 + obtain a where a: "a \<in> S"
236.290 using assms by auto
236.291 then have h0: "independent ((\<lambda>x. -a + x) ` (S-{a}))"
236.292 using affine_dependent_iff_dependent2 assms by auto
236.293 - then obtain B where B_def:
236.294 + then obtain B where B:
236.295 "(\<lambda>x. -a+x) ` (S - {a}) \<subseteq> B \<and> B \<subseteq> (\<lambda>x. -a+x) ` V \<and> independent B \<and> (\<lambda>x. -a+x) ` V \<subseteq> span B"
236.296 using maximal_independent_subset_extend[of "(\<lambda>x. -a+x) ` (S-{a})" "(\<lambda>x. -a + x) ` V"] assms
236.297 by blast
236.298 @@ -2565,18 +2566,18 @@
236.299 using affine_hull_insert_span_gen[of a "((\<lambda>x. a+x) ` B)"] translation_assoc[of "-a" a B]
236.300 by auto
236.301 then have "V \<subseteq> affine hull T"
236.302 - using B_def assms translation_inverse_subset[of a V "span B"]
236.303 + using B assms translation_inverse_subset[of a V "span B"]
236.304 by auto
236.305 moreover have "T \<subseteq> V"
236.306 - using T_def B_def a_def assms by auto
236.307 + using T_def B a assms by auto
236.308 ultimately have "affine hull T = affine hull V"
236.309 by (metis Int_absorb1 Int_absorb2 hull_hull hull_mono)
236.310 moreover have "S \<subseteq> T"
236.311 - using T_def B_def translation_inverse_subset[of a "S-{a}" B]
236.312 + using T_def B translation_inverse_subset[of a "S-{a}" B]
236.313 by auto
236.314 moreover have "\<not> affine_dependent T"
236.315 using T_def affine_dependent_translation_eq[of "insert 0 B"]
236.316 - affine_dependent_imp_dependent2 B_def
236.317 + affine_dependent_imp_dependent2 B
236.318 by auto
236.319 ultimately show ?thesis using `T \<subseteq> V` by auto
236.320 qed
236.321 @@ -2652,7 +2653,7 @@
236.322 moreover have h1: "card ((\<lambda>x. -a + x) ` (B-{a})) = card (B-{a})"
236.323 apply (rule card_image)
236.324 using translate_inj_on
236.325 - apply auto
236.326 + apply (auto simp del: uminus_add_conv_diff)
236.327 done
236.328 ultimately have "card (B-{a}) > 0" by auto
236.329 then have *: "finite (B - {a})"
236.330 @@ -2671,31 +2672,31 @@
236.331 shows "aff_dim V = int (dim L)"
236.332 proof -
236.333 obtain B where
236.334 - B_def: "affine hull B = affine hull V \<and> \<not> affine_dependent B \<and> int (card B) = aff_dim V + 1"
236.335 + B: "affine hull B = affine hull V \<and> \<not> affine_dependent B \<and> int (card B) = aff_dim V + 1"
236.336 using aff_dim_basis_exists by auto
236.337 then have "B \<noteq> {}"
236.338 - using assms B_def affine_hull_nonempty[of V] affine_hull_nonempty[of B]
236.339 + using assms B affine_hull_nonempty[of V] affine_hull_nonempty[of B]
236.340 by auto
236.341 - then obtain a where a_def: "a \<in> B" by auto
236.342 + then obtain a where a: "a \<in> B" by auto
236.343 def Lb \<equiv> "span ((\<lambda>x. -a+x) ` (B-{a}))"
236.344 moreover have "affine_parallel (affine hull B) Lb"
236.345 - using Lb_def B_def assms affine_hull_span2[of a B] a_def
236.346 + using Lb_def B assms affine_hull_span2[of a B] a
236.347 affine_parallel_commut[of "Lb" "(affine hull B)"]
236.348 unfolding affine_parallel_def
236.349 by auto
236.350 moreover have "subspace Lb"
236.351 using Lb_def subspace_span by auto
236.352 moreover have "affine hull B \<noteq> {}"
236.353 - using assms B_def affine_hull_nonempty[of V] by auto
236.354 + using assms B affine_hull_nonempty[of V] by auto
236.355 ultimately have "L = Lb"
236.356 - using assms affine_parallel_subspace[of "affine hull B"] affine_affine_hull[of B] B_def
236.357 + using assms affine_parallel_subspace[of "affine hull B"] affine_affine_hull[of B] B
236.358 by auto
236.359 then have "dim L = dim Lb"
236.360 by auto
236.361 moreover have "card B - 1 = dim Lb" and "finite B"
236.362 - using Lb_def aff_dim_parallel_subspace_aux a_def B_def by auto
236.363 + using Lb_def aff_dim_parallel_subspace_aux a B by auto
236.364 ultimately show ?thesis
236.365 - using B_def `B \<noteq> {}` card_gt_0_iff[of B] by auto
236.366 + using B `B \<noteq> {}` card_gt_0_iff[of B] by auto
236.367 qed
236.368
236.369 lemma aff_independent_finite:
236.370 @@ -2783,7 +2784,7 @@
236.371 defer
236.372 unfolding dim_span[of B]
236.373 apply(rule B)
236.374 - unfolding span_substd_basis[OF d, symmetric]
236.375 + unfolding span_substd_basis[OF d, symmetric]
236.376 apply (rule span_inc)
236.377 apply (rule independent_substdbasis[OF d])
236.378 apply rule
236.379 @@ -2832,10 +2833,10 @@
236.380 using `B = {}` by auto
236.381 next
236.382 case False
236.383 - then obtain a where a_def: "a \<in> B" by auto
236.384 + then obtain a where a: "a \<in> B" by auto
236.385 def Lb \<equiv> "span ((\<lambda>x. -a+x) ` (B-{a}))"
236.386 have "affine_parallel (affine hull B) Lb"
236.387 - using Lb_def affine_hull_span2[of a B] a_def
236.388 + using Lb_def affine_hull_span2[of a B] a
236.389 affine_parallel_commut[of "Lb" "(affine hull B)"]
236.390 unfolding affine_parallel_def by auto
236.391 moreover have "subspace Lb"
236.392 @@ -2843,7 +2844,7 @@
236.393 ultimately have "aff_dim B = int(dim Lb)"
236.394 using aff_dim_parallel_subspace[of B Lb] `B \<noteq> {}` by auto
236.395 moreover have "(card B) - 1 = dim Lb" "finite B"
236.396 - using Lb_def aff_dim_parallel_subspace_aux a_def assms by auto
236.397 + using Lb_def aff_dim_parallel_subspace_aux a assms by auto
236.398 ultimately have "of_nat (card B) = aff_dim B + 1"
236.399 using `B \<noteq> {}` card_gt_0_iff[of B] by auto
236.400 then show ?thesis
236.401 @@ -3172,8 +3173,8 @@
236.402 assume *: "x \<in> S" "open T" "x \<in> T" "T \<inter> affine hull S \<subseteq> S"
236.403 then have **: "x \<in> T \<inter> affine hull S"
236.404 using hull_inc by auto
236.405 - show "\<exists>Tb. (\<exists>Ta. open Ta \<and> Tb = affine hull S Int Ta) \<and> x \<in> Tb \<and> Tb \<subseteq> S"
236.406 - apply (rule_tac x="T Int (affine hull S)" in exI)
236.407 + show "\<exists>Tb. (\<exists>Ta. open Ta \<and> Tb = affine hull S \<inter> Ta) \<and> x \<in> Tb \<and> Tb \<subseteq> S"
236.408 + apply (rule_tac x = "T \<inter> (affine hull S)" in exI)
236.409 using * **
236.410 apply auto
236.411 done
236.412 @@ -3288,7 +3289,7 @@
236.413 and "e \<le> 1"
236.414 shows "x - e *\<^sub>R (x - c) \<in> rel_interior S"
236.415 proof -
236.416 - obtain d where "d > 0" and d: "ball c d Int affine hull S \<subseteq> S"
236.417 + obtain d where "d > 0" and d: "ball c d \<inter> affine hull S \<subseteq> S"
236.418 using assms(2) unfolding mem_rel_interior_ball by auto
236.419 {
236.420 fix y
236.421 @@ -3658,7 +3659,7 @@
236.422 {
236.423 fix x
236.424 assume x: "x \<in> rel_interior S"
236.425 - then obtain e2 where e2: "e2 > 0" "cball x e2 Int affine hull S \<subseteq> S"
236.426 + then obtain e2 where e2: "e2 > 0" "cball x e2 \<inter> affine hull S \<subseteq> S"
236.427 using rel_interior_cball[of S] by auto
236.428 have "x \<in> S" using x rel_interior_subset by auto
236.429 then have *: "f x \<in> f ` S" by auto
236.430 @@ -3787,7 +3788,7 @@
236.431 moreover from `x\<in>t` have "x \<in> s"
236.432 using obt(2) by auto
236.433 ultimately have "x + (y - a) \<in> s"
236.434 - using y and b[THEN bspec[where x=x]] unfolding subset_eq by fast
236.435 + using y and b[THEN bspec[where x=x]] unfolding subset_eq by fast
236.436 }
236.437 moreover
236.438 have *: "inj_on (\<lambda>v. v + (y - a)) t"
236.439 @@ -4507,38 +4508,30 @@
236.440 apply (erule_tac x="x - y" in ballE)
236.441 apply (auto simp add: inner_diff)
236.442 done
236.443 - def k \<equiv> "Sup ((\<lambda>x. inner a x) ` t)"
236.444 + def k \<equiv> "SUP x:t. a \<bullet> x"
236.445 show ?thesis
236.446 apply (rule_tac x="-a" in exI)
236.447 apply (rule_tac x="-(k + b / 2)" in exI)
236.448 - apply rule
236.449 - apply rule
236.450 - defer
236.451 - apply rule
236.452 + apply (intro conjI ballI)
236.453 unfolding inner_minus_left and neg_less_iff_less
236.454 proof -
236.455 - from ab have "((\<lambda>x. inner a x) ` t) *<= (inner a y - b)"
236.456 - apply (erule_tac x=y in ballE)
236.457 - apply (rule setleI)
236.458 - using `y \<in> s`
236.459 - apply auto
236.460 - done
236.461 - then have k: "isLub UNIV ((\<lambda>x. inner a x) ` t) k"
236.462 + fix x assume "x \<in> t"
236.463 + then have "inner a x - b / 2 < k"
236.464 unfolding k_def
236.465 - apply (rule_tac isLub_cSup)
236.466 - using assms(5)
236.467 - apply auto
236.468 - done
236.469 - fix x
236.470 - assume "x \<in> t"
236.471 - then show "inner a x < (k + b / 2)"
236.472 - using `0<b` and isLubD2[OF k, of "inner a x"] by auto
236.473 + proof (subst less_cSUP_iff)
236.474 + show "t \<noteq> {}" by fact
236.475 + show "bdd_above (op \<bullet> a ` t)"
236.476 + using ab[rule_format, of y] `y \<in> s`
236.477 + by (intro bdd_aboveI2[where M="inner a y - b"]) (auto simp: field_simps intro: less_imp_le)
236.478 + qed (auto intro!: bexI[of _ x] `0<b`)
236.479 + then show "inner a x < k + b / 2"
236.480 + by auto
236.481 next
236.482 fix x
236.483 assume "x \<in> s"
236.484 then have "k \<le> inner a x - b"
236.485 unfolding k_def
236.486 - apply (rule_tac cSup_least)
236.487 + apply (rule_tac cSUP_least)
236.488 using assms(5)
236.489 using ab[THEN bspec[where x=x]]
236.490 apply auto
236.491 @@ -4627,20 +4620,14 @@
236.492 from separating_hyperplane_set_0[OF convex_differences[OF assms(2,1)]]
236.493 obtain a where "a \<noteq> 0" "\<forall>x\<in>{x - y |x y. x \<in> t \<and> y \<in> s}. 0 \<le> inner a x"
236.494 using assms(3-5) by auto
236.495 - then have "\<forall>x\<in>t. \<forall>y\<in>s. inner a y \<le> inner a x"
236.496 + then have *: "\<And>x y. x \<in> t \<Longrightarrow> y \<in> s \<Longrightarrow> inner a y \<le> inner a x"
236.497 by (force simp add: inner_diff)
236.498 - then show ?thesis
236.499 - apply (rule_tac x=a in exI)
236.500 - apply (rule_tac x="Sup ((\<lambda>x. inner a x) ` s)" in exI)
236.501 + then have bdd: "bdd_above ((op \<bullet> a)`s)"
236.502 + using `t \<noteq> {}` by (auto intro: bdd_aboveI2[OF *])
236.503 + show ?thesis
236.504 using `a\<noteq>0`
236.505 - apply auto
236.506 - apply (rule isLub_cSup[THEN isLubD2])
236.507 - prefer 4
236.508 - apply (rule cSup_least)
236.509 - using assms(3-5)
236.510 - apply (auto simp add: setle_def)
236.511 - apply metis
236.512 - done
236.513 + by (intro exI[of _ a] exI[of _ "SUP x:s. a \<bullet> x"])
236.514 + (auto intro!: cSUP_upper bdd cSUP_least `a \<noteq> 0` `s \<noteq> {}` *)
236.515 qed
236.516
236.517
236.518 @@ -4771,7 +4758,8 @@
236.519 then show ?thesis by auto
236.520 next
236.521 case False
236.522 - then have *: "0 \<in> S & (!c. c>0 --> op *\<^sub>R c ` S = S)" using cone_iff[of S] assms by auto
236.523 + then have *: "0 \<in> S \<and> (\<forall>c. c > 0 \<longrightarrow> op *\<^sub>R c ` S = S)"
236.524 + using cone_iff[of S] assms by auto
236.525 {
236.526 fix c :: real
236.527 assume "c > 0"
236.528 @@ -4799,7 +4787,7 @@
236.529 unfolding Inter_iff Ball_def mem_Collect_eq
236.530 apply (rule,rule,erule conjE)
236.531 proof -
236.532 - fix x
236.533 + fix x
236.534 assume "\<forall>xa. s \<subseteq> xa \<and> (\<exists>a b. xa = {x. inner a x \<le> b}) \<longrightarrow> x \<in> xa"
236.535 then have "\<forall>a b. s \<subseteq> {x. inner a x \<le> b} \<longrightarrow> x \<in> {x. inner a x \<le> b}"
236.536 by blast
236.537 @@ -5690,28 +5678,55 @@
236.538 "is_interval (s::real set) \<longleftrightarrow> (\<forall>a\<in>s. \<forall>b\<in>s. \<forall> x. a \<le> x \<and> x \<le> b \<longrightarrow> x \<in> s)"
236.539 unfolding is_interval_def by auto
236.540
236.541 -lemma is_interval_connected_1: "is_interval s \<longleftrightarrow> connected (s::real set)"
236.542 - apply(rule, rule is_interval_connected, assumption) unfolding is_interval_1
236.543 - apply(rule,rule,rule,rule,erule conjE,rule ccontr) proof-
236.544 - fix a b x assume as:"connected s" "a \<in> s" "b \<in> s" "a \<le> x" "x \<le> b" "x\<notin>s"
236.545 - hence *:"a < x" "x < b" unfolding not_le [symmetric] by auto
236.546 - let ?halfl = "{..<x} " and ?halfr = "{x<..} "
236.547 - { fix y assume "y \<in> s" with `x \<notin> s` have "x \<noteq> y" by auto
236.548 - then have "y \<in> ?halfr \<union> ?halfl" by auto }
236.549 - moreover have "a\<in>?halfl" "b\<in>?halfr" using * by auto
236.550 - hence "?halfl \<inter> s \<noteq> {}" "?halfr \<inter> s \<noteq> {}" using as(2-3) by auto
236.551 - ultimately show False apply(rule_tac notE[OF as(1)[unfolded connected_def]])
236.552 - apply(rule_tac x="?halfl" in exI, rule_tac x="?halfr" in exI)
236.553 - apply(rule, rule open_lessThan, rule, rule open_greaterThan)
236.554 - by auto qed
236.555 +lemma is_interval_connected_1:
236.556 + fixes s :: "real set"
236.557 + shows "is_interval s \<longleftrightarrow> connected s"
236.558 + apply rule
236.559 + apply (rule is_interval_connected, assumption)
236.560 + unfolding is_interval_1
236.561 + apply rule
236.562 + apply rule
236.563 + apply rule
236.564 + apply rule
236.565 + apply (erule conjE)
236.566 + apply (rule ccontr)
236.567 +proof -
236.568 + fix a b x
236.569 + assume as: "connected s" "a \<in> s" "b \<in> s" "a \<le> x" "x \<le> b" "x \<notin> s"
236.570 + then have *: "a < x" "x < b"
236.571 + unfolding not_le [symmetric] by auto
236.572 + let ?halfl = "{..<x} "
236.573 + let ?halfr = "{x<..}"
236.574 + {
236.575 + fix y
236.576 + assume "y \<in> s"
236.577 + with `x \<notin> s` have "x \<noteq> y" by auto
236.578 + then have "y \<in> ?halfr \<union> ?halfl" by auto
236.579 + }
236.580 + moreover have "a \<in> ?halfl" "b \<in> ?halfr" using * by auto
236.581 + then have "?halfl \<inter> s \<noteq> {}" "?halfr \<inter> s \<noteq> {}"
236.582 + using as(2-3) by auto
236.583 + ultimately show False
236.584 + apply (rule_tac notE[OF as(1)[unfolded connected_def]])
236.585 + apply (rule_tac x = ?halfl in exI)
236.586 + apply (rule_tac x = ?halfr in exI)
236.587 + apply rule
236.588 + apply (rule open_lessThan)
236.589 + apply rule
236.590 + apply (rule open_greaterThan)
236.591 + apply auto
236.592 + done
236.593 +qed
236.594
236.595 lemma is_interval_convex_1:
236.596 - "is_interval s \<longleftrightarrow> convex (s::real set)"
236.597 -by(metis is_interval_convex convex_connected is_interval_connected_1)
236.598 + fixes s :: "real set"
236.599 + shows "is_interval s \<longleftrightarrow> convex s"
236.600 + by (metis is_interval_convex convex_connected is_interval_connected_1)
236.601
236.602 lemma convex_connected_1:
236.603 - "connected s \<longleftrightarrow> convex (s::real set)"
236.604 -by(metis is_interval_convex convex_connected is_interval_connected_1)
236.605 + fixes s :: "real set"
236.606 + shows "connected s \<longleftrightarrow> convex s"
236.607 + by (metis is_interval_convex convex_connected is_interval_connected_1)
236.608
236.609
236.610 subsection {* Another intermediate value theorem formulation *}
236.611 @@ -6619,7 +6634,7 @@
236.612 lemma substd_simplex:
236.613 assumes d: "d \<subseteq> Basis"
236.614 shows "convex hull (insert 0 d) =
236.615 - {x. (\<forall>i\<in>Basis. 0 \<le> x\<bullet>i) \<and> (\<Sum>i\<in>d. x\<bullet>i) \<le> 1 \<and> (\<forall>i\<in>Basis. i \<notin> d --> x\<bullet>i = 0)}"
236.616 + {x. (\<forall>i\<in>Basis. 0 \<le> x\<bullet>i) \<and> (\<Sum>i\<in>d. x\<bullet>i) \<le> 1 \<and> (\<forall>i\<in>Basis. i \<notin> d \<longrightarrow> x\<bullet>i = 0)}"
236.617 (is "convex hull (insert 0 ?p) = ?s")
236.618 proof -
236.619 let ?D = d
236.620 @@ -6628,7 +6643,7 @@
236.621 from d have "finite d"
236.622 by (blast intro: finite_subset finite_Basis)
236.623 show ?thesis
236.624 - unfolding simplex[OF `finite d` `0 ~: ?p`]
236.625 + unfolding simplex[OF `finite d` `0 \<notin> ?p`]
236.626 apply (rule set_eqI)
236.627 unfolding mem_Collect_eq
236.628 apply rule
236.629 @@ -6639,7 +6654,7 @@
236.630 fix u
236.631 assume as: "\<forall>x\<in>?D. 0 \<le> u x" "setsum u ?D \<le> 1" "(\<Sum>x\<in>?D. u x *\<^sub>R x) = x"
236.632 have *: "\<forall>i\<in>Basis. i:d \<longrightarrow> u i = x\<bullet>i"
236.633 - and "(\<forall>i\<in>Basis. i ~: d --> x \<bullet> i = 0)"
236.634 + and "(\<forall>i\<in>Basis. i \<notin> d \<longrightarrow> x \<bullet> i = 0)"
236.635 using as(3)
236.636 unfolding substdbasis_expansion_unique[OF assms]
236.637 by auto
236.638 @@ -6853,8 +6868,9 @@
236.639 unfolding ball_def unfolding substd_simplex[OF assms] using assms by auto
236.640 have x0: "(\<forall>i\<in>Basis. i \<notin> d \<longrightarrow> x\<bullet>i = 0)"
236.641 using x rel_interior_subset substd_simplex[OF assms] by auto
236.642 - have "(\<forall>i\<in>d. 0 < x \<bullet> i) \<and> setsum (op \<bullet> x) d < 1 \<and> (\<forall>i\<in>Basis. i \<notin> d --> x\<bullet>i = 0)"
236.643 - apply (rule, rule)
236.644 + have "(\<forall>i\<in>d. 0 < x \<bullet> i) \<and> setsum (op \<bullet> x) d < 1 \<and> (\<forall>i\<in>Basis. i \<notin> d \<longrightarrow> x\<bullet>i = 0)"
236.645 + apply rule
236.646 + apply rule
236.647 proof -
236.648 fix i :: 'a
236.649 assume "i \<in> d"
236.650 @@ -6906,7 +6922,7 @@
236.651 by auto
236.652 moreover have "\<forall>i. i \<in> d \<or> i \<notin> d" by auto
236.653 ultimately
236.654 - have "\<forall>i. (\<forall>i\<in>d. 0 < x\<bullet>i) \<and> (\<forall>i. i \<notin> d \<longrightarrow> x\<bullet>i = 0) --> 0 \<le> x\<bullet>i"
236.655 + have "\<forall>i. (\<forall>i\<in>d. 0 < x\<bullet>i) \<and> (\<forall>i. i \<notin> d \<longrightarrow> x\<bullet>i = 0) \<longrightarrow> 0 \<le> x\<bullet>i"
236.656 by metis
236.657 then have h2: "x \<in> convex hull (insert 0 ?p)"
236.658 using as assms
236.659 @@ -6923,7 +6939,7 @@
236.660 using as using `0 < card d` by auto
236.661 ultimately have h3: "min (Min ((op \<bullet> x) ` d)) ?d > 0"
236.662 by auto
236.663 -
236.664 +
236.665 have "x \<in> rel_interior (convex hull (insert 0 ?p))"
236.666 unfolding rel_interior_ball mem_Collect_eq h0
236.667 apply (rule,rule h2)
236.668 @@ -6955,7 +6971,7 @@
236.669 using `0 < card d`
236.670 by auto
236.671 finally show "setsum (op \<bullet> y) d \<le> 1" .
236.672 -
236.673 +
236.674 fix i :: 'a
236.675 assume i: "i \<in> Basis"
236.676 then show "0 \<le> y\<bullet>i"
236.677 @@ -7295,7 +7311,7 @@
236.678 moreover
236.679 {
236.680 fix z
236.681 - assume z: "z : rel_interior (closure S)"
236.682 + assume z: "z \<in> rel_interior (closure S)"
236.683 obtain x where x: "x \<in> rel_interior S"
236.684 using `S \<noteq> {}` assms rel_interior_convex_nonempty by auto
236.685 have "z \<in> rel_interior S"
236.686 @@ -7304,7 +7320,7 @@
236.687 then show ?thesis using x by auto
236.688 next
236.689 case False
236.690 - obtain e where e: "e > 0" "cball z e Int affine hull closure S \<le> closure S"
236.691 + obtain e where e: "e > 0" "cball z e \<inter> affine hull closure S \<le> closure S"
236.692 using z rel_interior_cball[of "closure S"] by auto
236.693 then have *: "0 < e/norm(z-x)"
236.694 using e False divide_pos_pos[of e "norm(z-x)"] by auto
236.695 @@ -7353,7 +7369,7 @@
236.696 assumes "convex S1"
236.697 and "convex S2"
236.698 shows "closure S1 = closure S2 \<longleftrightarrow> rel_interior S1 \<le> S2 \<and> S2 \<subseteq> closure S1"
236.699 - (is "?A <-> ?B")
236.700 + (is "?A \<longleftrightarrow> ?B")
236.701 proof
236.702 assume ?A
236.703 then show ?B
236.704 @@ -7437,7 +7453,7 @@
236.705 using mem_rel_interior[of a S1] a by auto
236.706 then have "a \<in> T \<inter> closure S2"
236.707 using a assms unfolding rel_frontier_def by auto
236.708 - then obtain b where b: "b \<in> T Int rel_interior S2"
236.709 + then obtain b where b: "b \<in> T \<inter> rel_interior S2"
236.710 using open_inter_closure_rel_interior[of S2 T] assms T by auto
236.711 then have "b \<in> affine hull S1"
236.712 using rel_interior_subset hull_subset[of S2] ** by auto
236.713 @@ -7457,12 +7473,13 @@
236.714 and "z \<in> rel_interior S"
236.715 shows "\<forall>x\<in>affine hull S. \<exists>m. m > 1 \<and> (\<forall>e. e > 1 \<and> e \<le> m \<longrightarrow> (1 - e) *\<^sub>R x + e *\<^sub>R z \<in> S)"
236.716 proof -
236.717 - obtain e1 where e1: "e1>0 & cball z e1 Int affine hull S <= S"
236.718 - using mem_rel_interior_cball[of z S] assms by auto
236.719 + obtain e1 where e1: "e1 > 0 \<and> cball z e1 \<inter> affine hull S \<subseteq> S"
236.720 + using mem_rel_interior_cball[of z S] assms by auto
236.721 {
236.722 fix x
236.723 assume x: "x \<in> affine hull S"
236.724 - { assume "x ~= z"
236.725 + {
236.726 + assume "x \<noteq> z"
236.727 def m \<equiv> "1 + e1/norm(x-z)"
236.728 then have "m > 1"
236.729 using e1 `x \<noteq> z` divide_pos_pos[of e1 "norm (x - z)"] by auto
236.730 @@ -7583,18 +7600,18 @@
236.731 assume r: "\<forall>x. \<exists>e. e > 0 \<and> z + e *\<^sub>R x \<in> S"
236.732 {
236.733 fix x
236.734 - obtain e1 where e1_def: "e1 > 0 \<and> z + e1 *\<^sub>R (x - z) \<in> S"
236.735 + obtain e1 where e1: "e1 > 0 \<and> z + e1 *\<^sub>R (x - z) \<in> S"
236.736 using r by auto
236.737 - obtain e2 where e2_def: "e2 > 0 \<and> z + e2 *\<^sub>R (z - x) \<in> S"
236.738 + obtain e2 where e2: "e2 > 0 \<and> z + e2 *\<^sub>R (z - x) \<in> S"
236.739 using r by auto
236.740 def x1 \<equiv> "z + e1 *\<^sub>R (x - z)"
236.741 then have x1: "x1 \<in> affine hull S"
236.742 - using e1_def hull_subset[of S] by auto
236.743 + using e1 hull_subset[of S] by auto
236.744 def x2 \<equiv> "z + e2 *\<^sub>R (z - x)"
236.745 then have x2: "x2 \<in> affine hull S"
236.746 - using e2_def hull_subset[of S] by auto
236.747 + using e2 hull_subset[of S] by auto
236.748 have *: "e1/(e1+e2) + e2/(e1+e2) = 1"
236.749 - using add_divide_distrib[of e1 e2 "e1+e2"] e1_def e2_def by simp
236.750 + using add_divide_distrib[of e1 e2 "e1+e2"] e1 e2 by simp
236.751 then have "z = (e2/(e1+e2)) *\<^sub>R x1 + (e1/(e1+e2)) *\<^sub>R x2"
236.752 using x1_def x2_def
236.753 apply (auto simp add: algebra_simps)
236.754 @@ -7608,7 +7625,7 @@
236.755 have "x1 - x2 = (e1 + e2) *\<^sub>R (x - z)"
236.756 using x1_def x2_def by (auto simp add: algebra_simps)
236.757 then have "x = z+(1/(e1+e2)) *\<^sub>R (x1-x2)"
236.758 - using e1_def e2_def by simp
236.759 + using e1 e2 by simp
236.760 then have "x \<in> affine hull S"
236.761 using mem_affine_3_minus[of "affine hull S" z x1 x2 "1/(e1+e2)"]
236.762 x1 x2 z affine_affine_hull[of S]
236.763 @@ -7705,9 +7722,9 @@
236.764 }
236.765 then have "\<Inter>I \<subseteq> \<Inter>{closure S |S. S \<in> I}"
236.766 by auto
236.767 - moreover have "closed (Inter {closure S |S. S \<in> I})"
236.768 + moreover have "closed (\<Inter>{closure S |S. S \<in> I})"
236.769 unfolding closed_Inter closed_closure by auto
236.770 - ultimately show ?thesis using closure_hull[of "Inter I"]
236.771 + ultimately show ?thesis using closure_hull[of "\<Inter>I"]
236.772 hull_minimal[of "\<Inter>I" "\<Inter>{closure S |S. S \<in> I}" "closed"] by auto
236.773 qed
236.774
236.775 @@ -7726,7 +7743,7 @@
236.776 {
236.777 assume "y = x"
236.778 then have "y \<in> closure (\<Inter>{rel_interior S |S. S \<in> I})"
236.779 - using x closure_subset[of "Inter {rel_interior S |S. S \<in> I}"] by auto
236.780 + using x closure_subset[of "\<Inter>{rel_interior S |S. S \<in> I}"] by auto
236.781 }
236.782 moreover
236.783 {
236.784 @@ -7768,13 +7785,13 @@
236.785 lemma convex_closure_inter:
236.786 assumes "\<forall>S\<in>I. convex (S :: 'n::euclidean_space set)"
236.787 and "\<Inter>{rel_interior S |S. S \<in> I} \<noteq> {}"
236.788 - shows "closure (Inter I) = Inter {closure S |S. S \<in> I}"
236.789 + shows "closure (\<Inter>I) = \<Inter>{closure S |S. S \<in> I}"
236.790 proof -
236.791 have "\<Inter>{closure S |S. S \<in> I} \<le> closure (\<Inter>{rel_interior S |S. S \<in> I})"
236.792 using convex_closure_rel_interior_inter assms by auto
236.793 moreover
236.794 - have "closure (Inter {rel_interior S |S. S \<in> I}) \<le> closure (Inter I)"
236.795 - using rel_interior_inter_aux closure_mono[of "Inter {rel_interior S |S. S \<in> I}" "\<Inter>I"]
236.796 + have "closure (\<Inter>{rel_interior S |S. S \<in> I}) \<le> closure (\<Inter> I)"
236.797 + using rel_interior_inter_aux closure_mono[of "\<Inter>{rel_interior S |S. S \<in> I}" "\<Inter>I"]
236.798 by auto
236.799 ultimately show ?thesis
236.800 using closure_inter[of I] by auto
236.801 @@ -7783,13 +7800,13 @@
236.802 lemma convex_inter_rel_interior_same_closure:
236.803 assumes "\<forall>S\<in>I. convex (S :: 'n::euclidean_space set)"
236.804 and "\<Inter>{rel_interior S |S. S \<in> I} \<noteq> {}"
236.805 - shows "closure (Inter {rel_interior S |S. S \<in> I}) = closure (\<Inter>I)"
236.806 + shows "closure (\<Inter>{rel_interior S |S. S \<in> I}) = closure (\<Inter>I)"
236.807 proof -
236.808 have "\<Inter>{closure S |S. S \<in> I} \<le> closure (\<Inter>{rel_interior S |S. S \<in> I})"
236.809 using convex_closure_rel_interior_inter assms by auto
236.810 moreover
236.811 have "closure (\<Inter>{rel_interior S |S. S \<in> I}) \<le> closure (\<Inter>I)"
236.812 - using rel_interior_inter_aux closure_mono[of "Inter {rel_interior S |S. S \<in> I}" "\<Inter>I"]
236.813 + using rel_interior_inter_aux closure_mono[of "\<Inter>{rel_interior S |S. S \<in> I}" "\<Inter>I"]
236.814 by auto
236.815 ultimately show ?thesis
236.816 using closure_inter[of I] by auto
236.817 @@ -7798,12 +7815,12 @@
236.818 lemma convex_rel_interior_inter:
236.819 assumes "\<forall>S\<in>I. convex (S :: 'n::euclidean_space set)"
236.820 and "\<Inter>{rel_interior S |S. S \<in> I} \<noteq> {}"
236.821 - shows "rel_interior (Inter I) \<le> Inter {rel_interior S |S. S \<in> I}"
236.822 + shows "rel_interior (\<Inter>I) \<subseteq> \<Inter>{rel_interior S |S. S \<in> I}"
236.823 proof -
236.824 have "convex (\<Inter>I)"
236.825 using assms convex_Inter by auto
236.826 moreover
236.827 - have "convex(Inter {rel_interior S |S. S \<in> I})"
236.828 + have "convex (\<Inter>{rel_interior S |S. S \<in> I})"
236.829 apply (rule convex_Inter)
236.830 using assms convex_rel_interior
236.831 apply auto
236.832 @@ -7983,18 +8000,18 @@
236.833 fix x
236.834 assume "x \<in> f ` S"
236.835 then obtain x1 where x1: "x1 \<in> S" "f x1 = x" by auto
236.836 - then obtain e where e_def: "e > 1" "(1 - e) *\<^sub>R x1 + e *\<^sub>R z1 : S"
236.837 + then obtain e where e: "e > 1" "(1 - e) *\<^sub>R x1 + e *\<^sub>R z1 : S"
236.838 using convex_rel_interior_iff[of S z1] `convex S` x1 z1 by auto
236.839 moreover have "f ((1 - e) *\<^sub>R x1 + e *\<^sub>R z1) = (1 - e) *\<^sub>R x + e *\<^sub>R z"
236.840 using x1 z1 `linear f` by (simp add: linear_add_cmul)
236.841 ultimately have "(1 - e) *\<^sub>R x + e *\<^sub>R z : f ` S"
236.842 using imageI[of "(1 - e) *\<^sub>R x1 + e *\<^sub>R z1" S f] by auto
236.843 then have "\<exists>e. e > 1 \<and> (1 - e) *\<^sub>R x + e *\<^sub>R z : f ` S"
236.844 - using e_def by auto
236.845 + using e by auto
236.846 }
236.847 then have "z \<in> rel_interior (f ` S)"
236.848 using convex_rel_interior_iff[of "f ` S" z] `convex S`
236.849 - `linear f` `S ~= {}` convex_linear_image[of f S] linear_conv_bounded_linear[of f]
236.850 + `linear f` `S \<noteq> {}` convex_linear_image[of f S] linear_conv_bounded_linear[of f]
236.851 by auto
236.852 }
236.853 ultimately show ?thesis by auto
236.854 @@ -8037,7 +8054,7 @@
236.855 using convex_rel_interior_iff[of "f -` S" z] conv nonemp by auto
236.856 }
236.857 moreover
236.858 - {
236.859 + {
236.860 fix z
236.861 assume z: "z \<in> rel_interior (f -` S)"
236.862 {
236.863 @@ -8052,7 +8069,7 @@
236.864 using e by auto
236.865 }
236.866 then have "f z \<in> rel_interior (S \<inter> range f)"
236.867 - using `convex (S Int (range f))` `S \<inter> range f \<noteq> {}`
236.868 + using `convex (S \<inter> (range f))` `S \<inter> range f \<noteq> {}`
236.869 convex_rel_interior_iff[of "S \<inter> (range f)" "f z"]
236.870 by auto
236.871 moreover have "affine (range f)"
236.872 @@ -8147,7 +8164,7 @@
236.873 assumes "\<forall>S\<in>I. convex (S :: 'n::euclidean_space set) \<and> rel_open S"
236.874 and "finite I"
236.875 shows "convex (\<Inter>I) \<and> rel_open (\<Inter>I)"
236.876 -proof (cases "Inter {rel_interior S |S. S : I} = {}")
236.877 +proof (cases "\<Inter>{rel_interior S |S. S \<in> I} = {}")
236.878 case True
236.879 then have "\<Inter>I = {}"
236.880 using assms unfolding rel_open_def by auto
236.881 @@ -8155,7 +8172,7 @@
236.882 unfolding rel_open_def using rel_interior_empty by auto
236.883 next
236.884 case False
236.885 - then have "rel_open (Inter I)"
236.886 + then have "rel_open (\<Inter>I)"
236.887 using assms unfolding rel_open_def
236.888 using convex_rel_interior_finite_inter[of I]
236.889 by auto
236.890 @@ -8305,191 +8322,274 @@
236.891 then have *: "0 \<in> S \<and> (\<forall>c. c > 0 \<longrightarrow> op *\<^sub>R c ` S = S)"
236.892 using cone_iff[of S] assms by auto
236.893 then have *: "0 \<in> ({0} \<union> rel_interior S)"
236.894 - and "\<forall>c. c > 0 \<longrightarrow> op *\<^sub>R c ` ({0} \<union> rel_interior S) = ({0} Un rel_interior S)"
236.895 + and "\<forall>c. c > 0 \<longrightarrow> op *\<^sub>R c ` ({0} \<union> rel_interior S) = ({0} \<union> rel_interior S)"
236.896 by (auto simp add: rel_interior_scaleR)
236.897 then show ?thesis
236.898 - using cone_iff[of "{0} Un rel_interior S"] by auto
236.899 + using cone_iff[of "{0} \<union> rel_interior S"] by auto
236.900 qed
236.901
236.902 lemma rel_interior_convex_cone_aux:
236.903 -fixes S :: "('m::euclidean_space) set"
236.904 -assumes "convex S"
236.905 -shows "(c,x) : rel_interior (cone hull ({(1 :: real)} <*> S)) <->
236.906 - c>0 & x : ((op *\<^sub>R c) ` (rel_interior S))"
236.907 -proof-
236.908 -{ assume "S={}" hence ?thesis by (simp add: rel_interior_empty cone_hull_empty) }
236.909 -moreover
236.910 -{ assume "S ~= {}" from this obtain s where "s : S" by auto
236.911 -have conv: "convex ({(1 :: real)} <*> S)" using convex_Times[of "{(1 :: real)}" S]
236.912 - assms convex_singleton[of "1 :: real"] by auto
236.913 -def f == "(%y. {z. (y,z) : cone hull ({(1 :: real)} <*> S)})"
236.914 -hence *: "(c, x) : rel_interior (cone hull ({(1 :: real)} <*> S)) =
236.915 - (c : rel_interior {y. f y ~= {}} & x : rel_interior (f c))"
236.916 - apply (subst rel_interior_projection[of "cone hull ({(1 :: real)} <*> S)" f c x])
236.917 - using convex_cone_hull[of "{(1 :: real)} <*> S"] conv by auto
236.918 -{ fix y assume "(y :: real)>=0"
236.919 - hence "y *\<^sub>R (1,s) : cone hull ({(1 :: real)} <*> S)"
236.920 - using cone_hull_expl[of "{(1 :: real)} <*> S"] `s:S` by auto
236.921 - hence "f y ~= {}" using f_def by auto
236.922 -}
236.923 -hence "{y. f y ~= {}} = {0..}" using f_def cone_hull_expl[of "{(1 :: real)} <*> S"] by auto
236.924 -hence **: "rel_interior {y. f y ~= {}} = {0<..}" using rel_interior_real_semiline by auto
236.925 -{ fix c assume "c>(0 :: real)"
236.926 - hence "f c = (op *\<^sub>R c ` S)" using f_def cone_hull_expl[of "{(1 :: real)} <*> S"] by auto
236.927 - hence "rel_interior (f c)= (op *\<^sub>R c ` rel_interior S)"
236.928 - using rel_interior_convex_scaleR[of S c] assms by auto
236.929 -}
236.930 -hence ?thesis using * ** by auto
236.931 -} ultimately show ?thesis by blast
236.932 -qed
236.933 -
236.934 + fixes S :: "'m::euclidean_space set"
236.935 + assumes "convex S"
236.936 + shows "(c, x) \<in> rel_interior (cone hull ({(1 :: real)} <*> S)) \<longleftrightarrow>
236.937 + c > 0 \<and> x \<in> ((op *\<^sub>R c) ` (rel_interior S))"
236.938 +proof (cases "S = {}")
236.939 + case True
236.940 + then show ?thesis
236.941 + by (simp add: rel_interior_empty cone_hull_empty)
236.942 +next
236.943 + case False
236.944 + then obtain s where "s \<in> S" by auto
236.945 + have conv: "convex ({(1 :: real)} <*> S)"
236.946 + using convex_Times[of "{(1 :: real)}" S] assms convex_singleton[of "1 :: real"]
236.947 + by auto
236.948 + def f \<equiv> "\<lambda>y. {z. (y, z) \<in> cone hull ({1 :: real} <*> S)}"
236.949 + then have *: "(c, x) \<in> rel_interior (cone hull ({(1 :: real)} <*> S)) =
236.950 + (c \<in> rel_interior {y. f y \<noteq> {}} \<and> x \<in> rel_interior (f c))"
236.951 + apply (subst rel_interior_projection[of "cone hull ({(1 :: real)} <*> S)" f c x])
236.952 + using convex_cone_hull[of "{(1 :: real)} <*> S"] conv
236.953 + apply auto
236.954 + done
236.955 + {
236.956 + fix y :: real
236.957 + assume "y \<ge> 0"
236.958 + then have "y *\<^sub>R (1,s) \<in> cone hull ({1 :: real} <*> S)"
236.959 + using cone_hull_expl[of "{(1 :: real)} <*> S"] `s \<in> S` by auto
236.960 + then have "f y \<noteq> {}"
236.961 + using f_def by auto
236.962 + }
236.963 + then have "{y. f y \<noteq> {}} = {0..}"
236.964 + using f_def cone_hull_expl[of "{1 :: real} <*> S"] by auto
236.965 + then have **: "rel_interior {y. f y \<noteq> {}} = {0<..}"
236.966 + using rel_interior_real_semiline by auto
236.967 + {
236.968 + fix c :: real
236.969 + assume "c > 0"
236.970 + then have "f c = (op *\<^sub>R c ` S)"
236.971 + using f_def cone_hull_expl[of "{1 :: real} <*> S"] by auto
236.972 + then have "rel_interior (f c) = op *\<^sub>R c ` rel_interior S"
236.973 + using rel_interior_convex_scaleR[of S c] assms by auto
236.974 + }
236.975 + then show ?thesis using * ** by auto
236.976 +qed
236.977
236.978 lemma rel_interior_convex_cone:
236.979 -fixes S :: "('m::euclidean_space) set"
236.980 -assumes "convex S"
236.981 -shows "rel_interior (cone hull ({(1 :: real)} <*> S)) =
236.982 - {(c,c *\<^sub>R x) |c x. c>0 & x : (rel_interior S)}"
236.983 -(is "?lhs=?rhs")
236.984 -proof-
236.985 -{ fix z assume "z:?lhs"
236.986 - have *: "z=(fst z,snd z)" by auto
236.987 - have "z:?rhs" using rel_interior_convex_cone_aux[of S "fst z" "snd z"] assms `z:?lhs` apply auto
236.988 - apply (rule_tac x="fst z" in exI) apply (rule_tac x="x" in exI) using * by auto
236.989 -}
236.990 -moreover
236.991 -{ fix z assume "z:?rhs" hence "z:?lhs"
236.992 - using rel_interior_convex_cone_aux[of S "fst z" "snd z"] assms by auto
236.993 -}
236.994 -ultimately show ?thesis by blast
236.995 + fixes S :: "'m::euclidean_space set"
236.996 + assumes "convex S"
236.997 + shows "rel_interior (cone hull ({1 :: real} <*> S)) =
236.998 + {(c, c *\<^sub>R x) | c x. c > 0 \<and> x \<in> rel_interior S}"
236.999 + (is "?lhs = ?rhs")
236.1000 +proof -
236.1001 + {
236.1002 + fix z
236.1003 + assume "z \<in> ?lhs"
236.1004 + have *: "z = (fst z, snd z)"
236.1005 + by auto
236.1006 + have "z \<in> ?rhs"
236.1007 + using rel_interior_convex_cone_aux[of S "fst z" "snd z"] assms `z \<in> ?lhs`
236.1008 + apply auto
236.1009 + apply (rule_tac x = "fst z" in exI)
236.1010 + apply (rule_tac x = x in exI)
236.1011 + using *
236.1012 + apply auto
236.1013 + done
236.1014 + }
236.1015 + moreover
236.1016 + {
236.1017 + fix z
236.1018 + assume "z \<in> ?rhs"
236.1019 + then have "z \<in> ?lhs"
236.1020 + using rel_interior_convex_cone_aux[of S "fst z" "snd z"] assms
236.1021 + by auto
236.1022 + }
236.1023 + ultimately show ?thesis by blast
236.1024 qed
236.1025
236.1026 lemma convex_hull_finite_union:
236.1027 -assumes "finite I"
236.1028 -assumes "!i:I. (convex (S i) & (S i) ~= {})"
236.1029 -shows "convex hull (Union (S ` I)) =
236.1030 - {setsum (%i. c i *\<^sub>R s i) I |c s. (!i:I. c i >= 0) & (setsum c I = 1) & (!i:I. s i : S i)}"
236.1031 + assumes "finite I"
236.1032 + assumes "\<forall>i\<in>I. convex (S i) \<and> (S i) \<noteq> {}"
236.1033 + shows "convex hull (\<Union>(S ` I)) =
236.1034 + {setsum (\<lambda>i. c i *\<^sub>R s i) I | c s. (\<forall>i\<in>I. c i \<ge> 0) \<and> setsum c I = 1 \<and> (\<forall>i\<in>I. s i \<in> S i)}"
236.1035 (is "?lhs = ?rhs")
236.1036 -proof-
236.1037 -{ fix x assume "x : ?rhs"
236.1038 - from this obtain c s
236.1039 - where *: "setsum (%i. c i *\<^sub>R s i) I=x" "(setsum c I = 1)"
236.1040 - "(!i:I. c i >= 0) & (!i:I. s i : S i)" by auto
236.1041 - hence "!i:I. s i : convex hull (Union (S ` I))" using hull_subset[of "Union (S ` I)" convex] by auto
236.1042 - hence "x : ?lhs" unfolding *(1)[symmetric]
236.1043 - apply (subst convex_setsum[of I "convex hull Union (S ` I)" c s])
236.1044 - using * assms convex_convex_hull by auto
236.1045 -} hence "?lhs >= ?rhs" by auto
236.1046 -
236.1047 -{ fix i assume "i:I"
236.1048 - from this assms have "EX p. p : S i" by auto
236.1049 -}
236.1050 -from this obtain p where p_def: "!i:I. p i : S i" by metis
236.1051 -
236.1052 -{ fix i assume "i:I"
236.1053 - { fix x assume "x : S i"
236.1054 - def c == "(%j. if (j=i) then (1::real) else 0)"
236.1055 - hence *: "setsum c I = 1" using `finite I` `i:I` setsum_delta[of I i "(%(j::'a). (1::real))"] by auto
236.1056 - def s == "(%j. if (j=i) then x else p j)"
236.1057 - hence "!j. c j *\<^sub>R s j = (if (j=i) then x else 0)" using c_def by (auto simp add: algebra_simps)
236.1058 - hence "x = setsum (%i. c i *\<^sub>R s i) I"
236.1059 - using s_def c_def `finite I` `i:I` setsum_delta[of I i "(%(j::'a). x)"] by auto
236.1060 - hence "x : ?rhs" apply auto
236.1061 - apply (rule_tac x="c" in exI)
236.1062 - apply (rule_tac x="s" in exI) using * c_def s_def p_def `x : S i` by auto
236.1063 - } hence "?rhs >= S i" by auto
236.1064 -} hence *: "?rhs >= Union (S ` I)" by auto
236.1065 -
236.1066 -{ fix u v assume uv: "(u :: real)>=0 & v>=0 & u+v=1"
236.1067 - fix x y assume xy: "(x : ?rhs) & (y : ?rhs)"
236.1068 - from xy obtain c s where xc: "x=setsum (%i. c i *\<^sub>R s i) I &
236.1069 - (!i:I. c i >= 0) & (setsum c I = 1) & (!i:I. s i : S i)" by auto
236.1070 - from xy obtain d t where yc: "y=setsum (%i. d i *\<^sub>R t i) I &
236.1071 - (!i:I. d i >= 0) & (setsum d I = 1) & (!i:I. t i : S i)" by auto
236.1072 - def e == "(%i. u * (c i)+v * (d i))"
236.1073 - have ge0: "!i:I. e i >= 0" using e_def xc yc uv by (simp add: mult_nonneg_nonneg)
236.1074 - have "setsum (%i. u * c i) I = u * setsum c I" by (simp add: setsum_right_distrib)
236.1075 - moreover have "setsum (%i. v * d i) I = v * setsum d I" by (simp add: setsum_right_distrib)
236.1076 - ultimately have sum1: "setsum e I = 1" using e_def xc yc uv by (simp add: setsum_addf)
236.1077 - def q == "(%i. if (e i = 0) then (p i)
236.1078 - else (u * (c i)/(e i))*\<^sub>R (s i)+(v * (d i)/(e i))*\<^sub>R (t i))"
236.1079 - { fix i assume "i:I"
236.1080 - { assume "e i = 0" hence "q i : S i" using `i:I` p_def q_def by auto }
236.1081 - moreover
236.1082 - { assume "e i ~= 0"
236.1083 - hence "q i : S i" using mem_convex_alt[of "S i" "s i" "t i" "u * (c i)" "v * (d i)"]
236.1084 - mult_nonneg_nonneg[of u "c i"] mult_nonneg_nonneg[of v "d i"]
236.1085 - assms q_def e_def `i:I` `e i ~= 0` xc yc uv by auto
236.1086 - } ultimately have "q i : S i" by auto
236.1087 - } hence qs: "!i:I. q i : S i" by auto
236.1088 - { fix i assume "i:I"
236.1089 - { assume "e i = 0"
236.1090 - have ge: "u * (c i) >= 0 & v * (d i) >= 0" using xc yc uv `i:I` by (simp add: mult_nonneg_nonneg)
236.1091 - moreover from ge have "u * (c i) <= 0 & v * (d i) <= 0" using `e i = 0` e_def `i:I` by simp
236.1092 - ultimately have "u * (c i) = 0 & v * (d i) = 0" by auto
236.1093 - hence "(u * (c i))*\<^sub>R (s i)+(v * (d i))*\<^sub>R (t i) = (e i) *\<^sub>R (q i)"
236.1094 - using `e i = 0` by auto
236.1095 +proof -
236.1096 + have "?lhs \<supseteq> ?rhs"
236.1097 + proof
236.1098 + fix x
236.1099 + assume "x : ?rhs"
236.1100 + then obtain c s where *: "setsum (\<lambda>i. c i *\<^sub>R s i) I = x" "setsum c I = 1"
236.1101 + "(\<forall>i\<in>I. c i \<ge> 0) \<and> (\<forall>i\<in>I. s i \<in> S i)" by auto
236.1102 + then have "\<forall>i\<in>I. s i \<in> convex hull (\<Union>(S ` I))"
236.1103 + using hull_subset[of "\<Union>(S ` I)" convex] by auto
236.1104 + then show "x \<in> ?lhs"
236.1105 + unfolding *(1)[symmetric]
236.1106 + apply (subst convex_setsum[of I "convex hull \<Union>(S ` I)" c s])
236.1107 + using * assms convex_convex_hull
236.1108 + apply auto
236.1109 + done
236.1110 + qed
236.1111 +
236.1112 + {
236.1113 + fix i
236.1114 + assume "i \<in> I"
236.1115 + with assms have "\<exists>p. p \<in> S i" by auto
236.1116 + }
236.1117 + then obtain p where p: "\<forall>i\<in>I. p i \<in> S i" by metis
236.1118 +
236.1119 + {
236.1120 + fix i
236.1121 + assume "i \<in> I"
236.1122 + {
236.1123 + fix x
236.1124 + assume "x \<in> S i"
236.1125 + def c \<equiv> "\<lambda>j. if j = i then 1::real else 0"
236.1126 + then have *: "setsum c I = 1"
236.1127 + using `finite I` `i \<in> I` setsum_delta[of I i "\<lambda>j::'a. 1::real"]
236.1128 + by auto
236.1129 + def s \<equiv> "\<lambda>j. if j = i then x else p j"
236.1130 + then have "\<forall>j. c j *\<^sub>R s j = (if j = i then x else 0)"
236.1131 + using c_def by (auto simp add: algebra_simps)
236.1132 + then have "x = setsum (\<lambda>i. c i *\<^sub>R s i) I"
236.1133 + using s_def c_def `finite I` `i \<in> I` setsum_delta[of I i "\<lambda>j::'a. x"]
236.1134 + by auto
236.1135 + then have "x \<in> ?rhs"
236.1136 + apply auto
236.1137 + apply (rule_tac x = c in exI)
236.1138 + apply (rule_tac x = s in exI)
236.1139 + using * c_def s_def p `x \<in> S i`
236.1140 + apply auto
236.1141 + done
236.1142 }
236.1143 - moreover
236.1144 - { assume "e i ~= 0"
236.1145 - hence "(u * (c i)/(e i))*\<^sub>R (s i)+(v * (d i)/(e i))*\<^sub>R (t i) = q i"
236.1146 - using q_def by auto
236.1147 - hence "e i *\<^sub>R ((u * (c i)/(e i))*\<^sub>R (s i)+(v * (d i)/(e i))*\<^sub>R (t i))
236.1148 - = (e i) *\<^sub>R (q i)" by auto
236.1149 - hence "(u * (c i))*\<^sub>R (s i)+(v * (d i))*\<^sub>R (t i) = (e i) *\<^sub>R (q i)"
236.1150 - using `e i ~= 0` by (simp add: algebra_simps)
236.1151 - } ultimately have
236.1152 - "(u * (c i))*\<^sub>R (s i)+(v * (d i))*\<^sub>R (t i) = (e i) *\<^sub>R (q i)" by blast
236.1153 - } hence *: "!i:I.
236.1154 - (u * (c i))*\<^sub>R (s i)+(v * (d i))*\<^sub>R (t i) = (e i) *\<^sub>R (q i)" by auto
236.1155 - have "u *\<^sub>R x + v *\<^sub>R y =
236.1156 - setsum (%i. (u * (c i))*\<^sub>R (s i)+(v * (d i))*\<^sub>R (t i)) I"
236.1157 - using xc yc by (simp add: algebra_simps scaleR_right.setsum setsum_addf)
236.1158 - also have "...=setsum (%i. (e i) *\<^sub>R (q i)) I" using * by auto
236.1159 - finally have "u *\<^sub>R x + v *\<^sub>R y = setsum (%i. (e i) *\<^sub>R (q i)) I" by auto
236.1160 - hence "u *\<^sub>R x + v *\<^sub>R y : ?rhs" using ge0 sum1 qs by auto
236.1161 -} hence "convex ?rhs" unfolding convex_def by auto
236.1162 -from this show ?thesis using `?lhs >= ?rhs` *
236.1163 - hull_minimal[of "Union (S ` I)" "?rhs" "convex"] by blast
236.1164 + then have "?rhs \<supseteq> S i" by auto
236.1165 + }
236.1166 + then have *: "?rhs \<supseteq> \<Union>(S ` I)" by auto
236.1167 +
236.1168 + {
236.1169 + fix u v :: real
236.1170 + assume uv: "u \<ge> 0 \<and> v \<ge> 0 \<and> u + v = 1"
236.1171 + fix x y
236.1172 + assume xy: "x \<in> ?rhs \<and> y \<in> ?rhs"
236.1173 + from xy obtain c s where
236.1174 + xc: "x = setsum (\<lambda>i. c i *\<^sub>R s i) I \<and> (\<forall>i\<in>I. c i \<ge> 0) \<and> setsum c I = 1 \<and> (\<forall>i\<in>I. s i \<in> S i)"
236.1175 + by auto
236.1176 + from xy obtain d t where
236.1177 + yc: "y = setsum (\<lambda>i. d i *\<^sub>R t i) I \<and> (\<forall>i\<in>I. d i \<ge> 0) \<and> setsum d I = 1 \<and> (\<forall>i\<in>I. t i \<in> S i)"
236.1178 + by auto
236.1179 + def e \<equiv> "\<lambda>i. u * c i + v * d i"
236.1180 + have ge0: "\<forall>i\<in>I. e i \<ge> 0"
236.1181 + using e_def xc yc uv by (simp add: mult_nonneg_nonneg)
236.1182 + have "setsum (\<lambda>i. u * c i) I = u * setsum c I"
236.1183 + by (simp add: setsum_right_distrib)
236.1184 + moreover have "setsum (\<lambda>i. v * d i) I = v * setsum d I"
236.1185 + by (simp add: setsum_right_distrib)
236.1186 + ultimately have sum1: "setsum e I = 1"
236.1187 + using e_def xc yc uv by (simp add: setsum_addf)
236.1188 + def q \<equiv> "\<lambda>i. if e i = 0 then p i else (u * c i / e i) *\<^sub>R s i + (v * d i / e i) *\<^sub>R t i"
236.1189 + {
236.1190 + fix i
236.1191 + assume i: "i \<in> I"
236.1192 + have "q i \<in> S i"
236.1193 + proof (cases "e i = 0")
236.1194 + case True
236.1195 + then show ?thesis using i p q_def by auto
236.1196 + next
236.1197 + case False
236.1198 + then show ?thesis
236.1199 + using mem_convex_alt[of "S i" "s i" "t i" "u * (c i)" "v * (d i)"]
236.1200 + mult_nonneg_nonneg[of u "c i"] mult_nonneg_nonneg[of v "d i"]
236.1201 + assms q_def e_def i False xc yc uv
236.1202 + by auto
236.1203 + qed
236.1204 + }
236.1205 + then have qs: "\<forall>i\<in>I. q i \<in> S i" by auto
236.1206 + {
236.1207 + fix i
236.1208 + assume i: "i \<in> I"
236.1209 + have "(u * c i) *\<^sub>R s i + (v * d i) *\<^sub>R t i = e i *\<^sub>R q i"
236.1210 + proof (cases "e i = 0")
236.1211 + case True
236.1212 + have ge: "u * (c i) \<ge> 0 \<and> v * d i \<ge> 0"
236.1213 + using xc yc uv i by (simp add: mult_nonneg_nonneg)
236.1214 + moreover from ge have "u * c i \<le> 0 \<and> v * d i \<le> 0"
236.1215 + using True e_def i by simp
236.1216 + ultimately have "u * c i = 0 \<and> v * d i = 0" by auto
236.1217 + with True show ?thesis by auto
236.1218 + next
236.1219 + case False
236.1220 + then have "(u * (c i)/(e i))*\<^sub>R (s i)+(v * (d i)/(e i))*\<^sub>R (t i) = q i"
236.1221 + using q_def by auto
236.1222 + then have "e i *\<^sub>R ((u * (c i)/(e i))*\<^sub>R (s i)+(v * (d i)/(e i))*\<^sub>R (t i))
236.1223 + = (e i) *\<^sub>R (q i)" by auto
236.1224 + with False show ?thesis by (simp add: algebra_simps)
236.1225 + qed
236.1226 + }
236.1227 + then have *: "\<forall>i\<in>I. (u * c i) *\<^sub>R s i + (v * d i) *\<^sub>R t i = e i *\<^sub>R q i"
236.1228 + by auto
236.1229 + have "u *\<^sub>R x + v *\<^sub>R y = setsum (\<lambda>i. (u * c i) *\<^sub>R s i + (v * d i) *\<^sub>R t i) I"
236.1230 + using xc yc by (simp add: algebra_simps scaleR_right.setsum setsum_addf)
236.1231 + also have "\<dots> = setsum (\<lambda>i. e i *\<^sub>R q i) I"
236.1232 + using * by auto
236.1233 + finally have "u *\<^sub>R x + v *\<^sub>R y = setsum (\<lambda>i. (e i) *\<^sub>R (q i)) I"
236.1234 + by auto
236.1235 + then have "u *\<^sub>R x + v *\<^sub>R y \<in> ?rhs"
236.1236 + using ge0 sum1 qs by auto
236.1237 + }
236.1238 + then have "convex ?rhs" unfolding convex_def by auto
236.1239 + then show ?thesis
236.1240 + using `?lhs \<supseteq> ?rhs` * hull_minimal[of "\<Union>(S ` I)" ?rhs convex]
236.1241 + by blast
236.1242 qed
236.1243
236.1244 lemma convex_hull_union_two:
236.1245 -fixes S T :: "('m::euclidean_space) set"
236.1246 -assumes "convex S" "S ~= {}" "convex T" "T ~= {}"
236.1247 -shows "convex hull (S Un T) = {u *\<^sub>R s + v *\<^sub>R t |u v s t. u>=0 & v>=0 & u+v=1 & s:S & t:T}"
236.1248 + fixes S T :: "'m::euclidean_space set"
236.1249 + assumes "convex S"
236.1250 + and "S \<noteq> {}"
236.1251 + and "convex T"
236.1252 + and "T \<noteq> {}"
236.1253 + shows "convex hull (S \<union> T) =
236.1254 + {u *\<^sub>R s + v *\<^sub>R t | u v s t. u \<ge> 0 \<and> v \<ge> 0 \<and> u + v = 1 \<and> s \<in> S \<and> t \<in> T}"
236.1255 (is "?lhs = ?rhs")
236.1256 -proof-
236.1257 -def I == "{(1::nat),2}"
236.1258 -def s == "(%i. (if i=(1::nat) then S else T))"
236.1259 -have "Union (s ` I) = S Un T" using s_def I_def by auto
236.1260 -hence "convex hull (Union (s ` I)) = convex hull (S Un T)" by auto
236.1261 -moreover have "convex hull Union (s ` I) =
236.1262 - {SUM i:I. c i *\<^sub>R sa i |c sa. (ALL i:I. 0 <= c i) & setsum c I = 1 & (ALL i:I. sa i : s i)}"
236.1263 - apply (subst convex_hull_finite_union[of I s]) using assms s_def I_def by auto
236.1264 -moreover have
236.1265 - "{SUM i:I. c i *\<^sub>R sa i |c sa. (ALL i:I. 0 <= c i) & setsum c I = 1 & (ALL i:I. sa i : s i)} <=
236.1266 - ?rhs"
236.1267 - using s_def I_def by auto
236.1268 -ultimately have "?lhs<=?rhs" by auto
236.1269 -{ fix x assume "x : ?rhs"
236.1270 - from this obtain u v s t
236.1271 - where *: "x=u *\<^sub>R s + v *\<^sub>R t & u>=0 & v>=0 & u+v=1 & s:S & t:T" by auto
236.1272 - hence "x : convex hull {s,t}" using convex_hull_2[of s t] by auto
236.1273 - hence "x : convex hull (S Un T)" using * hull_mono[of "{s, t}" "S Un T"] by auto
236.1274 -} hence "?lhs >= ?rhs" by blast
236.1275 -from this show ?thesis using `?lhs<=?rhs` by auto
236.1276 -qed
236.1277 +proof
236.1278 + def I \<equiv> "{1::nat, 2}"
236.1279 + def s \<equiv> "\<lambda>i. if i = (1::nat) then S else T"
236.1280 + have "\<Union>(s ` I) = S \<union> T"
236.1281 + using s_def I_def by auto
236.1282 + then have "convex hull (\<Union>(s ` I)) = convex hull (S \<union> T)"
236.1283 + by auto
236.1284 + moreover have "convex hull \<Union>(s ` I) =
236.1285 + {\<Sum> i\<in>I. c i *\<^sub>R sa i | c sa. (\<forall>i\<in>I. 0 \<le> c i) \<and> setsum c I = 1 \<and> (\<forall>i\<in>I. sa i \<in> s i)}"
236.1286 + apply (subst convex_hull_finite_union[of I s])
236.1287 + using assms s_def I_def
236.1288 + apply auto
236.1289 + done
236.1290 + moreover have
236.1291 + "{\<Sum>i\<in>I. c i *\<^sub>R sa i | c sa. (\<forall>i\<in>I. 0 \<le> c i) \<and> setsum c I = 1 \<and> (\<forall>i\<in>I. sa i \<in> s i)} \<le> ?rhs"
236.1292 + using s_def I_def by auto
236.1293 + ultimately show "?lhs \<subseteq> ?rhs" by auto
236.1294 + {
236.1295 + fix x
236.1296 + assume "x \<in> ?rhs"
236.1297 + then obtain u v s t where *: "x = u *\<^sub>R s + v *\<^sub>R t \<and> u \<ge> 0 \<and> v \<ge> 0 \<and> u + v = 1 \<and> s \<in> S \<and> t \<in> T"
236.1298 + by auto
236.1299 + then have "x \<in> convex hull {s, t}"
236.1300 + using convex_hull_2[of s t] by auto
236.1301 + then have "x \<in> convex hull (S \<union> T)"
236.1302 + using * hull_mono[of "{s, t}" "S \<union> T"] by auto
236.1303 + }
236.1304 + then show "?lhs \<supseteq> ?rhs" by blast
236.1305 +qed
236.1306 +
236.1307
236.1308 subsection {* Convexity on direct sums *}
236.1309
236.1310 lemma closure_sum:
236.1311 - fixes S T :: "('n::euclidean_space) set"
236.1312 + fixes S T :: "'n::euclidean_space set"
236.1313 shows "closure S + closure T \<subseteq> closure (S + T)"
236.1314 -proof-
236.1315 - have "(closure S) + (closure T) = (\<lambda>(x,y). x + y) ` (closure S \<times> closure T)"
236.1316 +proof -
236.1317 + have "closure S + closure T = (\<lambda>(x,y). x + y) ` (closure S \<times> closure T)"
236.1318 by (simp add: set_plus_image)
236.1319 - also have "... = (\<lambda>(x,y). x + y) ` closure (S \<times> T)"
236.1320 + also have "\<dots> = (\<lambda>(x,y). x + y) ` closure (S \<times> T)"
236.1321 using closure_Times by auto
236.1322 - also have "... \<subseteq> closure (S + T)"
236.1323 + also have "\<dots> \<subseteq> closure (S + T)"
236.1324 using fst_snd_linear closure_linear_image[of "(\<lambda>(x,y). x + y)" "S \<times> T"]
236.1325 by (auto simp: set_plus_image)
236.1326 finally show ?thesis
236.1327 @@ -8497,216 +8597,345 @@
236.1328 qed
236.1329
236.1330 lemma convex_oplus:
236.1331 -fixes S T :: "('n::euclidean_space) set"
236.1332 -assumes "convex S" "convex T"
236.1333 -shows "convex (S + T)"
236.1334 -proof-
236.1335 -have "{x + y |x y. x : S & y : T} = {c. EX a:S. EX b:T. c = a + b}" by auto
236.1336 -thus ?thesis unfolding set_plus_def using convex_sums[of S T] assms by auto
236.1337 + fixes S T :: "'n::euclidean_space set"
236.1338 + assumes "convex S"
236.1339 + and "convex T"
236.1340 + shows "convex (S + T)"
236.1341 +proof -
236.1342 + have "{x + y |x y. x \<in> S \<and> y \<in> T} = {c. \<exists>a\<in>S. \<exists>b\<in>T. c = a + b}"
236.1343 + by auto
236.1344 + then show ?thesis
236.1345 + unfolding set_plus_def
236.1346 + using convex_sums[of S T] assms
236.1347 + by auto
236.1348 qed
236.1349
236.1350 lemma convex_hull_sum:
236.1351 -fixes S T :: "('n::euclidean_space) set"
236.1352 -shows "convex hull (S + T) = (convex hull S) + (convex hull T)"
236.1353 -proof-
236.1354 -have "(convex hull S) + (convex hull T) =
236.1355 - (%(x,y). x + y) ` ((convex hull S) <*> (convex hull T))"
236.1356 - by (simp add: set_plus_image)
236.1357 -also have "... = (%(x,y). x + y) ` (convex hull (S <*> T))" using convex_hull_Times by auto
236.1358 -also have "...= convex hull (S + T)" using fst_snd_linear linear_conv_bounded_linear
236.1359 - convex_hull_linear_image[of "(%(x,y). x + y)" "S <*> T"] by (auto simp add: set_plus_image)
236.1360 -finally show ?thesis by auto
236.1361 + fixes S T :: "'n::euclidean_space set"
236.1362 + shows "convex hull (S + T) = convex hull S + convex hull T"
236.1363 +proof -
236.1364 + have "convex hull S + convex hull T = (\<lambda>(x,y). x + y) ` ((convex hull S) <*> (convex hull T))"
236.1365 + by (simp add: set_plus_image)
236.1366 + also have "\<dots> = (\<lambda>(x,y). x + y) ` (convex hull (S <*> T))"
236.1367 + using convex_hull_Times by auto
236.1368 + also have "\<dots> = convex hull (S + T)"
236.1369 + using fst_snd_linear linear_conv_bounded_linear
236.1370 + convex_hull_linear_image[of "(\<lambda>(x,y). x + y)" "S <*> T"]
236.1371 + by (auto simp add: set_plus_image)
236.1372 + finally show ?thesis ..
236.1373 qed
236.1374
236.1375 lemma rel_interior_sum:
236.1376 -fixes S T :: "('n::euclidean_space) set"
236.1377 -assumes "convex S" "convex T"
236.1378 -shows "rel_interior (S + T) = (rel_interior S) + (rel_interior T)"
236.1379 -proof-
236.1380 -have "(rel_interior S) + (rel_interior T) = (%(x,y). x + y) ` (rel_interior S <*> rel_interior T)"
236.1381 - by (simp add: set_plus_image)
236.1382 -also have "... = (%(x,y). x + y) ` rel_interior (S <*> T)" using rel_interior_direct_sum assms by auto
236.1383 -also have "...= rel_interior (S + T)" using fst_snd_linear convex_Times assms
236.1384 - rel_interior_convex_linear_image[of "(%(x,y). x + y)" "S <*> T"] by (auto simp add: set_plus_image)
236.1385 -finally show ?thesis by auto
236.1386 + fixes S T :: "'n::euclidean_space set"
236.1387 + assumes "convex S"
236.1388 + and "convex T"
236.1389 + shows "rel_interior (S + T) = rel_interior S + rel_interior T"
236.1390 +proof -
236.1391 + have "rel_interior S + rel_interior T = (\<lambda>(x,y). x + y) ` (rel_interior S <*> rel_interior T)"
236.1392 + by (simp add: set_plus_image)
236.1393 + also have "\<dots> = (\<lambda>(x,y). x + y) ` rel_interior (S <*> T)"
236.1394 + using rel_interior_direct_sum assms by auto
236.1395 + also have "\<dots> = rel_interior (S + T)"
236.1396 + using fst_snd_linear convex_Times assms
236.1397 + rel_interior_convex_linear_image[of "(\<lambda>(x,y). x + y)" "S <*> T"]
236.1398 + by (auto simp add: set_plus_image)
236.1399 + finally show ?thesis ..
236.1400 qed
236.1401
236.1402 lemma convex_sum_gen:
236.1403 fixes S :: "'a \<Rightarrow> 'n::euclidean_space set"
236.1404 assumes "\<And>i. i \<in> I \<Longrightarrow> (convex (S i))"
236.1405 shows "convex (setsum S I)"
236.1406 -proof cases
236.1407 - assume "finite I" from this assms show ?thesis
236.1408 +proof (cases "finite I")
236.1409 + case True
236.1410 + from this and assms show ?thesis
236.1411 by induct (auto simp: convex_oplus)
236.1412 -qed auto
236.1413 +next
236.1414 + case False
236.1415 + then show ?thesis by auto
236.1416 +qed
236.1417
236.1418 lemma convex_hull_sum_gen:
236.1419 -fixes S :: "'a => ('n::euclidean_space) set"
236.1420 -shows "convex hull (setsum S I) = setsum (%i. (convex hull (S i))) I"
236.1421 -apply (subst setsum_set_linear) using convex_hull_sum convex_hull_singleton by auto
236.1422 -
236.1423 + fixes S :: "'a \<Rightarrow> 'n::euclidean_space set"
236.1424 + shows "convex hull (setsum S I) = setsum (\<lambda>i. convex hull (S i)) I"
236.1425 + apply (subst setsum_set_linear)
236.1426 + using convex_hull_sum convex_hull_singleton
236.1427 + apply auto
236.1428 + done
236.1429
236.1430 lemma rel_interior_sum_gen:
236.1431 -fixes S :: "'a => ('n::euclidean_space) set"
236.1432 -assumes "!i:I. (convex (S i))"
236.1433 -shows "rel_interior (setsum S I) = setsum (%i. (rel_interior (S i))) I"
236.1434 -apply (subst setsum_set_cond_linear[of convex])
236.1435 - using rel_interior_sum rel_interior_sing[of "0"] assms by (auto simp add: convex_oplus)
236.1436 + fixes S :: "'a \<Rightarrow> 'n::euclidean_space set"
236.1437 + assumes "\<forall>i\<in>I. convex (S i)"
236.1438 + shows "rel_interior (setsum S I) = setsum (\<lambda>i. rel_interior (S i)) I"
236.1439 + apply (subst setsum_set_cond_linear[of convex])
236.1440 + using rel_interior_sum rel_interior_sing[of "0"] assms
236.1441 + apply (auto simp add: convex_oplus)
236.1442 + done
236.1443
236.1444 lemma convex_rel_open_direct_sum:
236.1445 -fixes S T :: "('n::euclidean_space) set"
236.1446 -assumes "convex S" "rel_open S" "convex T" "rel_open T"
236.1447 -shows "convex (S <*> T) & rel_open (S <*> T)"
236.1448 -by (metis assms convex_Times rel_interior_direct_sum rel_open_def)
236.1449 + fixes S T :: "'n::euclidean_space set"
236.1450 + assumes "convex S"
236.1451 + and "rel_open S"
236.1452 + and "convex T"
236.1453 + and "rel_open T"
236.1454 + shows "convex (S <*> T) \<and> rel_open (S <*> T)"
236.1455 + by (metis assms convex_Times rel_interior_direct_sum rel_open_def)
236.1456
236.1457 lemma convex_rel_open_sum:
236.1458 -fixes S T :: "('n::euclidean_space) set"
236.1459 -assumes "convex S" "rel_open S" "convex T" "rel_open T"
236.1460 -shows "convex (S + T) & rel_open (S + T)"
236.1461 -by (metis assms convex_oplus rel_interior_sum rel_open_def)
236.1462 + fixes S T :: "'n::euclidean_space set"
236.1463 + assumes "convex S"
236.1464 + and "rel_open S"
236.1465 + and "convex T"
236.1466 + and "rel_open T"
236.1467 + shows "convex (S + T) \<and> rel_open (S + T)"
236.1468 + by (metis assms convex_oplus rel_interior_sum rel_open_def)
236.1469
236.1470 lemma convex_hull_finite_union_cones:
236.1471 -assumes "finite I" "I ~= {}"
236.1472 -assumes "!i:I. (convex (S i) & cone (S i) & (S i) ~= {})"
236.1473 -shows "convex hull (Union (S ` I)) = setsum S I"
236.1474 + assumes "finite I"
236.1475 + and "I \<noteq> {}"
236.1476 + assumes "\<forall>i\<in>I. convex (S i) \<and> cone (S i) \<and> S i \<noteq> {}"
236.1477 + shows "convex hull (\<Union>(S ` I)) = setsum S I"
236.1478 (is "?lhs = ?rhs")
236.1479 -proof-
236.1480 -{ fix x assume "x : ?lhs"
236.1481 - from this obtain c xs where x_def: "x=setsum (%i. c i *\<^sub>R xs i) I &
236.1482 - (!i:I. c i >= 0) & (setsum c I = 1) & (!i:I. xs i : S i)"
236.1483 - using convex_hull_finite_union[of I S] assms by auto
236.1484 - def s == "(%i. c i *\<^sub>R xs i)"
236.1485 - { fix i assume "i:I"
236.1486 - hence "s i : S i" using s_def x_def assms mem_cone[of "S i" "xs i" "c i"] by auto
236.1487 - } hence "!i:I. s i : S i" by auto
236.1488 - moreover have "x = setsum s I" using x_def s_def by auto
236.1489 - ultimately have "x : ?rhs" using set_setsum_alt[of I S] assms by auto
236.1490 -}
236.1491 -moreover
236.1492 -{ fix x assume "x : ?rhs"
236.1493 - from this obtain s where x_def: "x=setsum s I & (!i:I. s i : S i)"
236.1494 - using set_setsum_alt[of I S] assms by auto
236.1495 - def xs == "(%i. of_nat(card I) *\<^sub>R s i)"
236.1496 - hence "x=setsum (%i. ((1 :: real)/of_nat(card I)) *\<^sub>R xs i) I" using x_def assms by auto
236.1497 - moreover have "!i:I. xs i : S i" using x_def xs_def assms by (simp add: cone_def)
236.1498 - moreover have "(!i:I. (1 :: real)/of_nat(card I) >= 0)" by auto
236.1499 - moreover have "setsum (%i. (1 :: real)/of_nat(card I)) I = 1" using assms by auto
236.1500 - ultimately have "x : ?lhs" apply (subst convex_hull_finite_union[of I S])
236.1501 - using assms apply blast
236.1502 - using assms apply blast
236.1503 - apply rule apply (rule_tac x="(%i. (1 :: real)/of_nat(card I))" in exI) by auto
236.1504 -} ultimately show ?thesis by auto
236.1505 -qed
236.1506 -
236.1507 -lemma convex_hull_union_cones_two:
236.1508 -fixes S T :: "('m::euclidean_space) set"
236.1509 -assumes "convex S" "cone S" "S ~= {}"
236.1510 -assumes "convex T" "cone T" "T ~= {}"
236.1511 -shows "convex hull (S Un T) = S + T"
236.1512 -proof-
236.1513 -def I == "{(1::nat),2}"
236.1514 -def A == "(%i. (if i=(1::nat) then S else T))"
236.1515 -have "Union (A ` I) = S Un T" using A_def I_def by auto
236.1516 -hence "convex hull (Union (A ` I)) = convex hull (S Un T)" by auto
236.1517 -moreover have "convex hull Union (A ` I) = setsum A I"
236.1518 - apply (subst convex_hull_finite_union_cones[of I A]) using assms A_def I_def by auto
236.1519 -moreover have
236.1520 - "setsum A I = S + T" using A_def I_def
236.1521 - unfolding set_plus_def apply auto unfolding set_plus_def by auto
236.1522 -ultimately show ?thesis by auto
236.1523 -qed
236.1524 -
236.1525 -lemma rel_interior_convex_hull_union:
236.1526 -fixes S :: "'a => ('n::euclidean_space) set"
236.1527 -assumes "finite I"
236.1528 -assumes "!i:I. convex (S i) & (S i) ~= {}"
236.1529 -shows "rel_interior (convex hull (Union (S ` I))) = {setsum (%i. c i *\<^sub>R s i) I
236.1530 - |c s. (!i:I. c i > 0) & (setsum c I = 1) & (!i:I. s i : rel_interior(S i))}"
236.1531 -(is "?lhs=?rhs")
236.1532 -proof-
236.1533 -{ assume "I={}" hence ?thesis using convex_hull_empty rel_interior_empty by auto }
236.1534 -moreover
236.1535 -{ assume "I ~= {}"
236.1536 - def C0 == "convex hull (Union (S ` I))"
236.1537 - have "!i:I. C0 >= S i" unfolding C0_def using hull_subset[of "Union (S ` I)"] by auto
236.1538 - def K0 == "cone hull ({(1 :: real)} <*> C0)"
236.1539 - def K == "(%i. cone hull ({(1 :: real)} <*> (S i)))"
236.1540 - have "!i:I. K i ~= {}" unfolding K_def using assms by (simp add: cone_hull_empty_iff[symmetric])
236.1541 - { fix i assume "i:I"
236.1542 - hence "convex (K i)" unfolding K_def apply (subst convex_cone_hull) apply (subst convex_Times)
236.1543 - using assms by auto
236.1544 - }
236.1545 - hence convK: "!i:I. convex (K i)" by auto
236.1546 - { fix i assume "i:I"
236.1547 - hence "K0 >= K i" unfolding K0_def K_def apply (subst hull_mono) using `!i:I. C0 >= S i` by auto
236.1548 - }
236.1549 - hence "K0 >= Union (K ` I)" by auto
236.1550 - moreover have "convex K0" unfolding K0_def
236.1551 - apply (subst convex_cone_hull) apply (subst convex_Times)
236.1552 - unfolding C0_def using convex_convex_hull by auto
236.1553 - ultimately have geq: "K0 >= convex hull (Union (K ` I))" using hull_minimal[of _ "K0" "convex"] by blast
236.1554 - have "!i:I. K i >= {(1 :: real)} <*> (S i)" using K_def by (simp add: hull_subset)
236.1555 - hence "Union (K ` I) >= {(1 :: real)} <*> Union (S ` I)" by auto
236.1556 - hence "convex hull Union (K ` I) >= convex hull ({(1 :: real)} <*> Union (S ` I))" by (simp add: hull_mono)
236.1557 - hence "convex hull Union (K ` I) >= {(1 :: real)} <*> C0" unfolding C0_def
236.1558 - using convex_hull_Times[of "{(1 :: real)}" "Union (S ` I)"] convex_hull_singleton by auto
236.1559 - moreover have "cone (convex hull(Union (K ` I)))" apply (subst cone_convex_hull)
236.1560 - using cone_Union[of "K ` I"] apply auto unfolding K_def using cone_cone_hull by auto
236.1561 - ultimately have "convex hull (Union (K ` I)) >= K0"
236.1562 - unfolding K0_def using hull_minimal[of _ "convex hull (Union (K ` I))" "cone"] by blast
236.1563 - hence "K0 = convex hull (Union (K ` I))" using geq by auto
236.1564 - also have "...=setsum K I"
236.1565 - apply (subst convex_hull_finite_union_cones[of I K])
236.1566 - using assms apply blast
236.1567 - using `I ~= {}` apply blast
236.1568 - unfolding K_def apply rule
236.1569 - apply (subst convex_cone_hull) apply (subst convex_Times)
236.1570 - using assms cone_cone_hull `!i:I. K i ~= {}` K_def by auto
236.1571 - finally have "K0 = setsum K I" by auto
236.1572 - hence *: "rel_interior K0 = setsum (%i. (rel_interior (K i))) I"
236.1573 - using rel_interior_sum_gen[of I K] convK by auto
236.1574 - { fix x assume "x : ?lhs"
236.1575 - hence "((1::real),x) : rel_interior K0" using K0_def C0_def
236.1576 - rel_interior_convex_cone_aux[of C0 "(1::real)" x] convex_convex_hull by auto
236.1577 - from this obtain k where k_def: "((1::real),x) = setsum k I & (!i:I. k i : rel_interior (K i))"
236.1578 - using `finite I` * set_setsum_alt[of I "(%i. rel_interior (K i))"] by auto
236.1579 - { fix i assume "i:I"
236.1580 - hence "(convex (S i)) & k i : rel_interior (cone hull {1} <*> S i)" using k_def K_def assms by auto
236.1581 - hence "EX ci si. k i = (ci, ci *\<^sub>R si) & 0 < ci & si : rel_interior (S i)"
236.1582 - using rel_interior_convex_cone[of "S i"] by auto
236.1583 +proof -
236.1584 + {
236.1585 + fix x
236.1586 + assume "x \<in> ?lhs"
236.1587 + then obtain c xs where
236.1588 + x: "x = setsum (\<lambda>i. c i *\<^sub>R xs i) I \<and> (\<forall>i\<in>I. c i \<ge> 0) \<and> setsum c I = 1 \<and> (\<forall>i\<in>I. xs i \<in> S i)"
236.1589 + using convex_hull_finite_union[of I S] assms by auto
236.1590 + def s \<equiv> "\<lambda>i. c i *\<^sub>R xs i"
236.1591 + {
236.1592 + fix i
236.1593 + assume "i \<in> I"
236.1594 + then have "s i \<in> S i"
236.1595 + using s_def x assms mem_cone[of "S i" "xs i" "c i"] by auto
236.1596 }
236.1597 - from this obtain c s where cs_def: "!i:I. (k i = (c i, c i *\<^sub>R s i) & 0 < c i
236.1598 - & s i : rel_interior (S i))" by metis
236.1599 - hence "x = (SUM i:I. c i *\<^sub>R s i) & setsum c I = 1" using k_def by (simp add: setsum_prod)
236.1600 - hence "x : ?rhs" using k_def apply auto
236.1601 - apply (rule_tac x="c" in exI) apply (rule_tac x="s" in exI) using cs_def by auto
236.1602 + then have "\<forall>i\<in>I. s i \<in> S i" by auto
236.1603 + moreover have "x = setsum s I" using x s_def by auto
236.1604 + ultimately have "x \<in> ?rhs"
236.1605 + using set_setsum_alt[of I S] assms by auto
236.1606 }
236.1607 moreover
236.1608 - { fix x assume "x : ?rhs"
236.1609 - from this obtain c s where cs_def: "x=setsum (%i. c i *\<^sub>R s i) I &
236.1610 - (!i:I. c i > 0) & (setsum c I = 1) & (!i:I. s i : rel_interior(S i))" by auto
236.1611 - def k == "(%i. (c i, c i *\<^sub>R s i))"
236.1612 - { fix i assume "i:I"
236.1613 - hence "k i : rel_interior (K i)"
236.1614 - using k_def K_def assms cs_def rel_interior_convex_cone[of "S i"] by auto
236.1615 + {
236.1616 + fix x
236.1617 + assume "x \<in> ?rhs"
236.1618 + then obtain s where x: "x = setsum s I \<and> (\<forall>i\<in>I. s i \<in> S i)"
236.1619 + using set_setsum_alt[of I S] assms by auto
236.1620 + def xs \<equiv> "\<lambda>i. of_nat(card I) *\<^sub>R s i"
236.1621 + then have "x = setsum (\<lambda>i. ((1 :: real) / of_nat(card I)) *\<^sub>R xs i) I"
236.1622 + using x assms by auto
236.1623 + moreover have "\<forall>i\<in>I. xs i \<in> S i"
236.1624 + using x xs_def assms by (simp add: cone_def)
236.1625 + moreover have "\<forall>i\<in>I. (1 :: real) / of_nat (card I) \<ge> 0"
236.1626 + by auto
236.1627 + moreover have "setsum (\<lambda>i. (1 :: real) / of_nat (card I)) I = 1"
236.1628 + using assms by auto
236.1629 + ultimately have "x \<in> ?lhs"
236.1630 + apply (subst convex_hull_finite_union[of I S])
236.1631 + using assms
236.1632 + apply blast
236.1633 + using assms
236.1634 + apply blast
236.1635 + apply rule
236.1636 + apply (rule_tac x = "(\<lambda>i. (1 :: real) / of_nat (card I))" in exI)
236.1637 + apply auto
236.1638 + done
236.1639 + }
236.1640 + ultimately show ?thesis by auto
236.1641 +qed
236.1642 +
236.1643 +lemma convex_hull_union_cones_two:
236.1644 + fixes S T :: "'m::euclidean_space set"
236.1645 + assumes "convex S"
236.1646 + and "cone S"
236.1647 + and "S \<noteq> {}"
236.1648 + assumes "convex T"
236.1649 + and "cone T"
236.1650 + and "T \<noteq> {}"
236.1651 + shows "convex hull (S \<union> T) = S + T"
236.1652 +proof -
236.1653 + def I \<equiv> "{1::nat, 2}"
236.1654 + def A \<equiv> "(\<lambda>i. if i = (1::nat) then S else T)"
236.1655 + have "\<Union>(A ` I) = S \<union> T"
236.1656 + using A_def I_def by auto
236.1657 + then have "convex hull (\<Union>(A ` I)) = convex hull (S \<union> T)"
236.1658 + by auto
236.1659 + moreover have "convex hull \<Union>(A ` I) = setsum A I"
236.1660 + apply (subst convex_hull_finite_union_cones[of I A])
236.1661 + using assms A_def I_def
236.1662 + apply auto
236.1663 + done
236.1664 + moreover have "setsum A I = S + T"
236.1665 + using A_def I_def
236.1666 + unfolding set_plus_def
236.1667 + apply auto
236.1668 + unfolding set_plus_def
236.1669 + apply auto
236.1670 + done
236.1671 + ultimately show ?thesis by auto
236.1672 +qed
236.1673 +
236.1674 +lemma rel_interior_convex_hull_union:
236.1675 + fixes S :: "'a \<Rightarrow> 'n::euclidean_space set"
236.1676 + assumes "finite I"
236.1677 + and "\<forall>i\<in>I. convex (S i) \<and> S i \<noteq> {}"
236.1678 + shows "rel_interior (convex hull (\<Union>(S ` I))) =
236.1679 + {setsum (\<lambda>i. c i *\<^sub>R s i) I | c s. (\<forall>i\<in>I. c i > 0) \<and> setsum c I = 1 \<and>
236.1680 + (\<forall>i\<in>I. s i \<in> rel_interior(S i))}"
236.1681 + (is "?lhs = ?rhs")
236.1682 +proof (cases "I = {}")
236.1683 + case True
236.1684 + then show ?thesis
236.1685 + using convex_hull_empty rel_interior_empty by auto
236.1686 +next
236.1687 + case False
236.1688 + def C0 \<equiv> "convex hull (\<Union>(S ` I))"
236.1689 + have "\<forall>i\<in>I. C0 \<ge> S i"
236.1690 + unfolding C0_def using hull_subset[of "\<Union>(S ` I)"] by auto
236.1691 + def K0 \<equiv> "cone hull ({1 :: real} <*> C0)"
236.1692 + def K \<equiv> "\<lambda>i. cone hull ({1 :: real} <*> S i)"
236.1693 + have "\<forall>i\<in>I. K i \<noteq> {}"
236.1694 + unfolding K_def using assms
236.1695 + by (simp add: cone_hull_empty_iff[symmetric])
236.1696 + {
236.1697 + fix i
236.1698 + assume "i \<in> I"
236.1699 + then have "convex (K i)"
236.1700 + unfolding K_def
236.1701 + apply (subst convex_cone_hull)
236.1702 + apply (subst convex_Times)
236.1703 + using assms
236.1704 + apply auto
236.1705 + done
236.1706 + }
236.1707 + then have convK: "\<forall>i\<in>I. convex (K i)"
236.1708 + by auto
236.1709 + {
236.1710 + fix i
236.1711 + assume "i \<in> I"
236.1712 + then have "K0 \<supseteq> K i"
236.1713 + unfolding K0_def K_def
236.1714 + apply (subst hull_mono)
236.1715 + using `\<forall>i\<in>I. C0 \<ge> S i`
236.1716 + apply auto
236.1717 + done
236.1718 + }
236.1719 + then have "K0 \<supseteq> \<Union>(K ` I)" by auto
236.1720 + moreover have "convex K0"
236.1721 + unfolding K0_def
236.1722 + apply (subst convex_cone_hull)
236.1723 + apply (subst convex_Times)
236.1724 + unfolding C0_def
236.1725 + using convex_convex_hull
236.1726 + apply auto
236.1727 + done
236.1728 + ultimately have geq: "K0 \<supseteq> convex hull (\<Union>(K ` I))"
236.1729 + using hull_minimal[of _ "K0" "convex"] by blast
236.1730 + have "\<forall>i\<in>I. K i \<supseteq> {1 :: real} <*> S i"
236.1731 + using K_def by (simp add: hull_subset)
236.1732 + then have "\<Union>(K ` I) \<supseteq> {1 :: real} <*> \<Union>(S ` I)"
236.1733 + by auto
236.1734 + then have "convex hull \<Union>(K ` I) \<supseteq> convex hull ({1 :: real} <*> \<Union>(S ` I))"
236.1735 + by (simp add: hull_mono)
236.1736 + then have "convex hull \<Union>(K ` I) \<supseteq> {1 :: real} <*> C0"
236.1737 + unfolding C0_def
236.1738 + using convex_hull_Times[of "{(1 :: real)}" "\<Union>(S ` I)"] convex_hull_singleton
236.1739 + by auto
236.1740 + moreover have "cone (convex hull (\<Union>(K ` I)))"
236.1741 + apply (subst cone_convex_hull)
236.1742 + using cone_Union[of "K ` I"]
236.1743 + apply auto
236.1744 + unfolding K_def
236.1745 + using cone_cone_hull
236.1746 + apply auto
236.1747 + done
236.1748 + ultimately have "convex hull (\<Union>(K ` I)) \<supseteq> K0"
236.1749 + unfolding K0_def
236.1750 + using hull_minimal[of _ "convex hull (\<Union> (K ` I))" "cone"]
236.1751 + by blast
236.1752 + then have "K0 = convex hull (\<Union>(K ` I))"
236.1753 + using geq by auto
236.1754 + also have "\<dots> = setsum K I"
236.1755 + apply (subst convex_hull_finite_union_cones[of I K])
236.1756 + using assms
236.1757 + apply blast
236.1758 + using False
236.1759 + apply blast
236.1760 + unfolding K_def
236.1761 + apply rule
236.1762 + apply (subst convex_cone_hull)
236.1763 + apply (subst convex_Times)
236.1764 + using assms cone_cone_hull `\<forall>i\<in>I. K i \<noteq> {}` K_def
236.1765 + apply auto
236.1766 + done
236.1767 + finally have "K0 = setsum K I" by auto
236.1768 + then have *: "rel_interior K0 = setsum (\<lambda>i. (rel_interior (K i))) I"
236.1769 + using rel_interior_sum_gen[of I K] convK by auto
236.1770 + {
236.1771 + fix x
236.1772 + assume "x \<in> ?lhs"
236.1773 + then have "(1::real, x) \<in> rel_interior K0"
236.1774 + using K0_def C0_def rel_interior_convex_cone_aux[of C0 "1::real" x] convex_convex_hull
236.1775 + by auto
236.1776 + then obtain k where k: "(1::real, x) = setsum k I \<and> (\<forall>i\<in>I. k i \<in> rel_interior (K i))"
236.1777 + using `finite I` * set_setsum_alt[of I "\<lambda>i. rel_interior (K i)"] by auto
236.1778 + {
236.1779 + fix i
236.1780 + assume "i \<in> I"
236.1781 + then have "convex (S i) \<and> k i \<in> rel_interior (cone hull {1} <*> S i)"
236.1782 + using k K_def assms by auto
236.1783 + then have "\<exists>ci si. k i = (ci, ci *\<^sub>R si) \<and> 0 < ci \<and> si \<in> rel_interior (S i)"
236.1784 + using rel_interior_convex_cone[of "S i"] by auto
236.1785 }
236.1786 - hence "((1::real),x) : rel_interior K0"
236.1787 - using K0_def * set_setsum_alt[of I "(%i. rel_interior (K i))"] assms k_def cs_def
236.1788 - apply auto apply (rule_tac x="k" in exI) by (simp add: setsum_prod)
236.1789 - hence "x : ?lhs" using K0_def C0_def
236.1790 - rel_interior_convex_cone_aux[of C0 "(1::real)" x] by (auto simp add: convex_convex_hull)
236.1791 + then obtain c s where
236.1792 + cs: "\<forall>i\<in>I. k i = (c i, c i *\<^sub>R s i) \<and> 0 < c i \<and> s i \<in> rel_interior (S i)"
236.1793 + by metis
236.1794 + then have "x = (\<Sum>i\<in>I. c i *\<^sub>R s i) \<and> setsum c I = 1"
236.1795 + using k by (simp add: setsum_prod)
236.1796 + then have "x \<in> ?rhs"
236.1797 + using k
236.1798 + apply auto
236.1799 + apply (rule_tac x = c in exI)
236.1800 + apply (rule_tac x = s in exI)
236.1801 + using cs
236.1802 + apply auto
236.1803 + done
236.1804 }
236.1805 - ultimately have ?thesis by blast
236.1806 -} ultimately show ?thesis by blast
236.1807 + moreover
236.1808 + {
236.1809 + fix x
236.1810 + assume "x \<in> ?rhs"
236.1811 + then obtain c s where cs: "x = setsum (\<lambda>i. c i *\<^sub>R s i) I \<and>
236.1812 + (\<forall>i\<in>I. c i > 0) \<and> setsum c I = 1 \<and> (\<forall>i\<in>I. s i \<in> rel_interior (S i))"
236.1813 + by auto
236.1814 + def k \<equiv> "\<lambda>i. (c i, c i *\<^sub>R s i)"
236.1815 + {
236.1816 + fix i assume "i:I"
236.1817 + then have "k i \<in> rel_interior (K i)"
236.1818 + using k_def K_def assms cs rel_interior_convex_cone[of "S i"]
236.1819 + by auto
236.1820 + }
236.1821 + then have "(1::real, x) \<in> rel_interior K0"
236.1822 + using K0_def * set_setsum_alt[of I "(\<lambda>i. rel_interior (K i))"] assms k_def cs
236.1823 + apply auto
236.1824 + apply (rule_tac x = k in exI)
236.1825 + apply (simp add: setsum_prod)
236.1826 + done
236.1827 + then have "x \<in> ?lhs"
236.1828 + using K0_def C0_def rel_interior_convex_cone_aux[of C0 1 x]
236.1829 + by (auto simp add: convex_convex_hull)
236.1830 + }
236.1831 + ultimately show ?thesis by blast
236.1832 qed
236.1833
236.1834
236.1835 lemma convex_le_Inf_differential:
236.1836 fixes f :: "real \<Rightarrow> real"
236.1837 assumes "convex_on I f"
236.1838 - assumes "x \<in> interior I" "y \<in> I"
236.1839 + and "x \<in> interior I"
236.1840 + and "y \<in> I"
236.1841 shows "f y \<ge> f x + Inf ((\<lambda>t. (f x - f t) / (x - t)) ` ({x<..} \<inter> I)) * (y - x)"
236.1842 - (is "_ \<ge> _ + Inf (?F x) * (y - x)")
236.1843 + (is "_ \<ge> _ + Inf (?F x) * (y - x)")
236.1844 proof (cases rule: linorder_cases)
236.1845 assume "x < y"
236.1846 moreover
236.1847 @@ -8720,18 +8949,21 @@
236.1848 have "open (interior I)" by auto
236.1849 from openE[OF this `x \<in> interior I`] guess e .
236.1850 moreover def K \<equiv> "x - e / 2"
236.1851 - with `0 < e` have "K \<in> ball x e" "K < x" by (auto simp: dist_real_def)
236.1852 + with `0 < e` have "K \<in> ball x e" "K < x"
236.1853 + by (auto simp: dist_real_def)
236.1854 ultimately have "K \<in> I" "K < x" "x \<in> I"
236.1855 using interior_subset[of I] `x \<in> interior I` by auto
236.1856
236.1857 have "Inf (?F x) \<le> (f x - f y) / (x - y)"
236.1858 - proof (rule cInf_lower2)
236.1859 + proof (intro bdd_belowI cInf_lower2)
236.1860 show "(f x - f t) / (x - t) \<in> ?F x"
236.1861 using `t \<in> I` `x < t` by auto
236.1862 show "(f x - f t) / (x - t) \<le> (f x - f y) / (x - y)"
236.1863 - using `convex_on I f` `x \<in> I` `y \<in> I` `x < t` `t < y` by (rule convex_on_diff)
236.1864 + using `convex_on I f` `x \<in> I` `y \<in> I` `x < t` `t < y`
236.1865 + by (rule convex_on_diff)
236.1866 next
236.1867 - fix y assume "y \<in> ?F x"
236.1868 + fix y
236.1869 + assume "y \<in> ?F x"
236.1870 with order_trans[OF convex_on_diff[OF `convex_on I f` `K \<in> I` _ `K < x` _]]
236.1871 show "(f K - f x) / (K - x) \<le> y" by auto
236.1872 qed
236.1873 @@ -8752,16 +8984,21 @@
236.1874 have "(f x - f y) / (x - y) = (f y - f x) / (y - x)"
236.1875 using `y < x` by (auto simp: field_simps)
236.1876 also
236.1877 - fix z assume "z \<in> ?F x"
236.1878 + fix z
236.1879 + assume "z \<in> ?F x"
236.1880 with order_trans[OF convex_on_diff[OF `convex_on I f` `y \<in> I` _ `y < x`]]
236.1881 - have "(f y - f x) / (y - x) \<le> z" by auto
236.1882 + have "(f y - f x) / (y - x) \<le> z"
236.1883 + by auto
236.1884 finally show "(f x - f y) / (x - y) \<le> z" .
236.1885 next
236.1886 have "open (interior I)" by auto
236.1887 from openE[OF this `x \<in> interior I`] guess e . note e = this
236.1888 - then have "x + e / 2 \<in> ball x e" by (auto simp: dist_real_def)
236.1889 - with e interior_subset[of I] have "x + e / 2 \<in> {x<..} \<inter> I" by auto
236.1890 - then show "?F x \<noteq> {}" by blast
236.1891 + then have "x + e / 2 \<in> ball x e"
236.1892 + by (auto simp: dist_real_def)
236.1893 + with e interior_subset[of I] have "x + e / 2 \<in> {x<..} \<inter> I"
236.1894 + by auto
236.1895 + then show "?F x \<noteq> {}"
236.1896 + by blast
236.1897 qed
236.1898 then show ?thesis
236.1899 using `y < x` by (simp add: field_simps)
237.1 --- a/src/HOL/Multivariate_Analysis/Derivative.thy Thu Dec 05 17:52:12 2013 +0100
237.2 +++ b/src/HOL/Multivariate_Analysis/Derivative.thy Thu Dec 05 17:58:03 2013 +0100
237.3 @@ -516,7 +516,7 @@
237.4 unfolding e_def
237.5 using c[THEN conjunct1]
237.6 using norm_minus_cancel[of "f' i - f'' i"]
237.7 - by (auto simp add: add.commute ab_diff_minus)
237.8 + by auto
237.9 finally show False
237.10 using c
237.11 using d[THEN conjunct2,rule_format,of "x + c *\<^sub>R i"]
238.1 --- a/src/HOL/Multivariate_Analysis/Extended_Real_Limits.thy Thu Dec 05 17:52:12 2013 +0100
238.2 +++ b/src/HOL/Multivariate_Analysis/Extended_Real_Limits.thy Thu Dec 05 17:58:03 2013 +0100
238.3 @@ -660,7 +660,7 @@
238.4 assume "S \<noteq> {}"
238.5 { assume ex: "\<exists>B. \<forall>x\<in>S. B \<le> x"
238.6 then have *: "\<forall>x\<in>S. Inf S \<le> x"
238.7 - using cInf_lower_EX[of _ S] ex by metis
238.8 + using cInf_lower[of _ S] ex by (metis bdd_below_def)
238.9 then have "Inf S \<in> S"
238.10 apply (subst closed_contains_Inf)
238.11 using ex `S \<noteq> {}` `closed S`
238.12 @@ -1193,12 +1193,12 @@
238.13 qed
238.14
238.15 lemma Liminf_at:
238.16 - fixes f :: "'a::metric_space \<Rightarrow> _"
238.17 + fixes f :: "'a::metric_space \<Rightarrow> 'b::complete_lattice"
238.18 shows "Liminf (at x) f = (SUP e:{0<..}. INF y:(ball x e - {x}). f y)"
238.19 using Liminf_within[of x UNIV f] by simp
238.20
238.21 lemma Limsup_at:
238.22 - fixes f :: "'a::metric_space \<Rightarrow> _"
238.23 + fixes f :: "'a::metric_space \<Rightarrow> 'b::complete_lattice"
238.24 shows "Limsup (at x) f = (INF e:{0<..}. SUP y:(ball x e - {x}). f y)"
238.25 using Limsup_within[of x UNIV f] by simp
238.26
238.27 @@ -1209,7 +1209,7 @@
238.28 apply (subst inf_commute)
238.29 apply (subst SUP_inf)
238.30 apply (intro SUP_cong[OF refl])
238.31 - apply (cut_tac A="ball x b - {x}" and B="{x}" and M=f in INF_union)
238.32 + apply (cut_tac A="ball x xa - {x}" and B="{x}" and M=f in INF_union)
238.33 apply (simp add: INF_def del: inf_ereal_def)
238.34 done
238.35
239.1 --- a/src/HOL/Multivariate_Analysis/Finite_Cartesian_Product.thy Thu Dec 05 17:52:12 2013 +0100
239.2 +++ b/src/HOL/Multivariate_Analysis/Finite_Cartesian_Product.thy Thu Dec 05 17:58:03 2013 +0100
239.3 @@ -115,7 +115,7 @@
239.4 instance vec :: (cancel_comm_monoid_add, finite) cancel_comm_monoid_add ..
239.5
239.6 instance vec :: (group_add, finite) group_add
239.7 - by default (simp_all add: vec_eq_iff diff_minus)
239.8 + by default (simp_all add: vec_eq_iff)
239.9
239.10 instance vec :: (ab_group_add, finite) ab_group_add
239.11 by default (simp_all add: vec_eq_iff)
240.1 --- a/src/HOL/Multivariate_Analysis/Integration.thy Thu Dec 05 17:52:12 2013 +0100
240.2 +++ b/src/HOL/Multivariate_Analysis/Integration.thy Thu Dec 05 17:58:03 2013 +0100
240.3 @@ -13,7 +13,7 @@
240.4 lemma cSup_abs_le: (* TODO: is this really needed? *)
240.5 fixes S :: "real set"
240.6 shows "S \<noteq> {} \<Longrightarrow> (\<forall>x\<in>S. \<bar>x\<bar> \<le> a) \<Longrightarrow> \<bar>Sup S\<bar> \<le> a"
240.7 - by (auto simp add: abs_le_interval_iff intro: cSup_least) (metis cSup_upper2)
240.8 + by (auto simp add: abs_le_interval_iff intro: cSup_least) (metis cSup_upper2 bdd_aboveI)
240.9
240.10 lemma cInf_abs_ge: (* TODO: is this really needed? *)
240.11 fixes S :: "real set"
240.12 @@ -28,10 +28,10 @@
240.13 proof -
240.14 have th: "\<And>(x::real) l e. \<bar>x - l\<bar> \<le> e \<longleftrightarrow> l - e \<le> x \<and> x \<le> l + e"
240.15 by arith
240.16 - then show ?thesis
240.17 - using S b cSup_bounds[of S "l - e" "l+e"]
240.18 - unfolding th
240.19 - by (auto simp add: setge_def setle_def)
240.20 + have "bdd_above S"
240.21 + using b by (auto intro!: bdd_aboveI[of _ "l + e"])
240.22 + with S b show ?thesis
240.23 + unfolding th by (auto intro!: cSup_upper2 cSup_least)
240.24 qed
240.25
240.26 lemma cInf_asclose: (* TODO: is this really needed? *)
240.27 @@ -44,9 +44,7 @@
240.28 by auto
240.29 also have "\<dots> \<le> e"
240.30 apply (rule cSup_asclose)
240.31 - apply (auto simp add: S)
240.32 - apply (metis abs_minus_add_cancel b add_commute diff_minus)
240.33 - done
240.34 + using abs_minus_add_cancel b by (auto simp add: S)
240.35 finally have "\<bar>- Sup (uminus ` S) - l\<bar> \<le> e" .
240.36 then show ?thesis
240.37 by (simp add: Inf_real_def)
240.38 @@ -72,39 +70,6 @@
240.39 shows "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> a \<ge> Inf S \<longleftrightarrow> (\<exists>x\<in>S. a \<ge> x)"
240.40 by (metis cInf_eq_Min Min_le_iff)
240.41
240.42 -lemma Inf: (* rename *)
240.43 - fixes S :: "real set"
240.44 - shows "S \<noteq> {} \<Longrightarrow> (\<exists>b. b <=* S) \<Longrightarrow> isGlb UNIV S (Inf S)"
240.45 - by (auto simp add: isLb_def setle_def setge_def isGlb_def greatestP_def
240.46 - intro: cInf_lower cInf_greatest)
240.47 -
240.48 -lemma real_le_inf_subset:
240.49 - assumes "t \<noteq> {}"
240.50 - and "t \<subseteq> s"
240.51 - and "\<exists>b. b <=* s"
240.52 - shows "Inf s \<le> Inf (t::real set)"
240.53 - apply (rule isGlb_le_isLb)
240.54 - apply (rule Inf[OF assms(1)])
240.55 - apply (insert assms)
240.56 - apply (erule exE)
240.57 - apply (rule_tac x = b in exI)
240.58 - apply (auto simp: isLb_def setge_def intro: cInf_lower cInf_greatest)
240.59 - done
240.60 -
240.61 -lemma real_ge_sup_subset:
240.62 - fixes t :: "real set"
240.63 - assumes "t \<noteq> {}"
240.64 - and "t \<subseteq> s"
240.65 - and "\<exists>b. s *<= b"
240.66 - shows "Sup s \<ge> Sup t"
240.67 - apply (rule isLub_le_isUb)
240.68 - apply (rule isLub_cSup[OF assms(1)])
240.69 - apply (insert assms)
240.70 - apply (erule exE)
240.71 - apply (rule_tac x = b in exI)
240.72 - apply (auto simp: isUb_def setle_def intro: cSup_upper cSup_least)
240.73 - done
240.74 -
240.75 (*declare not_less[simp] not_le[simp]*)
240.76
240.77 lemmas scaleR_simps = scaleR_zero_left scaleR_minus_left scaleR_left_diff_distrib
240.78 @@ -380,7 +345,7 @@
240.79 using Basis_le_norm[OF k, of "?z - y"] unfolding dist_norm by auto
240.80 then have "y\<bullet>k < a\<bullet>k"
240.81 using e[THEN conjunct1] k
240.82 - by (auto simp add: field_simps as inner_Basis inner_simps)
240.83 + by (auto simp add: field_simps abs_less_iff as inner_Basis inner_simps)
240.84 then have "y \<notin> i"
240.85 unfolding ab mem_interval by (auto intro!: bexI[OF _ k])
240.86 then show False using yi by auto
240.87 @@ -488,24 +453,24 @@
240.88 subsection {* Bounds on intervals where they exist. *}
240.89
240.90 definition interval_upperbound :: "('a::ordered_euclidean_space) set \<Rightarrow> 'a"
240.91 - where "interval_upperbound s = (\<Sum>i\<in>Basis. Sup {a. \<exists>x\<in>s. x\<bullet>i = a} *\<^sub>R i)"
240.92 + where "interval_upperbound s = (\<Sum>i\<in>Basis. (SUP x:s. x\<bullet>i) *\<^sub>R i)"
240.93
240.94 definition interval_lowerbound :: "('a::ordered_euclidean_space) set \<Rightarrow> 'a"
240.95 - where "interval_lowerbound s = (\<Sum>i\<in>Basis. Inf {a. \<exists>x\<in>s. x\<bullet>i = a} *\<^sub>R i)"
240.96 + where "interval_lowerbound s = (\<Sum>i\<in>Basis. (INF x:s. x\<bullet>i) *\<^sub>R i)"
240.97
240.98 lemma interval_upperbound[simp]:
240.99 "\<forall>i\<in>Basis. a\<bullet>i \<le> b\<bullet>i \<Longrightarrow>
240.100 interval_upperbound {a..b} = (b::'a::ordered_euclidean_space)"
240.101 unfolding interval_upperbound_def euclidean_representation_setsum
240.102 - by (auto simp del: ex_simps simp add: Bex_def ex_simps[symmetric] eucl_le[where 'a='a] setle_def
240.103 - intro!: cSup_unique)
240.104 + by (auto simp del: ex_simps simp add: Bex_def ex_simps[symmetric] eucl_le[where 'a='a] SUP_def
240.105 + intro!: cSup_eq)
240.106
240.107 lemma interval_lowerbound[simp]:
240.108 "\<forall>i\<in>Basis. a\<bullet>i \<le> b\<bullet>i \<Longrightarrow>
240.109 interval_lowerbound {a..b} = (a::'a::ordered_euclidean_space)"
240.110 unfolding interval_lowerbound_def euclidean_representation_setsum
240.111 - by (auto simp del: ex_simps simp add: Bex_def ex_simps[symmetric] eucl_le[where 'a='a] setge_def
240.112 - intro!: cInf_unique)
240.113 + by (auto simp del: ex_simps simp add: Bex_def ex_simps[symmetric] eucl_le[where 'a='a] INF_def
240.114 + intro!: cInf_eq)
240.115
240.116 lemmas interval_bounds = interval_upperbound interval_lowerbound
240.117
240.118 @@ -2371,12 +2336,11 @@
240.119 qed
240.120 {
240.121 fix n m :: nat
240.122 - assume "m \<le> n"
240.123 - then have "{A n..B n} \<subseteq> {A m..B m}"
240.124 - proof (induct rule: inc_induct)
240.125 + assume "m \<le> n" then have "{A n..B n} \<subseteq> {A m..B m}"
240.126 + proof (induction rule: inc_induct)
240.127 case (step i)
240.128 show ?case
240.129 - using AB(4) by (intro order_trans[OF step(2)] subset_interval_imp) auto
240.130 + using AB(4) by (intro order_trans[OF step.IH] subset_interval_imp) auto
240.131 qed simp
240.132 } note ABsubset = this
240.133 have "\<exists>a. \<forall>n. a\<in>{A n..B n}"
240.134 @@ -6629,7 +6593,7 @@
240.135 lemma interval_bound_sing[simp]:
240.136 "interval_upperbound {a} = a"
240.137 "interval_lowerbound {a} = a"
240.138 - unfolding interval_upperbound_def interval_lowerbound_def
240.139 + unfolding interval_upperbound_def interval_lowerbound_def SUP_def INF_def
240.140 by (auto simp: euclidean_representation)
240.141
240.142 lemma additive_tagged_division_1:
240.143 @@ -11238,37 +11202,26 @@
240.144 lemma bounded_variation_absolutely_integrable_interval:
240.145 fixes f :: "'n::ordered_euclidean_space \<Rightarrow> 'm::ordered_euclidean_space"
240.146 assumes "f integrable_on {a..b}"
240.147 - and "\<forall>d. d division_of {a..b} \<longrightarrow> setsum (\<lambda>k. norm(integral k f)) d \<le> B"
240.148 + and *: "\<forall>d. d division_of {a..b} \<longrightarrow> setsum (\<lambda>k. norm(integral k f)) d \<le> B"
240.149 shows "f absolutely_integrable_on {a..b}"
240.150 proof -
240.151 - let ?S = "(\<lambda>d. setsum (\<lambda>k. norm(integral k f)) d) ` {d. d division_of {a..b} }"
240.152 - def i \<equiv> "Sup ?S"
240.153 - have i: "isLub UNIV ?S i"
240.154 - unfolding i_def
240.155 - apply (rule isLub_cSup)
240.156 - apply (rule elementary_interval)
240.157 - defer
240.158 - apply (rule_tac x=B in exI)
240.159 - apply (rule setleI)
240.160 - using assms(2)
240.161 - apply auto
240.162 - done
240.163 + let ?f = "\<lambda>d. \<Sum>k\<in>d. norm (integral k f)" and ?D = "{d. d division_of {a..b}}"
240.164 + have D_1: "?D \<noteq> {}"
240.165 + by (rule elementary_interval[of a b]) auto
240.166 + have D_2: "bdd_above (?f`?D)"
240.167 + by (metis * mem_Collect_eq bdd_aboveI2)
240.168 + note D = D_1 D_2
240.169 + let ?S = "SUP x:?D. ?f x"
240.170 show ?thesis
240.171 apply rule
240.172 apply (rule assms)
240.173 apply rule
240.174 - apply (subst has_integral[of _ i])
240.175 + apply (subst has_integral[of _ ?S])
240.176 proof safe
240.177 case goal1
240.178 - then have "i - e / 2 \<notin> Collect (isUb UNIV (setsum (\<lambda>k. norm (integral k f)) `
240.179 - {d. d division_of {a..b}}))"
240.180 - using isLub_ubs[OF i,rule_format]
240.181 - unfolding setge_def ubs_def
240.182 - by auto
240.183 - then have "\<exists>y. y division_of {a..b} \<and> i - e / 2 < (\<Sum>k\<in>y. norm (integral k f))"
240.184 - unfolding mem_Collect_eq isUb_def setle_def
240.185 - by (simp add: not_le)
240.186 - then guess d .. note d=conjunctD2[OF this]
240.187 + then have "?S - e / 2 < ?S" by simp
240.188 + then obtain d where d: "d division_of {a..b}" "?S - e / 2 < (\<Sum>k\<in>d. norm (integral k f))"
240.189 + unfolding less_cSUP_iff[OF D] by auto
240.190 note d' = division_ofD[OF this(1)]
240.191
240.192 have "\<forall>x. \<exists>e>0. \<forall>i\<in>d. x \<notin> i \<longrightarrow> ball x e \<inter> i = {}"
240.193 @@ -11453,21 +11406,17 @@
240.194 done
240.195 note snd_p = division_ofD[OF division_of_tagged_division[OF p(1)]]
240.196
240.197 - have *: "\<And>sni sni' sf sf'. abs (sf' - sni') < e / 2 \<longrightarrow> i - e / 2 < sni \<and> sni' \<le> i \<and>
240.198 - sni \<le> sni' \<and> sf' = sf \<longrightarrow> abs (sf - i) < e"
240.199 + have *: "\<And>sni sni' sf sf'. abs (sf' - sni') < e / 2 \<longrightarrow> ?S - e / 2 < sni \<and> sni' \<le> ?S \<and>
240.200 + sni \<le> sni' \<and> sf' = sf \<longrightarrow> abs (sf - ?S) < e"
240.201 by arith
240.202 - show "norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R norm (f x)) - i) < e"
240.203 + show "norm ((\<Sum>(x, k)\<in>p. content k *\<^sub>R norm (f x)) - ?S) < e"
240.204 unfolding real_norm_def
240.205 apply (rule *[rule_format,OF **])
240.206 apply safe
240.207 apply(rule d(2))
240.208 proof -
240.209 - case goal1
240.210 - show ?case unfolding sum_p'
240.211 - apply (rule isLubD2[OF i])
240.212 - using division_of_tagged_division[OF p'']
240.213 - apply auto
240.214 - done
240.215 + case goal1 show ?case
240.216 + by (auto simp: sum_p' division_of_tagged_division[OF p''] D intro!: cSUP_upper)
240.217 next
240.218 case goal2
240.219 have *: "{k \<inter> l | k l. k \<in> d \<and> l \<in> snd ` p} =
240.220 @@ -11758,18 +11707,13 @@
240.221 and "\<forall>d. d division_of (\<Union>d) \<longrightarrow> setsum (\<lambda>k. norm (integral k f)) d \<le> B"
240.222 shows "f absolutely_integrable_on UNIV"
240.223 proof (rule absolutely_integrable_onI, fact, rule)
240.224 - let ?S = "(\<lambda>d. setsum (\<lambda>k. norm(integral k f)) d) ` {d. d division_of (\<Union>d)}"
240.225 - def i \<equiv> "Sup ?S"
240.226 - have i: "isLub UNIV ?S i"
240.227 - unfolding i_def
240.228 - apply (rule isLub_cSup)
240.229 - apply (rule elementary_interval)
240.230 - defer
240.231 - apply (rule_tac x=B in exI)
240.232 - apply (rule setleI)
240.233 - using assms(2)
240.234 - apply auto
240.235 - done
240.236 + let ?f = "\<lambda>d. \<Sum>k\<in>d. norm (integral k f)" and ?D = "{d. d division_of (\<Union>d)}"
240.237 + have D_1: "?D \<noteq> {}"
240.238 + by (rule elementary_interval) auto
240.239 + have D_2: "bdd_above (?f`?D)"
240.240 + by (intro bdd_aboveI2[where M=B] assms(2)[rule_format]) simp
240.241 + note D = D_1 D_2
240.242 + let ?S = "SUP d:?D. ?f d"
240.243 have f_int: "\<And>a b. f absolutely_integrable_on {a..b}"
240.244 apply (rule bounded_variation_absolutely_integrable_interval[where B=B])
240.245 apply (rule integrable_on_subinterval[OF assms(1)])
240.246 @@ -11778,7 +11722,7 @@
240.247 apply (rule assms(2)[rule_format])
240.248 apply auto
240.249 done
240.250 - show "((\<lambda>x. norm (f x)) has_integral i) UNIV"
240.251 + show "((\<lambda>x. norm (f x)) has_integral ?S) UNIV"
240.252 apply (subst has_integral_alt')
240.253 apply safe
240.254 proof -
240.255 @@ -11787,16 +11731,11 @@
240.256 using f_int[of a b] by auto
240.257 next
240.258 case goal2
240.259 - have "\<exists>y\<in>setsum (\<lambda>k. norm (integral k f)) ` {d. d division_of \<Union>d}. \<not> y \<le> i - e"
240.260 + have "\<exists>y\<in>setsum (\<lambda>k. norm (integral k f)) ` {d. d division_of \<Union>d}. \<not> y \<le> ?S - e"
240.261 proof (rule ccontr)
240.262 assume "\<not> ?thesis"
240.263 - then have "i \<le> i - e"
240.264 - apply -
240.265 - apply (rule isLub_le_isUb[OF i])
240.266 - apply (rule isUbI)
240.267 - unfolding setle_def
240.268 - apply auto
240.269 - done
240.270 + then have "?S \<le> ?S - e"
240.271 + by (intro cSUP_least[OF D(1)]) auto
240.272 then show False
240.273 using goal2 by auto
240.274 qed
240.275 @@ -11813,9 +11752,9 @@
240.276 proof -
240.277 fix a b :: 'n
240.278 assume ab: "ball 0 (K + 1) \<subseteq> {a..b}"
240.279 - have *: "\<forall>s s1. i - e < s1 \<and> s1 \<le> s \<and> s < i + e \<longrightarrow> abs (s - i) < e"
240.280 + have *: "\<forall>s s1. ?S - e < s1 \<and> s1 \<le> s \<and> s < ?S + e \<longrightarrow> abs (s - ?S) < e"
240.281 by arith
240.282 - show "norm (integral {a..b} (\<lambda>x. if x \<in> UNIV then norm (f x) else 0) - i) < e"
240.283 + show "norm (integral {a..b} (\<lambda>x. if x \<in> UNIV then norm (f x) else 0) - ?S) < e"
240.284 unfolding real_norm_def
240.285 apply (rule *[rule_format])
240.286 apply safe
240.287 @@ -11867,10 +11806,10 @@
240.288 from henstock_lemma[OF f(1) `e/2>0`] guess d2 . note d2=this
240.289 from fine_division_exists[OF gauge_inter[OF d1(1) d2(1)], of a b] guess p .
240.290 note p=this(1) conjunctD2[OF this(2)[unfolded fine_inter]]
240.291 - have *: "\<And>sf sf' si di. sf' = sf \<longrightarrow> si \<le> i \<longrightarrow> abs (sf - si) < e / 2 \<longrightarrow>
240.292 - abs (sf' - di) < e / 2 \<longrightarrow> di < i + e"
240.293 + have *: "\<And>sf sf' si di. sf' = sf \<longrightarrow> si \<le> ?S \<longrightarrow> abs (sf - si) < e / 2 \<longrightarrow>
240.294 + abs (sf' - di) < e / 2 \<longrightarrow> di < ?S + e"
240.295 by arith
240.296 - show "integral {a..b} (\<lambda>x. if x \<in> UNIV then norm (f x) else 0) < i + e"
240.297 + show "integral {a..b} (\<lambda>x. if x \<in> UNIV then norm (f x) else 0) < ?S + e"
240.298 apply (subst if_P)
240.299 apply rule
240.300 proof (rule *[rule_format])
240.301 @@ -11893,18 +11832,12 @@
240.302 apply (subst abs_of_nonneg)
240.303 apply auto
240.304 done
240.305 - show "(\<Sum>(x, k)\<in>p. norm (integral k f)) \<le> i"
240.306 + show "(\<Sum>(x, k)\<in>p. norm (integral k f)) \<le> ?S"
240.307 + using partial_division_of_tagged_division[of p "{a..b}"] p(1)
240.308 apply (subst setsum_over_tagged_division_lemma[OF p(1)])
240.309 - defer
240.310 - apply (rule isLubD2[OF i])
240.311 - unfolding image_iff
240.312 - apply (rule_tac x="snd ` p" in bexI)
240.313 - unfolding mem_Collect_eq
240.314 - defer
240.315 - apply (rule partial_division_of_tagged_division[of _ "{a..b}"])
240.316 - using p(1)
240.317 - unfolding tagged_division_of_def
240.318 - apply auto
240.319 + apply (simp add: integral_null)
240.320 + apply (intro cSUP_upper2[OF D(2), of "snd ` p"])
240.321 + apply (auto simp: tagged_partial_division_of_def)
240.322 done
240.323 qed
240.324 qed
240.325 @@ -11975,7 +11908,7 @@
240.326 and "g absolutely_integrable_on s"
240.327 shows "(\<lambda>x. f x - g x) absolutely_integrable_on s"
240.328 using absolutely_integrable_add[OF assms(1) absolutely_integrable_neg[OF assms(2)]]
240.329 - by (simp only: algebra_simps)
240.330 + by (simp add: algebra_simps)
240.331
240.332 lemma absolutely_integrable_linear:
240.333 fixes f :: "'m::ordered_euclidean_space \<Rightarrow> 'n::ordered_euclidean_space"
240.334 @@ -12380,11 +12313,22 @@
240.335 lemma dominated_convergence:
240.336 fixes f :: "nat \<Rightarrow> 'n::ordered_euclidean_space \<Rightarrow> real"
240.337 assumes "\<And>k. (f k) integrable_on s" "h integrable_on s"
240.338 - and "\<And>k. \<forall>x \<in> s. norm(f k x) \<le> (h x)"
240.339 + and "\<And>k. \<forall>x \<in> s. norm (f k x) \<le> h x"
240.340 and "\<forall>x \<in> s. ((\<lambda>k. f k x) ---> g x) sequentially"
240.341 shows "g integrable_on s"
240.342 and "((\<lambda>k. integral s (f k)) ---> integral s g) sequentially"
240.343 proof -
240.344 + have bdd_below[simp]: "\<And>x P. x \<in> s \<Longrightarrow> bdd_below {f n x |n. P n}"
240.345 + proof (safe intro!: bdd_belowI)
240.346 + fix n x show "x \<in> s \<Longrightarrow> - h x \<le> f n x"
240.347 + using assms(3)[rule_format, of x n] by simp
240.348 + qed
240.349 + have bdd_above[simp]: "\<And>x P. x \<in> s \<Longrightarrow> bdd_above {f n x |n. P n}"
240.350 + proof (safe intro!: bdd_aboveI)
240.351 + fix n x show "x \<in> s \<Longrightarrow> f n x \<le> h x"
240.352 + using assms(3)[rule_format, of x n] by simp
240.353 + qed
240.354 +
240.355 have "\<And>m. (\<lambda>x. Inf {f j x |j. m \<le> j}) integrable_on s \<and>
240.356 ((\<lambda>k. integral s (\<lambda>x. Inf {f j x |j. j \<in> {m..m + k}})) --->
240.357 integral s (\<lambda>x. Inf {f j x |j. m \<le> j}))sequentially"
240.358 @@ -12424,66 +12368,32 @@
240.359 fix x
240.360 assume x: "x \<in> s"
240.361 show "Inf {f j x |j. j \<in> {m..m + Suc k}} \<le> Inf {f j x |j. j \<in> {m..m + k}}"
240.362 - apply (rule cInf_ge)
240.363 - unfolding setge_def
240.364 - defer
240.365 - apply rule
240.366 - apply (subst cInf_finite_le_iff)
240.367 - prefer 3
240.368 - apply (rule_tac x=xa in bexI)
240.369 - apply auto
240.370 - done
240.371 - let ?S = "{f j x| j. m \<le> j}"
240.372 - def i \<equiv> "Inf ?S"
240.373 - show "((\<lambda>k. Inf {f j x |j. j \<in> {m..m + k}}) ---> i) sequentially"
240.374 + by (rule cInf_superset_mono) auto
240.375 + let ?S = "{f j x| j. m \<le> j}"
240.376 + show "((\<lambda>k. Inf {f j x |j. j \<in> {m..m + k}}) ---> Inf ?S) sequentially"
240.377 proof (rule LIMSEQ_I)
240.378 case goal1
240.379 note r = this
240.380 - have i: "isGlb UNIV ?S i"
240.381 - unfolding i_def
240.382 - apply (rule Inf)
240.383 - defer
240.384 - apply (rule_tac x="- h x - 1" in exI)
240.385 - unfolding setge_def
240.386 - proof safe
240.387 - case goal1
240.388 - then show ?case using assms(3)[rule_format,OF x, of j] by auto
240.389 - qed auto
240.390 -
240.391 - have "\<exists>y\<in>?S. \<not> y \<ge> i + r"
240.392 - proof(rule ccontr)
240.393 - assume "\<not> ?thesis"
240.394 - then have "i \<ge> i + r"
240.395 - apply -
240.396 - apply (rule isGlb_le_isLb[OF i])
240.397 - apply (rule isLbI)
240.398 - unfolding setge_def
240.399 - apply fastforce+
240.400 - done
240.401 - then show False using r by auto
240.402 - qed
240.403 - then guess y .. note y=this[unfolded not_le]
240.404 - from this(1)[unfolded mem_Collect_eq] guess N .. note N=conjunctD2[OF this]
240.405 +
240.406 + have "\<exists>y\<in>?S. y < Inf ?S + r"
240.407 + by (subst cInf_less_iff[symmetric]) (auto simp: `x\<in>s` r)
240.408 + then obtain N where N: "f N x < Inf ?S + r" "m \<le> N"
240.409 + by blast
240.410
240.411 show ?case
240.412 apply (rule_tac x=N in exI)
240.413 proof safe
240.414 case goal1
240.415 - have *: "\<And>y ix. y < i + r \<longrightarrow> i \<le> ix \<longrightarrow> ix \<le> y \<longrightarrow> abs(ix - i) < r"
240.416 + have *: "\<And>y ix. y < Inf ?S + r \<longrightarrow> Inf ?S \<le> ix \<longrightarrow> ix \<le> y \<longrightarrow> abs(ix - Inf ?S) < r"
240.417 by arith
240.418 show ?case
240.419 unfolding real_norm_def
240.420 - apply (rule *[rule_format,OF y(2)])
240.421 - unfolding i_def
240.422 - apply (rule real_le_inf_subset)
240.423 - prefer 3
240.424 - apply (rule,rule isGlbD1[OF i])
240.425 - prefer 3
240.426 - apply (subst cInf_finite_le_iff)
240.427 - prefer 3
240.428 - apply (rule_tac x=y in bexI)
240.429 + apply (rule *[rule_format, OF N(1)])
240.430 + apply (rule cInf_superset_mono, auto simp: `x\<in>s`) []
240.431 + apply (rule cInf_lower)
240.432 using N goal1
240.433 - apply auto
240.434 + apply auto []
240.435 + apply simp
240.436 done
240.437 qed
240.438 qed
240.439 @@ -12527,65 +12437,27 @@
240.440 fix x
240.441 assume x: "x\<in>s"
240.442 show "Sup {f j x |j. j \<in> {m..m + Suc k}} \<ge> Sup {f j x |j. j \<in> {m..m + k}}"
240.443 - apply (rule cSup_le)
240.444 - unfolding setle_def
240.445 - defer
240.446 - apply rule
240.447 - apply (subst cSup_finite_ge_iff)
240.448 - prefer 3
240.449 - apply (rule_tac x=y in bexI)
240.450 - apply auto
240.451 - done
240.452 - let ?S = "{f j x| j. m \<le> j}"
240.453 - def i \<equiv> "Sup ?S"
240.454 - show "((\<lambda>k. Sup {f j x |j. j \<in> {m..m + k}}) ---> i) sequentially"
240.455 + by (rule cSup_subset_mono) auto
240.456 + let ?S = "{f j x| j. m \<le> j}"
240.457 + show "((\<lambda>k. Sup {f j x |j. j \<in> {m..m + k}}) ---> Sup ?S) sequentially"
240.458 proof (rule LIMSEQ_I)
240.459 case goal1 note r=this
240.460 - have i: "isLub UNIV ?S i"
240.461 - unfolding i_def
240.462 - apply (rule isLub_cSup)
240.463 - defer
240.464 - apply (rule_tac x="h x" in exI)
240.465 - unfolding setle_def
240.466 - proof safe
240.467 - case goal1
240.468 - then show ?case
240.469 - using assms(3)[rule_format,OF x, of j] by auto
240.470 - qed auto
240.471 -
240.472 - have "\<exists>y\<in>?S. \<not> y \<le> i - r"
240.473 - proof (rule ccontr)
240.474 - assume "\<not> ?thesis"
240.475 - then have "i \<le> i - r"
240.476 - apply -
240.477 - apply (rule isLub_le_isUb[OF i])
240.478 - apply (rule isUbI)
240.479 - unfolding setle_def
240.480 - apply fastforce+
240.481 - done
240.482 - then show False
240.483 - using r by auto
240.484 - qed
240.485 - then guess y .. note y=this[unfolded not_le]
240.486 - from this(1)[unfolded mem_Collect_eq] guess N .. note N=conjunctD2[OF this]
240.487 + have "\<exists>y\<in>?S. Sup ?S - r < y"
240.488 + by (subst less_cSup_iff[symmetric]) (auto simp: r `x\<in>s`)
240.489 + then obtain N where N: "Sup ?S - r < f N x" "m \<le> N"
240.490 + by blast
240.491
240.492 show ?case
240.493 apply (rule_tac x=N in exI)
240.494 proof safe
240.495 case goal1
240.496 - have *: "\<And>y ix. i - r < y \<longrightarrow> ix \<le> i \<longrightarrow> y \<le> ix \<longrightarrow> abs(ix - i) < r"
240.497 + have *: "\<And>y ix. Sup ?S - r < y \<longrightarrow> ix \<le> Sup ?S \<longrightarrow> y \<le> ix \<longrightarrow> abs(ix - Sup ?S) < r"
240.498 by arith
240.499 show ?case
240.500 - unfolding real_norm_def
240.501 - apply (rule *[rule_format,OF y(2)])
240.502 - unfolding i_def
240.503 - apply (rule real_ge_sup_subset)
240.504 - prefer 3
240.505 - apply (rule, rule isLubD1[OF i])
240.506 - prefer 3
240.507 - apply (subst cSup_finite_ge_iff)
240.508 - prefer 3
240.509 - apply (rule_tac x = y in bexI)
240.510 + apply simp
240.511 + apply (rule *[rule_format, OF N(1)])
240.512 + apply (rule cSup_subset_mono, auto simp: `x\<in>s`) []
240.513 + apply (subst cSup_upper)
240.514 using N goal1
240.515 apply auto
240.516 done
240.517 @@ -12618,17 +12490,7 @@
240.518
240.519 have *: "\<And>x y::real. x \<ge> - y \<Longrightarrow> - x \<le> y" by auto
240.520 show "Inf {f j x |j. k \<le> j} \<le> Inf {f j x |j. Suc k \<le> j}"
240.521 - apply -
240.522 - apply (rule real_le_inf_subset)
240.523 - prefer 3
240.524 - unfolding setge_def
240.525 - apply (rule_tac x="- h x" in exI)
240.526 - apply safe
240.527 - apply (rule *)
240.528 - using assms(3)[rule_format,OF x]
240.529 - unfolding real_norm_def abs_le_iff
240.530 - apply auto
240.531 - done
240.532 + by (intro cInf_superset_mono) (auto simp: `x\<in>s`)
240.533
240.534 show "(\<lambda>k::nat. Inf {f j x |j. k \<le> j}) ----> g x"
240.535 proof (rule LIMSEQ_I)
240.536 @@ -12676,16 +12538,7 @@
240.537 assume x: "x \<in> s"
240.538
240.539 show "Sup {f j x |j. k \<le> j} \<ge> Sup {f j x |j. Suc k \<le> j}"
240.540 - apply -
240.541 - apply (rule real_ge_sup_subset)
240.542 - prefer 3
240.543 - unfolding setle_def
240.544 - apply (rule_tac x="h x" in exI)
240.545 - apply safe
240.546 - using assms(3)[rule_format,OF x]
240.547 - unfolding real_norm_def abs_le_iff
240.548 - apply auto
240.549 - done
240.550 + by (rule cSup_subset_mono) (auto simp: `x\<in>s`)
240.551 show "((\<lambda>k. Sup {f j x |j. k \<le> j}) ---> g x) sequentially"
240.552 proof (rule LIMSEQ_I)
240.553 case goal1
240.554 @@ -12714,42 +12567,18 @@
240.555 from LIMSEQ_D [OF inc2(2) goal1] guess N1 .. note N1=this[unfolded real_norm_def]
240.556 from LIMSEQ_D [OF dec2(2) goal1] guess N2 .. note N2=this[unfolded real_norm_def]
240.557 show ?case
240.558 - apply (rule_tac x="N1+N2" in exI, safe)
240.559 - proof -
240.560 + proof (rule_tac x="N1+N2" in exI, safe)
240.561 fix n
240.562 assume n: "n \<ge> N1 + N2"
240.563 have *: "\<And>i0 i i1 g. \<bar>i0 - g\<bar> < r \<longrightarrow> \<bar>i1 - g\<bar> < r \<longrightarrow> i0 \<le> i \<longrightarrow> i \<le> i1 \<longrightarrow> \<bar>i - g\<bar> < r"
240.564 by arith
240.565 show "norm (integral s (f n) - integral s g) < r"
240.566 unfolding real_norm_def
240.567 - apply (rule *[rule_format,OF N1[rule_format] N2[rule_format], of n n])
240.568 - proof -
240.569 + proof (rule *[rule_format,OF N1[rule_format] N2[rule_format], of n n])
240.570 show "integral s (\<lambda>x. Inf {f j x |j. n \<le> j}) \<le> integral s (f n)"
240.571 - proof (rule integral_le[OF dec1(1) assms(1)], safe)
240.572 - fix x
240.573 - assume x: "x \<in> s"
240.574 - have *: "\<And>x y::real. x \<ge> - y \<Longrightarrow> - x \<le> y" by auto
240.575 - show "Inf {f j x |j. n \<le> j} \<le> f n x"
240.576 - apply (rule cInf_lower[where z="- h x"])
240.577 - defer
240.578 - apply (rule *)
240.579 - using assms(3)[rule_format,OF x]
240.580 - unfolding real_norm_def abs_le_iff
240.581 - apply auto
240.582 - done
240.583 - qed
240.584 + by (rule integral_le[OF dec1(1) assms(1)]) (auto intro!: cInf_lower)
240.585 show "integral s (f n) \<le> integral s (\<lambda>x. Sup {f j x |j. n \<le> j})"
240.586 - proof (rule integral_le[OF assms(1) inc1(1)], safe)
240.587 - fix x
240.588 - assume x: "x \<in> s"
240.589 - show "f n x \<le> Sup {f j x |j. n \<le> j}"
240.590 - apply (rule cSup_upper[where z="h x"])
240.591 - defer
240.592 - using assms(3)[rule_format,OF x]
240.593 - unfolding real_norm_def abs_le_iff
240.594 - apply auto
240.595 - done
240.596 - qed
240.597 + by (rule integral_le[OF assms(1) inc1(1)]) (auto intro!: cSup_upper)
240.598 qed (insert n, auto)
240.599 qed
240.600 qed
241.1 --- a/src/HOL/Multivariate_Analysis/Linear_Algebra.thy Thu Dec 05 17:52:12 2013 +0100
241.2 +++ b/src/HOL/Multivariate_Analysis/Linear_Algebra.thy Thu Dec 05 17:58:03 2013 +0100
241.3 @@ -36,34 +36,6 @@
241.4 apply auto
241.5 done
241.6
241.7 -lemma real_le_lsqrt: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x \<le> y\<^sup>2 \<Longrightarrow> sqrt x \<le> y"
241.8 - using real_sqrt_le_iff[of x "y\<^sup>2"] by simp
241.9 -
241.10 -lemma real_le_rsqrt: "x\<^sup>2 \<le> y \<Longrightarrow> x \<le> sqrt y"
241.11 - using real_sqrt_le_mono[of "x\<^sup>2" y] by simp
241.12 -
241.13 -lemma real_less_rsqrt: "x\<^sup>2 < y \<Longrightarrow> x < sqrt y"
241.14 - using real_sqrt_less_mono[of "x\<^sup>2" y] by simp
241.15 -
241.16 -lemma sqrt_even_pow2:
241.17 - assumes n: "even n"
241.18 - shows "sqrt (2 ^ n) = 2 ^ (n div 2)"
241.19 -proof -
241.20 - from n obtain m where m: "n = 2 * m"
241.21 - unfolding even_mult_two_ex ..
241.22 - from m have "sqrt (2 ^ n) = sqrt ((2 ^ m)\<^sup>2)"
241.23 - by (simp only: power_mult[symmetric] mult_commute)
241.24 - then show ?thesis
241.25 - using m by simp
241.26 -qed
241.27 -
241.28 -lemma real_div_sqrt: "0 \<le> x \<Longrightarrow> x / sqrt x = sqrt x"
241.29 - apply (cases "x = 0")
241.30 - apply simp_all
241.31 - using sqrt_divide_self_eq[of x]
241.32 - apply (simp add: inverse_eq_divide field_simps)
241.33 - done
241.34 -
241.35 text{* Hence derive more interesting properties of the norm. *}
241.36
241.37 lemma norm_eq_0_dot: "norm x = 0 \<longleftrightarrow> x \<bullet> x = (0::real)"
241.38 @@ -303,7 +275,7 @@
241.39 by (metis linear_iff)
241.40
241.41 lemma linear_sub: "linear f \<Longrightarrow> f (x - y) = f x - f y"
241.42 - by (simp add: diff_minus linear_add linear_neg)
241.43 + using linear_add [of f x "- y"] by (simp add: linear_neg)
241.44
241.45 lemma linear_setsum:
241.46 assumes lin: "linear f"
241.47 @@ -365,10 +337,10 @@
241.48 by (simp add: bilinear_def linear_iff)
241.49
241.50 lemma bilinear_lneg: "bilinear h \<Longrightarrow> h (- x) y = - h x y"
241.51 - by (simp only: scaleR_minus1_left [symmetric] bilinear_lmul)
241.52 + by (drule bilinear_lmul [of _ "- 1"]) simp
241.53
241.54 lemma bilinear_rneg: "bilinear h \<Longrightarrow> h x (- y) = - h x y"
241.55 - by (simp only: scaleR_minus1_left [symmetric] bilinear_rmul)
241.56 + by (drule bilinear_rmul [of _ _ "- 1"]) simp
241.57
241.58 lemma (in ab_group_add) eq_add_iff: "x = x + y \<longleftrightarrow> y = 0"
241.59 using add_imp_eq[of x y 0] by auto
241.60 @@ -384,10 +356,10 @@
241.61 using bilinear_radd [OF assms, of x 0 0 ] by (simp add: eq_add_iff field_simps)
241.62
241.63 lemma bilinear_lsub: "bilinear h \<Longrightarrow> h (x - y) z = h x z - h y z"
241.64 - by (simp add: diff_minus bilinear_ladd bilinear_lneg)
241.65 + using bilinear_ladd [of h x "- y"] by (simp add: bilinear_lneg)
241.66
241.67 lemma bilinear_rsub: "bilinear h \<Longrightarrow> h z (x - y) = h z x - h z y"
241.68 - by (simp add: diff_minus bilinear_radd bilinear_rneg)
241.69 + using bilinear_radd [of h _ x "- y"] by (simp add: bilinear_rneg)
241.70
241.71 lemma bilinear_setsum:
241.72 assumes bh: "bilinear h"
241.73 @@ -730,7 +702,7 @@
241.74 by (metis scaleR_minus1_left subspace_mul)
241.75
241.76 lemma subspace_sub: "subspace S \<Longrightarrow> x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> x - y \<in> S"
241.77 - by (metis diff_minus subspace_add subspace_neg)
241.78 + using subspace_add [of S x "- y"] by (simp add: subspace_neg)
241.79
241.80 lemma (in real_vector) subspace_setsum:
241.81 assumes sA: "subspace A"
241.82 @@ -1021,8 +993,7 @@
241.83 apply safe
241.84 apply (rule_tac x=k in exI, simp)
241.85 apply (erule rev_image_eqI [OF SigmaI [OF rangeI]])
241.86 - apply simp
241.87 - apply (rule right_minus)
241.88 + apply auto
241.89 done
241.90 then show ?thesis by simp
241.91 qed
241.92 @@ -2064,7 +2035,7 @@
241.93 using C by simp
241.94 have "orthogonal ?a y"
241.95 unfolding orthogonal_def
241.96 - unfolding inner_diff inner_setsum_left diff_eq_0_iff_eq
241.97 + unfolding inner_diff inner_setsum_left right_minus_eq
241.98 unfolding setsum_diff1' [OF `finite C` `y \<in> C`]
241.99 apply (clarsimp simp add: inner_commute[of y a])
241.100 apply (rule setsum_0')
241.101 @@ -2407,58 +2378,6 @@
241.102
241.103 text {* Can construct an isomorphism between spaces of same dimension. *}
241.104
241.105 -lemma card_le_inj:
241.106 - assumes fA: "finite A"
241.107 - and fB: "finite B"
241.108 - and c: "card A \<le> card B"
241.109 - shows "\<exists>f. f ` A \<subseteq> B \<and> inj_on f A"
241.110 - using fA fB c
241.111 -proof (induct arbitrary: B rule: finite_induct)
241.112 - case empty
241.113 - then show ?case by simp
241.114 -next
241.115 - case (insert x s t)
241.116 - then show ?case
241.117 - proof (induct rule: finite_induct[OF "insert.prems"(1)])
241.118 - case 1
241.119 - then show ?case by simp
241.120 - next
241.121 - case (2 y t)
241.122 - from "2.prems"(1,2,5) "2.hyps"(1,2) have cst: "card s \<le> card t"
241.123 - by simp
241.124 - from "2.prems"(3) [OF "2.hyps"(1) cst]
241.125 - obtain f where "f ` s \<subseteq> t" "inj_on f s"
241.126 - by blast
241.127 - with "2.prems"(2) "2.hyps"(2) show ?case
241.128 - apply -
241.129 - apply (rule exI[where x = "\<lambda>z. if z = x then y else f z"])
241.130 - apply (auto simp add: inj_on_def)
241.131 - done
241.132 - qed
241.133 -qed
241.134 -
241.135 -lemma card_subset_eq:
241.136 - assumes fB: "finite B"
241.137 - and AB: "A \<subseteq> B"
241.138 - and c: "card A = card B"
241.139 - shows "A = B"
241.140 -proof -
241.141 - from fB AB have fA: "finite A"
241.142 - by (auto intro: finite_subset)
241.143 - from fA fB have fBA: "finite (B - A)"
241.144 - by auto
241.145 - have e: "A \<inter> (B - A) = {}"
241.146 - by blast
241.147 - have eq: "A \<union> (B - A) = B"
241.148 - using AB by blast
241.149 - from card_Un_disjoint[OF fA fBA e, unfolded eq c] have "card (B - A) = 0"
241.150 - by arith
241.151 - then have "B - A = {}"
241.152 - unfolding card_eq_0_iff using fA fB by simp
241.153 - with AB show "A = B"
241.154 - by blast
241.155 -qed
241.156 -
241.157 lemma subspace_isomorphism:
241.158 fixes S :: "'a::euclidean_space set"
241.159 and T :: "'b::euclidean_space set"
241.160 @@ -3026,7 +2945,7 @@
241.161 norm x * (norm y * (y \<bullet> x) - norm x * norm y * norm y) = 0)"
241.162 using x y
241.163 unfolding inner_simps
241.164 - unfolding power2_norm_eq_inner[symmetric] power2_eq_square diff_eq_0_iff_eq
241.165 + unfolding power2_norm_eq_inner[symmetric] power2_eq_square right_minus_eq
241.166 apply (simp add: inner_commute)
241.167 apply (simp add: field_simps)
241.168 apply metis
242.1 --- a/src/HOL/Multivariate_Analysis/Operator_Norm.thy Thu Dec 05 17:52:12 2013 +0100
242.2 +++ b/src/HOL/Multivariate_Analysis/Operator_Norm.thy Thu Dec 05 17:58:03 2013 +0100
242.3 @@ -8,7 +8,7 @@
242.4 imports Linear_Algebra
242.5 begin
242.6
242.7 -definition "onorm f = Sup {norm (f x)| x. norm x = 1}"
242.8 +definition "onorm f = (SUP x:{x. norm x = 1}. norm (f x))"
242.9
242.10 lemma norm_bound_generalize:
242.11 fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
242.12 @@ -67,25 +67,22 @@
242.13 shows "norm (f x) \<le> onorm f * norm x"
242.14 and "\<forall>x. norm (f x) \<le> b * norm x \<Longrightarrow> onorm f \<le> b"
242.15 proof -
242.16 - let ?S = "{norm (f x) |x. norm x = 1}"
242.17 + let ?S = "(\<lambda>x. norm (f x))`{x. norm x = 1}"
242.18 have "norm (f (SOME i. i \<in> Basis)) \<in> ?S"
242.19 by (auto intro!: exI[of _ "SOME i. i \<in> Basis"] norm_Basis SOME_Basis)
242.20 then have Se: "?S \<noteq> {}"
242.21 by auto
242.22 - from linear_bounded[OF lf] have b: "\<exists> b. ?S *<= b"
242.23 - unfolding norm_bound_generalize[OF lf, symmetric]
242.24 - by (auto simp add: setle_def)
242.25 - from isLub_cSup[OF Se b, unfolded onorm_def[symmetric]]
242.26 - show "norm (f x) \<le> onorm f * norm x"
242.27 + from linear_bounded[OF lf] have b: "bdd_above ?S"
242.28 + unfolding norm_bound_generalize[OF lf, symmetric] by auto
242.29 + then show "norm (f x) \<le> onorm f * norm x"
242.30 apply -
242.31 apply (rule spec[where x = x])
242.32 unfolding norm_bound_generalize[OF lf, symmetric]
242.33 - apply (auto simp add: isLub_def isUb_def leastP_def setge_def setle_def)
242.34 + apply (auto simp: onorm_def intro!: cSUP_upper)
242.35 done
242.36 show "\<forall>x. norm (f x) \<le> b * norm x \<Longrightarrow> onorm f \<le> b"
242.37 - using isLub_cSup[OF Se b, unfolded onorm_def[symmetric]]
242.38 unfolding norm_bound_generalize[OF lf, symmetric]
242.39 - by (auto simp add: isLub_def isUb_def leastP_def setge_def setle_def)
242.40 + using Se by (auto simp: onorm_def intro!: cSUP_least b)
242.41 qed
242.42
242.43 lemma onorm_pos_le:
242.44 @@ -107,18 +104,8 @@
242.45 apply arith
242.46 done
242.47
242.48 -lemma onorm_const:
242.49 - "onorm (\<lambda>x::'a::euclidean_space. y::'b::euclidean_space) = norm y"
242.50 -proof -
242.51 - let ?f = "\<lambda>x::'a. y::'b"
242.52 - have th: "{norm (?f x)| x. norm x = 1} = {norm y}"
242.53 - by (auto simp: SOME_Basis intro!: exI[of _ "SOME i. i \<in> Basis"])
242.54 - show ?thesis
242.55 - unfolding onorm_def th
242.56 - apply (rule cSup_unique)
242.57 - apply (simp_all add: setle_def)
242.58 - done
242.59 -qed
242.60 +lemma onorm_const: "onorm (\<lambda>x::'a::euclidean_space. y::'b::euclidean_space) = norm y"
242.61 + using SOME_Basis by (auto simp add: onorm_def intro!: cSUP_const norm_Basis)
242.62
242.63 lemma onorm_pos_lt:
242.64 fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
243.1 --- a/src/HOL/Multivariate_Analysis/Topology_Euclidean_Space.thy Thu Dec 05 17:52:12 2013 +0100
243.2 +++ b/src/HOL/Multivariate_Analysis/Topology_Euclidean_Space.thy Thu Dec 05 17:58:03 2013 +0100
243.3 @@ -10,7 +10,6 @@
243.4 imports
243.5 Complex_Main
243.6 "~~/src/HOL/Library/Countable_Set"
243.7 - "~~/src/HOL/Library/Glbs"
243.8 "~~/src/HOL/Library/FuncSet"
243.9 Linear_Algebra
243.10 Norm_Arith
243.11 @@ -28,8 +27,6 @@
243.12 lemma lim_subseq: "subseq r \<Longrightarrow> s ----> l \<Longrightarrow> (s \<circ> r) ----> l"
243.13 by (rule LIMSEQ_subseq_LIMSEQ)
243.14
243.15 -lemmas real_isGlb_unique = isGlb_unique[where 'a=real]
243.16 -
243.17 lemma countable_PiE:
243.18 "finite I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> countable (F i)) \<Longrightarrow> countable (PiE I F)"
243.19 by (induct I arbitrary: F rule: finite_induct) (auto simp: PiE_insert_eq)
243.20 @@ -789,18 +786,20 @@
243.21 "a - b \<ge> c \<longleftrightarrow> a \<ge> c + b"
243.22 by arith+
243.23
243.24 -lemma open_ball[intro, simp]: "open (ball x e)"
243.25 - unfolding open_dist ball_def mem_Collect_eq Ball_def
243.26 - unfolding dist_commute
243.27 - apply clarify
243.28 - apply (rule_tac x="e - dist xa x" in exI)
243.29 - using dist_triangle_alt[where z=x]
243.30 - apply (clarsimp simp add: diff_less_iff)
243.31 - apply atomize
243.32 - apply (erule_tac x="y" in allE)
243.33 - apply (erule_tac x="xa" in allE)
243.34 - apply arith
243.35 - done
243.36 +lemma open_vimage: (* TODO: move to Topological_Spaces.thy *)
243.37 + assumes "open s" and "continuous_on UNIV f"
243.38 + shows "open (vimage f s)"
243.39 + using assms unfolding continuous_on_open_vimage [OF open_UNIV]
243.40 + by simp
243.41 +
243.42 +lemma open_ball [intro, simp]: "open (ball x e)"
243.43 +proof -
243.44 + have "open (dist x -` {..<e})"
243.45 + by (intro open_vimage open_lessThan continuous_on_intros)
243.46 + also have "dist x -` {..<e} = ball x e"
243.47 + by auto
243.48 + finally show ?thesis .
243.49 +qed
243.50
243.51 lemma open_contains_ball: "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. ball x e \<subseteq> S)"
243.52 unfolding open_dist subset_eq mem_ball Ball_def dist_commute ..
243.53 @@ -1553,7 +1552,7 @@
243.54 fix y
243.55 assume "y \<in> {x<..} \<inter> I"
243.56 with False bnd have "Inf (f ` ({x<..} \<inter> I)) \<le> f y"
243.57 - by (auto intro: cInf_lower)
243.58 + by (auto intro!: cInf_lower bdd_belowI2)
243.59 with a have "a < f y"
243.60 by (blast intro: less_le_trans)
243.61 }
243.62 @@ -1889,7 +1888,6 @@
243.63 lemma closed_sequential_limits:
243.64 fixes S :: "'a::first_countable_topology set"
243.65 shows "closed S \<longleftrightarrow> (\<forall>x l. (\<forall>n. x n \<in> S) \<and> (x ---> l) sequentially \<longrightarrow> l \<in> S)"
243.66 - unfolding closed_limpt
243.67 using closure_sequential [where 'a='a] closure_closed [where 'a='a]
243.68 closed_limpt [where 'a='a] islimpt_sequential [where 'a='a] mem_delete [where 'a='a]
243.69 by metis
243.70 @@ -1908,17 +1906,17 @@
243.71
243.72 lemma closure_contains_Inf:
243.73 fixes S :: "real set"
243.74 - assumes "S \<noteq> {}" "\<forall>x\<in>S. B \<le> x"
243.75 + assumes "S \<noteq> {}" "bdd_below S"
243.76 shows "Inf S \<in> closure S"
243.77 proof -
243.78 have *: "\<forall>x\<in>S. Inf S \<le> x"
243.79 - using cInf_lower_EX[of _ S] assms by metis
243.80 + using cInf_lower[of _ S] assms by metis
243.81 {
243.82 fix e :: real
243.83 assume "e > 0"
243.84 then have "Inf S < Inf S + e" by simp
243.85 with assms obtain x where "x \<in> S" "x < Inf S + e"
243.86 - by (subst (asm) cInf_less_iff[of _ B]) auto
243.87 + by (subst (asm) cInf_less_iff) auto
243.88 with * have "\<exists>x\<in>S. dist x (Inf S) < e"
243.89 by (intro bexI[of _ x]) (auto simp add: dist_real_def)
243.90 }
243.91 @@ -1927,12 +1925,9 @@
243.92
243.93 lemma closed_contains_Inf:
243.94 fixes S :: "real set"
243.95 - assumes "S \<noteq> {}" "\<forall>x\<in>S. B \<le> x"
243.96 - and "closed S"
243.97 - shows "Inf S \<in> S"
243.98 + shows "S \<noteq> {} \<Longrightarrow> bdd_below S \<Longrightarrow> closed S \<Longrightarrow> Inf S \<in> S"
243.99 by (metis closure_contains_Inf closure_closed assms)
243.100
243.101 -
243.102 lemma not_trivial_limit_within_ball:
243.103 "\<not> trivial_limit (at x within S) \<longleftrightarrow> (\<forall>e>0. S \<inter> ball x e - {x} \<noteq> {})"
243.104 (is "?lhs = ?rhs")
243.105 @@ -1974,29 +1969,25 @@
243.106
243.107 subsection {* Infimum Distance *}
243.108
243.109 -definition "infdist x A = (if A = {} then 0 else Inf {dist x a|a. a \<in> A})"
243.110 -
243.111 -lemma infdist_notempty: "A \<noteq> {} \<Longrightarrow> infdist x A = Inf {dist x a|a. a \<in> A}"
243.112 +definition "infdist x A = (if A = {} then 0 else INF a:A. dist x a)"
243.113 +
243.114 +lemma bdd_below_infdist[intro, simp]: "bdd_below (dist x`A)"
243.115 + by (auto intro!: zero_le_dist)
243.116 +
243.117 +lemma infdist_notempty: "A \<noteq> {} \<Longrightarrow> infdist x A = (INF a:A. dist x a)"
243.118 by (simp add: infdist_def)
243.119
243.120 lemma infdist_nonneg: "0 \<le> infdist x A"
243.121 - by (auto simp add: infdist_def intro: cInf_greatest)
243.122 -
243.123 -lemma infdist_le:
243.124 - assumes "a \<in> A"
243.125 - and "d = dist x a"
243.126 - shows "infdist x A \<le> d"
243.127 - using assms by (auto intro!: cInf_lower[where z=0] simp add: infdist_def)
243.128 -
243.129 -lemma infdist_zero[simp]:
243.130 - assumes "a \<in> A"
243.131 - shows "infdist a A = 0"
243.132 -proof -
243.133 - from infdist_le[OF assms, of "dist a a"] have "infdist a A \<le> 0"
243.134 - by auto
243.135 - with infdist_nonneg[of a A] assms show "infdist a A = 0"
243.136 - by auto
243.137 -qed
243.138 + by (auto simp add: infdist_def intro: cINF_greatest)
243.139 +
243.140 +lemma infdist_le: "a \<in> A \<Longrightarrow> infdist x A \<le> dist x a"
243.141 + by (auto intro: cINF_lower simp add: infdist_def)
243.142 +
243.143 +lemma infdist_le2: "a \<in> A \<Longrightarrow> dist x a \<le> d \<Longrightarrow> infdist x A \<le> d"
243.144 + by (auto intro!: cINF_lower2 simp add: infdist_def)
243.145 +
243.146 +lemma infdist_zero[simp]: "a \<in> A \<Longrightarrow> infdist a A = 0"
243.147 + by (auto intro!: antisym infdist_nonneg infdist_le2)
243.148
243.149 lemma infdist_triangle: "infdist x A \<le> infdist y A + dist x y"
243.150 proof (cases "A = {}")
243.151 @@ -2015,18 +2006,11 @@
243.152 by auto
243.153 show "infdist x A \<le> d"
243.154 unfolding infdist_notempty[OF `A \<noteq> {}`]
243.155 - proof (rule cInf_lower2)
243.156 - show "dist x a \<in> {dist x a |a. a \<in> A}"
243.157 - using `a \<in> A` by auto
243.158 + proof (rule cINF_lower2)
243.159 + show "a \<in> A" by fact
243.160 show "dist x a \<le> d"
243.161 unfolding d by (rule dist_triangle)
243.162 - fix d
243.163 - assume "d \<in> {dist x a |a. a \<in> A}"
243.164 - then obtain a where "a \<in> A" "d = dist x a"
243.165 - by auto
243.166 - then show "infdist x A \<le> d"
243.167 - by (rule infdist_le)
243.168 - qed
243.169 + qed simp
243.170 qed
243.171 also have "\<dots> = dist x y + infdist y A"
243.172 proof (rule cInf_eq, safe)
243.173 @@ -2039,7 +2023,7 @@
243.174 assume inf: "\<And>d. d \<in> {dist x y + dist y a |a. a \<in> A} \<Longrightarrow> i \<le> d"
243.175 then have "i - dist x y \<le> infdist y A"
243.176 unfolding infdist_notempty[OF `A \<noteq> {}`] using `a \<in> A`
243.177 - by (intro cInf_greatest) (auto simp: field_simps)
243.178 + by (intro cINF_greatest) (auto simp: field_simps)
243.179 then show "i \<le> dist x y + infdist y A"
243.180 by simp
243.181 qed
243.182 @@ -2078,7 +2062,7 @@
243.183 assume "\<not> (\<exists>y\<in>A. dist y x < e)"
243.184 then have "infdist x A \<ge> e" using `a \<in> A`
243.185 unfolding infdist_def
243.186 - by (force simp: dist_commute intro: cInf_greatest)
243.187 + by (force simp: dist_commute intro: cINF_greatest)
243.188 with x `e > 0` show False by auto
243.189 qed
243.190 qed
243.191 @@ -2129,15 +2113,20 @@
243.192
243.193 subsection {* More properties of closed balls *}
243.194
243.195 +lemma closed_vimage: (* TODO: move to Topological_Spaces.thy *)
243.196 + assumes "closed s" and "continuous_on UNIV f"
243.197 + shows "closed (vimage f s)"
243.198 + using assms unfolding continuous_on_closed_vimage [OF closed_UNIV]
243.199 + by simp
243.200 +
243.201 lemma closed_cball: "closed (cball x e)"
243.202 - unfolding cball_def closed_def
243.203 - unfolding Collect_neg_eq [symmetric] not_le
243.204 - apply (clarsimp simp add: open_dist, rename_tac y)
243.205 - apply (rule_tac x="dist x y - e" in exI, clarsimp)
243.206 - apply (rename_tac x')
243.207 - apply (cut_tac x=x and y=x' and z=y in dist_triangle)
243.208 - apply simp
243.209 - done
243.210 +proof -
243.211 + have "closed (dist x -` {..e})"
243.212 + by (intro closed_vimage closed_atMost continuous_on_intros)
243.213 + also have "dist x -` {..e} = cball x e"
243.214 + by auto
243.215 + finally show ?thesis .
243.216 +qed
243.217
243.218 lemma open_contains_cball: "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. cball x e \<subseteq> S)"
243.219 proof -
243.220 @@ -2645,11 +2634,19 @@
243.221
243.222 text{* Some theorems on sups and infs using the notion "bounded". *}
243.223
243.224 -lemma bounded_real:
243.225 - fixes S :: "real set"
243.226 - shows "bounded S \<longleftrightarrow> (\<exists>a. \<forall>x\<in>S. abs x \<le> a)"
243.227 +lemma bounded_real: "bounded (S::real set) \<longleftrightarrow> (\<exists>a. \<forall>x\<in>S. \<bar>x\<bar> \<le> a)"
243.228 by (simp add: bounded_iff)
243.229
243.230 +lemma bounded_imp_bdd_above: "bounded S \<Longrightarrow> bdd_above (S :: real set)"
243.231 + by (auto simp: bounded_def bdd_above_def dist_real_def)
243.232 + (metis abs_le_D1 abs_minus_commute diff_le_eq)
243.233 +
243.234 +lemma bounded_imp_bdd_below: "bounded S \<Longrightarrow> bdd_below (S :: real set)"
243.235 + by (auto simp: bounded_def bdd_below_def dist_real_def)
243.236 + (metis abs_le_D1 add_commute diff_le_eq)
243.237 +
243.238 +(* TODO: remove the following lemmas about Inf and Sup, is now in conditionally complete lattice *)
243.239 +
243.240 lemma bounded_has_Sup:
243.241 fixes S :: "real set"
243.242 assumes "bounded S"
243.243 @@ -2657,22 +2654,14 @@
243.244 shows "\<forall>x\<in>S. x \<le> Sup S"
243.245 and "\<forall>b. (\<forall>x\<in>S. x \<le> b) \<longrightarrow> Sup S \<le> b"
243.246 proof
243.247 - fix x
243.248 - assume "x\<in>S"
243.249 - then show "x \<le> Sup S"
243.250 - by (metis cSup_upper abs_le_D1 assms(1) bounded_real)
243.251 -next
243.252 show "\<forall>b. (\<forall>x\<in>S. x \<le> b) \<longrightarrow> Sup S \<le> b"
243.253 using assms by (metis cSup_least)
243.254 -qed
243.255 +qed (metis cSup_upper assms(1) bounded_imp_bdd_above)
243.256
243.257 lemma Sup_insert:
243.258 fixes S :: "real set"
243.259 shows "bounded S \<Longrightarrow> Sup (insert x S) = (if S = {} then x else max x (Sup S))"
243.260 - apply (subst cSup_insert_If)
243.261 - apply (rule bounded_has_Sup(1)[of S, rule_format])
243.262 - apply (auto simp: sup_max)
243.263 - done
243.264 + by (auto simp: bounded_imp_bdd_above sup_max cSup_insert_If)
243.265
243.266 lemma Sup_insert_finite:
243.267 fixes S :: "real set"
243.268 @@ -2689,24 +2678,14 @@
243.269 shows "\<forall>x\<in>S. x \<ge> Inf S"
243.270 and "\<forall>b. (\<forall>x\<in>S. x \<ge> b) \<longrightarrow> Inf S \<ge> b"
243.271 proof
243.272 - fix x
243.273 - assume "x \<in> S"
243.274 - from assms(1) obtain a where a: "\<forall>x\<in>S. \<bar>x\<bar> \<le> a"
243.275 - unfolding bounded_real by auto
243.276 - then show "x \<ge> Inf S" using `x \<in> S`
243.277 - by (metis cInf_lower_EX abs_le_D2 minus_le_iff)
243.278 -next
243.279 show "\<forall>b. (\<forall>x\<in>S. x \<ge> b) \<longrightarrow> Inf S \<ge> b"
243.280 using assms by (metis cInf_greatest)
243.281 -qed
243.282 +qed (metis cInf_lower assms(1) bounded_imp_bdd_below)
243.283
243.284 lemma Inf_insert:
243.285 fixes S :: "real set"
243.286 shows "bounded S \<Longrightarrow> Inf (insert x S) = (if S = {} then x else min x (Inf S))"
243.287 - apply (subst cInf_insert_if)
243.288 - apply (rule bounded_has_Inf(1)[of S, rule_format])
243.289 - apply (auto simp: inf_min)
243.290 - done
243.291 + by (auto simp: bounded_imp_bdd_below inf_min cInf_insert_If)
243.292
243.293 lemma Inf_insert_finite:
243.294 fixes S :: "real set"
243.295 @@ -3298,6 +3277,50 @@
243.296 where "seq_compact S \<longleftrightarrow>
243.297 (\<forall>f. (\<forall>n. f n \<in> S) \<longrightarrow> (\<exists>l\<in>S. \<exists>r. subseq r \<and> ((f \<circ> r) ---> l) sequentially))"
243.298
243.299 +lemma seq_compactI:
243.300 + assumes "\<And>f. \<forall>n. f n \<in> S \<Longrightarrow> \<exists>l\<in>S. \<exists>r. subseq r \<and> ((f \<circ> r) ---> l) sequentially"
243.301 + shows "seq_compact S"
243.302 + unfolding seq_compact_def using assms by fast
243.303 +
243.304 +lemma seq_compactE:
243.305 + assumes "seq_compact S" "\<forall>n. f n \<in> S"
243.306 + obtains l r where "l \<in> S" "subseq r" "((f \<circ> r) ---> l) sequentially"
243.307 + using assms unfolding seq_compact_def by fast
243.308 +
243.309 +lemma closed_sequentially: (* TODO: move upwards *)
243.310 + assumes "closed s" and "\<forall>n. f n \<in> s" and "f ----> l"
243.311 + shows "l \<in> s"
243.312 +proof (rule ccontr)
243.313 + assume "l \<notin> s"
243.314 + with `closed s` and `f ----> l` have "eventually (\<lambda>n. f n \<in> - s) sequentially"
243.315 + by (fast intro: topological_tendstoD)
243.316 + with `\<forall>n. f n \<in> s` show "False"
243.317 + by simp
243.318 +qed
243.319 +
243.320 +lemma seq_compact_inter_closed:
243.321 + assumes "seq_compact s" and "closed t"
243.322 + shows "seq_compact (s \<inter> t)"
243.323 +proof (rule seq_compactI)
243.324 + fix f assume "\<forall>n::nat. f n \<in> s \<inter> t"
243.325 + hence "\<forall>n. f n \<in> s" and "\<forall>n. f n \<in> t"
243.326 + by simp_all
243.327 + from `seq_compact s` and `\<forall>n. f n \<in> s`
243.328 + obtain l r where "l \<in> s" and r: "subseq r" and l: "(f \<circ> r) ----> l"
243.329 + by (rule seq_compactE)
243.330 + from `\<forall>n. f n \<in> t` have "\<forall>n. (f \<circ> r) n \<in> t"
243.331 + by simp
243.332 + from `closed t` and this and l have "l \<in> t"
243.333 + by (rule closed_sequentially)
243.334 + with `l \<in> s` and r and l show "\<exists>l\<in>s \<inter> t. \<exists>r. subseq r \<and> (f \<circ> r) ----> l"
243.335 + by fast
243.336 +qed
243.337 +
243.338 +lemma seq_compact_closed_subset:
243.339 + assumes "closed s" and "s \<subseteq> t" and "seq_compact t"
243.340 + shows "seq_compact s"
243.341 + using assms seq_compact_inter_closed [of t s] by (simp add: Int_absorb1)
243.342 +
243.343 lemma seq_compact_imp_countably_compact:
243.344 fixes U :: "'a :: first_countable_topology set"
243.345 assumes "seq_compact U"
243.346 @@ -3410,16 +3433,6 @@
243.347 using `x \<in> U` by (auto simp: convergent_def comp_def)
243.348 qed
243.349
243.350 -lemma seq_compactI:
243.351 - assumes "\<And>f. \<forall>n. f n \<in> S \<Longrightarrow> \<exists>l\<in>S. \<exists>r. subseq r \<and> ((f \<circ> r) ---> l) sequentially"
243.352 - shows "seq_compact S"
243.353 - unfolding seq_compact_def using assms by fast
243.354 -
243.355 -lemma seq_compactE:
243.356 - assumes "seq_compact S" "\<forall>n. f n \<in> S"
243.357 - obtains l r where "l \<in> S" "subseq r" "((f \<circ> r) ---> l) sequentially"
243.358 - using assms unfolding seq_compact_def by fast
243.359 -
243.360 lemma countably_compact_imp_acc_point:
243.361 assumes "countably_compact s"
243.362 and "countable t"
243.363 @@ -3654,6 +3667,8 @@
243.364 "\<forall>t. infinite t \<and> t \<subseteq> s \<longrightarrow> (\<exists>x \<in> s. x islimpt t) \<Longrightarrow> bounded s"
243.365 using compact_imp_bounded unfolding compact_eq_bolzano_weierstrass .
243.366
243.367 +subsection {* Metric spaces with the Heine-Borel property *}
243.368 +
243.369 text {*
243.370 A metric space (or topological vector space) is said to have the
243.371 Heine-Borel property if every closed and bounded subset is compact.
243.372 @@ -3678,7 +3693,7 @@
243.373 from f have fr: "\<forall>n. (f \<circ> r) n \<in> s"
243.374 by simp
243.375 have "l \<in> s" using `closed s` fr l
243.376 - unfolding closed_sequential_limits by blast
243.377 + by (rule closed_sequentially)
243.378 show "\<exists>l\<in>s. \<exists>r. subseq r \<and> ((f \<circ> r) ---> l) sequentially"
243.379 using `l \<in> s` r l by blast
243.380 qed
243.381 @@ -3859,11 +3874,21 @@
243.382 using l r by fast
243.383 qed
243.384
243.385 -subsubsection{* Completeness *}
243.386 +subsubsection {* Completeness *}
243.387
243.388 definition complete :: "'a::metric_space set \<Rightarrow> bool"
243.389 where "complete s \<longleftrightarrow> (\<forall>f. (\<forall>n. f n \<in> s) \<and> Cauchy f \<longrightarrow> (\<exists>l\<in>s. f ----> l))"
243.390
243.391 +lemma completeI:
243.392 + assumes "\<And>f. \<forall>n. f n \<in> s \<Longrightarrow> Cauchy f \<Longrightarrow> \<exists>l\<in>s. f ----> l"
243.393 + shows "complete s"
243.394 + using assms unfolding complete_def by fast
243.395 +
243.396 +lemma completeE:
243.397 + assumes "complete s" and "\<forall>n. f n \<in> s" and "Cauchy f"
243.398 + obtains l where "l \<in> s" and "f ----> l"
243.399 + using assms unfolding complete_def by fast
243.400 +
243.401 lemma compact_imp_complete:
243.402 assumes "compact s"
243.403 shows "complete s"
243.404 @@ -4085,49 +4110,57 @@
243.405
243.406 instance euclidean_space \<subseteq> banach ..
243.407
243.408 -lemma complete_univ: "complete (UNIV :: 'a::complete_space set)"
243.409 -proof (simp add: complete_def, rule, rule)
243.410 - fix f :: "nat \<Rightarrow> 'a"
243.411 - assume "Cauchy f"
243.412 +lemma complete_UNIV: "complete (UNIV :: ('a::complete_space) set)"
243.413 +proof (rule completeI)
243.414 + fix f :: "nat \<Rightarrow> 'a" assume "Cauchy f"
243.415 then have "convergent f" by (rule Cauchy_convergent)
243.416 - then show "\<exists>l. f ----> l" unfolding convergent_def .
243.417 + then show "\<exists>l\<in>UNIV. f ----> l" unfolding convergent_def by simp
243.418 qed
243.419
243.420 lemma complete_imp_closed:
243.421 assumes "complete s"
243.422 shows "closed s"
243.423 -proof -
243.424 - {
243.425 - fix x
243.426 - assume "x islimpt s"
243.427 - then obtain f where f: "\<forall>n. f n \<in> s - {x}" "(f ---> x) sequentially"
243.428 - unfolding islimpt_sequential by auto
243.429 - then obtain l where l: "l\<in>s" "(f ---> l) sequentially"
243.430 - using `complete s`[unfolded complete_def] using LIMSEQ_imp_Cauchy[of f x] by auto
243.431 - then have "x \<in> s"
243.432 - using tendsto_unique[of sequentially f l x] trivial_limit_sequentially f(2) by auto
243.433 - }
243.434 - then show "closed s" unfolding closed_limpt by auto
243.435 -qed
243.436 +proof (unfold closed_sequential_limits, clarify)
243.437 + fix f x assume "\<forall>n. f n \<in> s" and "f ----> x"
243.438 + from `f ----> x` have "Cauchy f"
243.439 + by (rule LIMSEQ_imp_Cauchy)
243.440 + with `complete s` and `\<forall>n. f n \<in> s` obtain l where "l \<in> s" and "f ----> l"
243.441 + by (rule completeE)
243.442 + from `f ----> x` and `f ----> l` have "x = l"
243.443 + by (rule LIMSEQ_unique)
243.444 + with `l \<in> s` show "x \<in> s"
243.445 + by simp
243.446 +qed
243.447 +
243.448 +lemma complete_inter_closed:
243.449 + assumes "complete s" and "closed t"
243.450 + shows "complete (s \<inter> t)"
243.451 +proof (rule completeI)
243.452 + fix f assume "\<forall>n. f n \<in> s \<inter> t" and "Cauchy f"
243.453 + then have "\<forall>n. f n \<in> s" and "\<forall>n. f n \<in> t"
243.454 + by simp_all
243.455 + from `complete s` obtain l where "l \<in> s" and "f ----> l"
243.456 + using `\<forall>n. f n \<in> s` and `Cauchy f` by (rule completeE)
243.457 + from `closed t` and `\<forall>n. f n \<in> t` and `f ----> l` have "l \<in> t"
243.458 + by (rule closed_sequentially)
243.459 + with `l \<in> s` and `f ----> l` show "\<exists>l\<in>s \<inter> t. f ----> l"
243.460 + by fast
243.461 +qed
243.462 +
243.463 +lemma complete_closed_subset:
243.464 + assumes "closed s" and "s \<subseteq> t" and "complete t"
243.465 + shows "complete s"
243.466 + using assms complete_inter_closed [of t s] by (simp add: Int_absorb1)
243.467
243.468 lemma complete_eq_closed:
243.469 - fixes s :: "'a::complete_space set"
243.470 - shows "complete s \<longleftrightarrow> closed s" (is "?lhs = ?rhs")
243.471 + fixes s :: "('a::complete_space) set"
243.472 + shows "complete s \<longleftrightarrow> closed s"
243.473 proof
243.474 - assume ?lhs
243.475 - then show ?rhs by (rule complete_imp_closed)
243.476 + assume "closed s" then show "complete s"
243.477 + using subset_UNIV complete_UNIV by (rule complete_closed_subset)
243.478 next
243.479 - assume ?rhs
243.480 - {
243.481 - fix f
243.482 - assume as:"\<forall>n::nat. f n \<in> s" "Cauchy f"
243.483 - then obtain l where "(f ---> l) sequentially"
243.484 - using complete_univ[unfolded complete_def, THEN spec[where x=f]] by auto
243.485 - then have "\<exists>l\<in>s. (f ---> l) sequentially"
243.486 - using `?rhs`[unfolded closed_sequential_limits, THEN spec[where x=f], THEN spec[where x=l]]
243.487 - using as(1) by auto
243.488 - }
243.489 - then show ?lhs unfolding complete_def by auto
243.490 + assume "complete s" then show "closed s"
243.491 + by (rule complete_imp_closed)
243.492 qed
243.493
243.494 lemma convergent_eq_cauchy:
243.495 @@ -4142,13 +4175,13 @@
243.496
243.497 lemma compact_cball[simp]:
243.498 fixes x :: "'a::heine_borel"
243.499 - shows "compact(cball x e)"
243.500 + shows "compact (cball x e)"
243.501 using compact_eq_bounded_closed bounded_cball closed_cball
243.502 by blast
243.503
243.504 lemma compact_frontier_bounded[intro]:
243.505 fixes s :: "'a::heine_borel set"
243.506 - shows "bounded s \<Longrightarrow> compact(frontier s)"
243.507 + shows "bounded s \<Longrightarrow> compact (frontier s)"
243.508 unfolding frontier_def
243.509 using compact_eq_bounded_closed
243.510 by blast
243.511 @@ -4168,68 +4201,51 @@
243.512 subsection {* Bounded closed nest property (proof does not use Heine-Borel) *}
243.513
243.514 lemma bounded_closed_nest:
243.515 - assumes "\<forall>n. closed(s n)"
243.516 - and "\<forall>n. (s n \<noteq> {})"
243.517 - and "(\<forall>m n. m \<le> n --> s n \<subseteq> s m)"
243.518 - and "bounded(s 0)"
243.519 - shows "\<exists>a::'a::heine_borel. \<forall>n::nat. a \<in> s(n)"
243.520 + fixes s :: "nat \<Rightarrow> ('a::heine_borel) set"
243.521 + assumes "\<forall>n. closed (s n)"
243.522 + and "\<forall>n. s n \<noteq> {}"
243.523 + and "\<forall>m n. m \<le> n \<longrightarrow> s n \<subseteq> s m"
243.524 + and "bounded (s 0)"
243.525 + shows "\<exists>a. \<forall>n. a \<in> s n"
243.526 proof -
243.527 - from assms(2) obtain x where x:"\<forall>n::nat. x n \<in> s n"
243.528 - using choice[of "\<lambda>n x. x\<in> s n"] by auto
243.529 - from assms(4,1) have *:"seq_compact (s 0)"
243.530 - using bounded_closed_imp_seq_compact[of "s 0"] by auto
243.531 -
243.532 - then obtain l r where lr:"l\<in>s 0" "subseq r" "((x \<circ> r) ---> l) sequentially"
243.533 - unfolding seq_compact_def
243.534 - apply (erule_tac x=x in allE)
243.535 - using x using assms(3)
243.536 - apply blast
243.537 - done
243.538 -
243.539 - {
243.540 + from assms(2) obtain x where x: "\<forall>n. x n \<in> s n"
243.541 + using choice[of "\<lambda>n x. x \<in> s n"] by auto
243.542 + from assms(4,1) have "seq_compact (s 0)"
243.543 + by (simp add: bounded_closed_imp_seq_compact)
243.544 + then obtain l r where lr: "l \<in> s 0" "subseq r" "(x \<circ> r) ----> l"
243.545 + using x and assms(3) unfolding seq_compact_def by blast
243.546 + have "\<forall>n. l \<in> s n"
243.547 + proof
243.548 fix n :: nat
243.549 - {
243.550 - fix e :: real
243.551 - assume "e>0"
243.552 - with lr(3) obtain N where N:"\<forall>m\<ge>N. dist ((x \<circ> r) m) l < e"
243.553 - unfolding LIMSEQ_def by auto
243.554 - then have "dist ((x \<circ> r) (max N n)) l < e" by auto
243.555 - moreover
243.556 - have "r (max N n) \<ge> n" using lr(2) using seq_suble[of r "max N n"]
243.557 - by auto
243.558 - then have "(x \<circ> r) (max N n) \<in> s n"
243.559 - using x
243.560 - apply (erule_tac x=n in allE)
243.561 - using x
243.562 - apply (erule_tac x="r (max N n)" in allE)
243.563 - using assms(3)
243.564 - apply (erule_tac x=n in allE)
243.565 - apply (erule_tac x="r (max N n)" in allE)
243.566 - apply auto
243.567 - done
243.568 - ultimately have "\<exists>y\<in>s n. dist y l < e"
243.569 - by auto
243.570 - }
243.571 - then have "l \<in> s n"
243.572 - using closed_approachable[of "s n" l] assms(1) by blast
243.573 - }
243.574 - then show ?thesis by auto
243.575 + have "closed (s n)"
243.576 + using assms(1) by simp
243.577 + moreover have "\<forall>i. (x \<circ> r) i \<in> s i"
243.578 + using x and assms(3) and lr(2) [THEN seq_suble] by auto
243.579 + then have "\<forall>i. (x \<circ> r) (i + n) \<in> s n"
243.580 + using assms(3) by (fast intro!: le_add2)
243.581 + moreover have "(\<lambda>i. (x \<circ> r) (i + n)) ----> l"
243.582 + using lr(3) by (rule LIMSEQ_ignore_initial_segment)
243.583 + ultimately show "l \<in> s n"
243.584 + by (rule closed_sequentially)
243.585 + qed
243.586 + then show ?thesis ..
243.587 qed
243.588
243.589 text {* Decreasing case does not even need compactness, just completeness. *}
243.590
243.591 lemma decreasing_closed_nest:
243.592 + fixes s :: "nat \<Rightarrow> ('a::complete_space) set"
243.593 assumes
243.594 - "\<forall>n. closed(s n)"
243.595 - "\<forall>n. (s n \<noteq> {})"
243.596 - "\<forall>m n. m \<le> n --> s n \<subseteq> s m"
243.597 - "\<forall>e>0. \<exists>n. \<forall>x \<in> (s n). \<forall> y \<in> (s n). dist x y < e"
243.598 - shows "\<exists>a::'a::complete_space. \<forall>n::nat. a \<in> s n"
243.599 -proof-
243.600 - have "\<forall>n. \<exists> x. x\<in>s n"
243.601 + "\<forall>n. closed (s n)"
243.602 + "\<forall>n. s n \<noteq> {}"
243.603 + "\<forall>m n. m \<le> n \<longrightarrow> s n \<subseteq> s m"
243.604 + "\<forall>e>0. \<exists>n. \<forall>x\<in>s n. \<forall>y\<in>s n. dist x y < e"
243.605 + shows "\<exists>a. \<forall>n. a \<in> s n"
243.606 +proof -
243.607 + have "\<forall>n. \<exists>x. x \<in> s n"
243.608 using assms(2) by auto
243.609 then have "\<exists>t. \<forall>n. t n \<in> s n"
243.610 - using choice[of "\<lambda> n x. x \<in> s n"] by auto
243.611 + using choice[of "\<lambda>n x. x \<in> s n"] by auto
243.612 then obtain t where t: "\<forall>n. t n \<in> s n" by auto
243.613 {
243.614 fix e :: real
243.615 @@ -4250,7 +4266,7 @@
243.616 then have "Cauchy t"
243.617 unfolding cauchy_def by auto
243.618 then obtain l where l:"(t ---> l) sequentially"
243.619 - using complete_univ unfolding complete_def by auto
243.620 + using complete_UNIV unfolding complete_def by auto
243.621 {
243.622 fix n :: nat
243.623 {
243.624 @@ -4285,7 +4301,7 @@
243.625 assumes
243.626 "\<forall>n. closed(s n)"
243.627 "\<forall>n. s n \<noteq> {}"
243.628 - "\<forall>m n. m \<le> n --> s n \<subseteq> s m"
243.629 + "\<forall>m n. m \<le> n \<longrightarrow> s n \<subseteq> s m"
243.630 "\<forall>e>0. \<exists>n. \<forall>x \<in> (s n). \<forall> y\<in>(s n). dist x y < e"
243.631 shows "\<exists>a. \<Inter>(range s) = {a}"
243.632 proof -
243.633 @@ -4815,8 +4831,8 @@
243.634 assumes "uniformly_continuous_on s f"
243.635 and "uniformly_continuous_on s g"
243.636 shows "uniformly_continuous_on s (\<lambda>x. f x - g x)"
243.637 - unfolding ab_diff_minus using assms
243.638 - by (intro uniformly_continuous_on_add uniformly_continuous_on_minus)
243.639 + using assms uniformly_continuous_on_add [of s f "- g"]
243.640 + by (simp add: fun_Compl_def uniformly_continuous_on_minus)
243.641
243.642 text{* Continuity of all kinds is preserved under composition. *}
243.643
243.644 @@ -5147,9 +5163,8 @@
243.645
243.646 lemma open_negations:
243.647 fixes s :: "'a::real_normed_vector set"
243.648 - shows "open s \<Longrightarrow> open ((\<lambda> x. -x) ` s)"
243.649 - unfolding scaleR_minus1_left [symmetric]
243.650 - by (rule open_scaling, auto)
243.651 + shows "open s \<Longrightarrow> open ((\<lambda>x. - x) ` s)"
243.652 + using open_scaling [of "- 1" s] by simp
243.653
243.654 lemma open_translation:
243.655 fixes s :: "'a::real_normed_vector set"
243.656 @@ -5637,8 +5652,6 @@
243.657 apply auto
243.658 apply (rule_tac x= xa in exI)
243.659 apply auto
243.660 - apply (rule_tac x=xa in exI)
243.661 - apply auto
243.662 done
243.663 then show ?thesis
243.664 using compact_sums[OF assms(1) compact_negations[OF assms(2)]] by auto
243.665 @@ -5686,24 +5699,27 @@
243.666
243.667 text {* We can state this in terms of diameter of a set. *}
243.668
243.669 -definition "diameter s = (if s = {} then 0::real else Sup {dist x y | x y. x \<in> s \<and> y \<in> s})"
243.670 +definition diameter :: "'a::metric_space set \<Rightarrow> real" where
243.671 + "diameter S = (if S = {} then 0 else SUP (x,y):S\<times>S. dist x y)"
243.672
243.673 lemma diameter_bounded_bound:
243.674 fixes s :: "'a :: metric_space set"
243.675 assumes s: "bounded s" "x \<in> s" "y \<in> s"
243.676 shows "dist x y \<le> diameter s"
243.677 proof -
243.678 - let ?D = "{dist x y |x y. x \<in> s \<and> y \<in> s}"
243.679 from s obtain z d where z: "\<And>x. x \<in> s \<Longrightarrow> dist z x \<le> d"
243.680 unfolding bounded_def by auto
243.681 - have "dist x y \<le> Sup ?D"
243.682 - proof (rule cSup_upper, safe)
243.683 + have "bdd_above (split dist ` (s\<times>s))"
243.684 + proof (intro bdd_aboveI, safe)
243.685 fix a b
243.686 assume "a \<in> s" "b \<in> s"
243.687 with z[of a] z[of b] dist_triangle[of a b z]
243.688 show "dist a b \<le> 2 * d"
243.689 by (simp add: dist_commute)
243.690 - qed (insert s, auto)
243.691 + qed
243.692 + moreover have "(x,y) \<in> s\<times>s" using s by auto
243.693 + ultimately have "dist x y \<le> (SUP (x,y):s\<times>s. dist x y)"
243.694 + by (rule cSUP_upper2) simp
243.695 with `x \<in> s` show ?thesis
243.696 by (auto simp add: diameter_def)
243.697 qed
243.698 @@ -5714,16 +5730,12 @@
243.699 and d: "0 < d" "d < diameter s"
243.700 shows "\<exists>x\<in>s. \<exists>y\<in>s. d < dist x y"
243.701 proof (rule ccontr)
243.702 - let ?D = "{dist x y |x y. x \<in> s \<and> y \<in> s}"
243.703 assume contr: "\<not> ?thesis"
243.704 - moreover
243.705 - from d have "s \<noteq> {}"
243.706 - by (auto simp: diameter_def)
243.707 - then have "?D \<noteq> {}" by auto
243.708 - ultimately have "Sup ?D \<le> d"
243.709 - by (intro cSup_least) (auto simp: not_less)
243.710 - with `d < diameter s` `s \<noteq> {}` show False
243.711 - by (auto simp: diameter_def)
243.712 + moreover have "s \<noteq> {}"
243.713 + using d by (auto simp add: diameter_def)
243.714 + ultimately have "diameter s \<le> d"
243.715 + by (auto simp: not_less diameter_def intro!: cSUP_least)
243.716 + with `d < diameter s` show False by auto
243.717 qed
243.718
243.719 lemma diameter_bounded:
243.720 @@ -5746,7 +5758,7 @@
243.721 then have "diameter s \<le> dist x y"
243.722 unfolding diameter_def
243.723 apply clarsimp
243.724 - apply (rule cSup_least)
243.725 + apply (rule cSUP_least)
243.726 apply fast+
243.727 done
243.728 then show ?thesis
243.729 @@ -6989,7 +7001,8 @@
243.730 unfolding homeomorphic_minimal
243.731 apply (rule_tac x="\<lambda>x. a + x" in exI)
243.732 apply (rule_tac x="\<lambda>x. -a + x" in exI)
243.733 - using continuous_on_add[OF continuous_on_const continuous_on_id]
243.734 + using continuous_on_add [OF continuous_on_const continuous_on_id, of s a]
243.735 + continuous_on_add [OF continuous_on_const continuous_on_id, of "plus a ` s" "- a"]
243.736 apply auto
243.737 done
243.738
243.739 @@ -7350,14 +7363,14 @@
243.740 fix y
243.741 assume "a \<le> y" "y \<le> b" "m > 0"
243.742 then have "m *\<^sub>R a + c \<le> m *\<^sub>R y + c" and "m *\<^sub>R y + c \<le> m *\<^sub>R b + c"
243.743 - unfolding eucl_le[where 'a='a] by (auto simp: inner_simps)
243.744 + unfolding eucl_le[where 'a='a] by (auto simp: inner_distrib)
243.745 }
243.746 moreover
243.747 {
243.748 fix y
243.749 assume "a \<le> y" "y \<le> b" "m < 0"
243.750 then have "m *\<^sub>R b + c \<le> m *\<^sub>R y + c" and "m *\<^sub>R y + c \<le> m *\<^sub>R a + c"
243.751 - unfolding eucl_le[where 'a='a] by (auto simp add: mult_left_mono_neg inner_simps)
243.752 + unfolding eucl_le[where 'a='a] by (auto simp add: mult_left_mono_neg inner_distrib)
243.753 }
243.754 moreover
243.755 {
243.756 @@ -7366,7 +7379,7 @@
243.757 then have "y \<in> (\<lambda>x. m *\<^sub>R x + c) ` {a..b}"
243.758 unfolding image_iff Bex_def mem_interval eucl_le[where 'a='a]
243.759 apply (intro exI[where x="(1 / m) *\<^sub>R (y - c)"])
243.760 - apply (auto simp add: pos_le_divide_eq pos_divide_le_eq mult_commute diff_le_iff inner_simps)
243.761 + apply (auto simp add: pos_le_divide_eq pos_divide_le_eq mult_commute diff_le_iff inner_distrib inner_diff_left)
243.762 done
243.763 }
243.764 moreover
243.765 @@ -7376,7 +7389,7 @@
243.766 then have "y \<in> (\<lambda>x. m *\<^sub>R x + c) ` {a..b}"
243.767 unfolding image_iff Bex_def mem_interval eucl_le[where 'a='a]
243.768 apply (intro exI[where x="(1 / m) *\<^sub>R (y - c)"])
243.769 - apply (auto simp add: neg_le_divide_eq neg_divide_le_eq mult_commute diff_le_iff inner_simps)
243.770 + apply (auto simp add: neg_le_divide_eq neg_divide_le_eq mult_commute diff_le_iff inner_distrib inner_diff_left)
243.771 done
243.772 }
243.773 ultimately show ?thesis using False by auto
244.1 --- a/src/HOL/NSA/CLim.thy Thu Dec 05 17:52:12 2013 +0100
244.2 +++ b/src/HOL/NSA/CLim.thy Thu Dec 05 17:58:03 2013 +0100
244.3 @@ -22,11 +22,11 @@
244.4 lemma all_shift: "(\<forall>x::'a::comm_ring_1. P x) = (\<forall>x. P (x-a))";
244.5 apply auto
244.6 apply (drule_tac x="x+a" in spec)
244.7 -apply (simp add: diff_minus add_assoc)
244.8 +apply (simp add: add_assoc)
244.9 done
244.10
244.11 lemma complex_add_minus_iff [simp]: "(x + - a = (0::complex)) = (x=a)"
244.12 -by (simp add: diff_eq_eq diff_minus [symmetric])
244.13 +by (simp add: diff_eq_eq)
244.14
244.15 lemma complex_add_eq_0_iff [iff]: "(x+y = (0::complex)) = (y = -x)"
244.16 apply auto
245.1 --- a/src/HOL/NSA/HDeriv.thy Thu Dec 05 17:52:12 2013 +0100
245.2 +++ b/src/HOL/NSA/HDeriv.thy Thu Dec 05 17:58:03 2013 +0100
245.3 @@ -81,8 +81,7 @@
245.4 text{*second equivalence *}
245.5 lemma NSDERIV_NSLIM_iff2:
245.6 "(NSDERIV f x :> D) = ((%z. (f(z) - f(x)) / (z-x)) -- x --NS> D)"
245.7 -by (simp add: NSDERIV_NSLIM_iff DERIV_LIM_iff diff_minus [symmetric]
245.8 - LIM_NSLIM_iff [symmetric])
245.9 + by (simp add: NSDERIV_NSLIM_iff DERIV_LIM_iff LIM_NSLIM_iff [symmetric])
245.10
245.11 (* while we're at it! *)
245.12
245.13 @@ -120,11 +119,10 @@
245.14 hypreal_of_real (f x))\<approx> (hypreal_of_real D) * h)"
245.15 apply (auto simp add: nsderiv_def)
245.16 apply (case_tac "h = (0::hypreal) ")
245.17 -apply (auto simp add: diff_minus)
245.18 +apply auto
245.19 apply (drule_tac x = h in bspec)
245.20 apply (drule_tac [2] c = h in approx_mult1)
245.21 -apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD]
245.22 - simp add: diff_minus)
245.23 +apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD])
245.24 done
245.25
245.26 lemma NSDERIVD3:
245.27 @@ -135,8 +133,7 @@
245.28 apply (auto simp add: nsderiv_def)
245.29 apply (rule ccontr, drule_tac x = h in bspec)
245.30 apply (drule_tac [2] c = h in approx_mult1)
245.31 -apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD]
245.32 - simp add: mult_assoc diff_minus)
245.33 +apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD] simp add: mult_assoc)
245.34 done
245.35
245.36 text{*Differentiability implies continuity
245.37 @@ -174,7 +171,7 @@
245.38 apply (auto simp add: NSDERIV_NSLIM_iff NSLIM_def)
245.39 apply (auto simp add: add_divide_distrib diff_divide_distrib dest!: spec)
245.40 apply (drule_tac b = "star_of Da" and d = "star_of Db" in approx_add)
245.41 -apply (auto simp add: diff_minus add_ac)
245.42 +apply (auto simp add: add_ac algebra_simps)
245.43 done
245.44
245.45 text{*Product of functions - Proof is trivial but tedious
245.46 @@ -234,9 +231,11 @@
245.47 hence deriv: "(\<lambda>h. - ((f(x+h) - f x) / h)) -- 0 --NS> - D"
245.48 by (rule NSLIM_minus)
245.49 have "\<forall>h. - ((f (x + h) - f x) / h) = (- f (x + h) + f x) / h"
245.50 - by (simp add: minus_divide_left diff_minus)
245.51 + by (simp add: minus_divide_left)
245.52 with deriv
245.53 - show "(\<lambda>h. (- f (x + h) + f x) / h) -- 0 --NS> - D" by simp
245.54 + have "(\<lambda>h. (- f (x + h) + f x) / h) -- 0 --NS> - D" by simp
245.55 + then show "(\<lambda>h. (f (x + h) - f x) / h) -- 0 --NS> D \<Longrightarrow>
245.56 + (\<lambda>h. (f x - f (x + h)) / h) -- 0 --NS> - D" by simp
245.57 qed
245.58
245.59 text{*Subtraction*}
245.60 @@ -244,11 +243,8 @@
245.61 by (blast dest: NSDERIV_add NSDERIV_minus)
245.62
245.63 lemma NSDERIV_diff:
245.64 - "[| NSDERIV f x :> Da; NSDERIV g x :> Db |]
245.65 - ==> NSDERIV (%x. f x - g x) x :> Da-Db"
245.66 -apply (simp add: diff_minus)
245.67 -apply (blast intro: NSDERIV_add_minus)
245.68 -done
245.69 + "NSDERIV f x :> Da \<Longrightarrow> NSDERIV g x :> Db \<Longrightarrow> NSDERIV (\<lambda>x. f x - g x) x :> Da-Db"
245.70 + using NSDERIV_add_minus [of f x Da g Db] by simp
245.71
245.72 text{* Similarly to the above, the chain rule admits an entirely
245.73 straightforward derivation. Compare this with Harrison's
245.74 @@ -294,7 +290,7 @@
245.75 - star_of (f (g x)))
245.76 / (( *f* g) (star_of(x) + xa) - star_of (g x))
245.77 \<approx> star_of(Da)"
245.78 -by (auto simp add: NSDERIV_NSLIM_iff2 NSLIM_def diff_minus [symmetric])
245.79 +by (auto simp add: NSDERIV_NSLIM_iff2 NSLIM_def)
245.80
245.81 (*--------------------------------------------------------------
245.82 from other version of differentiability
245.83 @@ -354,13 +350,23 @@
245.84 from h_Inf have "h * star_of x \<in> Infinitesimal" by (rule Infinitesimal_HFinite_mult) simp
245.85 with assms have "inverse (- (h * star_of x) + - (star_of x * star_of x)) \<approx>
245.86 inverse (- (star_of x * star_of x))"
245.87 - by (auto intro: inverse_add_Infinitesimal_approx2
245.88 + apply - apply (rule inverse_add_Infinitesimal_approx2)
245.89 + apply (auto
245.90 dest!: hypreal_of_real_HFinite_diff_Infinitesimal
245.91 simp add: inverse_minus_eq [symmetric] HFinite_minus_iff)
245.92 - with not_0 `h \<noteq> 0` assms have "(inverse (star_of x + h) - inverse (star_of x)) / h \<approx>
245.93 + done
245.94 + moreover from not_0 `h \<noteq> 0` assms
245.95 + have "inverse (- (h * star_of x) + - (star_of x * star_of x)) =
245.96 + (inverse (star_of x + h) - inverse (star_of x)) / h"
245.97 + apply (simp add: division_ring_inverse_diff nonzero_inverse_mult_distrib [symmetric]
245.98 + nonzero_inverse_minus_eq [symmetric] ac_simps ring_distribs)
245.99 + apply (subst nonzero_inverse_minus_eq [symmetric])
245.100 + using distrib_right [symmetric, of h "star_of x" "star_of x"] apply simp
245.101 + apply (simp add: field_simps)
245.102 + done
245.103 + ultimately have "(inverse (star_of x + h) - inverse (star_of x)) / h \<approx>
245.104 - (inverse (star_of x) * inverse (star_of x))"
245.105 - by (simp add: inverse_add nonzero_inverse_mult_distrib [symmetric]
245.106 - nonzero_inverse_minus_eq [symmetric] add_ac mult_ac diff_minus ring_distribs)
245.107 + using assms by (simp add: nonzero_inverse_mult_distrib [symmetric] nonzero_inverse_minus_eq [symmetric])
245.108 } then show ?thesis by (simp add: nsderiv_def)
245.109 qed
245.110
246.1 --- a/src/HOL/NSA/HLim.thy Thu Dec 05 17:52:12 2013 +0100
246.2 +++ b/src/HOL/NSA/HLim.thy Thu Dec 05 17:58:03 2013 +0100
246.3 @@ -71,7 +71,7 @@
246.4
246.5 lemma NSLIM_diff:
246.6 "\<lbrakk>f -- x --NS> l; g -- x --NS> m\<rbrakk> \<Longrightarrow> (\<lambda>x. f x - g x) -- x --NS> (l - m)"
246.7 -by (simp only: diff_minus NSLIM_add NSLIM_minus)
246.8 + by (simp only: NSLIM_add NSLIM_minus diff_conv_add_uminus)
246.9
246.10 lemma NSLIM_add_minus: "[| f -- x --NS> l; g -- x --NS> m |] ==> (%x. f(x) + -g(x)) -- x --NS> (l + -m)"
246.11 by (simp only: NSLIM_add NSLIM_minus)
246.12 @@ -95,7 +95,7 @@
246.13
246.14 lemma NSLIM_zero_cancel: "(%x. f(x) - l) -- x --NS> 0 ==> f -- x --NS> l"
246.15 apply (drule_tac g = "%x. l" and m = l in NSLIM_add)
246.16 -apply (auto simp add: diff_minus add_assoc)
246.17 +apply (auto simp add: add_assoc)
246.18 done
246.19
246.20 lemma NSLIM_const_not_eq:
246.21 @@ -243,14 +243,14 @@
246.22 apply (drule_tac [2] x = "- star_of a + x" in spec, safe, simp)
246.23 apply (erule mem_infmal_iff [THEN iffD2, THEN Infinitesimal_add_approx_self [THEN approx_sym]])
246.24 apply (erule_tac [3] approx_minus_iff2 [THEN iffD1])
246.25 - prefer 2 apply (simp add: add_commute diff_minus [symmetric])
246.26 + prefer 2 apply (simp add: add_commute)
246.27 apply (rule_tac x = x in star_cases)
246.28 apply (rule_tac [2] x = x in star_cases)
246.29 -apply (auto simp add: starfun star_of_def star_n_minus star_n_add add_assoc approx_refl star_n_zero_num)
246.30 +apply (auto simp add: starfun star_of_def star_n_minus star_n_add add_assoc star_n_zero_num)
246.31 done
246.32
246.33 lemma NSLIM_isCont_iff: "(f -- a --NS> f a) = ((%h. f(a + h)) -- 0 --NS> f a)"
246.34 -by (rule NSLIM_h_iff)
246.35 + by (fact NSLIM_h_iff)
246.36
246.37 lemma isNSCont_minus: "isNSCont f a ==> isNSCont (%x. - f x) a"
246.38 by (simp add: isNSCont_def)
247.1 --- a/src/HOL/NSA/HSEQ.thy Thu Dec 05 17:52:12 2013 +0100
247.2 +++ b/src/HOL/NSA/HSEQ.thy Thu Dec 05 17:58:03 2013 +0100
247.3 @@ -73,14 +73,14 @@
247.4 lemma NSLIMSEQ_minus_cancel: "(%n. -(X n)) ----NS> -a ==> X ----NS> a"
247.5 by (drule NSLIMSEQ_minus, simp)
247.6
247.7 +lemma NSLIMSEQ_diff:
247.8 + "[| X ----NS> a; Y ----NS> b |] ==> (%n. X n - Y n) ----NS> a - b"
247.9 + using NSLIMSEQ_add [of X a "- Y" "- b"] by (simp add: NSLIMSEQ_minus fun_Compl_def)
247.10 +
247.11 (* FIXME: delete *)
247.12 lemma NSLIMSEQ_add_minus:
247.13 "[| X ----NS> a; Y ----NS> b |] ==> (%n. X n + -Y n) ----NS> a + -b"
247.14 -by (simp add: NSLIMSEQ_add NSLIMSEQ_minus)
247.15 -
247.16 -lemma NSLIMSEQ_diff:
247.17 - "[| X ----NS> a; Y ----NS> b |] ==> (%n. X n - Y n) ----NS> a - b"
247.18 -by (simp add: diff_minus NSLIMSEQ_add NSLIMSEQ_minus)
247.19 + by (simp add: NSLIMSEQ_diff)
247.20
247.21 lemma NSLIMSEQ_diff_const: "f ----NS> a ==> (%n.(f n - b)) ----NS> a - b"
247.22 by (simp add: NSLIMSEQ_diff NSLIMSEQ_const)
247.23 @@ -233,11 +233,11 @@
247.24
247.25 lemma NSLIMSEQ_inverse_real_of_nat_add_minus:
247.26 "(%n. r + -inverse(real(Suc n))) ----NS> r"
247.27 -by (simp add: LIMSEQ_NSLIMSEQ_iff [symmetric] LIMSEQ_inverse_real_of_nat_add_minus)
247.28 + using LIMSEQ_inverse_real_of_nat_add_minus by (simp add: LIMSEQ_NSLIMSEQ_iff [symmetric])
247.29
247.30 lemma NSLIMSEQ_inverse_real_of_nat_add_minus_mult:
247.31 "(%n. r*( 1 + -inverse(real(Suc n)))) ----NS> r"
247.32 -by (simp add: LIMSEQ_NSLIMSEQ_iff [symmetric] LIMSEQ_inverse_real_of_nat_add_minus_mult)
247.33 + using LIMSEQ_inverse_real_of_nat_add_minus_mult by (simp add: LIMSEQ_NSLIMSEQ_iff [symmetric])
247.34
247.35
247.36 subsection {* Convergence *}
248.1 --- a/src/HOL/NSA/HSeries.thy Thu Dec 05 17:52:12 2013 +0100
248.2 +++ b/src/HOL/NSA/HSeries.thy Thu Dec 05 17:58:03 2013 +0100
248.3 @@ -131,7 +131,7 @@
248.4 apply (auto simp add: approx_refl)
248.5 apply (drule approx_sym [THEN approx_minus_iff [THEN iffD1]])
248.6 apply (auto dest: approx_hrabs
248.7 - simp add: sumhr_split_diff diff_minus [symmetric])
248.8 + simp add: sumhr_split_diff)
248.9 done
248.10
248.11 (*----------------------------------------------------------------
248.12 @@ -172,7 +172,7 @@
248.13 apply (rule approx_minus_iff [THEN iffD2, THEN approx_sym])
248.14 apply (rule_tac [2] approx_minus_iff [THEN iffD2])
248.15 apply (auto dest: approx_hrabs_zero_cancel
248.16 - simp add: sumhr_split_diff diff_minus [symmetric])
248.17 + simp add: sumhr_split_diff)
248.18 done
248.19
248.20
249.1 --- a/src/HOL/NSA/HTranscendental.thy Thu Dec 05 17:52:12 2013 +0100
249.2 +++ b/src/HOL/NSA/HTranscendental.thy Thu Dec 05 17:58:03 2013 +0100
249.3 @@ -258,7 +258,7 @@
249.4 simp add: mult_assoc)
249.5 apply (rule approx_add_right_cancel [where d="-1"])
249.6 apply (rule approx_sym [THEN [2] approx_trans2])
249.7 -apply (auto simp add: diff_minus mem_infmal_iff)
249.8 +apply (auto simp add: mem_infmal_iff)
249.9 done
249.10
249.11 lemma STAR_exp_epsilon [simp]: "( *f* exp) epsilon @= 1"
249.12 @@ -450,7 +450,7 @@
249.13 apply (auto intro: Infinitesimal_subset_HFinite [THEN subsetD]
249.14 simp add: mult_assoc)
249.15 apply (rule approx_add_right_cancel [where d = "-1"])
249.16 -apply (simp add: diff_minus)
249.17 +apply simp
249.18 done
249.19
249.20 lemma STAR_tan_zero [simp]: "( *f* tan) 0 = 0"
249.21 @@ -587,7 +587,7 @@
249.22 "x \<in> Infinitesimal ==> ( *f* cos) x @= 1 - x\<^sup>2"
249.23 apply (rule STAR_cos_Infinitesimal [THEN approx_trans])
249.24 apply (auto simp add: Infinitesimal_approx_minus [symmetric]
249.25 - diff_minus add_assoc [symmetric] numeral_2_eq_2)
249.26 + add_assoc [symmetric] numeral_2_eq_2)
249.27 done
249.28
249.29 lemma STAR_cos_Infinitesimal_approx2:
250.1 --- a/src/HOL/NSA/HyperDef.thy Thu Dec 05 17:52:12 2013 +0100
250.2 +++ b/src/HOL/NSA/HyperDef.thy Thu Dec 05 17:58:03 2013 +0100
250.3 @@ -425,7 +425,7 @@
250.4 declare power_hypreal_of_real_numeral [of _ "numeral w", simp] for w
250.5
250.6 lemma power_hypreal_of_real_neg_numeral:
250.7 - "(neg_numeral v :: hypreal) ^ n = hypreal_of_real ((neg_numeral v) ^ n)"
250.8 + "(- numeral v :: hypreal) ^ n = hypreal_of_real ((- numeral v) ^ n)"
250.9 by simp
250.10 declare power_hypreal_of_real_neg_numeral [of _ "numeral w", simp] for w
250.11 (*
251.1 --- a/src/HOL/NSA/NSA.thy Thu Dec 05 17:52:12 2013 +0100
251.2 +++ b/src/HOL/NSA/NSA.thy Thu Dec 05 17:58:03 2013 +0100
251.3 @@ -6,7 +6,7 @@
251.4 header{*Infinite Numbers, Infinitesimals, Infinitely Close Relation*}
251.5
251.6 theory NSA
251.7 -imports HyperDef
251.8 +imports HyperDef "~~/src/HOL/Library/Lubs_Glbs"
251.9 begin
251.10
251.11 definition
251.12 @@ -368,7 +368,7 @@
251.13
251.14 lemma Infinitesimal_diff:
251.15 "[| x \<in> Infinitesimal; y \<in> Infinitesimal |] ==> x-y \<in> Infinitesimal"
251.16 -by (simp add: diff_minus Infinitesimal_add)
251.17 + using Infinitesimal_add [of x "- y"] by simp
251.18
251.19 lemma Infinitesimal_mult:
251.20 fixes x y :: "'a::real_normed_algebra star"
251.21 @@ -491,7 +491,9 @@
251.22 "[|(x::hypreal) \<in> HInfinite; y \<le> 0; x \<le> 0|] ==> (x + y): HInfinite"
251.23 apply (drule HInfinite_minus_iff [THEN iffD2])
251.24 apply (rule HInfinite_minus_iff [THEN iffD1])
251.25 -apply (auto intro: HInfinite_add_ge_zero)
251.26 +apply (simp only: minus_add add.commute)
251.27 +apply (rule HInfinite_add_ge_zero)
251.28 +apply simp_all
251.29 done
251.30
251.31 lemma HInfinite_add_lt_zero:
251.32 @@ -620,7 +622,7 @@
251.33 by (simp add: approx_def)
251.34
251.35 lemma approx_minus_iff2: " (x @= y) = (-y + x @= 0)"
251.36 -by (simp add: approx_def diff_minus add_commute)
251.37 +by (simp add: approx_def add_commute)
251.38
251.39 lemma approx_refl [iff]: "x @= x"
251.40 by (simp add: approx_def Infinitesimal_def)
251.41 @@ -637,7 +639,7 @@
251.42 lemma approx_trans: "[| x @= y; y @= z |] ==> x @= z"
251.43 apply (simp add: approx_def)
251.44 apply (drule (1) Infinitesimal_add)
251.45 -apply (simp add: diff_minus)
251.46 +apply simp
251.47 done
251.48
251.49 lemma approx_trans2: "[| r @= x; s @= x |] ==> r @= s"
251.50 @@ -652,7 +654,7 @@
251.51 (*reorientation simplification procedure: reorients (polymorphic)
251.52 0 = x, 1 = x, nnn = x provided x isn't 0, 1 or a numeral.*)
251.53 simproc_setup approx_reorient_simproc
251.54 - ("0 @= x" | "1 @= y" | "numeral w @= z" | "neg_numeral w @= r") =
251.55 + ("0 @= x" | "1 @= y" | "numeral w @= z" | "- 1 @= y" | "- numeral w @= r") =
251.56 {*
251.57 let val rule = @{thm approx_reorient} RS eq_reflection
251.58 fun proc phi ss ct = case term_of ct of
251.59 @@ -687,7 +689,7 @@
251.60 lemma approx_minus: "a @= b ==> -a @= -b"
251.61 apply (rule approx_minus_iff [THEN iffD2, THEN approx_sym])
251.62 apply (drule approx_minus_iff [THEN iffD1])
251.63 -apply (simp add: add_commute diff_minus)
251.64 +apply (simp add: add_commute)
251.65 done
251.66
251.67 lemma approx_minus2: "-a @= -b ==> a @= b"
251.68 @@ -700,7 +702,7 @@
251.69 by (blast intro!: approx_add approx_minus)
251.70
251.71 lemma approx_diff: "[| a @= b; c @= d |] ==> a - c @= b - d"
251.72 -by (simp only: diff_minus approx_add approx_minus)
251.73 + using approx_add [of a b "- c" "- d"] by simp
251.74
251.75 lemma approx_mult1:
251.76 fixes a b c :: "'a::real_normed_algebra star"
251.77 @@ -1213,7 +1215,9 @@
251.78 r \<in> Reals; 0 < r |]
251.79 ==> -(x + -t) \<le> r"
251.80 apply (subgoal_tac "(t + -r \<le> x)")
251.81 -apply (auto intro: lemma_st_part_le2)
251.82 +apply simp
251.83 +apply (rule lemma_st_part_le2)
251.84 +apply auto
251.85 done
251.86
251.87 lemma lemma_SReal_ub:
251.88 @@ -1238,7 +1242,7 @@
251.89 ==> x + -t \<noteq> r"
251.90 apply auto
251.91 apply (frule isLubD1a [THEN Reals_minus])
251.92 -apply (drule Reals_add_cancel, assumption)
251.93 +using Reals_add_cancel [of x "- t"] apply simp
251.94 apply (drule_tac x = x in lemma_SReal_lub)
251.95 apply (drule hypreal_isLub_unique, assumption, auto)
251.96 done
251.97 @@ -1250,8 +1254,7 @@
251.98 ==> -(x + -t) \<noteq> r"
251.99 apply (auto)
251.100 apply (frule isLubD1a)
251.101 -apply (drule Reals_add_cancel, assumption)
251.102 -apply (drule_tac a = "-x" in Reals_minus, simp)
251.103 +using Reals_add_cancel [of "- x" t] apply simp
251.104 apply (drule_tac x = x in lemma_SReal_lub)
251.105 apply (drule hypreal_isLub_unique, assumption, auto)
251.106 done
251.107 @@ -1846,8 +1849,12 @@
251.108 lemma st_numeral [simp]: "st (numeral w) = numeral w"
251.109 by (rule Reals_numeral [THEN st_SReal_eq])
251.110
251.111 -lemma st_neg_numeral [simp]: "st (neg_numeral w) = neg_numeral w"
251.112 -by (rule Reals_neg_numeral [THEN st_SReal_eq])
251.113 +lemma st_neg_numeral [simp]: "st (- numeral w) = - numeral w"
251.114 +proof -
251.115 + from Reals_numeral have "numeral w \<in> \<real>" .
251.116 + then have "- numeral w \<in> \<real>" by simp
251.117 + with st_SReal_eq show ?thesis .
251.118 +qed
251.119
251.120 lemma st_0 [simp]: "st 0 = 0"
251.121 by (simp add: st_SReal_eq)
251.122 @@ -1855,6 +1862,9 @@
251.123 lemma st_1 [simp]: "st 1 = 1"
251.124 by (simp add: st_SReal_eq)
251.125
251.126 +lemma st_neg_1 [simp]: "st (- 1) = - 1"
251.127 +by (simp add: st_SReal_eq)
251.128 +
251.129 lemma st_minus: "x \<in> HFinite \<Longrightarrow> st (- x) = - st x"
251.130 by (simp add: st_unique st_SReal st_approx_self approx_minus)
251.131
252.1 --- a/src/HOL/NSA/NSCA.thy Thu Dec 05 17:52:12 2013 +0100
252.2 +++ b/src/HOL/NSA/NSCA.thy Thu Dec 05 17:58:03 2013 +0100
252.3 @@ -165,7 +165,7 @@
252.4
252.5 lemma approx_hcmod_approx_zero: "(x @= y) = (hcmod (y - x) @= 0)"
252.6 apply (subst hnorm_minus_commute)
252.7 -apply (simp add: approx_def Infinitesimal_hcmod_iff diff_minus)
252.8 +apply (simp add: approx_def Infinitesimal_hcmod_iff)
252.9 done
252.10
252.11 lemma approx_approx_zero_iff: "(x @= 0) = (hcmod x @= 0)"
252.12 @@ -178,14 +178,14 @@
252.13 "u @= 0 ==> hcmod(x + u) - hcmod x \<in> Infinitesimal"
252.14 apply (drule approx_approx_zero_iff [THEN iffD1])
252.15 apply (rule_tac e = "hcmod u" and e' = "- hcmod u" in Infinitesimal_interval2)
252.16 -apply (auto simp add: mem_infmal_iff [symmetric] diff_minus)
252.17 +apply (auto simp add: mem_infmal_iff [symmetric])
252.18 apply (rule_tac c1 = "hcmod x" in add_le_cancel_left [THEN iffD1])
252.19 -apply (auto simp add: diff_minus [symmetric])
252.20 +apply auto
252.21 done
252.22
252.23 lemma approx_hcmod_add_hcmod: "u @= 0 ==> hcmod(x + u) @= hcmod x"
252.24 apply (rule approx_minus_iff [THEN iffD2])
252.25 -apply (auto intro: Infinitesimal_hcmod_add_diff simp add: mem_infmal_iff [symmetric] diff_minus [symmetric])
252.26 +apply (auto intro: Infinitesimal_hcmod_add_diff simp add: mem_infmal_iff [symmetric])
252.27 done
252.28
252.29
253.1 --- a/src/HOL/NSA/NSComplex.thy Thu Dec 05 17:52:12 2013 +0100
253.2 +++ b/src/HOL/NSA/NSComplex.thy Thu Dec 05 17:58:03 2013 +0100
253.3 @@ -635,7 +635,7 @@
253.4 by transfer (rule of_real_numeral [symmetric])
253.5
253.6 lemma hcomplex_hypreal_neg_numeral:
253.7 - "hcomplex_of_complex (neg_numeral w) = hcomplex_of_hypreal(neg_numeral w)"
253.8 + "hcomplex_of_complex (- numeral w) = hcomplex_of_hypreal(- numeral w)"
253.9 by transfer (rule of_real_neg_numeral [symmetric])
253.10
253.11 lemma hcomplex_numeral_hcnj [simp]:
253.12 @@ -647,7 +647,7 @@
253.13 by transfer (rule norm_numeral)
253.14
253.15 lemma hcomplex_neg_numeral_hcmod [simp]:
253.16 - "hcmod(neg_numeral v :: hcomplex) = (numeral v :: hypreal)"
253.17 + "hcmod(- numeral v :: hcomplex) = (numeral v :: hypreal)"
253.18 by transfer (rule norm_neg_numeral)
253.19
253.20 lemma hcomplex_numeral_hRe [simp]:
254.1 --- a/src/HOL/NSA/StarDef.thy Thu Dec 05 17:52:12 2013 +0100
254.2 +++ b/src/HOL/NSA/StarDef.thy Thu Dec 05 17:58:03 2013 +0100
254.3 @@ -18,7 +18,7 @@
254.4 apply (unfold FreeUltrafilterNat_def)
254.5 apply (rule someI_ex)
254.6 apply (rule freeultrafilter_Ex)
254.7 -apply (rule nat_infinite)
254.8 +apply (rule infinite_UNIV_nat)
254.9 done
254.10
254.11 interpretation FreeUltrafilterNat: freeultrafilter FreeUltrafilterNat
254.12 @@ -803,7 +803,7 @@
254.13 instance star :: (ab_group_add) ab_group_add
254.14 apply (intro_classes)
254.15 apply (transfer, rule left_minus)
254.16 -apply (transfer, rule diff_minus)
254.17 +apply (transfer, rule diff_conv_add_uminus)
254.18 done
254.19
254.20 instance star :: (ordered_ab_semigroup_add) ordered_ab_semigroup_add
254.21 @@ -968,13 +968,13 @@
254.22 by transfer (rule refl)
254.23
254.24 lemma star_neg_numeral_def [transfer_unfold]:
254.25 - "neg_numeral k = star_of (neg_numeral k)"
254.26 -by (simp only: neg_numeral_def star_of_minus star_of_numeral)
254.27 + "- numeral k = star_of (- numeral k)"
254.28 +by (simp only: star_of_minus star_of_numeral)
254.29
254.30 -lemma Standard_neg_numeral [simp]: "neg_numeral k \<in> Standard"
254.31 -by (simp add: star_neg_numeral_def)
254.32 +lemma Standard_neg_numeral [simp]: "- numeral k \<in> Standard"
254.33 + using star_neg_numeral_def [of k] by simp
254.34
254.35 -lemma star_of_neg_numeral [simp]: "star_of (neg_numeral k) = neg_numeral k"
254.36 +lemma star_of_neg_numeral [simp]: "star_of (- numeral k) = - numeral k"
254.37 by transfer (rule refl)
254.38
254.39 lemma star_of_nat_def [transfer_unfold]: "of_nat n = star_of (of_nat n)"
254.40 @@ -987,12 +987,12 @@
254.41 star_of_less [of _ "numeral k", simplified star_of_numeral]
254.42 star_of_le [of _ "numeral k", simplified star_of_numeral]
254.43 star_of_eq [of _ "numeral k", simplified star_of_numeral]
254.44 - star_of_less [of "neg_numeral k", simplified star_of_numeral]
254.45 - star_of_le [of "neg_numeral k", simplified star_of_numeral]
254.46 - star_of_eq [of "neg_numeral k", simplified star_of_numeral]
254.47 - star_of_less [of _ "neg_numeral k", simplified star_of_numeral]
254.48 - star_of_le [of _ "neg_numeral k", simplified star_of_numeral]
254.49 - star_of_eq [of _ "neg_numeral k", simplified star_of_numeral] for k
254.50 + star_of_less [of "- numeral k", simplified star_of_numeral]
254.51 + star_of_le [of "- numeral k", simplified star_of_numeral]
254.52 + star_of_eq [of "- numeral k", simplified star_of_numeral]
254.53 + star_of_less [of _ "- numeral k", simplified star_of_numeral]
254.54 + star_of_le [of _ "- numeral k", simplified star_of_numeral]
254.55 + star_of_eq [of _ "- numeral k", simplified star_of_numeral] for k
254.56
254.57 lemma Standard_of_nat [simp]: "of_nat n \<in> Standard"
254.58 by (simp add: star_of_nat_def)
255.1 --- a/src/HOL/Nat.thy Thu Dec 05 17:52:12 2013 +0100
255.2 +++ b/src/HOL/Nat.thy Thu Dec 05 17:58:03 2013 +0100
255.3 @@ -327,7 +327,7 @@
255.4 apply auto
255.5 done
255.6
255.7 -lemma one_eq_mult_iff [simp,no_atp]: "(Suc 0 = m * n) = (m = Suc 0 & n = Suc 0)"
255.8 +lemma one_eq_mult_iff [simp]: "(Suc 0 = m * n) = (m = Suc 0 & n = Suc 0)"
255.9 apply (rule trans)
255.10 apply (rule_tac [2] mult_eq_1_iff, fastforce)
255.11 done
255.12 @@ -369,8 +369,8 @@
255.13 | "Suc m \<le> n \<longleftrightarrow> (case n of 0 \<Rightarrow> False | Suc n \<Rightarrow> m \<le> n)"
255.14
255.15 declare less_eq_nat.simps [simp del]
255.16 -lemma [code]: "(0\<Colon>nat) \<le> n \<longleftrightarrow> True" by (simp add: less_eq_nat.simps)
255.17 lemma le0 [iff]: "0 \<le> (n\<Colon>nat)" by (simp add: less_eq_nat.simps)
255.18 +lemma [code]: "(0\<Colon>nat) \<le> n \<longleftrightarrow> True" by simp
255.19
255.20 definition less_nat where
255.21 less_eq_Suc_le: "n < m \<longleftrightarrow> Suc n \<le> m"
255.22 @@ -491,7 +491,7 @@
255.23 lemma less_Suc0 [iff]: "(n < Suc 0) = (n = 0)"
255.24 by (simp add: less_Suc_eq)
255.25
255.26 -lemma less_one [iff, no_atp]: "(n < (1::nat)) = (n = 0)"
255.27 +lemma less_one [iff]: "(n < (1::nat)) = (n = 0)"
255.28 unfolding One_nat_def by (rule less_Suc0)
255.29
255.30 lemma Suc_mono: "m < n ==> Suc m < Suc n"
255.31 @@ -659,7 +659,7 @@
255.32 lemma gr0_conv_Suc: "(0 < n) = (\<exists>m. n = Suc m)"
255.33 by (fast intro: not0_implies_Suc)
255.34
255.35 -lemma not_gr0 [iff,no_atp]: "!!n::nat. (~ (0 < n)) = (n = 0)"
255.36 +lemma not_gr0 [iff]: "!!n::nat. (~ (0 < n)) = (n = 0)"
255.37 using neq0_conv by blast
255.38
255.39 lemma Suc_le_D: "(Suc n \<le> m') ==> (? m. m' = Suc m)"
255.40 @@ -1315,6 +1315,11 @@
255.41 shows "comp f ^^ n = comp (f ^^ n)"
255.42 by (induct n) simp_all
255.43
255.44 +lemma Suc_funpow[simp]: "Suc ^^ n = (op + n)"
255.45 + by (induct n) simp_all
255.46 +
255.47 +lemma id_funpow[simp]: "id ^^ n = id"
255.48 + by (induct n) simp_all
255.49
255.50 subsection {* Kleene iteration *}
255.51
255.52 @@ -1396,10 +1401,10 @@
255.53
255.54 text{*Special cases where either operand is zero*}
255.55
255.56 -lemma of_nat_0_eq_iff [simp, no_atp]: "0 = of_nat n \<longleftrightarrow> 0 = n"
255.57 +lemma of_nat_0_eq_iff [simp]: "0 = of_nat n \<longleftrightarrow> 0 = n"
255.58 by (fact of_nat_eq_iff [of 0 n, unfolded of_nat_0])
255.59
255.60 -lemma of_nat_eq_0_iff [simp, no_atp]: "of_nat m = 0 \<longleftrightarrow> m = 0"
255.61 +lemma of_nat_eq_0_iff [simp]: "of_nat m = 0 \<longleftrightarrow> m = 0"
255.62 by (fact of_nat_eq_iff [of m 0, unfolded of_nat_0])
255.63
255.64 end
255.65 @@ -1432,7 +1437,7 @@
255.66
255.67 text{*Special cases where either operand is zero*}
255.68
255.69 -lemma of_nat_le_0_iff [simp, no_atp]: "of_nat m \<le> 0 \<longleftrightarrow> m = 0"
255.70 +lemma of_nat_le_0_iff [simp]: "of_nat m \<le> 0 \<longleftrightarrow> m = 0"
255.71 by (rule of_nat_le_iff [of _ 0, simplified])
255.72
255.73 lemma of_nat_0_less_iff [simp]: "0 < of_nat n \<longleftrightarrow> 0 < n"
255.74 @@ -1718,20 +1723,20 @@
255.75 text {* Specialized induction principles that work "backwards": *}
255.76
255.77 lemma inc_induct[consumes 1, case_names base step]:
255.78 - assumes less: "i <= j"
255.79 + assumes less: "i \<le> j"
255.80 assumes base: "P j"
255.81 - assumes step: "!!i. [| i < j; P (Suc i) |] ==> P i"
255.82 + assumes step: "\<And>n. i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P (Suc n) \<Longrightarrow> P n"
255.83 shows "P i"
255.84 - using less
255.85 -proof (induct d=="j - i" arbitrary: i)
255.86 + using less step
255.87 +proof (induct d\<equiv>"j - i" arbitrary: i)
255.88 case (0 i)
255.89 hence "i = j" by simp
255.90 with base show ?case by simp
255.91 next
255.92 - case (Suc d i)
255.93 - hence "i < j" "P (Suc i)"
255.94 + case (Suc d n)
255.95 + hence "n \<le> n" "n < j" "P (Suc n)"
255.96 by simp_all
255.97 - thus "P i" by (rule step)
255.98 + then show "P n" by fact
255.99 qed
255.100
255.101 lemma strict_inc_induct[consumes 1, case_names base step]:
255.102 @@ -1760,9 +1765,8 @@
255.103 text {* Further induction rule similar to @{thm inc_induct} *}
255.104
255.105 lemma dec_induct[consumes 1, case_names base step]:
255.106 - "i \<le> j \<Longrightarrow> P i \<Longrightarrow> (\<And>n. i \<le> n \<Longrightarrow> P n \<Longrightarrow> P (Suc n)) \<Longrightarrow> P j"
255.107 + "i \<le> j \<Longrightarrow> P i \<Longrightarrow> (\<And>n. i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P n \<Longrightarrow> P (Suc n)) \<Longrightarrow> P j"
255.108 by (induct j arbitrary: i) (auto simp: le_Suc_eq)
255.109 -
255.110
255.111 subsection {* The divides relation on @{typ nat} *}
255.112
255.113 @@ -1872,12 +1876,12 @@
255.114 shows "m dvd n + q \<longleftrightarrow> m dvd n"
255.115 using assms by (simp add: dvd_plus_eq_right add_commute [of n])
255.116
255.117 -lemma less_dvd_minus:
255.118 +lemma less_eq_dvd_minus:
255.119 fixes m n :: nat
255.120 - assumes "m < n"
255.121 - shows "m dvd n \<longleftrightarrow> m dvd (n - m)"
255.122 + assumes "m \<le> n"
255.123 + shows "m dvd n \<longleftrightarrow> m dvd n - m"
255.124 proof -
255.125 - from assms have "n = m + (n - m)" by arith
255.126 + from assms have "n = m + (n - m)" by simp
255.127 then obtain q where "n = m + q" ..
255.128 then show ?thesis by (simp add: dvd_reduce add_commute [of m])
255.129 qed
256.1 --- a/src/HOL/Nitpick.thy Thu Dec 05 17:52:12 2013 +0100
256.2 +++ b/src/HOL/Nitpick.thy Thu Dec 05 17:58:03 2013 +0100
256.3 @@ -8,7 +8,7 @@
256.4 header {* Nitpick: Yet Another Counterexample Generator for Isabelle/HOL *}
256.5
256.6 theory Nitpick
256.7 -imports Hilbert_Choice List Map Quotient Record Sledgehammer
256.8 +imports Map Record Sledgehammer
256.9 keywords "nitpick" :: diag and "nitpick_params" :: thy_decl
256.10 begin
256.11
256.12 @@ -33,7 +33,7 @@
256.13 Alternative definitions.
256.14 *}
256.15
256.16 -lemma Ex1_unfold [nitpick_unfold, no_atp]:
256.17 +lemma Ex1_unfold [nitpick_unfold]:
256.18 "Ex1 P \<equiv> \<exists>x. {x. P x} = {x}"
256.19 apply (rule eq_reflection)
256.20 apply (simp add: Ex1_def set_eq_iff)
256.21 @@ -46,18 +46,18 @@
256.22 apply (erule_tac x = y in allE)
256.23 by auto
256.24
256.25 -lemma rtrancl_unfold [nitpick_unfold, no_atp]: "r\<^sup>* \<equiv> (r\<^sup>+)\<^sup>="
256.26 +lemma rtrancl_unfold [nitpick_unfold]: "r\<^sup>* \<equiv> (r\<^sup>+)\<^sup>="
256.27 by (simp only: rtrancl_trancl_reflcl)
256.28
256.29 -lemma rtranclp_unfold [nitpick_unfold, no_atp]:
256.30 +lemma rtranclp_unfold [nitpick_unfold]:
256.31 "rtranclp r a b \<equiv> (a = b \<or> tranclp r a b)"
256.32 by (rule eq_reflection) (auto dest: rtranclpD)
256.33
256.34 -lemma tranclp_unfold [nitpick_unfold, no_atp]:
256.35 +lemma tranclp_unfold [nitpick_unfold]:
256.36 "tranclp r a b \<equiv> (a, b) \<in> trancl {(x, y). r x y}"
256.37 by (simp add: trancl_def)
256.38
256.39 -lemma [nitpick_simp, no_atp]:
256.40 +lemma [nitpick_simp]:
256.41 "of_nat n = (if n = 0 then 0 else 1 + of_nat (n - 1))"
256.42 by (cases n) auto
256.43
256.44 @@ -85,18 +85,18 @@
256.45 \textit{specialize} optimization.
256.46 *}
256.47
256.48 -lemma The_psimp [nitpick_psimp, no_atp]:
256.49 +lemma The_psimp [nitpick_psimp]:
256.50 "P = (op =) x \<Longrightarrow> The P = x"
256.51 by auto
256.52
256.53 -lemma Eps_psimp [nitpick_psimp, no_atp]:
256.54 +lemma Eps_psimp [nitpick_psimp]:
256.55 "\<lbrakk>P x; \<not> P y; Eps P = y\<rbrakk> \<Longrightarrow> Eps P = x"
256.56 apply (cases "P (Eps P)")
256.57 apply auto
256.58 apply (erule contrapos_np)
256.59 by (rule someI)
256.60
256.61 -lemma unit_case_unfold [nitpick_unfold, no_atp]:
256.62 +lemma unit_case_unfold [nitpick_unfold]:
256.63 "unit_case x u \<equiv> x"
256.64 apply (subgoal_tac "u = ()")
256.65 apply (simp only: unit.cases)
256.66 @@ -104,14 +104,14 @@
256.67
256.68 declare unit.cases [nitpick_simp del]
256.69
256.70 -lemma nat_case_unfold [nitpick_unfold, no_atp]:
256.71 +lemma nat_case_unfold [nitpick_unfold]:
256.72 "nat_case x f n \<equiv> if n = 0 then x else f (n - 1)"
256.73 apply (rule eq_reflection)
256.74 by (cases n) auto
256.75
256.76 declare nat.cases [nitpick_simp del]
256.77
256.78 -lemma list_size_simp [nitpick_simp, no_atp]:
256.79 +lemma list_size_simp [nitpick_simp]:
256.80 "list_size f xs = (if xs = [] then 0
256.81 else Suc (f (hd xs) + list_size f (tl xs)))"
256.82 "size xs = (if xs = [] then 0 else Suc (size (tl xs)))"
257.1 --- a/src/HOL/Nitpick_Examples/Core_Nits.thy Thu Dec 05 17:52:12 2013 +0100
257.2 +++ b/src/HOL/Nitpick_Examples/Core_Nits.thy Thu Dec 05 17:58:03 2013 +0100
257.3 @@ -12,7 +12,7 @@
257.4 begin
257.5
257.6 nitpick_params [verbose, card = 1\<emdash>6, unary_ints, max_potential = 0,
257.7 - sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]
257.8 + sat_solver = Riss3g, max_threads = 1, timeout = 240]
257.9
257.10 subsection {* Curry in a Hurry *}
257.11
258.1 --- a/src/HOL/Nitpick_Examples/Datatype_Nits.thy Thu Dec 05 17:52:12 2013 +0100
258.2 +++ b/src/HOL/Nitpick_Examples/Datatype_Nits.thy Thu Dec 05 17:58:03 2013 +0100
258.3 @@ -12,7 +12,7 @@
258.4 begin
258.5
258.6 nitpick_params [verbose, card = 1\<emdash>8, max_potential = 0,
258.7 - sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]
258.8 + sat_solver = Riss3g, max_threads = 1, timeout = 240]
258.9
258.10 primrec rot where
258.11 "rot Nibble0 = Nibble1" | "rot Nibble1 = Nibble2" | "rot Nibble2 = Nibble3" |
259.1 --- a/src/HOL/Nitpick_Examples/Hotel_Nits.thy Thu Dec 05 17:52:12 2013 +0100
259.2 +++ b/src/HOL/Nitpick_Examples/Hotel_Nits.thy Thu Dec 05 17:58:03 2013 +0100
259.3 @@ -12,7 +12,7 @@
259.4 imports Main
259.5 begin
259.6
259.7 -nitpick_params [verbose, max_potential = 0, sat_solver = MiniSat_JNI,
259.8 +nitpick_params [verbose, max_potential = 0, sat_solver = Riss3g,
259.9 max_threads = 1, timeout = 240]
259.10
259.11 typedecl guest
260.1 --- a/src/HOL/Nitpick_Examples/Induct_Nits.thy Thu Dec 05 17:52:12 2013 +0100
260.2 +++ b/src/HOL/Nitpick_Examples/Induct_Nits.thy Thu Dec 05 17:58:03 2013 +0100
260.3 @@ -12,7 +12,7 @@
260.4 begin
260.5
260.6 nitpick_params [verbose, card = 1\<emdash>8, unary_ints,
260.7 - sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]
260.8 + sat_solver = Riss3g, max_threads = 1, timeout = 240]
260.9
260.10 inductive p1 :: "nat \<Rightarrow> bool" where
260.11 "p1 0" |
261.1 --- a/src/HOL/Nitpick_Examples/Integer_Nits.thy Thu Dec 05 17:52:12 2013 +0100
261.2 +++ b/src/HOL/Nitpick_Examples/Integer_Nits.thy Thu Dec 05 17:58:03 2013 +0100
261.3 @@ -12,7 +12,7 @@
261.4 begin
261.5
261.6 nitpick_params [verbose, card = 1\<emdash>5, bits = 1,2,3,4,6,
261.7 - sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]
261.8 + sat_solver = Riss3g, max_threads = 1, timeout = 240]
261.9
261.10 lemma "Suc x = x + 1"
261.11 nitpick [unary_ints, expect = none]
262.1 --- a/src/HOL/Nitpick_Examples/Manual_Nits.thy Thu Dec 05 17:52:12 2013 +0100
262.2 +++ b/src/HOL/Nitpick_Examples/Manual_Nits.thy Thu Dec 05 17:58:03 2013 +0100
262.3 @@ -17,7 +17,7 @@
262.4
262.5 chapter {* 2. First Steps *}
262.6
262.7 -nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]
262.8 +nitpick_params [sat_solver = Riss3g, max_threads = 1, timeout = 240]
262.9
262.10 subsection {* 2.1. Propositional Logic *}
262.11
263.1 --- a/src/HOL/Nitpick_Examples/Mini_Nits.thy Thu Dec 05 17:52:12 2013 +0100
263.2 +++ b/src/HOL/Nitpick_Examples/Mini_Nits.thy Thu Dec 05 17:58:03 2013 +0100
263.3 @@ -13,7 +13,7 @@
263.4
263.5 ML_file "minipick.ML"
263.6
263.7 -nitpick_params [verbose, sat_solver = MiniSat_JNI, max_threads = 1]
263.8 +nitpick_params [verbose, sat_solver = Riss3g, max_threads = 1]
263.9
263.10 nitpick_params [total_consts = smart]
263.11
264.1 --- a/src/HOL/Nitpick_Examples/Pattern_Nits.thy Thu Dec 05 17:52:12 2013 +0100
264.2 +++ b/src/HOL/Nitpick_Examples/Pattern_Nits.thy Thu Dec 05 17:58:03 2013 +0100
264.3 @@ -11,7 +11,7 @@
264.4 imports Main
264.5 begin
264.6
264.7 -nitpick_params [verbose, card = 8, max_potential = 0, sat_solver = MiniSat_JNI,
264.8 +nitpick_params [verbose, card = 8, max_potential = 0, sat_solver = Riss3g,
264.9 max_threads = 1, timeout = 240]
264.10
264.11 lemma "x = (case u of () \<Rightarrow> y)"
265.1 --- a/src/HOL/Nitpick_Examples/Record_Nits.thy Thu Dec 05 17:52:12 2013 +0100
265.2 +++ b/src/HOL/Nitpick_Examples/Record_Nits.thy Thu Dec 05 17:58:03 2013 +0100
265.3 @@ -12,7 +12,7 @@
265.4 begin
265.5
265.6 nitpick_params [verbose, card = 1\<emdash>6, max_potential = 0,
265.7 - sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]
265.8 + sat_solver = Riss3g, max_threads = 1, timeout = 240]
265.9
265.10 record point2d =
265.11 xc :: int
266.1 --- a/src/HOL/Nitpick_Examples/Refute_Nits.thy Thu Dec 05 17:52:12 2013 +0100
266.2 +++ b/src/HOL/Nitpick_Examples/Refute_Nits.thy Thu Dec 05 17:58:03 2013 +0100
266.3 @@ -12,7 +12,7 @@
266.4 begin
266.5
266.6 nitpick_params [verbose, card = 1\<emdash>6, max_potential = 0,
266.7 - sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]
266.8 + sat_solver = Riss3g, max_threads = 1, timeout = 240]
266.9
266.10 lemma "P \<and> Q"
266.11 apply (rule conjI)
267.1 --- a/src/HOL/Nitpick_Examples/Special_Nits.thy Thu Dec 05 17:52:12 2013 +0100
267.2 +++ b/src/HOL/Nitpick_Examples/Special_Nits.thy Thu Dec 05 17:58:03 2013 +0100
267.3 @@ -11,7 +11,7 @@
267.4 imports Main
267.5 begin
267.6
267.7 -nitpick_params [verbose, card = 4, sat_solver = MiniSat_JNI, max_threads = 1,
267.8 +nitpick_params [verbose, card = 4, sat_solver = Riss3g, max_threads = 1,
267.9 timeout = 240]
267.10
267.11 fun f1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
268.1 --- a/src/HOL/Nitpick_Examples/Typedef_Nits.thy Thu Dec 05 17:52:12 2013 +0100
268.2 +++ b/src/HOL/Nitpick_Examples/Typedef_Nits.thy Thu Dec 05 17:58:03 2013 +0100
268.3 @@ -11,7 +11,7 @@
268.4 imports Complex_Main
268.5 begin
268.6
268.7 -nitpick_params [verbose, card = 1\<emdash>4, sat_solver = MiniSat_JNI, max_threads = 1,
268.8 +nitpick_params [verbose, card = 1\<emdash>4, sat_solver = Riss3g, max_threads = 1,
268.9 timeout = 240]
268.10
268.11 definition "three = {0\<Colon>nat, 1, 2}"
269.1 --- a/src/HOL/Nominal/Nominal.thy Thu Dec 05 17:52:12 2013 +0100
269.2 +++ b/src/HOL/Nominal/Nominal.thy Thu Dec 05 17:58:03 2013 +0100
269.3 @@ -3517,7 +3517,7 @@
269.4 by (simp add: perm_int_def perm_int_def)
269.5
269.6 lemma neg_numeral_int_eqvt:
269.7 - shows "pi\<bullet>((neg_numeral n)::int) = neg_numeral n"
269.8 + shows "pi\<bullet>((- numeral n)::int) = - numeral n"
269.9 by (simp add: perm_int_def perm_int_def)
269.10
269.11 lemma max_int_eqvt:
270.1 --- a/src/HOL/NthRoot.thy Thu Dec 05 17:52:12 2013 +0100
270.2 +++ b/src/HOL/NthRoot.thy Thu Dec 05 17:58:03 2013 +0100
270.3 @@ -410,6 +410,27 @@
270.4 lemma real_sqrt_eq_iff [simp]: "(sqrt x = sqrt y) = (x = y)"
270.5 unfolding sqrt_def by (rule real_root_eq_iff [OF pos2])
270.6
270.7 +lemma real_le_lsqrt: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x \<le> y\<^sup>2 \<Longrightarrow> sqrt x \<le> y"
270.8 + using real_sqrt_le_iff[of x "y\<^sup>2"] by simp
270.9 +
270.10 +lemma real_le_rsqrt: "x\<^sup>2 \<le> y \<Longrightarrow> x \<le> sqrt y"
270.11 + using real_sqrt_le_mono[of "x\<^sup>2" y] by simp
270.12 +
270.13 +lemma real_less_rsqrt: "x\<^sup>2 < y \<Longrightarrow> x < sqrt y"
270.14 + using real_sqrt_less_mono[of "x\<^sup>2" y] by simp
270.15 +
270.16 +lemma sqrt_even_pow2:
270.17 + assumes n: "even n"
270.18 + shows "sqrt (2 ^ n) = 2 ^ (n div 2)"
270.19 +proof -
270.20 + from n obtain m where m: "n = 2 * m"
270.21 + unfolding even_mult_two_ex ..
270.22 + from m have "sqrt (2 ^ n) = sqrt ((2 ^ m)\<^sup>2)"
270.23 + by (simp only: power_mult[symmetric] mult_commute)
270.24 + then show ?thesis
270.25 + using m by simp
270.26 +qed
270.27 +
270.28 lemmas real_sqrt_gt_0_iff [simp] = real_sqrt_less_iff [where x=0, unfolded real_sqrt_zero]
270.29 lemmas real_sqrt_lt_0_iff [simp] = real_sqrt_less_iff [where y=0, unfolded real_sqrt_zero]
270.30 lemmas real_sqrt_ge_0_iff [simp] = real_sqrt_le_iff [where x=0, unfolded real_sqrt_zero]
270.31 @@ -490,6 +511,13 @@
270.32 qed
270.33 qed
270.34
270.35 +lemma real_div_sqrt: "0 \<le> x \<Longrightarrow> x / sqrt x = sqrt x"
270.36 + apply (cases "x = 0")
270.37 + apply simp_all
270.38 + using sqrt_divide_self_eq[of x]
270.39 + apply (simp add: inverse_eq_divide field_simps)
270.40 + done
270.41 +
270.42 lemma real_divide_square_eq [simp]: "(((r::real) * a) / (r * r)) = a / r"
270.43 apply (simp add: divide_inverse)
270.44 apply (case_tac "r=0")
271.1 --- a/src/HOL/Num.thy Thu Dec 05 17:52:12 2013 +0100
271.2 +++ b/src/HOL/Num.thy Thu Dec 05 17:58:03 2013 +0100
271.3 @@ -275,16 +275,6 @@
271.4
271.5 end
271.6
271.7 -text {* Negative numerals. *}
271.8 -
271.9 -class neg_numeral = numeral + group_add
271.10 -begin
271.11 -
271.12 -definition neg_numeral :: "num \<Rightarrow> 'a" where
271.13 - "neg_numeral k = - numeral k"
271.14 -
271.15 -end
271.16 -
271.17 text {* Numeral syntax. *}
271.18
271.19 syntax
271.20 @@ -299,8 +289,8 @@
271.21 | (n, 0) => Syntax.const @{const_name Bit0} $ num_of_int n
271.22 | (n, 1) => Syntax.const @{const_name Bit1} $ num_of_int n)
271.23 else raise Match
271.24 - val pos = Syntax.const @{const_name numeral}
271.25 - val neg = Syntax.const @{const_name neg_numeral}
271.26 + val numeral = Syntax.const @{const_name numeral}
271.27 + val uminus = Syntax.const @{const_name uminus}
271.28 val one = Syntax.const @{const_name Groups.one}
271.29 val zero = Syntax.const @{const_name Groups.zero}
271.30 fun numeral_tr [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u] =
271.31 @@ -311,8 +301,9 @@
271.32 in
271.33 if value = 0 then zero else
271.34 if value > 0
271.35 - then pos $ num_of_int value
271.36 - else neg $ num_of_int (~value)
271.37 + then numeral $ num_of_int value
271.38 + else if value = ~1 then uminus $ one
271.39 + else uminus $ (numeral $ num_of_int (~value))
271.40 end
271.41 | numeral_tr ts = raise TERM ("numeral_tr", ts);
271.42 in [("_Numeral", K numeral_tr)] end
271.43 @@ -323,12 +314,12 @@
271.44 fun dest_num (Const (@{const_syntax Bit0}, _) $ n) = 2 * dest_num n
271.45 | dest_num (Const (@{const_syntax Bit1}, _) $ n) = 2 * dest_num n + 1
271.46 | dest_num (Const (@{const_syntax One}, _)) = 1;
271.47 - fun num_tr' sign ctxt T [n] =
271.48 + fun num_tr' ctxt T [n] =
271.49 let
271.50 val k = dest_num n;
271.51 val t' =
271.52 Syntax.const @{syntax_const "_Numeral"} $
271.53 - Syntax.free (sign ^ string_of_int k);
271.54 + Syntax.free (string_of_int k);
271.55 in
271.56 (case T of
271.57 Type (@{type_name fun}, [_, T']) =>
271.58 @@ -339,8 +330,7 @@
271.59 | _ => if T = dummyT then t' else raise Match)
271.60 end;
271.61 in
271.62 - [(@{const_syntax numeral}, num_tr' ""),
271.63 - (@{const_syntax neg_numeral}, num_tr' "-")]
271.64 + [(@{const_syntax numeral}, num_tr')]
271.65 end
271.66 *}
271.67
271.68 @@ -383,9 +373,13 @@
271.69 Structures with negation: class @{text neg_numeral}
271.70 *}
271.71
271.72 -context neg_numeral
271.73 +class neg_numeral = numeral + group_add
271.74 begin
271.75
271.76 +lemma uminus_numeral_One:
271.77 + "- Numeral1 = - 1"
271.78 + by (simp add: numeral_One)
271.79 +
271.80 text {* Numerals form an abelian subgroup. *}
271.81
271.82 inductive is_num :: "'a \<Rightarrow> bool" where
271.83 @@ -403,11 +397,11 @@
271.84 apply simp
271.85 apply (rule_tac a=x in add_left_imp_eq)
271.86 apply (rule_tac a=x in add_right_imp_eq)
271.87 - apply (simp add: add_assoc minus_add_cancel)
271.88 + apply (simp add: add_assoc)
271.89 apply (simp add: add_assoc [symmetric], simp add: add_assoc)
271.90 apply (rule_tac a=x in add_left_imp_eq)
271.91 apply (rule_tac a=x in add_right_imp_eq)
271.92 - apply (simp add: add_assoc minus_add_cancel add_minus_cancel)
271.93 + apply (simp add: add_assoc)
271.94 apply (simp add: add_assoc, simp add: add_assoc [symmetric])
271.95 done
271.96
271.97 @@ -418,7 +412,7 @@
271.98 lemmas is_num_normalize =
271.99 add_assoc is_num_add_commute is_num_add_left_commute
271.100 is_num.intros is_num_numeral
271.101 - diff_minus minus_add add_minus_cancel minus_add_cancel
271.102 + minus_add
271.103
271.104 definition dbl :: "'a \<Rightarrow> 'a" where "dbl x = x + x"
271.105 definition dbl_inc :: "'a \<Rightarrow> 'a" where "dbl_inc x = x + x + 1"
271.106 @@ -431,83 +425,85 @@
271.107 by (simp only: BitM_plus_one [symmetric] numeral_add numeral_One eq_diff_eq)
271.108
271.109 lemma dbl_simps [simp]:
271.110 - "dbl (neg_numeral k) = neg_numeral (Bit0 k)"
271.111 + "dbl (- numeral k) = - dbl (numeral k)"
271.112 "dbl 0 = 0"
271.113 "dbl 1 = 2"
271.114 + "dbl (- 1) = - 2"
271.115 "dbl (numeral k) = numeral (Bit0 k)"
271.116 - unfolding dbl_def neg_numeral_def numeral.simps
271.117 - by (simp_all add: minus_add)
271.118 + by (simp_all add: dbl_def numeral.simps minus_add)
271.119
271.120 lemma dbl_inc_simps [simp]:
271.121 - "dbl_inc (neg_numeral k) = neg_numeral (BitM k)"
271.122 + "dbl_inc (- numeral k) = - dbl_dec (numeral k)"
271.123 "dbl_inc 0 = 1"
271.124 "dbl_inc 1 = 3"
271.125 + "dbl_inc (- 1) = - 1"
271.126 "dbl_inc (numeral k) = numeral (Bit1 k)"
271.127 - unfolding dbl_inc_def neg_numeral_def numeral.simps numeral_BitM
271.128 - by (simp_all add: is_num_normalize)
271.129 + by (simp_all add: dbl_inc_def dbl_dec_def numeral.simps numeral_BitM is_num_normalize algebra_simps del: add_uminus_conv_diff)
271.130
271.131 lemma dbl_dec_simps [simp]:
271.132 - "dbl_dec (neg_numeral k) = neg_numeral (Bit1 k)"
271.133 - "dbl_dec 0 = -1"
271.134 + "dbl_dec (- numeral k) = - dbl_inc (numeral k)"
271.135 + "dbl_dec 0 = - 1"
271.136 "dbl_dec 1 = 1"
271.137 + "dbl_dec (- 1) = - 3"
271.138 "dbl_dec (numeral k) = numeral (BitM k)"
271.139 - unfolding dbl_dec_def neg_numeral_def numeral.simps numeral_BitM
271.140 - by (simp_all add: is_num_normalize)
271.141 + by (simp_all add: dbl_dec_def dbl_inc_def numeral.simps numeral_BitM is_num_normalize)
271.142
271.143 lemma sub_num_simps [simp]:
271.144 "sub One One = 0"
271.145 - "sub One (Bit0 l) = neg_numeral (BitM l)"
271.146 - "sub One (Bit1 l) = neg_numeral (Bit0 l)"
271.147 + "sub One (Bit0 l) = - numeral (BitM l)"
271.148 + "sub One (Bit1 l) = - numeral (Bit0 l)"
271.149 "sub (Bit0 k) One = numeral (BitM k)"
271.150 "sub (Bit1 k) One = numeral (Bit0 k)"
271.151 "sub (Bit0 k) (Bit0 l) = dbl (sub k l)"
271.152 "sub (Bit0 k) (Bit1 l) = dbl_dec (sub k l)"
271.153 "sub (Bit1 k) (Bit0 l) = dbl_inc (sub k l)"
271.154 "sub (Bit1 k) (Bit1 l) = dbl (sub k l)"
271.155 - unfolding dbl_def dbl_dec_def dbl_inc_def sub_def
271.156 - unfolding neg_numeral_def numeral.simps numeral_BitM
271.157 - by (simp_all add: is_num_normalize)
271.158 + by (simp_all add: dbl_def dbl_dec_def dbl_inc_def sub_def numeral.simps
271.159 + numeral_BitM is_num_normalize del: add_uminus_conv_diff add: diff_conv_add_uminus)
271.160
271.161 lemma add_neg_numeral_simps:
271.162 - "numeral m + neg_numeral n = sub m n"
271.163 - "neg_numeral m + numeral n = sub n m"
271.164 - "neg_numeral m + neg_numeral n = neg_numeral (m + n)"
271.165 - unfolding sub_def diff_minus neg_numeral_def numeral_add numeral.simps
271.166 - by (simp_all add: is_num_normalize)
271.167 + "numeral m + - numeral n = sub m n"
271.168 + "- numeral m + numeral n = sub n m"
271.169 + "- numeral m + - numeral n = - (numeral m + numeral n)"
271.170 + by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize
271.171 + del: add_uminus_conv_diff add: diff_conv_add_uminus)
271.172
271.173 lemma add_neg_numeral_special:
271.174 - "1 + neg_numeral m = sub One m"
271.175 - "neg_numeral m + 1 = sub One m"
271.176 - unfolding sub_def diff_minus neg_numeral_def numeral_add numeral.simps
271.177 - by (simp_all add: is_num_normalize)
271.178 + "1 + - numeral m = sub One m"
271.179 + "- numeral m + 1 = sub One m"
271.180 + "numeral m + - 1 = sub m One"
271.181 + "- 1 + numeral n = sub n One"
271.182 + "- 1 + - numeral n = - numeral (inc n)"
271.183 + "- numeral m + - 1 = - numeral (inc m)"
271.184 + "1 + - 1 = 0"
271.185 + "- 1 + 1 = 0"
271.186 + "- 1 + - 1 = - 2"
271.187 + by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize right_minus numeral_inc
271.188 + del: add_uminus_conv_diff add: diff_conv_add_uminus)
271.189
271.190 lemma diff_numeral_simps:
271.191 "numeral m - numeral n = sub m n"
271.192 - "numeral m - neg_numeral n = numeral (m + n)"
271.193 - "neg_numeral m - numeral n = neg_numeral (m + n)"
271.194 - "neg_numeral m - neg_numeral n = sub n m"
271.195 - unfolding neg_numeral_def sub_def diff_minus numeral_add numeral.simps
271.196 - by (simp_all add: is_num_normalize)
271.197 + "numeral m - - numeral n = numeral (m + n)"
271.198 + "- numeral m - numeral n = - numeral (m + n)"
271.199 + "- numeral m - - numeral n = sub n m"
271.200 + by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize
271.201 + del: add_uminus_conv_diff add: diff_conv_add_uminus)
271.202
271.203 lemma diff_numeral_special:
271.204 "1 - numeral n = sub One n"
271.205 - "1 - neg_numeral n = numeral (One + n)"
271.206 "numeral m - 1 = sub m One"
271.207 - "neg_numeral m - 1 = neg_numeral (m + One)"
271.208 - unfolding neg_numeral_def sub_def diff_minus numeral_add numeral.simps
271.209 - by (simp_all add: is_num_normalize)
271.210 -
271.211 -lemma minus_one: "- 1 = -1"
271.212 - unfolding neg_numeral_def numeral.simps ..
271.213 -
271.214 -lemma minus_numeral: "- numeral n = neg_numeral n"
271.215 - unfolding neg_numeral_def ..
271.216 -
271.217 -lemma minus_neg_numeral: "- neg_numeral n = numeral n"
271.218 - unfolding neg_numeral_def by simp
271.219 -
271.220 -lemmas minus_numeral_simps [simp] =
271.221 - minus_one minus_numeral minus_neg_numeral
271.222 + "1 - - numeral n = numeral (One + n)"
271.223 + "- numeral m - 1 = - numeral (m + One)"
271.224 + "- 1 - numeral n = - numeral (inc n)"
271.225 + "numeral m - - 1 = numeral (inc m)"
271.226 + "- 1 - - numeral n = sub n One"
271.227 + "- numeral m - - 1 = sub One m"
271.228 + "1 - 1 = 0"
271.229 + "- 1 - 1 = - 2"
271.230 + "1 - - 1 = 2"
271.231 + "- 1 - - 1 = 0"
271.232 + by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize numeral_inc
271.233 + del: add_uminus_conv_diff add: diff_conv_add_uminus)
271.234
271.235 end
271.236
271.237 @@ -681,17 +677,17 @@
271.238 subclass neg_numeral ..
271.239
271.240 lemma mult_neg_numeral_simps:
271.241 - "neg_numeral m * neg_numeral n = numeral (m * n)"
271.242 - "neg_numeral m * numeral n = neg_numeral (m * n)"
271.243 - "numeral m * neg_numeral n = neg_numeral (m * n)"
271.244 - unfolding neg_numeral_def mult_minus_left mult_minus_right
271.245 + "- numeral m * - numeral n = numeral (m * n)"
271.246 + "- numeral m * numeral n = - numeral (m * n)"
271.247 + "numeral m * - numeral n = - numeral (m * n)"
271.248 + unfolding mult_minus_left mult_minus_right
271.249 by (simp_all only: minus_minus numeral_mult)
271.250
271.251 -lemma mult_minus1 [simp]: "-1 * z = - z"
271.252 - unfolding neg_numeral_def numeral.simps mult_minus_left by simp
271.253 +lemma mult_minus1 [simp]: "- 1 * z = - z"
271.254 + unfolding numeral.simps mult_minus_left by simp
271.255
271.256 -lemma mult_minus1_right [simp]: "z * -1 = - z"
271.257 - unfolding neg_numeral_def numeral.simps mult_minus_right by simp
271.258 +lemma mult_minus1_right [simp]: "z * - 1 = - z"
271.259 + unfolding numeral.simps mult_minus_right by simp
271.260
271.261 end
271.262
271.263 @@ -714,9 +710,15 @@
271.264 lemma not_iszero_Numeral1: "\<not> iszero Numeral1"
271.265 by (simp add: numeral_One)
271.266
271.267 +lemma not_iszero_neg_1 [simp]: "\<not> iszero (- 1)"
271.268 + by (simp add: iszero_def)
271.269 +
271.270 +lemma not_iszero_neg_Numeral1: "\<not> iszero (- Numeral1)"
271.271 + by (simp add: numeral_One)
271.272 +
271.273 lemma iszero_neg_numeral [simp]:
271.274 - "iszero (neg_numeral w) \<longleftrightarrow> iszero (numeral w)"
271.275 - unfolding iszero_def neg_numeral_def
271.276 + "iszero (- numeral w) \<longleftrightarrow> iszero (numeral w)"
271.277 + unfolding iszero_def
271.278 by (rule neg_equal_0_iff_equal)
271.279
271.280 lemma eq_iff_iszero_diff: "x = y \<longleftrightarrow> iszero (x - y)"
271.281 @@ -736,17 +738,17 @@
271.282
271.283 lemma eq_numeral_iff_iszero:
271.284 "numeral x = numeral y \<longleftrightarrow> iszero (sub x y)"
271.285 - "numeral x = neg_numeral y \<longleftrightarrow> iszero (numeral (x + y))"
271.286 - "neg_numeral x = numeral y \<longleftrightarrow> iszero (numeral (x + y))"
271.287 - "neg_numeral x = neg_numeral y \<longleftrightarrow> iszero (sub y x)"
271.288 + "numeral x = - numeral y \<longleftrightarrow> iszero (numeral (x + y))"
271.289 + "- numeral x = numeral y \<longleftrightarrow> iszero (numeral (x + y))"
271.290 + "- numeral x = - numeral y \<longleftrightarrow> iszero (sub y x)"
271.291 "numeral x = 1 \<longleftrightarrow> iszero (sub x One)"
271.292 "1 = numeral y \<longleftrightarrow> iszero (sub One y)"
271.293 - "neg_numeral x = 1 \<longleftrightarrow> iszero (numeral (x + One))"
271.294 - "1 = neg_numeral y \<longleftrightarrow> iszero (numeral (One + y))"
271.295 + "- numeral x = 1 \<longleftrightarrow> iszero (numeral (x + One))"
271.296 + "1 = - numeral y \<longleftrightarrow> iszero (numeral (One + y))"
271.297 "numeral x = 0 \<longleftrightarrow> iszero (numeral x)"
271.298 "0 = numeral y \<longleftrightarrow> iszero (numeral y)"
271.299 - "neg_numeral x = 0 \<longleftrightarrow> iszero (numeral x)"
271.300 - "0 = neg_numeral y \<longleftrightarrow> iszero (numeral y)"
271.301 + "- numeral x = 0 \<longleftrightarrow> iszero (numeral x)"
271.302 + "0 = - numeral y \<longleftrightarrow> iszero (numeral y)"
271.303 unfolding eq_iff_iszero_diff diff_numeral_simps diff_numeral_special
271.304 by simp_all
271.305
271.306 @@ -762,33 +764,69 @@
271.307 lemma not_iszero_numeral [simp]: "\<not> iszero (numeral w)"
271.308 by (simp add: iszero_def)
271.309
271.310 -lemma neg_numeral_eq_iff: "neg_numeral m = neg_numeral n \<longleftrightarrow> m = n"
271.311 - by (simp only: neg_numeral_def neg_equal_iff_equal numeral_eq_iff)
271.312 +lemma neg_numeral_eq_iff: "- numeral m = - numeral n \<longleftrightarrow> m = n"
271.313 + by simp
271.314
271.315 -lemma numeral_neq_neg_numeral: "numeral m \<noteq> neg_numeral n"
271.316 - unfolding neg_numeral_def eq_neg_iff_add_eq_0
271.317 +lemma numeral_neq_neg_numeral: "numeral m \<noteq> - numeral n"
271.318 + unfolding eq_neg_iff_add_eq_0
271.319 by (simp add: numeral_plus_numeral)
271.320
271.321 -lemma neg_numeral_neq_numeral: "neg_numeral m \<noteq> numeral n"
271.322 +lemma neg_numeral_neq_numeral: "- numeral m \<noteq> numeral n"
271.323 by (rule numeral_neq_neg_numeral [symmetric])
271.324
271.325 -lemma zero_neq_neg_numeral: "0 \<noteq> neg_numeral n"
271.326 - unfolding neg_numeral_def neg_0_equal_iff_equal by simp
271.327 +lemma zero_neq_neg_numeral: "0 \<noteq> - numeral n"
271.328 + unfolding neg_0_equal_iff_equal by simp
271.329
271.330 -lemma neg_numeral_neq_zero: "neg_numeral n \<noteq> 0"
271.331 - unfolding neg_numeral_def neg_equal_0_iff_equal by simp
271.332 +lemma neg_numeral_neq_zero: "- numeral n \<noteq> 0"
271.333 + unfolding neg_equal_0_iff_equal by simp
271.334
271.335 -lemma one_neq_neg_numeral: "1 \<noteq> neg_numeral n"
271.336 +lemma one_neq_neg_numeral: "1 \<noteq> - numeral n"
271.337 using numeral_neq_neg_numeral [of One n] by (simp add: numeral_One)
271.338
271.339 -lemma neg_numeral_neq_one: "neg_numeral n \<noteq> 1"
271.340 +lemma neg_numeral_neq_one: "- numeral n \<noteq> 1"
271.341 using neg_numeral_neq_numeral [of n One] by (simp add: numeral_One)
271.342
271.343 +lemma neg_one_neq_numeral:
271.344 + "- 1 \<noteq> numeral n"
271.345 + using neg_numeral_neq_numeral [of One n] by (simp add: numeral_One)
271.346 +
271.347 +lemma numeral_neq_neg_one:
271.348 + "numeral n \<noteq> - 1"
271.349 + using numeral_neq_neg_numeral [of n One] by (simp add: numeral_One)
271.350 +
271.351 +lemma neg_one_eq_numeral_iff:
271.352 + "- 1 = - numeral n \<longleftrightarrow> n = One"
271.353 + using neg_numeral_eq_iff [of One n] by (auto simp add: numeral_One)
271.354 +
271.355 +lemma numeral_eq_neg_one_iff:
271.356 + "- numeral n = - 1 \<longleftrightarrow> n = One"
271.357 + using neg_numeral_eq_iff [of n One] by (auto simp add: numeral_One)
271.358 +
271.359 +lemma neg_one_neq_zero:
271.360 + "- 1 \<noteq> 0"
271.361 + by simp
271.362 +
271.363 +lemma zero_neq_neg_one:
271.364 + "0 \<noteq> - 1"
271.365 + by simp
271.366 +
271.367 +lemma neg_one_neq_one:
271.368 + "- 1 \<noteq> 1"
271.369 + using neg_numeral_neq_numeral [of One One] by (simp only: numeral_One not_False_eq_True)
271.370 +
271.371 +lemma one_neq_neg_one:
271.372 + "1 \<noteq> - 1"
271.373 + using numeral_neq_neg_numeral [of One One] by (simp only: numeral_One not_False_eq_True)
271.374 +
271.375 lemmas eq_neg_numeral_simps [simp] =
271.376 neg_numeral_eq_iff
271.377 numeral_neq_neg_numeral neg_numeral_neq_numeral
271.378 one_neq_neg_numeral neg_numeral_neq_one
271.379 zero_neq_neg_numeral neg_numeral_neq_zero
271.380 + neg_one_neq_numeral numeral_neq_neg_one
271.381 + neg_one_eq_numeral_iff numeral_eq_neg_one_iff
271.382 + neg_one_neq_zero zero_neq_neg_one
271.383 + neg_one_neq_one one_neq_neg_one
271.384
271.385 end
271.386
271.387 @@ -801,48 +839,72 @@
271.388
271.389 subclass ring_char_0 ..
271.390
271.391 -lemma neg_numeral_le_iff: "neg_numeral m \<le> neg_numeral n \<longleftrightarrow> n \<le> m"
271.392 - by (simp only: neg_numeral_def neg_le_iff_le numeral_le_iff)
271.393 +lemma neg_numeral_le_iff: "- numeral m \<le> - numeral n \<longleftrightarrow> n \<le> m"
271.394 + by (simp only: neg_le_iff_le numeral_le_iff)
271.395
271.396 -lemma neg_numeral_less_iff: "neg_numeral m < neg_numeral n \<longleftrightarrow> n < m"
271.397 - by (simp only: neg_numeral_def neg_less_iff_less numeral_less_iff)
271.398 +lemma neg_numeral_less_iff: "- numeral m < - numeral n \<longleftrightarrow> n < m"
271.399 + by (simp only: neg_less_iff_less numeral_less_iff)
271.400
271.401 -lemma neg_numeral_less_zero: "neg_numeral n < 0"
271.402 - by (simp only: neg_numeral_def neg_less_0_iff_less zero_less_numeral)
271.403 +lemma neg_numeral_less_zero: "- numeral n < 0"
271.404 + by (simp only: neg_less_0_iff_less zero_less_numeral)
271.405
271.406 -lemma neg_numeral_le_zero: "neg_numeral n \<le> 0"
271.407 - by (simp only: neg_numeral_def neg_le_0_iff_le zero_le_numeral)
271.408 +lemma neg_numeral_le_zero: "- numeral n \<le> 0"
271.409 + by (simp only: neg_le_0_iff_le zero_le_numeral)
271.410
271.411 -lemma not_zero_less_neg_numeral: "\<not> 0 < neg_numeral n"
271.412 +lemma not_zero_less_neg_numeral: "\<not> 0 < - numeral n"
271.413 by (simp only: not_less neg_numeral_le_zero)
271.414
271.415 -lemma not_zero_le_neg_numeral: "\<not> 0 \<le> neg_numeral n"
271.416 +lemma not_zero_le_neg_numeral: "\<not> 0 \<le> - numeral n"
271.417 by (simp only: not_le neg_numeral_less_zero)
271.418
271.419 -lemma neg_numeral_less_numeral: "neg_numeral m < numeral n"
271.420 +lemma neg_numeral_less_numeral: "- numeral m < numeral n"
271.421 using neg_numeral_less_zero zero_less_numeral by (rule less_trans)
271.422
271.423 -lemma neg_numeral_le_numeral: "neg_numeral m \<le> numeral n"
271.424 +lemma neg_numeral_le_numeral: "- numeral m \<le> numeral n"
271.425 by (simp only: less_imp_le neg_numeral_less_numeral)
271.426
271.427 -lemma not_numeral_less_neg_numeral: "\<not> numeral m < neg_numeral n"
271.428 +lemma not_numeral_less_neg_numeral: "\<not> numeral m < - numeral n"
271.429 by (simp only: not_less neg_numeral_le_numeral)
271.430
271.431 -lemma not_numeral_le_neg_numeral: "\<not> numeral m \<le> neg_numeral n"
271.432 +lemma not_numeral_le_neg_numeral: "\<not> numeral m \<le> - numeral n"
271.433 by (simp only: not_le neg_numeral_less_numeral)
271.434
271.435 -lemma neg_numeral_less_one: "neg_numeral m < 1"
271.436 +lemma neg_numeral_less_one: "- numeral m < 1"
271.437 by (rule neg_numeral_less_numeral [of m One, unfolded numeral_One])
271.438
271.439 -lemma neg_numeral_le_one: "neg_numeral m \<le> 1"
271.440 +lemma neg_numeral_le_one: "- numeral m \<le> 1"
271.441 by (rule neg_numeral_le_numeral [of m One, unfolded numeral_One])
271.442
271.443 -lemma not_one_less_neg_numeral: "\<not> 1 < neg_numeral m"
271.444 +lemma not_one_less_neg_numeral: "\<not> 1 < - numeral m"
271.445 by (simp only: not_less neg_numeral_le_one)
271.446
271.447 -lemma not_one_le_neg_numeral: "\<not> 1 \<le> neg_numeral m"
271.448 +lemma not_one_le_neg_numeral: "\<not> 1 \<le> - numeral m"
271.449 by (simp only: not_le neg_numeral_less_one)
271.450
271.451 +lemma not_numeral_less_neg_one: "\<not> numeral m < - 1"
271.452 + using not_numeral_less_neg_numeral [of m One] by (simp add: numeral_One)
271.453 +
271.454 +lemma not_numeral_le_neg_one: "\<not> numeral m \<le> - 1"
271.455 + using not_numeral_le_neg_numeral [of m One] by (simp add: numeral_One)
271.456 +
271.457 +lemma neg_one_less_numeral: "- 1 < numeral m"
271.458 + using neg_numeral_less_numeral [of One m] by (simp add: numeral_One)
271.459 +
271.460 +lemma neg_one_le_numeral: "- 1 \<le> numeral m"
271.461 + using neg_numeral_le_numeral [of One m] by (simp add: numeral_One)
271.462 +
271.463 +lemma neg_numeral_less_neg_one_iff: "- numeral m < - 1 \<longleftrightarrow> m \<noteq> One"
271.464 + by (cases m) simp_all
271.465 +
271.466 +lemma neg_numeral_le_neg_one: "- numeral m \<le> - 1"
271.467 + by simp
271.468 +
271.469 +lemma not_neg_one_less_neg_numeral: "\<not> - 1 < - numeral m"
271.470 + by simp
271.471 +
271.472 +lemma not_neg_one_le_neg_numeral_iff: "\<not> - 1 \<le> - numeral m \<longleftrightarrow> m \<noteq> One"
271.473 + by (cases m) simp_all
271.474 +
271.475 lemma sub_non_negative:
271.476 "sub n m \<ge> 0 \<longleftrightarrow> n \<ge> m"
271.477 by (simp only: sub_def le_diff_eq) simp
271.478 @@ -864,18 +926,40 @@
271.479 neg_numeral_le_numeral not_numeral_le_neg_numeral
271.480 neg_numeral_le_zero not_zero_le_neg_numeral
271.481 neg_numeral_le_one not_one_le_neg_numeral
271.482 + neg_one_le_numeral not_numeral_le_neg_one
271.483 + neg_numeral_le_neg_one not_neg_one_le_neg_numeral_iff
271.484 +
271.485 +lemma le_minus_one_simps [simp]:
271.486 + "- 1 \<le> 0"
271.487 + "- 1 \<le> 1"
271.488 + "\<not> 0 \<le> - 1"
271.489 + "\<not> 1 \<le> - 1"
271.490 + by simp_all
271.491
271.492 lemmas less_neg_numeral_simps [simp] =
271.493 neg_numeral_less_iff
271.494 neg_numeral_less_numeral not_numeral_less_neg_numeral
271.495 neg_numeral_less_zero not_zero_less_neg_numeral
271.496 neg_numeral_less_one not_one_less_neg_numeral
271.497 + neg_one_less_numeral not_numeral_less_neg_one
271.498 + neg_numeral_less_neg_one_iff not_neg_one_less_neg_numeral
271.499 +
271.500 +lemma less_minus_one_simps [simp]:
271.501 + "- 1 < 0"
271.502 + "- 1 < 1"
271.503 + "\<not> 0 < - 1"
271.504 + "\<not> 1 < - 1"
271.505 + by (simp_all add: less_le)
271.506
271.507 lemma abs_numeral [simp]: "abs (numeral n) = numeral n"
271.508 by simp
271.509
271.510 -lemma abs_neg_numeral [simp]: "abs (neg_numeral n) = numeral n"
271.511 - by (simp only: neg_numeral_def abs_minus_cancel abs_numeral)
271.512 +lemma abs_neg_numeral [simp]: "abs (- numeral n) = numeral n"
271.513 + by (simp only: abs_minus_cancel abs_numeral)
271.514 +
271.515 +lemma abs_neg_one [simp]:
271.516 + "abs (- 1) = 1"
271.517 + by simp
271.518
271.519 end
271.520
271.521 @@ -1038,31 +1122,36 @@
271.522 text{*Theorem lists for the cancellation simprocs. The use of a binary
271.523 numeral for 1 reduces the number of special cases.*}
271.524
271.525 -lemmas mult_1s =
271.526 - mult_numeral_1 mult_numeral_1_right
271.527 - mult_minus1 mult_minus1_right
271.528 +lemma mult_1s:
271.529 + fixes a :: "'a::semiring_numeral"
271.530 + and b :: "'b::ring_1"
271.531 + shows "Numeral1 * a = a"
271.532 + "a * Numeral1 = a"
271.533 + "- Numeral1 * b = - b"
271.534 + "b * - Numeral1 = - b"
271.535 + by simp_all
271.536
271.537 setup {*
271.538 Reorient_Proc.add
271.539 (fn Const (@{const_name numeral}, _) $ _ => true
271.540 - | Const (@{const_name neg_numeral}, _) $ _ => true
271.541 + | Const (@{const_name uminus}, _) $ (Const (@{const_name numeral}, _) $ _) => true
271.542 | _ => false)
271.543 *}
271.544
271.545 simproc_setup reorient_numeral
271.546 - ("numeral w = x" | "neg_numeral w = y") = Reorient_Proc.proc
271.547 + ("numeral w = x" | "- numeral w = y") = Reorient_Proc.proc
271.548
271.549
271.550 subsubsection {* Simplification of arithmetic operations on integer constants. *}
271.551
271.552 lemmas arith_special = (* already declared simp above *)
271.553 add_numeral_special add_neg_numeral_special
271.554 - diff_numeral_special minus_one
271.555 + diff_numeral_special
271.556
271.557 (* rules already in simpset *)
271.558 lemmas arith_extra_simps =
271.559 numeral_plus_numeral add_neg_numeral_simps add_0_left add_0_right
271.560 - minus_numeral minus_neg_numeral minus_zero minus_one
271.561 + minus_zero
271.562 diff_numeral_simps diff_0 diff_0_right
271.563 numeral_times_numeral mult_neg_numeral_simps
271.564 mult_zero_left mult_zero_right
271.565 @@ -1078,6 +1167,16 @@
271.566 BitM.simps dbl_simps dbl_inc_simps dbl_dec_simps
271.567 abs_zero abs_one arith_extra_simps
271.568
271.569 +lemmas more_arith_simps =
271.570 + neg_le_iff_le
271.571 + minus_zero left_minus right_minus
271.572 + mult_1_left mult_1_right
271.573 + mult_minus_left mult_minus_right
271.574 + minus_add_distrib minus_minus mult_assoc
271.575 +
271.576 +lemmas of_nat_simps =
271.577 + of_nat_0 of_nat_1 of_nat_Suc of_nat_add of_nat_mult
271.578 +
271.579 text {* Simplification of relational operations *}
271.580
271.581 lemmas eq_numeral_extra =
271.582 @@ -1085,10 +1184,42 @@
271.583
271.584 lemmas rel_simps =
271.585 le_num_simps less_num_simps eq_num_simps
271.586 - le_numeral_simps le_neg_numeral_simps le_numeral_extra
271.587 - less_numeral_simps less_neg_numeral_simps less_numeral_extra
271.588 + le_numeral_simps le_neg_numeral_simps le_minus_one_simps le_numeral_extra
271.589 + less_numeral_simps less_neg_numeral_simps less_minus_one_simps less_numeral_extra
271.590 eq_numeral_simps eq_neg_numeral_simps eq_numeral_extra
271.591
271.592 +lemma Let_numeral [simp]: "Let (numeral v) f = f (numeral v)"
271.593 + -- {* Unfold all @{text let}s involving constants *}
271.594 + unfolding Let_def ..
271.595 +
271.596 +lemma Let_neg_numeral [simp]: "Let (- numeral v) f = f (- numeral v)"
271.597 + -- {* Unfold all @{text let}s involving constants *}
271.598 + unfolding Let_def ..
271.599 +
271.600 +declaration {*
271.601 +let
271.602 + fun number_of thy T n =
271.603 + if not (Sign.of_sort thy (T, @{sort numeral}))
271.604 + then raise CTERM ("number_of", [])
271.605 + else Numeral.mk_cnumber (Thm.ctyp_of thy T) n;
271.606 +in
271.607 + K (
271.608 + Lin_Arith.add_simps (@{thms arith_simps} @ @{thms more_arith_simps}
271.609 + @ @{thms rel_simps}
271.610 + @ @{thms pred_numeral_simps}
271.611 + @ @{thms arith_special numeral_One}
271.612 + @ @{thms of_nat_simps})
271.613 + #> Lin_Arith.add_simps [@{thm Suc_numeral},
271.614 + @{thm Let_numeral}, @{thm Let_neg_numeral}, @{thm Let_0}, @{thm Let_1},
271.615 + @{thm le_Suc_numeral}, @{thm le_numeral_Suc},
271.616 + @{thm less_Suc_numeral}, @{thm less_numeral_Suc},
271.617 + @{thm Suc_eq_numeral}, @{thm eq_numeral_Suc},
271.618 + @{thm mult_Suc}, @{thm mult_Suc_right},
271.619 + @{thm of_nat_numeral}]
271.620 + #> Lin_Arith.set_number_of number_of)
271.621 +end
271.622 +*}
271.623 +
271.624
271.625 subsubsection {* Simplification of arithmetic when nested to the right. *}
271.626
271.627 @@ -1097,16 +1228,16 @@
271.628 by (simp_all add: add_assoc [symmetric])
271.629
271.630 lemma add_neg_numeral_left [simp]:
271.631 - "numeral v + (neg_numeral w + y) = (sub v w + y)"
271.632 - "neg_numeral v + (numeral w + y) = (sub w v + y)"
271.633 - "neg_numeral v + (neg_numeral w + y) = (neg_numeral(v + w) + y)"
271.634 + "numeral v + (- numeral w + y) = (sub v w + y)"
271.635 + "- numeral v + (numeral w + y) = (sub w v + y)"
271.636 + "- numeral v + (- numeral w + y) = (- numeral(v + w) + y)"
271.637 by (simp_all add: add_assoc [symmetric])
271.638
271.639 lemma mult_numeral_left [simp]:
271.640 "numeral v * (numeral w * z) = (numeral(v * w) * z :: 'a::semiring_numeral)"
271.641 - "neg_numeral v * (numeral w * y) = (neg_numeral(v * w) * y :: 'b::ring_1)"
271.642 - "numeral v * (neg_numeral w * y) = (neg_numeral(v * w) * y :: 'b::ring_1)"
271.643 - "neg_numeral v * (neg_numeral w * y) = (numeral(v * w) * y :: 'b::ring_1)"
271.644 + "- numeral v * (numeral w * y) = (- numeral(v * w) * y :: 'b::ring_1)"
271.645 + "numeral v * (- numeral w * y) = (- numeral(v * w) * y :: 'b::ring_1)"
271.646 + "- numeral v * (- numeral w * y) = (numeral(v * w) * y :: 'b::ring_1)"
271.647 by (simp_all add: mult_assoc [symmetric])
271.648
271.649 hide_const (open) One Bit0 Bit1 BitM inc pow sqr sub dbl dbl_inc dbl_dec
271.650 @@ -1119,4 +1250,3 @@
271.651
271.652 end
271.653
271.654 -
272.1 --- a/src/HOL/Number_Theory/Cong.thy Thu Dec 05 17:52:12 2013 +0100
272.2 +++ b/src/HOL/Number_Theory/Cong.thy Thu Dec 05 17:58:03 2013 +0100
272.3 @@ -323,8 +323,6 @@
272.4 \<Longrightarrow> [a = 1] (mod p) \<or> [a = - 1] (mod p)"
272.5 apply (simp only: cong_altdef_int)
272.6 apply (subst prime_dvd_mult_eq_int [symmetric], assumption)
272.7 - (* any way around this? *)
272.8 - apply (subgoal_tac "a * a - 1 = (a - 1) * (a - -1)")
272.9 apply (auto simp add: field_simps)
272.10 done
272.11
272.12 @@ -543,7 +541,8 @@
272.13 apply (subgoal_tac "a * b = (-a * -b)")
272.14 apply (erule ssubst)
272.15 apply (subst zmod_zmult2_eq)
272.16 - apply (auto simp add: mod_add_left_eq)
272.17 + apply (auto simp add: mod_add_left_eq mod_minus_right div_minus_right)
272.18 + apply (metis mod_diff_left_eq mod_diff_right_eq mod_mult_self1_is_0 semiring_numeral_div_class.diff_zero)+
272.19 done
272.20
272.21 lemma cong_to_1_nat: "([(a::nat) = 1] (mod n)) \<Longrightarrow> (n dvd (a - 1))"
272.22 @@ -664,7 +663,6 @@
272.23 apply auto
272.24 apply (cases "n \<ge> 0")
272.25 apply auto
272.26 - apply (subst cong_int_def, auto)
272.27 apply (frule cong_solve_int [of a n])
272.28 apply auto
272.29 done
273.1 --- a/src/HOL/Number_Theory/Eratosthenes.thy Thu Dec 05 17:52:12 2013 +0100
273.2 +++ b/src/HOL/Number_Theory/Eratosthenes.thy Thu Dec 05 17:58:03 2013 +0100
273.3 @@ -75,7 +75,7 @@
273.4 lemma numbers_of_marks_mark_out:
273.5 "numbers_of_marks n (mark_out m bs) = {q \<in> numbers_of_marks n bs. \<not> Suc m dvd Suc q - n}"
273.6 by (auto simp add: numbers_of_marks_def mark_out_def in_set_enumerate_eq image_iff
273.7 - nth_enumerate_eq less_dvd_minus)
273.8 + nth_enumerate_eq less_eq_dvd_minus)
273.9
273.10
273.11 text {* Auxiliary operation for efficient implementation *}
273.12 @@ -128,7 +128,7 @@
273.13 by (simp add: mark_out_aux_def)
273.14 show ?thesis2
273.15 by (auto simp add: mark_out_code [symmetric] mark_out_aux_def mark_out_def
273.16 - enumerate_Suc_eq in_set_enumerate_eq less_dvd_minus)
273.17 + enumerate_Suc_eq in_set_enumerate_eq less_eq_dvd_minus)
273.18 { def v \<equiv> "Suc m" and w \<equiv> "Suc n"
273.19 fix q
273.20 assume "m + n \<le> q"
274.1 --- a/src/HOL/Number_Theory/Primes.thy Thu Dec 05 17:52:12 2013 +0100
274.2 +++ b/src/HOL/Number_Theory/Primes.thy Thu Dec 05 17:58:03 2013 +0100
274.3 @@ -74,8 +74,9 @@
274.4 subsection {* Primes *}
274.5
274.6 lemma prime_odd_nat: "prime (p::nat) \<Longrightarrow> p > 2 \<Longrightarrow> odd p"
274.7 - unfolding prime_nat_def
274.8 - by (metis gcd_lcm_complete_lattice_nat.bot_least nat_even_iff_2_dvd nat_neq_iff odd_1_nat)
274.9 + apply (auto simp add: prime_nat_def even_def dvd_eq_mod_eq_0)
274.10 + apply (metis dvd_eq_mod_eq_0 even_Suc even_def mod_by_1 nat_dvd_not_less not_mod_2_eq_0_eq_1 zero_less_numeral)
274.11 + done
274.12
274.13 lemma prime_odd_int: "prime (p::int) \<Longrightarrow> p > 2 \<Longrightarrow> odd p"
274.14 unfolding prime_int_def
275.1 --- a/src/HOL/Number_Theory/Residues.thy Thu Dec 05 17:52:12 2013 +0100
275.2 +++ b/src/HOL/Number_Theory/Residues.thy Thu Dec 05 17:58:03 2013 +0100
275.3 @@ -131,10 +131,8 @@
275.4 lemma finite [iff]: "finite (carrier R)"
275.5 by (subst res_carrier_eq, auto)
275.6
275.7 -declare [[simproc del: finite_Collect]]
275.8 lemma finite_Units [iff]: "finite (Units R)"
275.9 by (subst res_units_eq) auto
275.10 -declare [[simproc add: finite_Collect]]
275.11
275.12 (* The function a -> a mod m maps the integers to the
275.13 residue classes. The following lemmas show that this mapping
275.14 @@ -455,6 +453,7 @@
275.15 apply (subst fact_altdef_int, simp)
275.16 apply (subst cong_int_def)
275.17 apply simp
275.18 + apply arith
275.19 apply (rule residues_prime.wilson_theorem1)
275.20 apply (rule residues_prime.intro)
275.21 apply auto
276.1 --- a/src/HOL/Number_Theory/UniqueFactorization.thy Thu Dec 05 17:52:12 2013 +0100
276.2 +++ b/src/HOL/Number_Theory/UniqueFactorization.thy Thu Dec 05 17:58:03 2013 +0100
276.3 @@ -359,7 +359,6 @@
276.4 apply auto
276.5 done
276.6
276.7 -declare [[simproc del: finite_Collect]]
276.8 lemma prime_factors_characterization_int: "S = {p. 0 < f (p::int)} \<Longrightarrow>
276.9 finite S \<Longrightarrow> (ALL p:S. prime p) \<Longrightarrow> n = (PROD p:S. p ^ f p) \<Longrightarrow>
276.10 prime_factors n = S"
276.11 @@ -832,7 +831,5 @@
276.12 apply auto
276.13 done
276.14
276.15 -declare [[simproc add: finite_Collect]]
276.16 -
276.17 end
276.18
277.1 --- a/src/HOL/Numeral_Simprocs.thy Thu Dec 05 17:52:12 2013 +0100
277.2 +++ b/src/HOL/Numeral_Simprocs.thy Thu Dec 05 17:58:03 2013 +0100
277.3 @@ -13,11 +13,11 @@
277.4 ML_file "~~/src/Provers/Arith/extract_common_term.ML"
277.5
277.6 lemmas semiring_norm =
277.7 - Let_def arith_simps nat_arith rel_simps
277.8 + Let_def arith_simps diff_nat_numeral rel_simps
277.9 if_False if_True
277.10 add_0 add_Suc add_numeral_left
277.11 add_neg_numeral_left mult_numeral_left
277.12 - numeral_1_eq_1 [symmetric] Suc_eq_plus1
277.13 + numeral_One [symmetric] uminus_numeral_One [symmetric] Suc_eq_plus1
277.14 eq_numeral_iff_iszero not_iszero_Numeral1
277.15
277.16 declare split_div [of _ _ "numeral k", arith_split] for k
277.17 @@ -85,18 +85,19 @@
277.18
277.19 text {* For @{text cancel_factor} *}
277.20
277.21 -lemma nat_mult_le_cancel_disj: "(k*m <= k*n) = ((0::nat) < k --> m<=n)"
277.22 -by auto
277.23 +lemmas nat_mult_le_cancel_disj = mult_le_cancel1
277.24
277.25 -lemma nat_mult_less_cancel_disj: "(k*m < k*n) = ((0::nat) < k & m<n)"
277.26 -by auto
277.27 +lemmas nat_mult_less_cancel_disj = mult_less_cancel1
277.28
277.29 -lemma nat_mult_eq_cancel_disj: "(k*m = k*n) = (k = (0::nat) | m=n)"
277.30 -by auto
277.31 +lemma nat_mult_eq_cancel_disj:
277.32 + fixes k m n :: nat
277.33 + shows "k * m = k * n \<longleftrightarrow> k = 0 \<or> m = n"
277.34 + by auto
277.35
277.36 -lemma nat_mult_div_cancel_disj[simp]:
277.37 - "(k*m) div (k*n) = (if k = (0::nat) then 0 else m div n)"
277.38 -by (simp add: nat_mult_div_cancel1)
277.39 +lemma nat_mult_div_cancel_disj [simp]:
277.40 + fixes k m n :: nat
277.41 + shows "(k * m) div (k * n) = (if k = 0 then 0 else m div n)"
277.42 + by (fact div_mult_mult1_if)
277.43
277.44 ML_file "Tools/numeral_simprocs.ML"
277.45
277.46 @@ -278,27 +279,8 @@
277.47 ("((l::nat) * m) dvd n" | "(l::nat) dvd (m * n)") =
277.48 {* fn phi => Nat_Numeral_Simprocs.dvd_cancel_factor *}
277.49
277.50 -(* FIXME: duplicate rule warnings for:
277.51 - ring_distribs
277.52 - numeral_plus_numeral numeral_times_numeral
277.53 - numeral_eq_iff numeral_less_iff numeral_le_iff
277.54 - numeral_neq_zero zero_neq_numeral zero_less_numeral
277.55 - if_True if_False *)
277.56 declaration {*
277.57 - K (Lin_Arith.add_simps ([@{thm Suc_numeral}, @{thm int_numeral}])
277.58 - #> Lin_Arith.add_simps (@{thms ring_distribs} @ [@{thm Let_numeral}, @{thm Let_neg_numeral}, @{thm Let_0}, @{thm Let_1},
277.59 - @{thm nat_0}, @{thm nat_1},
277.60 - @{thm numeral_plus_numeral}, @{thm diff_nat_numeral}, @{thm numeral_times_numeral},
277.61 - @{thm numeral_eq_iff}, @{thm numeral_less_iff}, @{thm numeral_le_iff},
277.62 - @{thm le_Suc_numeral}, @{thm le_numeral_Suc},
277.63 - @{thm less_Suc_numeral}, @{thm less_numeral_Suc},
277.64 - @{thm Suc_eq_numeral}, @{thm eq_numeral_Suc},
277.65 - @{thm mult_Suc}, @{thm mult_Suc_right},
277.66 - @{thm add_Suc}, @{thm add_Suc_right},
277.67 - @{thm numeral_neq_zero}, @{thm zero_neq_numeral}, @{thm zero_less_numeral},
277.68 - @{thm of_int_numeral}, @{thm of_nat_numeral}, @{thm nat_numeral},
277.69 - @{thm if_True}, @{thm if_False}])
277.70 - #> Lin_Arith.add_simprocs
277.71 + K (Lin_Arith.add_simprocs
277.72 [@{simproc semiring_assoc_fold},
277.73 @{simproc int_combine_numerals},
277.74 @{simproc inteq_cancel_numerals},
278.1 --- a/src/HOL/Old_Number_Theory/Pocklington.thy Thu Dec 05 17:52:12 2013 +0100
278.2 +++ b/src/HOL/Old_Number_Theory/Pocklington.thy Thu Dec 05 17:58:03 2013 +0100
278.3 @@ -348,15 +348,11 @@
278.4 let ?w = "x mod (a*b)"
278.5 have wab: "?w < a*b" by (simp add: mod_less_divisor[OF abpos])
278.6 from xq12(1) have "?w mod a = ((m + q1 * a) mod (a*b)) mod a" by simp
278.7 - also have "\<dots> = m mod a" apply (simp add: mod_mult2_eq)
278.8 - apply (subst mod_add_left_eq)
278.9 - by simp
278.10 + also have "\<dots> = m mod a" by (simp add: mod_mult2_eq)
278.11 finally have th1: "[?w = m] (mod a)" by (simp add: modeq_def)
278.12 from xq12(2) have "?w mod b = ((n + q2 * b) mod (a*b)) mod b" by simp
278.13 also have "\<dots> = ((n + q2 * b) mod (b*a)) mod b" by (simp add: mult_commute)
278.14 - also have "\<dots> = n mod b" apply (simp add: mod_mult2_eq)
278.15 - apply (subst mod_add_left_eq)
278.16 - by simp
278.17 + also have "\<dots> = n mod b" by (simp add: mod_mult2_eq)
278.18 finally have th2: "[?w = n] (mod b)" by (simp add: modeq_def)
278.19 {fix y assume H: "y < a*b" "[y = m] (mod a)" "[y = n] (mod b)"
278.20 with th1 th2 have H': "[y = ?w] (mod a)" "[y = ?w] (mod b)"
279.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
279.2 +++ b/src/HOL/Order_Relation.thy Thu Dec 05 17:58:03 2013 +0100
279.3 @@ -0,0 +1,125 @@
279.4 +(* Title: HOL/Order_Relation.thy
279.5 + Author: Tobias Nipkow
279.6 +*)
279.7 +
279.8 +header {* Orders as Relations *}
279.9 +
279.10 +theory Order_Relation
279.11 +imports Wellfounded
279.12 +begin
279.13 +
279.14 +subsection{* Orders on a set *}
279.15 +
279.16 +definition "preorder_on A r \<equiv> refl_on A r \<and> trans r"
279.17 +
279.18 +definition "partial_order_on A r \<equiv> preorder_on A r \<and> antisym r"
279.19 +
279.20 +definition "linear_order_on A r \<equiv> partial_order_on A r \<and> total_on A r"
279.21 +
279.22 +definition "strict_linear_order_on A r \<equiv> trans r \<and> irrefl r \<and> total_on A r"
279.23 +
279.24 +definition "well_order_on A r \<equiv> linear_order_on A r \<and> wf(r - Id)"
279.25 +
279.26 +lemmas order_on_defs =
279.27 + preorder_on_def partial_order_on_def linear_order_on_def
279.28 + strict_linear_order_on_def well_order_on_def
279.29 +
279.30 +
279.31 +lemma preorder_on_empty[simp]: "preorder_on {} {}"
279.32 +by(simp add:preorder_on_def trans_def)
279.33 +
279.34 +lemma partial_order_on_empty[simp]: "partial_order_on {} {}"
279.35 +by(simp add:partial_order_on_def)
279.36 +
279.37 +lemma lnear_order_on_empty[simp]: "linear_order_on {} {}"
279.38 +by(simp add:linear_order_on_def)
279.39 +
279.40 +lemma well_order_on_empty[simp]: "well_order_on {} {}"
279.41 +by(simp add:well_order_on_def)
279.42 +
279.43 +
279.44 +lemma preorder_on_converse[simp]: "preorder_on A (r^-1) = preorder_on A r"
279.45 +by (simp add:preorder_on_def)
279.46 +
279.47 +lemma partial_order_on_converse[simp]:
279.48 + "partial_order_on A (r^-1) = partial_order_on A r"
279.49 +by (simp add: partial_order_on_def)
279.50 +
279.51 +lemma linear_order_on_converse[simp]:
279.52 + "linear_order_on A (r^-1) = linear_order_on A r"
279.53 +by (simp add: linear_order_on_def)
279.54 +
279.55 +
279.56 +lemma strict_linear_order_on_diff_Id:
279.57 + "linear_order_on A r \<Longrightarrow> strict_linear_order_on A (r-Id)"
279.58 +by(simp add: order_on_defs trans_diff_Id)
279.59 +
279.60 +
279.61 +subsection{* Orders on the field *}
279.62 +
279.63 +abbreviation "Refl r \<equiv> refl_on (Field r) r"
279.64 +
279.65 +abbreviation "Preorder r \<equiv> preorder_on (Field r) r"
279.66 +
279.67 +abbreviation "Partial_order r \<equiv> partial_order_on (Field r) r"
279.68 +
279.69 +abbreviation "Total r \<equiv> total_on (Field r) r"
279.70 +
279.71 +abbreviation "Linear_order r \<equiv> linear_order_on (Field r) r"
279.72 +
279.73 +abbreviation "Well_order r \<equiv> well_order_on (Field r) r"
279.74 +
279.75 +
279.76 +lemma subset_Image_Image_iff:
279.77 + "\<lbrakk> Preorder r; A \<subseteq> Field r; B \<subseteq> Field r\<rbrakk> \<Longrightarrow>
279.78 + r `` A \<subseteq> r `` B \<longleftrightarrow> (\<forall>a\<in>A.\<exists>b\<in>B. (b,a):r)"
279.79 +unfolding preorder_on_def refl_on_def Image_def
279.80 +apply (simp add: subset_eq)
279.81 +unfolding trans_def by fast
279.82 +
279.83 +lemma subset_Image1_Image1_iff:
279.84 + "\<lbrakk> Preorder r; a : Field r; b : Field r\<rbrakk> \<Longrightarrow> r `` {a} \<subseteq> r `` {b} \<longleftrightarrow> (b,a):r"
279.85 +by(simp add:subset_Image_Image_iff)
279.86 +
279.87 +lemma Refl_antisym_eq_Image1_Image1_iff:
279.88 + assumes r: "Refl r" and as: "antisym r" and abf: "a \<in> Field r" "b \<in> Field r"
279.89 + shows "r `` {a} = r `` {b} \<longleftrightarrow> a = b"
279.90 +proof
279.91 + assume "r `` {a} = r `` {b}"
279.92 + hence e: "\<And>x. (a, x) \<in> r \<longleftrightarrow> (b, x) \<in> r" by (simp add: set_eq_iff)
279.93 + have "(a, a) \<in> r" "(b, b) \<in> r" using r abf by (simp_all add: refl_on_def)
279.94 + hence "(a, b) \<in> r" "(b, a) \<in> r" using e[of a] e[of b] by simp_all
279.95 + thus "a = b" using as[unfolded antisym_def] by blast
279.96 +qed fast
279.97 +
279.98 +lemma Partial_order_eq_Image1_Image1_iff:
279.99 + "\<lbrakk>Partial_order r; a:Field r; b:Field r\<rbrakk> \<Longrightarrow> r `` {a} = r `` {b} \<longleftrightarrow> a=b"
279.100 +by(auto simp:order_on_defs Refl_antisym_eq_Image1_Image1_iff)
279.101 +
279.102 +lemma Total_Id_Field:
279.103 +assumes TOT: "Total r" and NID: "\<not> (r <= Id)"
279.104 +shows "Field r = Field(r - Id)"
279.105 +using mono_Field[of "r - Id" r] Diff_subset[of r Id]
279.106 +proof(auto)
279.107 + have "r \<noteq> {}" using NID by fast
279.108 + then obtain b and c where "b \<noteq> c \<and> (b,c) \<in> r" using NID by auto
279.109 + hence 1: "b \<noteq> c \<and> {b,c} \<le> Field r" by (auto simp: Field_def)
279.110 +
279.111 + fix a assume *: "a \<in> Field r"
279.112 + obtain d where 2: "d \<in> Field r" and 3: "d \<noteq> a"
279.113 + using * 1 by auto
279.114 + hence "(a,d) \<in> r \<or> (d,a) \<in> r" using * TOT
279.115 + by (simp add: total_on_def)
279.116 + thus "a \<in> Field(r - Id)" using 3 unfolding Field_def by blast
279.117 +qed
279.118 +
279.119 +
279.120 +subsection{* Orders on a type *}
279.121 +
279.122 +abbreviation "strict_linear_order \<equiv> strict_linear_order_on UNIV"
279.123 +
279.124 +abbreviation "linear_order \<equiv> linear_order_on UNIV"
279.125 +
279.126 +abbreviation "well_order \<equiv> well_order_on UNIV"
279.127 +
279.128 +end
280.1 --- a/src/HOL/Orderings.thy Thu Dec 05 17:52:12 2013 +0100
280.2 +++ b/src/HOL/Orderings.thy Thu Dec 05 17:58:03 2013 +0100
280.3 @@ -998,7 +998,7 @@
280.4 (!!x y. x > y ==> f x > f y) ==> f a > c"
280.5 by (subgoal_tac "f a > f b", force, force)
280.6
280.7 -lemmas xtrans = xt1 xt2 xt3 xt4 xt5 xt6 xt7 xt8 xt9 [no_atp]
280.8 +lemmas xtrans = xt1 xt2 xt3 xt4 xt5 xt6 xt7 xt8 xt9
280.9
280.10 (*
280.11 Since "a >= b" abbreviates "b <= a", the abbreviation "..." stands
281.1 --- a/src/HOL/Parity.thy Thu Dec 05 17:52:12 2013 +0100
281.2 +++ b/src/HOL/Parity.thy Thu Dec 05 17:58:03 2013 +0100
281.3 @@ -9,26 +9,52 @@
281.4 imports Main
281.5 begin
281.6
281.7 -class even_odd =
281.8 - fixes even :: "'a \<Rightarrow> bool"
281.9 -
281.10 -abbreviation
281.11 - odd :: "'a\<Colon>even_odd \<Rightarrow> bool" where
281.12 - "odd x \<equiv> \<not> even x"
281.13 -
281.14 -instantiation nat and int :: even_odd
281.15 +class even_odd = semiring_div_parity
281.16 begin
281.17
281.18 -definition
281.19 - even_def [presburger]: "even x \<longleftrightarrow> (x\<Colon>int) mod 2 = 0"
281.20 +definition even :: "'a \<Rightarrow> bool"
281.21 +where
281.22 + even_def [presburger]: "even a \<longleftrightarrow> a mod 2 = 0"
281.23
281.24 -definition
281.25 - even_nat_def [presburger]: "even x \<longleftrightarrow> even (int x)"
281.26 +lemma even_iff_2_dvd [algebra]:
281.27 + "even a \<longleftrightarrow> 2 dvd a"
281.28 + by (simp add: even_def dvd_eq_mod_eq_0)
281.29
281.30 -instance ..
281.31 +lemma even_zero [simp]:
281.32 + "even 0"
281.33 + by (simp add: even_def)
281.34 +
281.35 +lemma even_times_anything:
281.36 + "even a \<Longrightarrow> even (a * b)"
281.37 + by (simp add: even_iff_2_dvd)
281.38 +
281.39 +lemma anything_times_even:
281.40 + "even a \<Longrightarrow> even (b * a)"
281.41 + by (simp add: even_iff_2_dvd)
281.42 +
281.43 +abbreviation odd :: "'a \<Rightarrow> bool"
281.44 +where
281.45 + "odd a \<equiv> \<not> even a"
281.46 +
281.47 +lemma odd_times_odd:
281.48 + "odd a \<Longrightarrow> odd b \<Longrightarrow> odd (a * b)"
281.49 + by (auto simp add: even_def mod_mult_left_eq)
281.50 +
281.51 +lemma even_product [simp, presburger]:
281.52 + "even (a * b) \<longleftrightarrow> even a \<or> even b"
281.53 + apply (auto simp add: even_times_anything anything_times_even)
281.54 + apply (rule ccontr)
281.55 + apply (auto simp add: odd_times_odd)
281.56 + done
281.57
281.58 end
281.59
281.60 +instance nat and int :: even_odd ..
281.61 +
281.62 +lemma even_nat_def [presburger]:
281.63 + "even x \<longleftrightarrow> even (int x)"
281.64 + by (auto simp add: even_def int_eq_iff int_mult nat_mult_distrib)
281.65 +
281.66 lemma transfer_int_nat_relations:
281.67 "even (int x) \<longleftrightarrow> even x"
281.68 by (simp add: even_nat_def)
281.69 @@ -37,13 +63,13 @@
281.70 transfer_int_nat_relations
281.71 ]
281.72
281.73 -lemma even_zero_int[simp]: "even (0::int)" by presburger
281.74 +lemma odd_one_int [simp]:
281.75 + "odd (1::int)"
281.76 + by presburger
281.77
281.78 -lemma odd_one_int[simp]: "odd (1::int)" by presburger
281.79 -
281.80 -lemma even_zero_nat[simp]: "even (0::nat)" by presburger
281.81 -
281.82 -lemma odd_1_nat [simp]: "odd (1::nat)" by presburger
281.83 +lemma odd_1_nat [simp]:
281.84 + "odd (1::nat)"
281.85 + by presburger
281.86
281.87 lemma even_numeral_int [simp]: "even (numeral (Num.Bit0 k) :: int)"
281.88 unfolding even_def by simp
281.89 @@ -52,7 +78,7 @@
281.90 unfolding even_def by simp
281.91
281.92 (* TODO: proper simp rules for Num.Bit0, Num.Bit1 *)
281.93 -declare even_def[of "neg_numeral v", simp] for v
281.94 +declare even_def [of "- numeral v", simp] for v
281.95
281.96 lemma even_numeral_nat [simp]: "even (numeral (Num.Bit0 k) :: nat)"
281.97 unfolding even_nat_def by simp
281.98 @@ -62,34 +88,8 @@
281.99
281.100 subsection {* Even and odd are mutually exclusive *}
281.101
281.102 -lemma int_pos_lt_two_imp_zero_or_one:
281.103 - "0 <= x ==> (x::int) < 2 ==> x = 0 | x = 1"
281.104 - by presburger
281.105 -
281.106 -lemma neq_one_mod_two [simp, presburger]:
281.107 - "((x::int) mod 2 ~= 0) = (x mod 2 = 1)" by presburger
281.108 -
281.109
281.110 subsection {* Behavior under integer arithmetic operations *}
281.111 -declare dvd_def[algebra]
281.112 -lemma nat_even_iff_2_dvd[algebra]: "even (x::nat) \<longleftrightarrow> 2 dvd x"
281.113 - by presburger
281.114 -lemma int_even_iff_2_dvd[algebra]: "even (x::int) \<longleftrightarrow> 2 dvd x"
281.115 - by presburger
281.116 -
281.117 -lemma even_times_anything: "even (x::int) ==> even (x * y)"
281.118 - by algebra
281.119 -
281.120 -lemma anything_times_even: "even (y::int) ==> even (x * y)" by algebra
281.121 -
281.122 -lemma odd_times_odd: "odd (x::int) ==> odd y ==> odd (x * y)"
281.123 - by (simp add: even_def mod_mult_right_eq)
281.124 -
281.125 -lemma even_product[simp,presburger]: "even((x::int) * y) = (even x | even y)"
281.126 - apply (auto simp add: even_times_anything anything_times_even)
281.127 - apply (rule ccontr)
281.128 - apply (auto simp add: odd_times_odd)
281.129 - done
281.130
281.131 lemma even_plus_even: "even (x::int) ==> even y ==> even (x + y)"
281.132 by presburger
281.133 @@ -158,10 +158,6 @@
281.134
281.135 subsection {* Equivalent definitions *}
281.136
281.137 -lemma nat_lt_two_imp_zero_or_one:
281.138 - "(x::nat) < Suc (Suc 0) ==> x = 0 | x = Suc 0"
281.139 -by presburger
281.140 -
281.141 lemma even_nat_mod_two_eq_zero: "even (x::nat) ==> x mod (Suc (Suc 0)) = 0"
281.142 by presburger
281.143
281.144 @@ -189,45 +185,14 @@
281.145
281.146 subsection {* Parity and powers *}
281.147
281.148 -lemma minus_one_even_odd_power:
281.149 - "(even x --> (- 1::'a::{comm_ring_1})^x = 1) &
281.150 - (odd x --> (- 1::'a)^x = - 1)"
281.151 - apply (induct x)
281.152 - apply (rule conjI)
281.153 - apply simp
281.154 - apply (insert even_zero_nat, blast)
281.155 - apply simp
281.156 - done
281.157 +lemma (in comm_ring_1) neg_power_if:
281.158 + "(- a) ^ n = (if even n then (a ^ n) else - (a ^ n))"
281.159 + by (induct n) simp_all
281.160
281.161 -lemma minus_one_even_power [simp]:
281.162 - "even x ==> (- 1::'a::{comm_ring_1})^x = 1"
281.163 - using minus_one_even_odd_power by blast
281.164 -
281.165 -lemma minus_one_odd_power [simp]:
281.166 - "odd x ==> (- 1::'a::{comm_ring_1})^x = - 1"
281.167 - using minus_one_even_odd_power by blast
281.168 -
281.169 -lemma neg_one_even_odd_power:
281.170 - "(even x --> (-1::'a::{comm_ring_1})^x = 1) &
281.171 - (odd x --> (-1::'a)^x = -1)"
281.172 - apply (induct x)
281.173 - apply (simp, simp)
281.174 - done
281.175 -
281.176 -lemma neg_one_even_power [simp]:
281.177 - "even x ==> (-1::'a::{comm_ring_1})^x = 1"
281.178 - using neg_one_even_odd_power by blast
281.179 -
281.180 -lemma neg_one_odd_power [simp]:
281.181 - "odd x ==> (-1::'a::{comm_ring_1})^x = -1"
281.182 - using neg_one_even_odd_power by blast
281.183 -
281.184 -lemma neg_power_if:
281.185 - "(-x::'a::{comm_ring_1}) ^ n =
281.186 - (if even n then (x ^ n) else -(x ^ n))"
281.187 - apply (induct n)
281.188 - apply simp_all
281.189 - done
281.190 +lemma (in comm_ring_1)
281.191 + shows neg_one_even_power [simp]: "even n \<Longrightarrow> (- 1) ^ n = 1"
281.192 + and neg_one_odd_power [simp]: "odd n \<Longrightarrow> (- 1) ^ n = - 1"
281.193 + by (simp_all add: neg_power_if)
281.194
281.195 lemma zero_le_even_power: "even n ==>
281.196 0 <= (x::'a::{linordered_ring,monoid_mult}) ^ n"
281.197 @@ -244,7 +209,7 @@
281.198 apply (metis field_power_not_zero divisors_zero order_antisym_conv zero_le_square)
281.199 done
281.200
281.201 -lemma zero_le_power_eq[presburger]: "(0 <= (x::'a::{linordered_idom}) ^ n) =
281.202 +lemma zero_le_power_eq [presburger]: "(0 <= (x::'a::{linordered_idom}) ^ n) =
281.203 (even n | (odd n & 0 <= x))"
281.204 apply auto
281.205 apply (subst zero_le_odd_power [symmetric])
281.206 @@ -277,9 +242,6 @@
281.207 apply (simp add: zero_le_even_power)
281.208 done
281.209
281.210 -lemma zero_less_power_nat_eq[presburger]: "(0 < (x::nat) ^ n) = (n = 0 | 0 < x)"
281.211 - by (induct n) auto
281.212 -
281.213 lemma power_minus_even [simp]: "even n ==>
281.214 (- x)^n = (x^n::'a::{comm_ring_1})"
281.215 apply (subst power_minus)
281.216 @@ -336,13 +298,6 @@
281.217
281.218 lemma odd_add [simp]: "odd(m + n::nat) = (odd m \<noteq> odd n)" by presburger
281.219
281.220 -lemma div_Suc: "Suc a div c = a div c + Suc 0 div c +
281.221 - (a mod c + Suc 0 mod c) div c"
281.222 - apply (subgoal_tac "Suc a = a + Suc 0")
281.223 - apply (erule ssubst)
281.224 - apply (rule div_add1_eq, simp)
281.225 - done
281.226 -
281.227 lemma lemma_even_div2 [simp]: "even (n::nat) ==> (n + 1) div 2 = n div 2" by presburger
281.228
281.229 lemma lemma_not_even_div2 [simp]: "~even n ==> (n + 1) div 2 = Suc (n div 2)"
281.230 @@ -359,31 +314,29 @@
281.231 text {* Simplify, when the exponent is a numeral *}
281.232
281.233 lemmas zero_le_power_eq_numeral [simp] =
281.234 - zero_le_power_eq [of _ "numeral w"] for w
281.235 + zero_le_power_eq [of _ "numeral w"] for w
281.236
281.237 lemmas zero_less_power_eq_numeral [simp] =
281.238 - zero_less_power_eq [of _ "numeral w"] for w
281.239 + zero_less_power_eq [of _ "numeral w"] for w
281.240
281.241 lemmas power_le_zero_eq_numeral [simp] =
281.242 - power_le_zero_eq [of _ "numeral w"] for w
281.243 + power_le_zero_eq [of _ "numeral w"] for w
281.244
281.245 lemmas power_less_zero_eq_numeral [simp] =
281.246 - power_less_zero_eq [of _ "numeral w"] for w
281.247 + power_less_zero_eq [of _ "numeral w"] for w
281.248
281.249 lemmas zero_less_power_nat_eq_numeral [simp] =
281.250 - zero_less_power_nat_eq [of _ "numeral w"] for w
281.251 + nat_zero_less_power_iff [of _ "numeral w"] for w
281.252
281.253 -lemmas power_eq_0_iff_numeral [simp] = power_eq_0_iff [of _ "numeral w"] for w
281.254 +lemmas power_eq_0_iff_numeral [simp] =
281.255 + power_eq_0_iff [of _ "numeral w"] for w
281.256
281.257 -lemmas power_even_abs_numeral [simp] = power_even_abs [of "numeral w" _] for w
281.258 +lemmas power_even_abs_numeral [simp] =
281.259 + power_even_abs [of "numeral w" _] for w
281.260
281.261
281.262 subsection {* An Equivalence for @{term [source] "0 \<le> a^n"} *}
281.263
281.264 -lemma even_power_le_0_imp_0:
281.265 - "a ^ (2*k) \<le> (0::'a::{linordered_idom}) ==> a=0"
281.266 - by (induct k) (auto simp add: zero_le_mult_iff mult_le_0_iff)
281.267 -
281.268 lemma zero_le_power_iff[presburger]:
281.269 "(0 \<le> a^n) = (0 \<le> (a::'a::{linordered_idom}) | even n)"
281.270 proof cases
281.271 @@ -395,9 +348,10 @@
281.272 assume odd: "odd n"
281.273 then obtain k where "n = Suc(2*k)"
281.274 by (auto simp add: odd_nat_equiv_def2 numeral_2_eq_2)
281.275 - thus ?thesis
281.276 - by (auto simp add: zero_le_mult_iff zero_le_even_power
281.277 - dest!: even_power_le_0_imp_0)
281.278 + moreover have "a ^ (2 * k) \<le> 0 \<Longrightarrow> a = 0"
281.279 + by (induct k) (auto simp add: zero_le_mult_iff mult_le_0_iff)
281.280 + ultimately show ?thesis
281.281 + by (auto simp add: zero_le_mult_iff zero_le_even_power)
281.282 qed
281.283
281.284
281.285 @@ -409,7 +363,6 @@
281.286 lemma odd_plus_one_div_two: "odd (x::int) ==> (x + 1) div 2 = x div 2 + 1" by presburger
281.287
281.288 lemma [presburger]: "(Suc x) div Suc (Suc 0) = x div Suc (Suc 0) \<longleftrightarrow> even x" by presburger
281.289 -lemma [presburger]: "(Suc x) div Suc (Suc 0) = x div Suc (Suc 0) \<longleftrightarrow> even x" by presburger
281.290 lemma even_nat_plus_one_div_two: "even (x::nat) ==>
281.291 (Suc x) div Suc (Suc 0) = x div Suc (Suc 0)" by presburger
281.292
281.293 @@ -417,3 +370,4 @@
281.294 (Suc x) div Suc (Suc 0) = Suc (x div Suc (Suc 0))" by presburger
281.295
281.296 end
281.297 +
282.1 --- a/src/HOL/Partial_Function.thy Thu Dec 05 17:52:12 2013 +0100
282.2 +++ b/src/HOL/Partial_Function.thy Thu Dec 05 17:58:03 2013 +0100
282.3 @@ -176,11 +176,12 @@
282.4 assumes eq: "f \<equiv> C (fixp_fun (\<lambda>f. U (F (C f))))"
282.5 assumes inverse: "\<And>f. U (C f) = f"
282.6 assumes adm: "ccpo.admissible lub_fun le_fun P"
282.7 + and bot: "P (\<lambda>_. lub {})"
282.8 assumes step: "\<And>f. P (U f) \<Longrightarrow> P (U (F f))"
282.9 shows "P (U f)"
282.10 unfolding eq inverse
282.11 apply (rule ccpo.fixp_induct[OF ccpo adm])
282.12 -apply (insert mono, auto simp: monotone_def fun_ord_def)[1]
282.13 +apply (insert mono, auto simp: monotone_def fun_ord_def bot fun_lub_def)[2]
282.14 by (rule_tac f="C x" in step, simp add: inverse)
282.15
282.16
282.17 @@ -237,11 +238,13 @@
282.18
282.19 interpretation tailrec!:
282.20 partial_function_definitions "flat_ord undefined" "flat_lub undefined"
282.21 -by (rule flat_interpretation)
282.22 + where "flat_lub undefined {} \<equiv> undefined"
282.23 +by (rule flat_interpretation)(simp add: flat_lub_def)
282.24
282.25 interpretation option!:
282.26 partial_function_definitions "flat_ord None" "flat_lub None"
282.27 -by (rule flat_interpretation)
282.28 + where "flat_lub None {} \<equiv> None"
282.29 +by (rule flat_interpretation)(simp add: flat_lub_def)
282.30
282.31
282.32 abbreviation "tailrec_ord \<equiv> flat_ord undefined"
282.33 @@ -281,7 +284,7 @@
282.34 proof -
282.35 have "\<forall>x y. U f x = y \<longrightarrow> y \<noteq> c \<longrightarrow> P x y"
282.36 by(rule partial_function_definitions.fixp_induct_uc[OF flat_interpretation, of _ U F C, OF mono eq inverse2])
282.37 - (auto intro: step tailrec_admissible)
282.38 + (auto intro: step tailrec_admissible simp add: fun_lub_def flat_lub_def)
282.39 thus ?thesis using result defined by blast
282.40 qed
282.41
282.42 @@ -293,14 +296,15 @@
282.43 shows "ccpo.admissible (img_lub f g lub) (img_ord f le) P"
282.44 proof (rule ccpo.admissibleI)
282.45 fix A assume "chain (img_ord f le) A"
282.46 - then have ch': "chain le (f ` A)"
282.47 - by (auto simp: img_ord_def intro: chainI dest: chainD)
282.48 + then have ch': "chain le (f ` A)"
282.49 + by (auto simp: img_ord_def intro: chainI dest: chainD)
282.50 + assume "A \<noteq> {}"
282.51 assume P_A: "\<forall>x\<in>A. P x"
282.52 have "(P o g) (lub (f ` A))" using adm ch'
282.53 proof (rule ccpo.admissibleD)
282.54 fix x assume "x \<in> f ` A"
282.55 with P_A show "(P o g) x" by (auto simp: inj[OF inv])
282.56 - qed
282.57 + qed(simp add: `A \<noteq> {}`)
282.58 thus "P (img_lub f g lub A)" unfolding img_lub_def by simp
282.59 qed
282.60
282.61 @@ -312,9 +316,11 @@
282.62 fix A :: "('b \<Rightarrow> 'a) set"
282.63 assume Q: "\<forall>f\<in>A. \<forall>x. Q x (f x)"
282.64 assume ch: "chain (fun_ord le) A"
282.65 + assume "A \<noteq> {}"
282.66 + hence non_empty: "\<And>a. {y. \<exists>f\<in>A. y = f a} \<noteq> {}" by auto
282.67 show "\<forall>x. Q x (fun_lub lub A x)"
282.68 unfolding fun_lub_def
282.69 - by (rule allI, rule ccpo.admissibleD[OF adm chain_fun[OF ch]])
282.70 + by (rule allI, rule ccpo.admissibleD[OF adm chain_fun[OF ch] non_empty])
282.71 (auto simp: Q)
282.72 qed
282.73
282.74 @@ -388,7 +394,7 @@
282.75 assumes defined: "U f x = Some y"
282.76 shows "P x y"
282.77 using step defined option.fixp_induct_uc[of U F C, OF mono eq inverse2 option_admissible]
282.78 - by blast
282.79 + unfolding fun_lub_def flat_lub_def by(auto 9 2)
282.80
282.81 declaration {* Partial_Function.init "tailrec" @{term tailrec.fixp_fun}
282.82 @{term tailrec.mono_body} @{thm tailrec.fixp_rule_uc} @{thm tailrec.fixp_induct_uc}
283.1 --- a/src/HOL/Power.thy Thu Dec 05 17:52:12 2013 +0100
283.2 +++ b/src/HOL/Power.thy Thu Dec 05 17:58:03 2013 +0100
283.3 @@ -209,14 +209,6 @@
283.4 "(- x) ^ numeral (Num.Bit1 k) = - (x ^ numeral (Num.Bit1 k))"
283.5 by (simp only: eval_nat_numeral(3) power_Suc power_minus_Bit0 mult_minus_left)
283.6
283.7 -lemma power_neg_numeral_Bit0 [simp]:
283.8 - "neg_numeral k ^ numeral (Num.Bit0 l) = numeral (Num.pow k (Num.Bit0 l))"
283.9 - by (simp only: neg_numeral_def power_minus_Bit0 power_numeral)
283.10 -
283.11 -lemma power_neg_numeral_Bit1 [simp]:
283.12 - "neg_numeral k ^ numeral (Num.Bit1 l) = neg_numeral (Num.pow k (Num.Bit1 l))"
283.13 - by (simp only: neg_numeral_def power_minus_Bit1 power_numeral pow.simps)
283.14 -
283.15 lemma power2_minus [simp]:
283.16 "(- a)\<^sup>2 = a\<^sup>2"
283.17 by (rule power_minus_Bit0)
283.18 @@ -530,7 +522,7 @@
283.19 "abs ((-a) ^ n) = abs (a ^ n)"
283.20 by (simp add: power_abs)
283.21
283.22 -lemma zero_less_power_abs_iff [simp, no_atp]:
283.23 +lemma zero_less_power_abs_iff [simp]:
283.24 "0 < abs a ^ n \<longleftrightarrow> a \<noteq> 0 \<or> n = 0"
283.25 proof (induct n)
283.26 case 0 show ?case by simp
283.27 @@ -730,8 +722,18 @@
283.28 fixes m n :: nat
283.29 assumes "m\<^sup>2 \<le> n"
283.30 shows "m \<le> n"
283.31 - using assms by (cases m) (simp_all add: power2_eq_square)
283.32 -
283.33 +proof (cases m)
283.34 + case 0 then show ?thesis by simp
283.35 +next
283.36 + case (Suc k)
283.37 + show ?thesis
283.38 + proof (rule ccontr)
283.39 + assume "\<not> m \<le> n"
283.40 + then have "n < m" by simp
283.41 + with assms Suc show False
283.42 + by (auto simp add: algebra_simps) (simp add: power2_eq_square)
283.43 + qed
283.44 +qed
283.45
283.46
283.47 subsection {* Code generator tweak *}
284.1 --- a/src/HOL/Presburger.thy Thu Dec 05 17:52:12 2013 +0100
284.2 +++ b/src/HOL/Presburger.thy Thu Dec 05 17:58:03 2013 +0100
284.3 @@ -360,11 +360,15 @@
284.4 apply simp
284.5 done
284.6
284.7 -lemma zdvd_mono: assumes not0: "(k::int) \<noteq> 0"
284.8 -shows "((m::int) dvd t) \<equiv> (k*m dvd k*t)"
284.9 - using not0 by (simp add: dvd_def)
284.10 +lemma zdvd_mono:
284.11 + fixes k m t :: int
284.12 + assumes "k \<noteq> 0"
284.13 + shows "m dvd t \<equiv> k * m dvd k * t"
284.14 + using assms by simp
284.15
284.16 -lemma uminus_dvd_conv: "(d dvd (t::int)) \<equiv> (-d dvd t)" "(d dvd (t::int)) \<equiv> (d dvd -t)"
284.17 +lemma uminus_dvd_conv:
284.18 + fixes d t :: int
284.19 + shows "d dvd t \<equiv> - d dvd t" and "d dvd t \<equiv> d dvd - t"
284.20 by simp_all
284.21
284.22 text {* \bigskip Theorems for transforming predicates on nat to predicates on @{text int}*}
284.23 @@ -406,24 +410,23 @@
284.24 end
284.25 *} "Cooper's algorithm for Presburger arithmetic"
284.26
284.27 -declare dvd_eq_mod_eq_0[symmetric, presburger]
284.28 -declare mod_1[presburger]
284.29 -declare mod_0[presburger]
284.30 -declare mod_by_1[presburger]
284.31 -declare mod_self[presburger]
284.32 -declare mod_by_0[presburger]
284.33 -declare mod_div_trivial[presburger]
284.34 -declare div_mod_equality2[presburger]
284.35 -declare div_mod_equality[presburger]
284.36 -declare mod_div_equality2[presburger]
284.37 -declare mod_div_equality[presburger]
284.38 -declare mod_mult_self1[presburger]
284.39 -declare mod_mult_self2[presburger]
284.40 -declare div_mod_equality[presburger]
284.41 -declare div_mod_equality2[presburger]
284.42 +declare dvd_eq_mod_eq_0 [symmetric, presburger]
284.43 +declare mod_1 [presburger]
284.44 +declare mod_0 [presburger]
284.45 +declare mod_by_1 [presburger]
284.46 +declare mod_self [presburger]
284.47 +declare div_by_0 [presburger]
284.48 +declare mod_by_0 [presburger]
284.49 +declare mod_div_trivial [presburger]
284.50 +declare div_mod_equality2 [presburger]
284.51 +declare div_mod_equality [presburger]
284.52 +declare mod_div_equality2 [presburger]
284.53 +declare mod_div_equality [presburger]
284.54 +declare mod_mult_self1 [presburger]
284.55 +declare mod_mult_self2 [presburger]
284.56 declare mod2_Suc_Suc[presburger]
284.57 -lemma [presburger]: "(a::int) div 0 = 0" and [presburger]: "a mod 0 = a"
284.58 -by simp_all
284.59 +declare not_mod_2_eq_0_eq_1 [presburger]
284.60 +declare nat_zero_less_power_iff [presburger]
284.61
284.62 lemma [presburger, algebra]: "m mod 2 = (1::nat) \<longleftrightarrow> \<not> 2 dvd m " by presburger
284.63 lemma [presburger, algebra]: "m mod 2 = Suc 0 \<longleftrightarrow> \<not> 2 dvd m " by presburger
284.64 @@ -432,3 +435,4 @@
284.65 lemma [presburger, algebra]: "m mod 2 = (1::int) \<longleftrightarrow> \<not> 2 dvd m " by presburger
284.66
284.67 end
284.68 +
285.1 --- a/src/HOL/Probability/Borel_Space.thy Thu Dec 05 17:52:12 2013 +0100
285.2 +++ b/src/HOL/Probability/Borel_Space.thy Thu Dec 05 17:58:03 2013 +0100
285.3 @@ -677,7 +677,7 @@
285.4 assumes f: "f \<in> borel_measurable M"
285.5 assumes g: "g \<in> borel_measurable M"
285.6 shows "(\<lambda>x. f x - g x) \<in> borel_measurable M"
285.7 - unfolding diff_minus using assms by simp
285.8 + using borel_measurable_add [of f M "- g"] assms by (simp add: fun_Compl_def)
285.9
285.10 lemma borel_measurable_times[measurable (raw)]:
285.11 fixes f :: "'a \<Rightarrow> 'b::{second_countable_topology, real_normed_algebra}"
285.12 @@ -719,7 +719,8 @@
285.13 proof cases
285.14 assume "b \<noteq> 0"
285.15 with `open S` have "open ((\<lambda>x. (- a + x) /\<^sub>R b) ` S)" (is "open ?S")
285.16 - by (auto intro!: open_affinity simp: scaleR_add_right)
285.17 + using open_affinity [of S "inverse b" "- a /\<^sub>R b"]
285.18 + by (auto simp: algebra_simps)
285.19 hence "?S \<in> sets borel" by auto
285.20 moreover
285.21 from `b \<noteq> 0` have "(\<lambda>x. a + b *\<^sub>R f x) -` S = f -` ?S"
286.1 --- a/src/HOL/Probability/Lebesgue_Integration.thy Thu Dec 05 17:52:12 2013 +0100
286.2 +++ b/src/HOL/Probability/Lebesgue_Integration.thy Thu Dec 05 17:58:03 2013 +0100
286.3 @@ -1528,7 +1528,7 @@
286.4 using mono by auto
286.5 ultimately show ?thesis using fg
286.6 by (auto intro!: add_mono positive_integral_mono_AE real_of_ereal_positive_mono
286.7 - simp: positive_integral_positive lebesgue_integral_def diff_minus)
286.8 + simp: positive_integral_positive lebesgue_integral_def algebra_simps)
286.9 qed
286.10
286.11 lemma integral_mono:
286.12 @@ -1732,7 +1732,7 @@
286.13 shows "integrable M (\<lambda>t. f t - g t)"
286.14 and "(\<integral> t. f t - g t \<partial>M) = integral\<^sup>L M f - integral\<^sup>L M g"
286.15 using integral_add[OF f integral_minus(1)[OF g]]
286.16 - unfolding diff_minus integral_minus(2)[OF g]
286.17 + unfolding integral_minus(2)[OF g]
286.18 by auto
286.19
286.20 lemma integral_indicator[simp, intro]:
286.21 @@ -2521,6 +2521,91 @@
286.22 "f \<in> borel_measurable (count_space A)"
286.23 by simp
286.24
286.25 +lemma lessThan_eq_empty_iff: "{..< n::nat} = {} \<longleftrightarrow> n = 0"
286.26 + by auto
286.27 +
286.28 +lemma emeasure_UN_countable:
286.29 + assumes sets: "\<And>i. i \<in> I \<Longrightarrow> X i \<in> sets M" and I: "countable I"
286.30 + assumes disj: "disjoint_family_on X I"
286.31 + shows "emeasure M (UNION I X) = (\<integral>\<^sup>+i. emeasure M (X i) \<partial>count_space I)"
286.32 +proof cases
286.33 + assume "finite I" with sets disj show ?thesis
286.34 + by (subst setsum_emeasure[symmetric])
286.35 + (auto intro!: setsum_cong simp add: max_def subset_eq positive_integral_count_space_finite emeasure_nonneg)
286.36 +next
286.37 + assume f: "\<not> finite I"
286.38 + then have [intro]: "I \<noteq> {}" by auto
286.39 + from from_nat_into_inj_infinite[OF I f] from_nat_into[OF this] disj
286.40 + have disj2: "disjoint_family (\<lambda>i. X (from_nat_into I i))"
286.41 + unfolding disjoint_family_on_def by metis
286.42 +
286.43 + from f have "bij_betw (from_nat_into I) UNIV I"
286.44 + using bij_betw_from_nat_into[OF I] by simp
286.45 + then have "(\<Union>i\<in>I. X i) = (\<Union>i. (X \<circ> from_nat_into I) i)"
286.46 + unfolding SUP_def image_compose by (simp add: bij_betw_def)
286.47 + then have "emeasure M (UNION I X) = emeasure M (\<Union>i. X (from_nat_into I i))"
286.48 + by simp
286.49 + also have "\<dots> = (\<Sum>i. emeasure M (X (from_nat_into I i)))"
286.50 + by (intro suminf_emeasure[symmetric] disj disj2) (auto intro!: sets from_nat_into[OF `I \<noteq> {}`])
286.51 + also have "\<dots> = (\<Sum>n. \<integral>\<^sup>+i. emeasure M (X i) * indicator {from_nat_into I n} i \<partial>count_space I)"
286.52 + proof (intro arg_cong[where f=suminf] ext)
286.53 + fix i
286.54 + have eq: "{a \<in> I. 0 < emeasure M (X a) * indicator {from_nat_into I i} a}
286.55 + = (if 0 < emeasure M (X (from_nat_into I i)) then {from_nat_into I i} else {})"
286.56 + using ereal_0_less_1
286.57 + by (auto simp: ereal_zero_less_0_iff indicator_def from_nat_into `I \<noteq> {}` simp del: ereal_0_less_1)
286.58 + have "(\<integral>\<^sup>+ ia. emeasure M (X ia) * indicator {from_nat_into I i} ia \<partial>count_space I) =
286.59 + (if 0 < emeasure M (X (from_nat_into I i)) then emeasure M (X (from_nat_into I i)) else 0)"
286.60 + by (subst positive_integral_count_space) (simp_all add: eq)
286.61 + also have "\<dots> = emeasure M (X (from_nat_into I i))"
286.62 + by (simp add: less_le emeasure_nonneg)
286.63 + finally show "emeasure M (X (from_nat_into I i)) =
286.64 + \<integral>\<^sup>+ ia. emeasure M (X ia) * indicator {from_nat_into I i} ia \<partial>count_space I" ..
286.65 + qed
286.66 + also have "\<dots> = (\<integral>\<^sup>+i. emeasure M (X i) \<partial>count_space I)"
286.67 + apply (subst positive_integral_suminf[symmetric])
286.68 + apply (auto simp: emeasure_nonneg intro!: positive_integral_cong)
286.69 + proof -
286.70 + fix x assume "x \<in> I"
286.71 + then have "(\<Sum>i. emeasure M (X x) * indicator {from_nat_into I i} x) = (\<Sum>i\<in>{to_nat_on I x}. emeasure M (X x) * indicator {from_nat_into I i} x)"
286.72 + by (intro suminf_finite) (auto simp: indicator_def I f)
286.73 + also have "\<dots> = emeasure M (X x)"
286.74 + by (simp add: I f `x\<in>I`)
286.75 + finally show "(\<Sum>i. emeasure M (X x) * indicator {from_nat_into I i} x) = emeasure M (X x)" .
286.76 + qed
286.77 + finally show ?thesis .
286.78 +qed
286.79 +
286.80 +section {* Measures with Restricted Space *}
286.81 +
286.82 +lemma positive_integral_restrict_space:
286.83 + assumes \<Omega>: "\<Omega> \<in> sets M" and f: "f \<in> borel_measurable M" "\<And>x. 0 \<le> f x" "\<And>x. x \<in> space M - \<Omega> \<Longrightarrow> f x = 0"
286.84 + shows "positive_integral (restrict_space M \<Omega>) f = positive_integral M f"
286.85 +using f proof (induct rule: borel_measurable_induct)
286.86 + case (cong f g) then show ?case
286.87 + using positive_integral_cong[of M f g] positive_integral_cong[of "restrict_space M \<Omega>" f g]
286.88 + sets.sets_into_space[OF `\<Omega> \<in> sets M`]
286.89 + by (simp add: subset_eq space_restrict_space)
286.90 +next
286.91 + case (set A)
286.92 + then have "A \<subseteq> \<Omega>"
286.93 + unfolding indicator_eq_0_iff by (auto dest: sets.sets_into_space)
286.94 + with set `\<Omega> \<in> sets M` sets.sets_into_space[OF `\<Omega> \<in> sets M`] show ?case
286.95 + by (subst positive_integral_indicator')
286.96 + (auto simp add: sets_restrict_space_iff space_restrict_space
286.97 + emeasure_restrict_space Int_absorb2
286.98 + dest: sets.sets_into_space)
286.99 +next
286.100 + case (mult f c) then show ?case
286.101 + by (cases "c = 0") (simp_all add: measurable_restrict_space1 \<Omega> positive_integral_cmult)
286.102 +next
286.103 + case (add f g) then show ?case
286.104 + by (simp add: measurable_restrict_space1 \<Omega> positive_integral_add ereal_add_nonneg_eq_0_iff)
286.105 +next
286.106 + case (seq F) then show ?case
286.107 + by (auto simp add: SUP_eq_iff measurable_restrict_space1 \<Omega> positive_integral_monotone_convergence_SUP)
286.108 +qed
286.109 +
286.110 section {* Measure spaces with an associated density *}
286.111
286.112 definition density :: "'a measure \<Rightarrow> ('a \<Rightarrow> ereal) \<Rightarrow> 'a measure" where
286.113 @@ -2775,7 +2860,6 @@
286.114 "simple_function (point_measure A f) g \<longleftrightarrow> finite (g ` A)"
286.115 by (simp add: point_measure_def)
286.116
286.117 -declare [[simproc del: finite_Collect]]
286.118 lemma emeasure_point_measure:
286.119 assumes A: "finite {a\<in>X. 0 < f a}" "X \<subseteq> A"
286.120 shows "emeasure (point_measure A f) X = (\<Sum>a|a\<in>X \<and> 0 < f a. f a)"
286.121 @@ -2786,7 +2870,6 @@
286.122 by (simp add: emeasure_density positive_integral_count_space ereal_zero_le_0_iff
286.123 point_measure_def indicator_def)
286.124 qed
286.125 -declare [[simproc add: finite_Collect]]
286.126
286.127 lemma emeasure_point_measure_finite:
286.128 "finite A \<Longrightarrow> (\<And>i. i \<in> A \<Longrightarrow> 0 \<le> f i) \<Longrightarrow> X \<subseteq> A \<Longrightarrow> emeasure (point_measure A f) X = (\<Sum>a\<in>X. f a)"
287.1 --- a/src/HOL/Probability/Lebesgue_Measure.thy Thu Dec 05 17:52:12 2013 +0100
287.2 +++ b/src/HOL/Probability/Lebesgue_Measure.thy Thu Dec 05 17:58:03 2013 +0100
287.3 @@ -1138,7 +1138,7 @@
287.4 show "\<And>i x. 0 \<le> ?f i x"
287.5 using nonneg by (auto split: split_indicator)
287.6 qed
287.7 - also have "\<dots> = (SUP i::nat. F (a + real i) - F a)"
287.8 + also have "\<dots> = (SUP i::nat. ereal (F (a + real i) - F a))"
287.9 by (subst positive_integral_FTC_atLeastAtMost[OF f_borel f nonneg]) auto
287.10 also have "\<dots> = T - F a"
287.11 proof (rule SUP_Lim_ereal)
288.1 --- a/src/HOL/Probability/Measure_Space.thy Thu Dec 05 17:52:12 2013 +0100
288.2 +++ b/src/HOL/Probability/Measure_Space.thy Thu Dec 05 17:58:03 2013 +0100
288.3 @@ -1118,6 +1118,10 @@
288.4 and measurable_distr_eq2[simp]: "measurable Mg' (distr Mg Ng g) = measurable Mg' Ng"
288.5 by (auto simp: measurable_def)
288.6
288.7 +lemma distr_cong:
288.8 + "M = K \<Longrightarrow> sets N = sets L \<Longrightarrow> (\<And>x. x \<in> space M \<Longrightarrow> f x = g x) \<Longrightarrow> distr M N f = distr K L g"
288.9 + using sets_eq_imp_space_eq[of N L] by (simp add: distr_def Int_def cong: rev_conj_cong)
288.10 +
288.11 lemma emeasure_distr:
288.12 fixes f :: "'a \<Rightarrow> 'b"
288.13 assumes f: "f \<in> measurable M N" and A: "A \<in> sets N"
288.14 @@ -1649,5 +1653,50 @@
288.15 show "sigma_finite_measure (count_space A)" ..
288.16 qed
288.17
288.18 +section {* Measure restricted to space *}
288.19 +
288.20 +lemma emeasure_restrict_space:
288.21 + assumes "\<Omega> \<in> sets M" "A \<subseteq> \<Omega>"
288.22 + shows "emeasure (restrict_space M \<Omega>) A = emeasure M A"
288.23 +proof cases
288.24 + assume "A \<in> sets M"
288.25 +
288.26 + have "emeasure (restrict_space M \<Omega>) A = emeasure M (A \<inter> \<Omega>)"
288.27 + proof (rule emeasure_measure_of[OF restrict_space_def])
288.28 + show "op \<inter> \<Omega> ` sets M \<subseteq> Pow \<Omega>" "A \<in> sets (restrict_space M \<Omega>)"
288.29 + using assms `A \<in> sets M` by (auto simp: sets_restrict_space sets.sets_into_space)
288.30 + show "positive (sets (restrict_space M \<Omega>)) (\<lambda>A. emeasure M (A \<inter> \<Omega>))"
288.31 + by (auto simp: positive_def emeasure_nonneg)
288.32 + show "countably_additive (sets (restrict_space M \<Omega>)) (\<lambda>A. emeasure M (A \<inter> \<Omega>))"
288.33 + proof (rule countably_additiveI)
288.34 + fix A :: "nat \<Rightarrow> _" assume "range A \<subseteq> sets (restrict_space M \<Omega>)" "disjoint_family A"
288.35 + with assms have "\<And>i. A i \<in> sets M" "\<And>i. A i \<subseteq> space M" "disjoint_family A"
288.36 + by (auto simp: sets_restrict_space_iff subset_eq dest: sets.sets_into_space)
288.37 + with `\<Omega> \<in> sets M` show "(\<Sum>i. emeasure M (A i \<inter> \<Omega>)) = emeasure M ((\<Union>i. A i) \<inter> \<Omega>)"
288.38 + by (subst suminf_emeasure) (auto simp: disjoint_family_subset)
288.39 + qed
288.40 + qed
288.41 + with `A \<subseteq> \<Omega>` show ?thesis
288.42 + by (simp add: Int_absorb2)
288.43 +next
288.44 + assume "A \<notin> sets M"
288.45 + moreover with assms have "A \<notin> sets (restrict_space M \<Omega>)"
288.46 + by (simp add: sets_restrict_space_iff)
288.47 + ultimately show ?thesis
288.48 + by (simp add: emeasure_notin_sets)
288.49 +qed
288.50 +
288.51 +lemma restrict_count_space:
288.52 + assumes "A \<subseteq> B" shows "restrict_space (count_space B) A = count_space A"
288.53 +proof (rule measure_eqI)
288.54 + show "sets (restrict_space (count_space B) A) = sets (count_space A)"
288.55 + using `A \<subseteq> B` by (subst sets_restrict_space) auto
288.56 + moreover fix X assume "X \<in> sets (restrict_space (count_space B) A)"
288.57 + moreover note `A \<subseteq> B`
288.58 + ultimately have "X \<subseteq> A" by auto
288.59 + with `A \<subseteq> B` show "emeasure (restrict_space (count_space B) A) X = emeasure (count_space A) X"
288.60 + by (cases "finite X") (auto simp add: emeasure_restrict_space)
288.61 +qed
288.62 +
288.63 end
288.64
289.1 --- a/src/HOL/Probability/Probability_Measure.thy Thu Dec 05 17:52:12 2013 +0100
289.2 +++ b/src/HOL/Probability/Probability_Measure.thy Thu Dec 05 17:58:03 2013 +0100
289.3 @@ -268,6 +268,31 @@
289.4 by (intro finite_measure_UNION) auto
289.5 qed
289.6
289.7 +lemma (in prob_space) prob_EX_countable:
289.8 + assumes sets: "\<And>i. i \<in> I \<Longrightarrow> {x\<in>space M. P i x} \<in> sets M" and I: "countable I"
289.9 + assumes disj: "AE x in M. \<forall>i\<in>I. \<forall>j\<in>I. P i x \<longrightarrow> P j x \<longrightarrow> i = j"
289.10 + shows "\<P>(x in M. \<exists>i\<in>I. P i x) = (\<integral>\<^sup>+i. \<P>(x in M. P i x) \<partial>count_space I)"
289.11 +proof -
289.12 + let ?N= "\<lambda>x. \<exists>!i\<in>I. P i x"
289.13 + have "ereal (\<P>(x in M. \<exists>i\<in>I. P i x)) = \<P>(x in M. (\<exists>i\<in>I. P i x \<and> ?N x))"
289.14 + unfolding ereal.inject
289.15 + proof (rule prob_eq_AE)
289.16 + show "AE x in M. (\<exists>i\<in>I. P i x) = (\<exists>i\<in>I. P i x \<and> ?N x)"
289.17 + using disj by eventually_elim blast
289.18 + qed (auto intro!: sets.sets_Collect_countable_Ex' sets.sets_Collect_conj sets.sets_Collect_countable_Ex1' I sets)+
289.19 + also have "\<P>(x in M. (\<exists>i\<in>I. P i x \<and> ?N x)) = emeasure M (\<Union>i\<in>I. {x\<in>space M. P i x \<and> ?N x})"
289.20 + unfolding emeasure_eq_measure by (auto intro!: arg_cong[where f=prob])
289.21 + also have "\<dots> = (\<integral>\<^sup>+i. emeasure M {x\<in>space M. P i x \<and> ?N x} \<partial>count_space I)"
289.22 + by (rule emeasure_UN_countable)
289.23 + (auto intro!: sets.sets_Collect_countable_Ex' sets.sets_Collect_conj sets.sets_Collect_countable_Ex1' I sets
289.24 + simp: disjoint_family_on_def)
289.25 + also have "\<dots> = (\<integral>\<^sup>+i. \<P>(x in M. P i x) \<partial>count_space I)"
289.26 + unfolding emeasure_eq_measure using disj
289.27 + by (intro positive_integral_cong ereal.inject[THEN iffD2] prob_eq_AE)
289.28 + (auto intro!: sets.sets_Collect_countable_Ex' sets.sets_Collect_conj sets.sets_Collect_countable_Ex1' I sets)+
289.29 + finally show ?thesis .
289.30 +qed
289.31 +
289.32 lemma (in prob_space) cond_prob_eq_AE:
289.33 assumes P: "AE x in M. Q x \<longrightarrow> P x \<longleftrightarrow> P' x" "{x\<in>space M. P x} \<in> events" "{x\<in>space M. P' x} \<in> events"
289.34 assumes Q: "AE x in M. Q x \<longleftrightarrow> Q' x" "{x\<in>space M. Q x} \<in> events" "{x\<in>space M. Q' x} \<in> events"
290.1 --- a/src/HOL/Probability/Sigma_Algebra.thy Thu Dec 05 17:52:12 2013 +0100
290.2 +++ b/src/HOL/Probability/Sigma_Algebra.thy Thu Dec 05 17:58:03 2013 +0100
290.3 @@ -397,7 +397,7 @@
290.4 qed
290.5
290.6 lemma (in sigma_algebra) sets_Collect_countable_Ex':
290.7 - assumes "\<And>i. {x\<in>\<Omega>. P i x} \<in> M"
290.8 + assumes "\<And>i. i \<in> I \<Longrightarrow> {x\<in>\<Omega>. P i x} \<in> M"
290.9 assumes "countable I"
290.10 shows "{x\<in>\<Omega>. \<exists>i\<in>I. P i x} \<in> M"
290.11 proof -
290.12 @@ -406,6 +406,27 @@
290.13 by (auto intro!: countable_UN')
290.14 qed
290.15
290.16 +lemma (in sigma_algebra) sets_Collect_countable_All':
290.17 + assumes "\<And>i. i \<in> I \<Longrightarrow> {x\<in>\<Omega>. P i x} \<in> M"
290.18 + assumes "countable I"
290.19 + shows "{x\<in>\<Omega>. \<forall>i\<in>I. P i x} \<in> M"
290.20 +proof -
290.21 + have "{x\<in>\<Omega>. \<forall>i\<in>I. P i x} = (\<Inter>i\<in>I. {x\<in>\<Omega>. P i x}) \<inter> \<Omega>" by auto
290.22 + with assms show ?thesis
290.23 + by (cases "I = {}") (auto intro!: countable_INT')
290.24 +qed
290.25 +
290.26 +lemma (in sigma_algebra) sets_Collect_countable_Ex1':
290.27 + assumes "\<And>i. i \<in> I \<Longrightarrow> {x\<in>\<Omega>. P i x} \<in> M"
290.28 + assumes "countable I"
290.29 + shows "{x\<in>\<Omega>. \<exists>!i\<in>I. P i x} \<in> M"
290.30 +proof -
290.31 + have "{x\<in>\<Omega>. \<exists>!i\<in>I. P i x} = {x\<in>\<Omega>. \<exists>i\<in>I. P i x \<and> (\<forall>j\<in>I. P j x \<longrightarrow> i = j)}"
290.32 + by auto
290.33 + with assms show ?thesis
290.34 + by (auto intro!: sets_Collect_countable_All' sets_Collect_countable_Ex' sets_Collect_conj sets_Collect_imp sets_Collect_const)
290.35 +qed
290.36 +
290.37 lemmas (in sigma_algebra) sets_Collect =
290.38 sets_Collect_imp sets_Collect_disj sets_Collect_conj sets_Collect_neg sets_Collect_const
290.39 sets_Collect_countable_All sets_Collect_countable_Ex sets_Collect_countable_All
290.40 @@ -1171,16 +1192,13 @@
290.41 using assms
290.42 by(simp_all add: sets_measure_of_conv space_measure_of_conv)
290.43
290.44 -lemma (in sigma_algebra) sets_measure_of_eq[simp]:
290.45 - "sets (measure_of \<Omega> M \<mu>) = M"
290.46 +lemma (in sigma_algebra) sets_measure_of_eq[simp]: "sets (measure_of \<Omega> M \<mu>) = M"
290.47 using space_closed by (auto intro!: sigma_sets_eq)
290.48
290.49 -lemma (in sigma_algebra) space_measure_of_eq[simp]:
290.50 - "space (measure_of \<Omega> M \<mu>) = \<Omega>"
290.51 - using space_closed by (auto intro!: sigma_sets_eq)
290.52 +lemma (in sigma_algebra) space_measure_of_eq[simp]: "space (measure_of \<Omega> M \<mu>) = \<Omega>"
290.53 + by (rule space_measure_of_conv)
290.54
290.55 -lemma measure_of_subset:
290.56 - "M \<subseteq> Pow \<Omega> \<Longrightarrow> M' \<subseteq> M \<Longrightarrow> sets (measure_of \<Omega> M' \<mu>) \<subseteq> sets (measure_of \<Omega> M \<mu>')"
290.57 +lemma measure_of_subset: "M \<subseteq> Pow \<Omega> \<Longrightarrow> M' \<subseteq> M \<Longrightarrow> sets (measure_of \<Omega> M' \<mu>) \<subseteq> sets (measure_of \<Omega> M \<mu>')"
290.58 by (auto intro!: sigma_sets_subseteq)
290.59
290.60 lemma sigma_sets_mono'':
290.61 @@ -1547,6 +1565,19 @@
290.62 shows "(\<lambda>x. f (g x)) \<in> measurable M N"
290.63 using measurable_compose[OF g f] .
290.64
290.65 +lemma measurable_count_space_eq_countable:
290.66 + assumes "countable A"
290.67 + shows "f \<in> measurable M (count_space A) \<longleftrightarrow> (f \<in> space M \<rightarrow> A \<and> (\<forall>a\<in>A. f -` {a} \<inter> space M \<in> sets M))"
290.68 +proof -
290.69 + { fix X assume "X \<subseteq> A" "f \<in> space M \<rightarrow> A"
290.70 + with `countable A` have "f -` X \<inter> space M = (\<Union>a\<in>X. f -` {a} \<inter> space M)" "countable X"
290.71 + by (auto dest: countable_subset)
290.72 + moreover assume "\<forall>a\<in>A. f -` {a} \<inter> space M \<in> sets M"
290.73 + ultimately have "f -` X \<inter> space M \<in> sets M"
290.74 + using `X \<subseteq> A` by (auto intro!: sets.countable_UN' simp del: UN_simps) }
290.75 + then show ?thesis
290.76 + unfolding measurable_def by auto
290.77 +qed
290.78
290.79 subsection {* Extend measure *}
290.80
290.81 @@ -1611,7 +1642,7 @@
290.82 subsection {* Sigma algebra generated by function preimages *}
290.83
290.84 definition
290.85 - "vimage_algebra M S f = sigma S ((\<lambda>A. f -` A \<inter> S) ` sets M)"
290.86 + "vimage_algebra M S X = sigma S ((\<lambda>A. X -` A \<inter> S) ` sets M)"
290.87
290.88 lemma sigma_algebra_preimages:
290.89 fixes f :: "'x \<Rightarrow> 'a"
290.90 @@ -1725,6 +1756,42 @@
290.91 qed auto
290.92 qed
290.93
290.94 +subsection {* Restricted Space Sigma Algebra *}
290.95 +
290.96 +definition "restrict_space M \<Omega> = measure_of \<Omega> ((op \<inter> \<Omega>) ` sets M) (\<lambda>A. emeasure M (A \<inter> \<Omega>))"
290.97 +
290.98 +lemma space_restrict_space: "space (restrict_space M \<Omega>) = \<Omega>"
290.99 + unfolding restrict_space_def by (subst space_measure_of) auto
290.100 +
290.101 +lemma sets_restrict_space: "\<Omega> \<subseteq> space M \<Longrightarrow> sets (restrict_space M \<Omega>) = (op \<inter> \<Omega>) ` sets M"
290.102 + using sigma_sets_vimage[of "\<lambda>x. x" \<Omega> "space M" "sets M"]
290.103 + unfolding restrict_space_def
290.104 + by (subst sets_measure_of) (auto simp: sets.sigma_sets_eq Int_commute[of _ \<Omega>] sets.space_closed)
290.105 +
290.106 +lemma sets_restrict_space_iff:
290.107 + "\<Omega> \<in> sets M \<Longrightarrow> A \<in> sets (restrict_space M \<Omega>) \<longleftrightarrow> (A \<subseteq> \<Omega> \<and> A \<in> sets M)"
290.108 + by (subst sets_restrict_space) (auto dest: sets.sets_into_space)
290.109 +
290.110 +lemma measurable_restrict_space1:
290.111 + assumes \<Omega>: "\<Omega> \<in> sets M" and f: "f \<in> measurable M N" shows "f \<in> measurable (restrict_space M \<Omega>) N"
290.112 + unfolding measurable_def
290.113 +proof (intro CollectI conjI ballI)
290.114 + show sp: "f \<in> space (restrict_space M \<Omega>) \<rightarrow> space N"
290.115 + using measurable_space[OF f] sets.sets_into_space[OF \<Omega>] by (auto simp: space_restrict_space)
290.116 +
290.117 + fix A assume "A \<in> sets N"
290.118 + have "f -` A \<inter> space (restrict_space M \<Omega>) = (f -` A \<inter> space M) \<inter> \<Omega>"
290.119 + using sets.sets_into_space[OF \<Omega>] by (auto simp: space_restrict_space)
290.120 + also have "\<dots> \<in> sets (restrict_space M \<Omega>)"
290.121 + unfolding sets_restrict_space_iff[OF \<Omega>]
290.122 + using measurable_sets[OF f `A \<in> sets N`] \<Omega> by blast
290.123 + finally show "f -` A \<inter> space (restrict_space M \<Omega>) \<in> sets (restrict_space M \<Omega>)" .
290.124 +qed
290.125 +
290.126 +lemma measurable_restrict_space2:
290.127 + "\<Omega> \<in> sets N \<Longrightarrow> f \<in> space M \<rightarrow> \<Omega> \<Longrightarrow> f \<in> measurable M N \<Longrightarrow> f \<in> measurable M (restrict_space N \<Omega>)"
290.128 + by (simp add: measurable_def space_restrict_space sets_restrict_space_iff)
290.129 +
290.130 subsection {* A Two-Element Series *}
290.131
290.132 definition binaryset :: "'a set \<Rightarrow> 'a set \<Rightarrow> nat \<Rightarrow> 'a set "
291.1 --- a/src/HOL/Product_Type.thy Thu Dec 05 17:52:12 2013 +0100
291.2 +++ b/src/HOL/Product_Type.thy Thu Dec 05 17:58:03 2013 +0100
291.3 @@ -75,10 +75,10 @@
291.4 f} rather than by @{term [source] "%u. f ()"}.
291.5 *}
291.6
291.7 -lemma unit_abs_eta_conv [simp, no_atp]: "(%u::unit. f ()) = f"
291.8 +lemma unit_abs_eta_conv [simp]: "(%u::unit. f ()) = f"
291.9 by (rule ext) simp
291.10
291.11 -lemma UNIV_unit [no_atp]:
291.12 +lemma UNIV_unit:
291.13 "UNIV = {()}" by auto
291.14
291.15 instantiation unit :: default
291.16 @@ -586,10 +586,10 @@
291.17 to quite time-consuming computations (in particular for nested tuples) *)
291.18 setup {* map_theory_claset (fn ctxt => ctxt addSbefore ("split_conv_tac", split_conv_tac)) *}
291.19
291.20 -lemma split_eta_SetCompr [simp,no_atp]: "(%u. EX x y. u = (x, y) & P (x, y)) = P"
291.21 +lemma split_eta_SetCompr [simp, no_atp]: "(%u. EX x y. u = (x, y) & P (x, y)) = P"
291.22 by (rule ext) fast
291.23
291.24 -lemma split_eta_SetCompr2 [simp,no_atp]: "(%u. EX x y. u = (x, y) & P x y) = split P"
291.25 +lemma split_eta_SetCompr2 [simp, no_atp]: "(%u. EX x y. u = (x, y) & P x y) = split P"
291.26 by (rule ext) fast
291.27
291.28 lemma split_part [simp]: "(%(a,b). P & Q a b) = (%ab. P & split Q ab)"
291.29 @@ -729,6 +729,9 @@
291.30 lemma split_curry [simp]: "split (curry f) = f"
291.31 by (simp add: curry_def split_def)
291.32
291.33 +lemma curry_K: "curry (\<lambda>x. c) = (\<lambda>x y. c)"
291.34 +by(simp add: fun_eq_iff)
291.35 +
291.36 text {*
291.37 The composition-uncurry combinator.
291.38 *}
292.1 --- a/src/HOL/Proofs/Lambda/ListOrder.thy Thu Dec 05 17:52:12 2013 +0100
292.2 +++ b/src/HOL/Proofs/Lambda/ListOrder.thy Thu Dec 05 17:58:03 2013 +0100
292.3 @@ -89,15 +89,15 @@
292.4 done
292.5
292.6 lemma Cons_acc_step1I [intro!]:
292.7 - "accp r x ==> accp (step1 r) xs \<Longrightarrow> accp (step1 r) (x # xs)"
292.8 - apply (induct arbitrary: xs set: accp)
292.9 + "Wellfounded.accp r x ==> Wellfounded.accp (step1 r) xs \<Longrightarrow> Wellfounded.accp (step1 r) (x # xs)"
292.10 + apply (induct arbitrary: xs set: Wellfounded.accp)
292.11 apply (erule thin_rl)
292.12 apply (erule accp_induct)
292.13 apply (rule accp.accI)
292.14 apply blast
292.15 done
292.16
292.17 -lemma lists_accD: "listsp (accp r) xs ==> accp (step1 r) xs"
292.18 +lemma lists_accD: "listsp (Wellfounded.accp r) xs ==> Wellfounded.accp (step1 r) xs"
292.19 apply (induct set: listsp)
292.20 apply (rule accp.accI)
292.21 apply simp
292.22 @@ -113,8 +113,8 @@
292.23 apply force
292.24 done
292.25
292.26 -lemma lists_accI: "accp (step1 r) xs ==> listsp (accp r) xs"
292.27 - apply (induct set: accp)
292.28 +lemma lists_accI: "Wellfounded.accp (step1 r) xs ==> listsp (Wellfounded.accp r) xs"
292.29 + apply (induct set: Wellfounded.accp)
292.30 apply clarify
292.31 apply (rule accp.accI)
292.32 apply (drule_tac r=r in ex_step1I, assumption)
293.1 --- a/src/HOL/Quotient.thy Thu Dec 05 17:52:12 2013 +0100
293.2 +++ b/src/HOL/Quotient.thy Thu Dec 05 17:58:03 2013 +0100
293.3 @@ -5,7 +5,7 @@
293.4 header {* Definition of Quotient Types *}
293.5
293.6 theory Quotient
293.7 -imports Hilbert_Choice Equiv_Relations Lifting
293.8 +imports Lifting
293.9 keywords
293.10 "print_quotmapsQ3" "print_quotientsQ3" "print_quotconsts" :: diag and
293.11 "quotient_type" :: thy_goal and "/" and
294.1 --- a/src/HOL/ROOT Thu Dec 05 17:52:12 2013 +0100
294.2 +++ b/src/HOL/ROOT Thu Dec 05 17:58:03 2013 +0100
294.3 @@ -43,6 +43,7 @@
294.4 Code_Real_Approx_By_Float
294.5 Code_Target_Numeral
294.6 DAList
294.7 + DAList_Multiset
294.8 RBT_Mapping
294.9 RBT_Set
294.10 (*legacy tools*)
294.11 @@ -686,14 +687,14 @@
294.12 theories Nominal_Examples
294.13 theories [quick_and_dirty] VC_Condition
294.14
294.15 -session "HOL-Cardinals-Base" in Cardinals = HOL +
294.16 +session "HOL-Cardinals-FP" in Cardinals = HOL +
294.17 description {*
294.18 - Ordinals and Cardinals, Base Theories.
294.19 + Ordinals and Cardinals, Theories Needed for BNF FP Constructions.
294.20 *}
294.21 options [document = false]
294.22 - theories Cardinal_Arithmetic
294.23 + theories Cardinal_Arithmetic_FP
294.24
294.25 -session "HOL-Cardinals" in Cardinals = "HOL-Cardinals-Base" +
294.26 +session "HOL-Cardinals" in Cardinals = "HOL-Cardinals-FP" +
294.27 description {*
294.28 Ordinals and Cardinals, Full Theories.
294.29 *}
294.30 @@ -704,16 +705,16 @@
294.31 "document/root.tex"
294.32 "document/root.bib"
294.33
294.34 -session "HOL-BNF-LFP" in BNF = "HOL-Cardinals-Base" +
294.35 +session "HOL-BNF-FP" in BNF = "HOL-Cardinals-FP" +
294.36 description {*
294.37 - Bounded Natural Functors for Datatypes.
294.38 + Bounded Natural Functors for (Co)datatypes.
294.39 *}
294.40 options [document = false]
294.41 - theories BNF_LFP
294.42 + theories BNF_LFP BNF_GFP
294.43
294.44 -session "HOL-BNF" in BNF = "HOL-Cardinals" +
294.45 +session "HOL-BNF" in BNF = "HOL-BNF-FP" +
294.46 description {*
294.47 - Bounded Natural Functors for (Co)datatypes.
294.48 + Bounded Natural Functors for (Co)datatypes, Including More BNFs.
294.49 *}
294.50 options [document = false]
294.51 theories BNF
294.52 @@ -733,6 +734,7 @@
294.53 theories [condition = ISABELLE_FULL_TEST]
294.54 Misc_Codatatype
294.55 Misc_Datatype
294.56 + Misc_Primcorec
294.57 Misc_Primrec
294.58
294.59 session "HOL-Word" (main) in Word = HOL +
294.60 @@ -778,13 +780,10 @@
294.61 theories [condition = ISABELLE_FULL_TEST]
294.62 SMT_Tests
294.63 files
294.64 - "Boogie_Dijkstra.b2i"
294.65 "Boogie_Dijkstra.certs"
294.66 - "Boogie_Max.b2i"
294.67 "Boogie_Max.certs"
294.68 "SMT_Examples.certs"
294.69 "SMT_Word_Examples.certs"
294.70 - "VCC_Max.b2i"
294.71 "VCC_Max.certs"
294.72
294.73 session "HOL-SPARK" (main) in "SPARK" = "HOL-Word" +
295.1 --- a/src/HOL/Rat.thy Thu Dec 05 17:52:12 2013 +0100
295.2 +++ b/src/HOL/Rat.thy Thu Dec 05 17:58:03 2013 +0100
295.3 @@ -215,17 +215,19 @@
295.4 "Fract 0 k = 0"
295.5 "Fract 1 1 = 1"
295.6 "Fract (numeral w) 1 = numeral w"
295.7 - "Fract (neg_numeral w) 1 = neg_numeral w"
295.8 + "Fract (- numeral w) 1 = - numeral w"
295.9 + "Fract (- 1) 1 = - 1"
295.10 "Fract k 0 = 0"
295.11 using Fract_of_int_eq [of "numeral w"]
295.12 - using Fract_of_int_eq [of "neg_numeral w"]
295.13 + using Fract_of_int_eq [of "- numeral w"]
295.14 by (simp_all add: Zero_rat_def One_rat_def eq_rat)
295.15
295.16 lemma rat_number_expand:
295.17 "0 = Fract 0 1"
295.18 "1 = Fract 1 1"
295.19 "numeral k = Fract (numeral k) 1"
295.20 - "neg_numeral k = Fract (neg_numeral k) 1"
295.21 + "- 1 = Fract (- 1) 1"
295.22 + "- numeral k = Fract (- numeral k) 1"
295.23 by (simp_all add: rat_number_collapse)
295.24
295.25 lemma Rat_cases_nonzero [case_names Fract 0]:
295.26 @@ -356,7 +358,8 @@
295.27 "quotient_of 0 = (0, 1)"
295.28 "quotient_of 1 = (1, 1)"
295.29 "quotient_of (numeral k) = (numeral k, 1)"
295.30 - "quotient_of (neg_numeral k) = (neg_numeral k, 1)"
295.31 + "quotient_of (- 1) = (- 1, 1)"
295.32 + "quotient_of (- numeral k) = (- numeral k, 1)"
295.33 by (simp_all add: rat_number_expand quotient_of_Fract)
295.34
295.35 lemma quotient_of_eq: "quotient_of (Fract a b) = (p, q) \<Longrightarrow> Fract p q = Fract a b"
295.36 @@ -468,7 +471,7 @@
295.37 unfolding less_eq_rat_def less_rat_def
295.38 by (auto, drule (1) positive_add, simp add: positive_zero)
295.39 show "a \<le> b \<Longrightarrow> c + a \<le> c + b"
295.40 - unfolding less_eq_rat_def less_rat_def by (auto simp: diff_minus)
295.41 + unfolding less_eq_rat_def less_rat_def by auto
295.42 show "sgn a = (if a = 0 then 0 else if 0 < a then 1 else - 1)"
295.43 by (rule sgn_rat_def)
295.44 show "a \<le> b \<or> b \<le> a"
295.45 @@ -620,7 +623,7 @@
295.46 #> Lin_Arith.add_simps [@{thm neg_less_iff_less},
295.47 @{thm True_implies_equals},
295.48 read_instantiate @{context} [(("a", 0), "(numeral ?v)")] @{thm distrib_left},
295.49 - read_instantiate @{context} [(("a", 0), "(neg_numeral ?v)")] @{thm distrib_left},
295.50 + read_instantiate @{context} [(("a", 0), "(- numeral ?v)")] @{thm distrib_left},
295.51 @{thm divide_1}, @{thm divide_zero_left},
295.52 @{thm times_divide_eq_right}, @{thm times_divide_eq_left},
295.53 @{thm minus_divide_left} RS sym, @{thm minus_divide_right} RS sym,
295.54 @@ -664,8 +667,12 @@
295.55 lemma of_rat_minus: "of_rat (- a) = - of_rat a"
295.56 by transfer simp
295.57
295.58 +lemma of_rat_neg_one [simp]:
295.59 + "of_rat (- 1) = - 1"
295.60 + by (simp add: of_rat_minus)
295.61 +
295.62 lemma of_rat_diff: "of_rat (a - b) = of_rat a - of_rat b"
295.63 -by (simp only: diff_minus of_rat_add of_rat_minus)
295.64 + using of_rat_add [of a "- b"] by (simp add: of_rat_minus)
295.65
295.66 lemma of_rat_mult: "of_rat (a * b) = of_rat a * of_rat b"
295.67 apply transfer
295.68 @@ -702,6 +709,18 @@
295.69 apply (simp only: of_int_mult [symmetric] of_int_eq_iff)
295.70 done
295.71
295.72 +lemma of_rat_eq_0_iff [simp]: "(of_rat a = 0) = (a = 0)"
295.73 + using of_rat_eq_iff [of _ 0] by simp
295.74 +
295.75 +lemma zero_eq_of_rat_iff [simp]: "(0 = of_rat a) = (0 = a)"
295.76 + by simp
295.77 +
295.78 +lemma of_rat_eq_1_iff [simp]: "(of_rat a = 1) = (a = 1)"
295.79 + using of_rat_eq_iff [of _ 1] by simp
295.80 +
295.81 +lemma one_eq_of_rat_iff [simp]: "(1 = of_rat a) = (1 = a)"
295.82 + by simp
295.83 +
295.84 lemma of_rat_less:
295.85 "(of_rat r :: 'a::linordered_field) < of_rat s \<longleftrightarrow> r < s"
295.86 proof (induct r, induct s)
295.87 @@ -722,7 +741,29 @@
295.88 "(of_rat r :: 'a::linordered_field) \<le> of_rat s \<longleftrightarrow> r \<le> s"
295.89 unfolding le_less by (auto simp add: of_rat_less)
295.90
295.91 -lemmas of_rat_eq_0_iff [simp] = of_rat_eq_iff [of _ 0, simplified]
295.92 +lemma of_rat_le_0_iff [simp]: "((of_rat r :: 'a::linordered_field) \<le> 0) = (r \<le> 0)"
295.93 + using of_rat_less_eq [of r 0, where 'a='a] by simp
295.94 +
295.95 +lemma zero_le_of_rat_iff [simp]: "(0 \<le> (of_rat r :: 'a::linordered_field)) = (0 \<le> r)"
295.96 + using of_rat_less_eq [of 0 r, where 'a='a] by simp
295.97 +
295.98 +lemma of_rat_le_1_iff [simp]: "((of_rat r :: 'a::linordered_field) \<le> 1) = (r \<le> 1)"
295.99 + using of_rat_less_eq [of r 1] by simp
295.100 +
295.101 +lemma one_le_of_rat_iff [simp]: "(1 \<le> (of_rat r :: 'a::linordered_field)) = (1 \<le> r)"
295.102 + using of_rat_less_eq [of 1 r] by simp
295.103 +
295.104 +lemma of_rat_less_0_iff [simp]: "((of_rat r :: 'a::linordered_field) < 0) = (r < 0)"
295.105 + using of_rat_less [of r 0, where 'a='a] by simp
295.106 +
295.107 +lemma zero_less_of_rat_iff [simp]: "(0 < (of_rat r :: 'a::linordered_field)) = (0 < r)"
295.108 + using of_rat_less [of 0 r, where 'a='a] by simp
295.109 +
295.110 +lemma of_rat_less_1_iff [simp]: "((of_rat r :: 'a::linordered_field) < 1) = (r < 1)"
295.111 + using of_rat_less [of r 1] by simp
295.112 +
295.113 +lemma one_less_of_rat_iff [simp]: "(1 < (of_rat r :: 'a::linordered_field)) = (1 < r)"
295.114 + using of_rat_less [of 1 r] by simp
295.115
295.116 lemma of_rat_eq_id [simp]: "of_rat = id"
295.117 proof
295.118 @@ -744,8 +785,8 @@
295.119 using of_rat_of_int_eq [of "numeral w"] by simp
295.120
295.121 lemma of_rat_neg_numeral_eq [simp]:
295.122 - "of_rat (neg_numeral w) = neg_numeral w"
295.123 -using of_rat_of_int_eq [of "neg_numeral w"] by simp
295.124 + "of_rat (- numeral w) = - numeral w"
295.125 +using of_rat_of_int_eq [of "- numeral w"] by simp
295.126
295.127 lemmas zero_rat = Zero_rat_def
295.128 lemmas one_rat = One_rat_def
295.129 @@ -786,9 +827,6 @@
295.130 lemma Rats_number_of [simp]: "numeral w \<in> Rats"
295.131 by (subst of_rat_numeral_eq [symmetric], rule Rats_of_rat)
295.132
295.133 -lemma Rats_neg_number_of [simp]: "neg_numeral w \<in> Rats"
295.134 -by (subst of_rat_neg_numeral_eq [symmetric], rule Rats_of_rat)
295.135 -
295.136 lemma Rats_0 [simp]: "0 \<in> Rats"
295.137 apply (unfold Rats_def)
295.138 apply (rule range_eqI)
295.139 @@ -909,7 +947,7 @@
295.140 by (simp add: Rat.of_int_def)
295.141
295.142 lemma [code_unfold]:
295.143 - "neg_numeral k = Rat.of_int (neg_numeral k)"
295.144 + "- numeral k = Rat.of_int (- numeral k)"
295.145 by (simp add: Rat.of_int_def)
295.146
295.147 lemma Frct_code_post [code_post]:
295.148 @@ -917,13 +955,13 @@
295.149 "Frct (a, 0) = 0"
295.150 "Frct (1, 1) = 1"
295.151 "Frct (numeral k, 1) = numeral k"
295.152 - "Frct (neg_numeral k, 1) = neg_numeral k"
295.153 + "Frct (- numeral k, 1) = - numeral k"
295.154 "Frct (1, numeral k) = 1 / numeral k"
295.155 - "Frct (1, neg_numeral k) = 1 / neg_numeral k"
295.156 + "Frct (1, - numeral k) = 1 / - numeral k"
295.157 "Frct (numeral k, numeral l) = numeral k / numeral l"
295.158 - "Frct (numeral k, neg_numeral l) = numeral k / neg_numeral l"
295.159 - "Frct (neg_numeral k, numeral l) = neg_numeral k / numeral l"
295.160 - "Frct (neg_numeral k, neg_numeral l) = neg_numeral k / neg_numeral l"
295.161 + "Frct (numeral k, - numeral l) = numeral k / - numeral l"
295.162 + "Frct (- numeral k, numeral l) = - numeral k / numeral l"
295.163 + "Frct (- numeral k, - numeral l) = - numeral k / - numeral l"
295.164 by (simp_all add: Fract_of_int_quotient)
295.165
295.166
295.167 @@ -1122,7 +1160,7 @@
295.168 in
295.169 if i = 0 then Syntax.const @{const_syntax Groups.zero}
295.170 else if i > 0 then Syntax.const @{const_syntax Num.numeral} $ mk i
295.171 - else Syntax.const @{const_syntax Num.neg_numeral} $ mk (~i)
295.172 + else Syntax.const @{const_syntax Groups.uminus} $ (Syntax.const @{const_syntax Num.numeral} $ mk (~i))
295.173 end;
295.174
295.175 fun mk_frac str =
296.1 --- a/src/HOL/Real.thy Thu Dec 05 17:52:12 2013 +0100
296.2 +++ b/src/HOL/Real.thy Thu Dec 05 17:58:03 2013 +0100
296.3 @@ -98,7 +98,7 @@
296.4 lemma vanishes_diff:
296.5 assumes X: "vanishes X" and Y: "vanishes Y"
296.6 shows "vanishes (\<lambda>n. X n - Y n)"
296.7 -unfolding diff_minus by (intro vanishes_add vanishes_minus X Y)
296.8 + unfolding diff_conv_add_uminus by (intro vanishes_add vanishes_minus X Y)
296.9
296.10 lemma vanishes_mult_bounded:
296.11 assumes X: "\<exists>a>0. \<forall>n. \<bar>X n\<bar> < a"
296.12 @@ -170,7 +170,7 @@
296.13 lemma cauchy_diff [simp]:
296.14 assumes X: "cauchy X" and Y: "cauchy Y"
296.15 shows "cauchy (\<lambda>n. X n - Y n)"
296.16 -using assms unfolding diff_minus by simp
296.17 + using assms unfolding diff_conv_add_uminus by (simp del: add_uminus_conv_diff)
296.18
296.19 lemma cauchy_imp_bounded:
296.20 assumes "cauchy X" shows "\<exists>b>0. \<forall>n. \<bar>X n\<bar> < b"
296.21 @@ -456,7 +456,7 @@
296.22 lemma diff_Real:
296.23 assumes X: "cauchy X" and Y: "cauchy Y"
296.24 shows "Real X - Real Y = Real (\<lambda>n. X n - Y n)"
296.25 - unfolding minus_real_def diff_minus
296.26 + unfolding minus_real_def
296.27 by (simp add: minus_Real add_Real X Y)
296.28
296.29 lemma mult_Real:
296.30 @@ -607,7 +607,7 @@
296.31 unfolding less_eq_real_def less_real_def
296.32 by (auto, drule (1) positive_add, simp add: positive_zero)
296.33 show "a \<le> b \<Longrightarrow> c + a \<le> c + b"
296.34 - unfolding less_eq_real_def less_real_def by (auto simp: diff_minus) (* by auto *)
296.35 + unfolding less_eq_real_def less_real_def by auto
296.36 (* FIXME: Procedure int_combine_numerals: c + b - (c + a) \<equiv> b + - a *)
296.37 (* Should produce c + b - (c + a) \<equiv> b - a *)
296.38 show "sgn a = (if a = 0 then 0 else if 0 < a then 1 else - 1)"
296.39 @@ -919,24 +919,20 @@
296.40 using 1 2 3 by (rule_tac x="Real B" in exI, simp)
296.41 qed
296.42
296.43 -
296.44 instantiation real :: linear_continuum
296.45 begin
296.46
296.47 subsection{*Supremum of a set of reals*}
296.48
296.49 -definition
296.50 - Sup_real_def: "Sup X \<equiv> LEAST z::real. \<forall>x\<in>X. x\<le>z"
296.51 -
296.52 -definition
296.53 - Inf_real_def: "Inf (X::real set) \<equiv> - Sup (uminus ` X)"
296.54 +definition "Sup X = (LEAST z::real. \<forall>x\<in>X. x \<le> z)"
296.55 +definition "Inf (X::real set) = - Sup (uminus ` X)"
296.56
296.57 instance
296.58 proof
296.59 - { fix z x :: real and X :: "real set"
296.60 - assume x: "x \<in> X" and z: "\<And>x. x \<in> X \<Longrightarrow> x \<le> z"
296.61 + { fix x :: real and X :: "real set"
296.62 + assume x: "x \<in> X" "bdd_above X"
296.63 then obtain s where s: "\<forall>y\<in>X. y \<le> s" "\<And>z. \<forall>y\<in>X. y \<le> z \<Longrightarrow> s \<le> z"
296.64 - using complete_real[of X] by blast
296.65 + using complete_real[of X] unfolding bdd_above_def by blast
296.66 then show "x \<le> Sup X"
296.67 unfolding Sup_real_def by (rule LeastI2_order) (auto simp: x) }
296.68 note Sup_upper = this
296.69 @@ -952,32 +948,15 @@
296.70 finally show "Sup X \<le> z" . }
296.71 note Sup_least = this
296.72
296.73 - { fix x z :: real and X :: "real set"
296.74 - assume x: "x \<in> X" and z: "\<And>x. x \<in> X \<Longrightarrow> z \<le> x"
296.75 - have "-x \<le> Sup (uminus ` X)"
296.76 - by (rule Sup_upper[of _ _ "- z"]) (auto simp add: image_iff x z)
296.77 - then show "Inf X \<le> x"
296.78 - by (auto simp add: Inf_real_def) }
296.79 -
296.80 - { fix z :: real and X :: "real set"
296.81 - assume x: "X \<noteq> {}" and z: "\<And>x. x \<in> X \<Longrightarrow> z \<le> x"
296.82 - have "Sup (uminus ` X) \<le> -z"
296.83 - using x z by (force intro: Sup_least)
296.84 - then show "z \<le> Inf X"
296.85 - by (auto simp add: Inf_real_def) }
296.86 -
296.87 + { fix x :: real and X :: "real set" assume x: "x \<in> X" "bdd_below X" then show "Inf X \<le> x"
296.88 + using Sup_upper[of "-x" "uminus ` X"] by (auto simp: Inf_real_def) }
296.89 + { fix z :: real and X :: "real set" assume "X \<noteq> {}" "\<And>x. x \<in> X \<Longrightarrow> z \<le> x" then show "z \<le> Inf X"
296.90 + using Sup_least[of "uminus ` X" "- z"] by (force simp: Inf_real_def) }
296.91 show "\<exists>a b::real. a \<noteq> b"
296.92 using zero_neq_one by blast
296.93 qed
296.94 end
296.95
296.96 -text {*
296.97 - \medskip Completeness properties using @{text "isUb"}, @{text "isLub"}:
296.98 -*}
296.99 -
296.100 -lemma reals_complete: "\<exists>X. X \<in> S \<Longrightarrow> \<exists>Y. isUb (UNIV::real set) S Y \<Longrightarrow> \<exists>t. isLub (UNIV :: real set) S t"
296.101 - by (intro exI[of _ "Sup S"] isLub_cSup) (auto simp: setle_def isUb_def intro: cSup_upper)
296.102 -
296.103
296.104 subsection {* Hiding implementation details *}
296.105
296.106 @@ -1468,13 +1447,13 @@
296.107
296.108 lemma [code_abbrev]:
296.109 "real_of_int (numeral k) = numeral k"
296.110 - "real_of_int (neg_numeral k) = neg_numeral k"
296.111 + "real_of_int (- numeral k) = - numeral k"
296.112 by simp_all
296.113
296.114 -text{*Collapse applications of @{term real} to @{term number_of}*}
296.115 +text{*Collapse applications of @{const real} to @{const numeral}*}
296.116 lemma real_numeral [simp]:
296.117 "real (numeral v :: int) = numeral v"
296.118 - "real (neg_numeral v :: int) = neg_numeral v"
296.119 + "real (- numeral v :: int) = - numeral v"
296.120 by (simp_all add: real_of_int_def)
296.121
296.122 lemma real_of_nat_numeral [simp]:
296.123 @@ -1580,11 +1559,11 @@
296.124 unfolding real_of_int_le_iff[symmetric] by simp
296.125
296.126 lemma neg_numeral_power_le_real_of_int_cancel_iff[simp]:
296.127 - "(neg_numeral x::real) ^ n \<le> real a \<longleftrightarrow> (neg_numeral x::int) ^ n \<le> a"
296.128 + "(- numeral x::real) ^ n \<le> real a \<longleftrightarrow> (- numeral x::int) ^ n \<le> a"
296.129 unfolding real_of_int_le_iff[symmetric] by simp
296.130
296.131 lemma real_of_int_le_neg_numeral_power_cancel_iff[simp]:
296.132 - "real a \<le> (neg_numeral x::real) ^ n \<longleftrightarrow> a \<le> (neg_numeral x::int) ^ n"
296.133 + "real a \<le> (- numeral x::real) ^ n \<longleftrightarrow> a \<le> (- numeral x::int) ^ n"
296.134 unfolding real_of_int_le_iff[symmetric] by simp
296.135
296.136 subsection{*Density of the Reals*}
296.137 @@ -2072,7 +2051,7 @@
296.138 by simp
296.139
296.140 lemma [code_abbrev]:
296.141 - "(of_rat (neg_numeral k) :: real) = neg_numeral k"
296.142 + "(of_rat (- numeral k) :: real) = - numeral k"
296.143 by simp
296.144
296.145 lemma [code_post]:
296.146 @@ -2080,14 +2059,14 @@
296.147 "(of_rat (r / 0) :: real) = 0"
296.148 "(of_rat (1 / 1) :: real) = 1"
296.149 "(of_rat (numeral k / 1) :: real) = numeral k"
296.150 - "(of_rat (neg_numeral k / 1) :: real) = neg_numeral k"
296.151 + "(of_rat (- numeral k / 1) :: real) = - numeral k"
296.152 "(of_rat (1 / numeral k) :: real) = 1 / numeral k"
296.153 - "(of_rat (1 / neg_numeral k) :: real) = 1 / neg_numeral k"
296.154 + "(of_rat (1 / - numeral k) :: real) = 1 / - numeral k"
296.155 "(of_rat (numeral k / numeral l) :: real) = numeral k / numeral l"
296.156 - "(of_rat (numeral k / neg_numeral l) :: real) = numeral k / neg_numeral l"
296.157 - "(of_rat (neg_numeral k / numeral l) :: real) = neg_numeral k / numeral l"
296.158 - "(of_rat (neg_numeral k / neg_numeral l) :: real) = neg_numeral k / neg_numeral l"
296.159 - by (simp_all add: of_rat_divide)
296.160 + "(of_rat (numeral k / - numeral l) :: real) = numeral k / - numeral l"
296.161 + "(of_rat (- numeral k / numeral l) :: real) = - numeral k / numeral l"
296.162 + "(of_rat (- numeral k / - numeral l) :: real) = - numeral k / - numeral l"
296.163 + by (simp_all add: of_rat_divide of_rat_minus)
296.164
296.165
296.166 text {* Operations *}
297.1 --- a/src/HOL/Real_Vector_Spaces.thy Thu Dec 05 17:52:12 2013 +0100
297.2 +++ b/src/HOL/Real_Vector_Spaces.thy Thu Dec 05 17:58:03 2013 +0100
297.3 @@ -31,7 +31,7 @@
297.4 qed
297.5
297.6 lemma diff: "f (x - y) = f x - f y"
297.7 -by (simp add: add minus diff_minus)
297.8 + using add [of x "- y"] by (simp add: minus)
297.9
297.10 lemma setsum: "f (setsum g A) = (\<Sum>x\<in>A. f (g x))"
297.11 apply (cases "finite A")
297.12 @@ -307,8 +307,8 @@
297.13 lemma of_real_numeral: "of_real (numeral w) = numeral w"
297.14 using of_real_of_int_eq [of "numeral w"] by simp
297.15
297.16 -lemma of_real_neg_numeral: "of_real (neg_numeral w) = neg_numeral w"
297.17 -using of_real_of_int_eq [of "neg_numeral w"] by simp
297.18 +lemma of_real_neg_numeral: "of_real (- numeral w) = - numeral w"
297.19 +using of_real_of_int_eq [of "- numeral w"] by simp
297.20
297.21 text{*Every real algebra has characteristic zero*}
297.22
297.23 @@ -341,9 +341,6 @@
297.24 lemma Reals_numeral [simp]: "numeral w \<in> Reals"
297.25 by (subst of_real_numeral [symmetric], rule Reals_of_real)
297.26
297.27 -lemma Reals_neg_numeral [simp]: "neg_numeral w \<in> Reals"
297.28 -by (subst of_real_neg_numeral [symmetric], rule Reals_of_real)
297.29 -
297.30 lemma Reals_0 [simp]: "0 \<in> Reals"
297.31 apply (unfold Reals_def)
297.32 apply (rule range_eqI)
297.33 @@ -553,8 +550,7 @@
297.34 proof -
297.35 have "norm (a + - b) \<le> norm a + norm (- b)"
297.36 by (rule norm_triangle_ineq)
297.37 - thus ?thesis
297.38 - by (simp only: diff_minus norm_minus_cancel)
297.39 + then show ?thesis by simp
297.40 qed
297.41
297.42 lemma norm_diff_ineq:
297.43 @@ -571,7 +567,7 @@
297.44 shows "norm ((a + b) - (c + d)) \<le> norm (a - c) + norm (b - d)"
297.45 proof -
297.46 have "norm ((a + b) - (c + d)) = norm ((a - c) + (b - d))"
297.47 - by (simp add: diff_minus add_ac)
297.48 + by (simp add: algebra_simps)
297.49 also have "\<dots> \<le> norm (a - c) + norm (b - d)"
297.50 by (rule norm_triangle_ineq)
297.51 finally show ?thesis .
297.52 @@ -603,7 +599,7 @@
297.53 by (subst of_real_numeral [symmetric], subst norm_of_real, simp)
297.54
297.55 lemma norm_neg_numeral [simp]:
297.56 - "norm (neg_numeral w::'a::real_normed_algebra_1) = numeral w"
297.57 + "norm (- numeral w::'a::real_normed_algebra_1) = numeral w"
297.58 by (subst of_real_neg_numeral [symmetric], subst norm_of_real, simp)
297.59
297.60 lemma norm_of_int [simp]:
297.61 @@ -1426,9 +1422,6 @@
297.62 @{term "{r::real. \<exists>N. \<forall>n\<ge>N. r < X n}"}
297.63 *}
297.64
297.65 -lemma isUb_UNIV_I: "(\<And>y. y \<in> S \<Longrightarrow> y \<le> u) \<Longrightarrow> isUb UNIV S u"
297.66 -by (simp add: isUbI setleI)
297.67 -
297.68 lemma increasing_LIMSEQ:
297.69 fixes f :: "nat \<Rightarrow> real"
297.70 assumes inc: "\<And>n. f n \<le> f (Suc n)"
297.71 @@ -1455,40 +1448,33 @@
297.72 then have mem_S: "\<And>N x. \<forall>n\<ge>N. x < X n \<Longrightarrow> x \<in> S" by auto
297.73
297.74 { fix N x assume N: "\<forall>n\<ge>N. X n < x"
297.75 - have "isUb UNIV S x"
297.76 - proof (rule isUb_UNIV_I)
297.77 fix y::real assume "y \<in> S"
297.78 hence "\<exists>M. \<forall>n\<ge>M. y < X n"
297.79 by (simp add: S_def)
297.80 then obtain M where "\<forall>n\<ge>M. y < X n" ..
297.81 hence "y < X (max M N)" by simp
297.82 also have "\<dots> < x" using N by simp
297.83 - finally show "y \<le> x"
297.84 - by (rule order_less_imp_le)
297.85 - qed }
297.86 + finally have "y \<le> x"
297.87 + by (rule order_less_imp_le) }
297.88 note bound_isUb = this
297.89
297.90 - have "\<exists>u. isLub UNIV S u"
297.91 - proof (rule reals_complete)
297.92 obtain N where "\<forall>m\<ge>N. \<forall>n\<ge>N. dist (X m) (X n) < 1"
297.93 using X[THEN metric_CauchyD, OF zero_less_one] by auto
297.94 hence N: "\<forall>n\<ge>N. dist (X n) (X N) < 1" by simp
297.95 - show "\<exists>x. x \<in> S"
297.96 - proof
297.97 + have [simp]: "S \<noteq> {}"
297.98 + proof (intro exI ex_in_conv[THEN iffD1])
297.99 from N have "\<forall>n\<ge>N. X N - 1 < X n"
297.100 by (simp add: abs_diff_less_iff dist_real_def)
297.101 thus "X N - 1 \<in> S" by (rule mem_S)
297.102 qed
297.103 - show "\<exists>u. isUb UNIV S u"
297.104 + have [simp]: "bdd_above S"
297.105 proof
297.106 from N have "\<forall>n\<ge>N. X n < X N + 1"
297.107 by (simp add: abs_diff_less_iff dist_real_def)
297.108 - thus "isUb UNIV S (X N + 1)"
297.109 + thus "\<And>s. s \<in> S \<Longrightarrow> s \<le> X N + 1"
297.110 by (rule bound_isUb)
297.111 qed
297.112 - qed
297.113 - then obtain x where x: "isLub UNIV S x" ..
297.114 - have "X ----> x"
297.115 + have "X ----> Sup S"
297.116 proof (rule metric_LIMSEQ_I)
297.117 fix r::real assume "0 < r"
297.118 hence r: "0 < r/2" by simp
297.119 @@ -1500,17 +1486,18 @@
297.120
297.121 from N have "\<forall>n\<ge>N. X N - r/2 < X n" by fast
297.122 hence "X N - r/2 \<in> S" by (rule mem_S)
297.123 - hence 1: "X N - r/2 \<le> x" using x isLub_isUb isUbD by fast
297.124 + hence 1: "X N - r/2 \<le> Sup S" by (simp add: cSup_upper)
297.125
297.126 from N have "\<forall>n\<ge>N. X n < X N + r/2" by fast
297.127 - hence "isUb UNIV S (X N + r/2)" by (rule bound_isUb)
297.128 - hence 2: "x \<le> X N + r/2" using x isLub_le_isUb by fast
297.129 + from bound_isUb[OF this]
297.130 + have 2: "Sup S \<le> X N + r/2"
297.131 + by (intro cSup_least) simp_all
297.132
297.133 - show "\<exists>N. \<forall>n\<ge>N. dist (X n) x < r"
297.134 + show "\<exists>N. \<forall>n\<ge>N. dist (X n) (Sup S) < r"
297.135 proof (intro exI allI impI)
297.136 fix n assume n: "N \<le> n"
297.137 from N n have "X n < X N + r/2" and "X N - r/2 < X n" by simp+
297.138 - thus "dist (X n) x < r" using 1 2
297.139 + thus "dist (X n) (Sup S) < r" using 1 2
297.140 by (simp add: abs_diff_less_iff dist_real_def)
297.141 qed
297.142 qed
298.1 --- a/src/HOL/Record.thy Thu Dec 05 17:52:12 2013 +0100
298.2 +++ b/src/HOL/Record.thy Thu Dec 05 17:58:03 2013 +0100
298.3 @@ -399,7 +399,7 @@
298.4 lemma refl_conj_eq: "Q = R \<Longrightarrow> P \<and> Q \<longleftrightarrow> P \<and> R"
298.5 by simp
298.6
298.7 -lemma iso_tuple_UNIV_I [no_atp]: "x \<in> UNIV \<equiv> True"
298.8 +lemma iso_tuple_UNIV_I: "x \<in> UNIV \<equiv> True"
298.9 by simp
298.10
298.11 lemma iso_tuple_True_simp: "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
299.1 --- a/src/HOL/Relation.thy Thu Dec 05 17:52:12 2013 +0100
299.2 +++ b/src/HOL/Relation.thy Thu Dec 05 17:58:03 2013 +0100
299.3 @@ -5,7 +5,7 @@
299.4 header {* Relations – as sets of pairs, and binary predicates *}
299.5
299.6 theory Relation
299.7 -imports Datatype Finite_Set
299.8 +imports Finite_Set
299.9 begin
299.10
299.11 text {* A preliminary: classical rules for reasoning on predicates *}
299.12 @@ -478,7 +478,7 @@
299.13 lemma Id_on_eqI: "a = b ==> a : A ==> (a, b) : Id_on A"
299.14 by (simp add: Id_on_def)
299.15
299.16 -lemma Id_onI [intro!,no_atp]: "a : A ==> (a, a) : Id_on A"
299.17 +lemma Id_onI [intro!]: "a : A ==> (a, a) : Id_on A"
299.18 by (rule Id_on_eqI) (rule refl)
299.19
299.20 lemma Id_onE [elim!]:
299.21 @@ -760,7 +760,8 @@
299.22 by (auto simp: total_on_def)
299.23
299.24 lemma finite_converse [iff]: "finite (r^-1) = finite r"
299.25 - unfolding converse_def conversep_iff by (auto elim: finite_imageD simp: inj_on_def)
299.26 + unfolding converse_def conversep_iff using [[simproc add: finite_Collect]]
299.27 + by (auto elim: finite_imageD simp: inj_on_def)
299.28
299.29 lemma conversep_noteq [simp]: "(op \<noteq>)^--1 = op \<noteq>"
299.30 by (auto simp add: fun_eq_iff)
299.31 @@ -939,8 +940,6 @@
299.32 where
299.33 "r `` s = {y. \<exists>x\<in>s. (x, y) \<in> r}"
299.34
299.35 -declare Image_def [no_atp]
299.36 -
299.37 lemma Image_iff: "(b : r``A) = (EX x:A. (x, b) : r)"
299.38 by (simp add: Image_def)
299.39
299.40 @@ -950,7 +949,7 @@
299.41 lemma Image_singleton_iff [iff]: "(b : r``{a}) = ((a, b) : r)"
299.42 by (rule Image_iff [THEN trans]) simp
299.43
299.44 -lemma ImageI [intro,no_atp]: "(a, b) : r ==> a : A ==> b : r``A"
299.45 +lemma ImageI [intro]: "(a, b) : r ==> a : A ==> b : r``A"
299.46 by (unfold Image_def) blast
299.47
299.48 lemma ImageE [elim!]:
299.49 @@ -996,6 +995,9 @@
299.50 lemma Image_UN: "(r `` (UNION A B)) = (\<Union>x\<in>A. r `` (B x))"
299.51 by blast
299.52
299.53 +lemma UN_Image: "(\<Union>i\<in>I. X i) `` S = (\<Union>i\<in>I. X i `` S)"
299.54 + by auto
299.55 +
299.56 lemma Image_INT_subset: "(r `` INTER A B) \<subseteq> (\<Inter>x\<in>A. r `` (B x))"
299.57 by blast
299.58
299.59 @@ -1013,6 +1015,11 @@
299.60 lemma Image_Collect_split [simp]: "{(x, y). P x y} `` A = {y. EX x:A. P x y}"
299.61 by auto
299.62
299.63 +lemma Sigma_Image: "(SIGMA x:A. B x) `` X = (\<Union>x\<in>X \<inter> A. B x)"
299.64 + by auto
299.65 +
299.66 +lemma relcomp_Image: "(X O Y) `` Z = Y `` (X `` Z)"
299.67 + by auto
299.68
299.69 subsubsection {* Inverse image *}
299.70
300.1 --- a/src/HOL/Rings.thy Thu Dec 05 17:52:12 2013 +0100
300.2 +++ b/src/HOL/Rings.thy Thu Dec 05 17:58:03 2013 +0100
300.3 @@ -86,7 +86,20 @@
300.4 lemma one_neq_zero [simp]: "1 \<noteq> 0"
300.5 by (rule not_sym) (rule zero_neq_one)
300.6
300.7 -end
300.8 +definition of_bool :: "bool \<Rightarrow> 'a"
300.9 +where
300.10 + "of_bool p = (if p then 1 else 0)"
300.11 +
300.12 +lemma of_bool_eq [simp, code]:
300.13 + "of_bool False = 0"
300.14 + "of_bool True = 1"
300.15 + by (simp_all add: of_bool_def)
300.16 +
300.17 +lemma of_bool_eq_iff:
300.18 + "of_bool p = of_bool q \<longleftrightarrow> p = q"
300.19 + by (simp add: of_bool_def)
300.20 +
300.21 +end
300.22
300.23 class semiring_1 = zero_neq_one + semiring_0 + monoid_mult
300.24
300.25 @@ -127,7 +140,7 @@
300.26 then show ?thesis ..
300.27 qed
300.28
300.29 -lemma dvd_0_left_iff [no_atp, simp]: "0 dvd a \<longleftrightarrow> a = 0"
300.30 +lemma dvd_0_left_iff [simp]: "0 dvd a \<longleftrightarrow> a = 0"
300.31 by (auto intro: dvd_refl elim!: dvdE)
300.32
300.33 lemma dvd_0_right [iff]: "a dvd 0"
300.34 @@ -233,8 +246,8 @@
300.35 by (rule minus_unique) (simp add: distrib_left [symmetric])
300.36
300.37 text{*Extract signs from products*}
300.38 -lemmas mult_minus_left [simp, no_atp] = minus_mult_left [symmetric]
300.39 -lemmas mult_minus_right [simp,no_atp] = minus_mult_right [symmetric]
300.40 +lemmas mult_minus_left [simp] = minus_mult_left [symmetric]
300.41 +lemmas mult_minus_right [simp] = minus_mult_right [symmetric]
300.42
300.43 lemma minus_mult_minus [simp]: "- a * - b = a * b"
300.44 by simp
300.45 @@ -242,13 +255,15 @@
300.46 lemma minus_mult_commute: "- a * b = a * - b"
300.47 by simp
300.48
300.49 -lemma right_diff_distrib[algebra_simps, field_simps]: "a * (b - c) = a * b - a * c"
300.50 -by (simp add: distrib_left diff_minus)
300.51 +lemma right_diff_distrib [algebra_simps, field_simps]:
300.52 + "a * (b - c) = a * b - a * c"
300.53 + using distrib_left [of a b "-c "] by simp
300.54
300.55 -lemma left_diff_distrib[algebra_simps, field_simps]: "(a - b) * c = a * c - b * c"
300.56 -by (simp add: distrib_right diff_minus)
300.57 +lemma left_diff_distrib [algebra_simps, field_simps]:
300.58 + "(a - b) * c = a * c - b * c"
300.59 + using distrib_right [of a "- b" c] by simp
300.60
300.61 -lemmas ring_distribs[no_atp] =
300.62 +lemmas ring_distribs =
300.63 distrib_left distrib_right left_diff_distrib right_diff_distrib
300.64
300.65 lemma eq_add_iff1:
300.66 @@ -261,7 +276,7 @@
300.67
300.68 end
300.69
300.70 -lemmas ring_distribs[no_atp] =
300.71 +lemmas ring_distribs =
300.72 distrib_left distrib_right left_diff_distrib right_diff_distrib
300.73
300.74 class comm_ring = comm_semiring + ab_group_add
300.75 @@ -318,8 +333,9 @@
300.76 then show "- x dvd y" ..
300.77 qed
300.78
300.79 -lemma dvd_diff[simp]: "x dvd y \<Longrightarrow> x dvd z \<Longrightarrow> x dvd (y - z)"
300.80 -by (simp only: diff_minus dvd_add dvd_minus_iff)
300.81 +lemma dvd_diff [simp]:
300.82 + "x dvd y \<Longrightarrow> x dvd z \<Longrightarrow> x dvd (y - z)"
300.83 + using dvd_add [of x y "- z"] by simp
300.84
300.85 end
300.86
300.87 @@ -336,7 +352,7 @@
300.88 qed
300.89
300.90 text{*Cancellation of equalities with a common factor*}
300.91 -lemma mult_cancel_right [simp, no_atp]:
300.92 +lemma mult_cancel_right [simp]:
300.93 "a * c = b * c \<longleftrightarrow> c = 0 \<or> a = b"
300.94 proof -
300.95 have "(a * c = b * c) = ((a - b) * c = 0)"
300.96 @@ -344,7 +360,7 @@
300.97 thus ?thesis by (simp add: disj_commute)
300.98 qed
300.99
300.100 -lemma mult_cancel_left [simp, no_atp]:
300.101 +lemma mult_cancel_left [simp]:
300.102 "c * a = c * b \<longleftrightarrow> c = 0 \<or> a = b"
300.103 proof -
300.104 have "(c * a = c * b) = (c * (a - b) = 0)"
300.105 @@ -742,9 +758,7 @@
300.106 proof
300.107 fix a b
300.108 show "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
300.109 - by (auto simp add: abs_if not_less)
300.110 - (auto simp del: minus_add_distrib simp add: minus_add_distrib [symmetric],
300.111 - auto intro!: less_imp_le add_neg_neg)
300.112 + by (auto simp add: abs_if not_le not_less algebra_simps simp del: add.commute dest: add_neg_neg add_nonneg_nonneg)
300.113 qed (auto simp add: abs_if)
300.114
300.115 lemma zero_le_square [simp]: "0 \<le> a * a"
300.116 @@ -1044,11 +1058,39 @@
300.117 "\<bar>l\<bar> = \<bar>k\<bar> \<Longrightarrow> l dvd k"
300.118 by(subst abs_dvd_iff[symmetric]) simp
300.119
300.120 +text {* The following lemmas can be proven in more generale structures, but
300.121 +are dangerous as simp rules in absence of @{thm neg_equal_zero},
300.122 +@{thm neg_less_pos}, @{thm neg_less_eq_nonneg}. *}
300.123 +
300.124 +lemma equation_minus_iff_1 [simp, no_atp]:
300.125 + "1 = - a \<longleftrightarrow> a = - 1"
300.126 + by (fact equation_minus_iff)
300.127 +
300.128 +lemma minus_equation_iff_1 [simp, no_atp]:
300.129 + "- a = 1 \<longleftrightarrow> a = - 1"
300.130 + by (subst minus_equation_iff, auto)
300.131 +
300.132 +lemma le_minus_iff_1 [simp, no_atp]:
300.133 + "1 \<le> - b \<longleftrightarrow> b \<le> - 1"
300.134 + by (fact le_minus_iff)
300.135 +
300.136 +lemma minus_le_iff_1 [simp, no_atp]:
300.137 + "- a \<le> 1 \<longleftrightarrow> - 1 \<le> a"
300.138 + by (fact minus_le_iff)
300.139 +
300.140 +lemma less_minus_iff_1 [simp, no_atp]:
300.141 + "1 < - b \<longleftrightarrow> b < - 1"
300.142 + by (fact less_minus_iff)
300.143 +
300.144 +lemma minus_less_iff_1 [simp, no_atp]:
300.145 + "- a < 1 \<longleftrightarrow> - 1 < a"
300.146 + by (fact minus_less_iff)
300.147 +
300.148 end
300.149
300.150 text {* Simprules for comparisons where common factors can be cancelled. *}
300.151
300.152 -lemmas mult_compare_simps[no_atp] =
300.153 +lemmas mult_compare_simps =
300.154 mult_le_cancel_right mult_le_cancel_left
300.155 mult_le_cancel_right1 mult_le_cancel_right2
300.156 mult_le_cancel_left1 mult_le_cancel_left2
300.157 @@ -1131,10 +1173,6 @@
300.158 thus ?thesis by (simp add: ac cpos mult_strict_mono)
300.159 qed
300.160
300.161 -lemma less_minus_self_iff:
300.162 - "a < - a \<longleftrightarrow> a < 0"
300.163 - by (simp only: less_le less_eq_neg_nonpos equal_neg_zero)
300.164 -
300.165 lemma abs_less_iff:
300.166 "\<bar>a\<bar> < b \<longleftrightarrow> a < b \<and> - a < b"
300.167 by (simp add: less_le abs_le_iff) (auto simp add: abs_if)
301.1 --- a/src/HOL/SMT_Examples/Boogie.thy Thu Dec 05 17:52:12 2013 +0100
301.2 +++ b/src/HOL/SMT_Examples/Boogie.thy Thu Dec 05 17:58:03 2013 +0100
301.3 @@ -6,6 +6,7 @@
301.4
301.5 theory Boogie
301.6 imports Main
301.7 +keywords "boogie_file" :: thy_load ("b2i")
301.8 begin
301.9
301.10 text {*
301.11 @@ -56,17 +57,17 @@
301.12
301.13 declare [[smt_certificates = "Boogie_Max.certs"]]
301.14
301.15 -setup {* Boogie.boogie_prove "Boogie_Max.b2i" *}
301.16 +boogie_file Boogie_Max
301.17
301.18
301.19 declare [[smt_certificates = "Boogie_Dijkstra.certs"]]
301.20
301.21 -setup {* Boogie.boogie_prove "Boogie_Dijkstra.b2i" *}
301.22 +boogie_file Boogie_Dijkstra
301.23
301.24
301.25 declare [[z3_with_extensions = true]]
301.26 declare [[smt_certificates = "VCC_Max.certs"]]
301.27
301.28 -setup {* Boogie.boogie_prove "VCC_Max.b2i" *}
301.29 +boogie_file VCC_Max
301.30
301.31 end
302.1 --- a/src/HOL/SMT_Examples/SMT_Tests.thy Thu Dec 05 17:52:12 2013 +0100
302.2 +++ b/src/HOL/SMT_Examples/SMT_Tests.thy Thu Dec 05 17:58:03 2013 +0100
302.3 @@ -374,7 +374,6 @@
302.4
302.5 lemma
302.6 "(0::int) = 0"
302.7 - "(0::int) = -0"
302.8 "(0::int) = (- 0)"
302.9 "(1::int) = 1"
302.10 "\<not>(-1 = (1::int))"
303.1 --- a/src/HOL/SMT_Examples/SMT_Word_Examples.certs Thu Dec 05 17:52:12 2013 +0100
303.2 +++ b/src/HOL/SMT_Examples/SMT_Word_Examples.certs Thu Dec 05 17:58:03 2013 +0100
303.3 @@ -54,3 +54,5 @@
303.4 unsat
303.5 e5c27ae0a583eeafeaa4ef3c59b1b4ec53e06b0f 1 0
303.6 unsat
303.7 +7d3ef49480d3ed3a7e5f2d7a12e7108cf7fc7819 1 0
303.8 +unsat
304.1 --- a/src/HOL/SMT_Examples/boogie.ML Thu Dec 05 17:52:12 2013 +0100
304.2 +++ b/src/HOL/SMT_Examples/boogie.ML Thu Dec 05 17:58:03 2013 +0100
304.3 @@ -6,7 +6,7 @@
304.4
304.5 signature BOOGIE =
304.6 sig
304.7 - val boogie_prove: string -> theory -> theory
304.8 + val boogie_prove: theory -> string -> unit
304.9 end
304.10
304.11 structure Boogie: BOOGIE =
304.12 @@ -299,21 +299,33 @@
304.13 ALLGOALS (SMT_Solver.smt_tac ctxt (boogie_rules @ axioms))
304.14
304.15
304.16 -fun boogie_prove file_name thy =
304.17 +fun boogie_prove thy text =
304.18 let
304.19 - val (text, thy') = Thy_Load.use_file (Path.explode file_name) thy
304.20 val lines = explode_lines text
304.21
304.22 val ((axioms, vc), ctxt) =
304.23 empty_context
304.24 |> parse_lines lines
304.25 |> add_unique_axioms
304.26 - |> build_proof_context thy'
304.27 + |> build_proof_context thy
304.28
304.29 val _ = Goal.prove ctxt [] axioms vc (fn {prems, context} =>
304.30 boogie_tac context prems)
304.31 val _ = writeln "Verification condition proved successfully"
304.32
304.33 - in thy' end
304.34 + in () end
304.35 +
304.36 +
304.37 +(* Isar command *)
304.38 +
304.39 +val _ =
304.40 + Outer_Syntax.command @{command_spec "boogie_file"}
304.41 + "prove verification condition from .b2i file"
304.42 + (Thy_Load.provide_parse_files "boogie_file" >> (fn files =>
304.43 + Toplevel.theory (fn thy =>
304.44 + let
304.45 + val ([{text, ...}], thy') = files thy;
304.46 + val _ = boogie_prove thy' text;
304.47 + in thy' end)))
304.48
304.49 end
305.1 --- a/src/HOL/SPARK/SPARK.thy Thu Dec 05 17:52:12 2013 +0100
305.2 +++ b/src/HOL/SPARK/SPARK.thy Thu Dec 05 17:58:03 2013 +0100
305.3 @@ -16,151 +16,6 @@
305.4 bit__or (integer, integer) : integer = "op OR"
305.5 bit__xor (integer, integer) : integer = "op XOR"
305.6
305.7 -lemma AND_lower [simp]:
305.8 - fixes x :: int and y :: int
305.9 - assumes "0 \<le> x"
305.10 - shows "0 \<le> x AND y"
305.11 - using assms
305.12 -proof (induct x arbitrary: y rule: bin_induct)
305.13 - case (3 bin bit)
305.14 - show ?case
305.15 - proof (cases y rule: bin_exhaust)
305.16 - case (1 bin' bit')
305.17 - from 3 have "0 \<le> bin"
305.18 - by (simp add: Bit_def bitval_def split add: bit.split_asm)
305.19 - then have "0 \<le> bin AND bin'" by (rule 3)
305.20 - with 1 show ?thesis
305.21 - by simp (simp add: Bit_def bitval_def split add: bit.split)
305.22 - qed
305.23 -next
305.24 - case 2
305.25 - then show ?case by (simp only: Min_def)
305.26 -qed simp
305.27 -
305.28 -lemma OR_lower [simp]:
305.29 - fixes x :: int and y :: int
305.30 - assumes "0 \<le> x" "0 \<le> y"
305.31 - shows "0 \<le> x OR y"
305.32 - using assms
305.33 -proof (induct x arbitrary: y rule: bin_induct)
305.34 - case (3 bin bit)
305.35 - show ?case
305.36 - proof (cases y rule: bin_exhaust)
305.37 - case (1 bin' bit')
305.38 - from 3 have "0 \<le> bin"
305.39 - by (simp add: Bit_def bitval_def split add: bit.split_asm)
305.40 - moreover from 1 3 have "0 \<le> bin'"
305.41 - by (simp add: Bit_def bitval_def split add: bit.split_asm)
305.42 - ultimately have "0 \<le> bin OR bin'" by (rule 3)
305.43 - with 1 show ?thesis
305.44 - by simp (simp add: Bit_def bitval_def split add: bit.split)
305.45 - qed
305.46 -qed simp_all
305.47 -
305.48 -lemma XOR_lower [simp]:
305.49 - fixes x :: int and y :: int
305.50 - assumes "0 \<le> x" "0 \<le> y"
305.51 - shows "0 \<le> x XOR y"
305.52 - using assms
305.53 -proof (induct x arbitrary: y rule: bin_induct)
305.54 - case (3 bin bit)
305.55 - show ?case
305.56 - proof (cases y rule: bin_exhaust)
305.57 - case (1 bin' bit')
305.58 - from 3 have "0 \<le> bin"
305.59 - by (simp add: Bit_def bitval_def split add: bit.split_asm)
305.60 - moreover from 1 3 have "0 \<le> bin'"
305.61 - by (simp add: Bit_def bitval_def split add: bit.split_asm)
305.62 - ultimately have "0 \<le> bin XOR bin'" by (rule 3)
305.63 - with 1 show ?thesis
305.64 - by simp (simp add: Bit_def bitval_def split add: bit.split)
305.65 - qed
305.66 -next
305.67 - case 2
305.68 - then show ?case by (simp only: Min_def)
305.69 -qed simp
305.70 -
305.71 -lemma AND_upper1 [simp]:
305.72 - fixes x :: int and y :: int
305.73 - assumes "0 \<le> x"
305.74 - shows "x AND y \<le> x"
305.75 - using assms
305.76 -proof (induct x arbitrary: y rule: bin_induct)
305.77 - case (3 bin bit)
305.78 - show ?case
305.79 - proof (cases y rule: bin_exhaust)
305.80 - case (1 bin' bit')
305.81 - from 3 have "0 \<le> bin"
305.82 - by (simp add: Bit_def bitval_def split add: bit.split_asm)
305.83 - then have "bin AND bin' \<le> bin" by (rule 3)
305.84 - with 1 show ?thesis
305.85 - by simp (simp add: Bit_def bitval_def split add: bit.split)
305.86 - qed
305.87 -next
305.88 - case 2
305.89 - then show ?case by (simp only: Min_def)
305.90 -qed simp
305.91 -
305.92 -lemmas AND_upper1' [simp] = order_trans [OF AND_upper1]
305.93 -lemmas AND_upper1'' [simp] = order_le_less_trans [OF AND_upper1]
305.94 -
305.95 -lemma AND_upper2 [simp]:
305.96 - fixes x :: int and y :: int
305.97 - assumes "0 \<le> y"
305.98 - shows "x AND y \<le> y"
305.99 - using assms
305.100 -proof (induct y arbitrary: x rule: bin_induct)
305.101 - case (3 bin bit)
305.102 - show ?case
305.103 - proof (cases x rule: bin_exhaust)
305.104 - case (1 bin' bit')
305.105 - from 3 have "0 \<le> bin"
305.106 - by (simp add: Bit_def bitval_def split add: bit.split_asm)
305.107 - then have "bin' AND bin \<le> bin" by (rule 3)
305.108 - with 1 show ?thesis
305.109 - by simp (simp add: Bit_def bitval_def split add: bit.split)
305.110 - qed
305.111 -next
305.112 - case 2
305.113 - then show ?case by (simp only: Min_def)
305.114 -qed simp
305.115 -
305.116 -lemmas AND_upper2' [simp] = order_trans [OF AND_upper2]
305.117 -lemmas AND_upper2'' [simp] = order_le_less_trans [OF AND_upper2]
305.118 -
305.119 -lemma OR_upper:
305.120 - fixes x :: int and y :: int
305.121 - assumes "0 \<le> x" "x < 2 ^ n" "y < 2 ^ n"
305.122 - shows "x OR y < 2 ^ n"
305.123 - using assms
305.124 -proof (induct x arbitrary: y n rule: bin_induct)
305.125 - case (3 bin bit)
305.126 - show ?case
305.127 - proof (cases y rule: bin_exhaust)
305.128 - case (1 bin' bit')
305.129 - show ?thesis
305.130 - proof (cases n)
305.131 - case 0
305.132 - with 3 have "bin BIT bit = 0" by simp
305.133 - then have "bin = 0" "bit = 0"
305.134 - by (auto simp add: Bit_def bitval_def split add: bit.split_asm) arith
305.135 - then show ?thesis using 0 1 `y < 2 ^ n`
305.136 - by simp
305.137 - next
305.138 - case (Suc m)
305.139 - from 3 have "0 \<le> bin"
305.140 - by (simp add: Bit_def bitval_def split add: bit.split_asm)
305.141 - moreover from 3 Suc have "bin < 2 ^ m"
305.142 - by (simp add: Bit_def bitval_def split add: bit.split_asm)
305.143 - moreover from 1 3 Suc have "bin' < 2 ^ m"
305.144 - by (simp add: Bit_def bitval_def split add: bit.split_asm)
305.145 - ultimately have "bin OR bin' < 2 ^ m" by (rule 3)
305.146 - with 1 Suc show ?thesis
305.147 - by simp (simp add: Bit_def bitval_def split add: bit.split)
305.148 - qed
305.149 - qed
305.150 -qed simp_all
305.151 -
305.152 lemmas [simp] =
305.153 OR_upper [of _ 8, simplified zle_diff1_eq [symmetric], simplified]
305.154 OR_upper [of _ 8, simplified]
305.155 @@ -171,42 +26,6 @@
305.156 OR_upper [of _ 64, simplified zle_diff1_eq [symmetric], simplified]
305.157 OR_upper [of _ 64, simplified]
305.158
305.159 -lemma XOR_upper:
305.160 - fixes x :: int and y :: int
305.161 - assumes "0 \<le> x" "x < 2 ^ n" "y < 2 ^ n"
305.162 - shows "x XOR y < 2 ^ n"
305.163 - using assms
305.164 -proof (induct x arbitrary: y n rule: bin_induct)
305.165 - case (3 bin bit)
305.166 - show ?case
305.167 - proof (cases y rule: bin_exhaust)
305.168 - case (1 bin' bit')
305.169 - show ?thesis
305.170 - proof (cases n)
305.171 - case 0
305.172 - with 3 have "bin BIT bit = 0" by simp
305.173 - then have "bin = 0" "bit = 0"
305.174 - by (auto simp add: Bit_def bitval_def split add: bit.split_asm) arith
305.175 - then show ?thesis using 0 1 `y < 2 ^ n`
305.176 - by simp
305.177 - next
305.178 - case (Suc m)
305.179 - from 3 have "0 \<le> bin"
305.180 - by (simp add: Bit_def bitval_def split add: bit.split_asm)
305.181 - moreover from 3 Suc have "bin < 2 ^ m"
305.182 - by (simp add: Bit_def bitval_def split add: bit.split_asm)
305.183 - moreover from 1 3 Suc have "bin' < 2 ^ m"
305.184 - by (simp add: Bit_def bitval_def split add: bit.split_asm)
305.185 - ultimately have "bin XOR bin' < 2 ^ m" by (rule 3)
305.186 - with 1 Suc show ?thesis
305.187 - by simp (simp add: Bit_def bitval_def split add: bit.split)
305.188 - qed
305.189 - qed
305.190 -next
305.191 - case 2
305.192 - then show ?case by (simp only: Min_def)
305.193 -qed simp
305.194 -
305.195 lemmas [simp] =
305.196 XOR_upper [of _ 8, simplified zle_diff1_eq [symmetric], simplified]
305.197 XOR_upper [of _ 8, simplified]
305.198 @@ -234,47 +53,6 @@
305.199 bit_not_spark_eq [where 'a=32, simplified]
305.200 bit_not_spark_eq [where 'a=64, simplified]
305.201
305.202 -lemma power_BIT: "2 ^ (Suc n) - 1 = (2 ^ n - 1) BIT 1"
305.203 - unfolding Bit_B1
305.204 - by (induct n) simp_all
305.205 -
305.206 -lemma mod_BIT:
305.207 - "bin BIT bit mod 2 ^ Suc n = (bin mod 2 ^ n) BIT bit"
305.208 -proof -
305.209 - have "bin mod 2 ^ n < 2 ^ n" by simp
305.210 - then have "bin mod 2 ^ n \<le> 2 ^ n - 1" by simp
305.211 - then have "2 * (bin mod 2 ^ n) \<le> 2 * (2 ^ n - 1)"
305.212 - by (rule mult_left_mono) simp
305.213 - then have "2 * (bin mod 2 ^ n) + 1 < 2 * 2 ^ n" by simp
305.214 - then show ?thesis
305.215 - by (auto simp add: Bit_def bitval_def mod_mult_mult1 mod_add_left_eq [of "2 * bin"]
305.216 - mod_pos_pos_trivial split add: bit.split)
305.217 -qed
305.218 -
305.219 -lemma AND_mod:
305.220 - fixes x :: int
305.221 - shows "x AND 2 ^ n - 1 = x mod 2 ^ n"
305.222 -proof (induct x arbitrary: n rule: bin_induct)
305.223 - case 1
305.224 - then show ?case
305.225 - by simp
305.226 -next
305.227 - case 2
305.228 - then show ?case
305.229 - by (simp, simp add: m1mod2k)
305.230 -next
305.231 - case (3 bin bit)
305.232 - show ?case
305.233 - proof (cases n)
305.234 - case 0
305.235 - then show ?thesis by (simp add: int_and_extra_simps)
305.236 - next
305.237 - case (Suc m)
305.238 - with 3 show ?thesis
305.239 - by (simp only: power_BIT mod_BIT int_and_Bits) simp
305.240 - qed
305.241 -qed
305.242 -
305.243
305.244 text {* Minimum and maximum *}
305.245
305.246 @@ -283,3 +61,4 @@
305.247 integer__max = "max :: int \<Rightarrow> int \<Rightarrow> int"
305.248
305.249 end
305.250 +
306.1 --- a/src/HOL/SPARK/SPARK_Setup.thy Thu Dec 05 17:52:12 2013 +0100
306.2 +++ b/src/HOL/SPARK/SPARK_Setup.thy Thu Dec 05 17:58:03 2013 +0100
306.3 @@ -6,7 +6,7 @@
306.4 *)
306.5
306.6 theory SPARK_Setup
306.7 -imports Word
306.8 +imports "~~/src/HOL/Word/Word" "~~/src/HOL/Word/Bit_Comparison"
306.9 keywords
306.10 "spark_open_vcg" :: thy_load ("vcg", "fdl", "rls") and
306.11 "spark_open_siv" :: thy_load ("siv", "fdl", "rls") and
307.1 --- a/src/HOL/Semiring_Normalization.thy Thu Dec 05 17:52:12 2013 +0100
307.2 +++ b/src/HOL/Semiring_Normalization.thy Thu Dec 05 17:58:03 2013 +0100
307.3 @@ -137,7 +137,7 @@
307.4 lemma normalizing_ring_rules:
307.5 "- x = (- 1) * x"
307.6 "x - y = x + (- y)"
307.7 - by (simp_all add: diff_minus)
307.8 + by simp_all
307.9
307.10 lemmas normalizing_comm_ring_1_axioms =
307.11 comm_ring_1_axioms [normalizer
308.1 --- a/src/HOL/Series.thy Thu Dec 05 17:52:12 2013 +0100
308.2 +++ b/src/HOL/Series.thy Thu Dec 05 17:58:03 2013 +0100
308.3 @@ -34,7 +34,7 @@
308.4
308.5 lemma sumr_diff_mult_const:
308.6 "setsum f {0..<n} - (real n*r) = setsum (%i. f i - r) {0..<n::nat}"
308.7 -by (simp add: diff_minus setsum_addf real_of_nat_def)
308.8 + by (simp add: setsum_subtractf real_of_nat_def)
308.9
308.10 lemma real_setsum_nat_ivl_bounded:
308.11 "(!!p. p < n \<Longrightarrow> f(p) \<le> K)
309.1 --- a/src/HOL/Set.thy Thu Dec 05 17:52:12 2013 +0100
309.2 +++ b/src/HOL/Set.thy Thu Dec 05 17:58:03 2013 +0100
309.3 @@ -87,7 +87,7 @@
309.4 then show ?thesis by simp
309.5 qed
309.6
309.7 -lemma set_eq_iff [no_atp]:
309.8 +lemma set_eq_iff:
309.9 "A = B \<longleftrightarrow> (\<forall>x. x \<in> A \<longleftrightarrow> x \<in> B)"
309.10 by (auto intro:set_eqI)
309.11
309.12 @@ -495,7 +495,7 @@
309.13 by (simp add: less_eq_set_def le_fun_def)
309.14 -- {* Rule in Modus Ponens style. *}
309.15
309.16 -lemma rev_subsetD [no_atp,intro?]: "c \<in> A ==> A \<subseteq> B ==> c \<in> B"
309.17 +lemma rev_subsetD [intro?]: "c \<in> A ==> A \<subseteq> B ==> c \<in> B"
309.18 -- {* The same, with reversed premises for use with @{text erule} --
309.19 cf @{text rev_mp}. *}
309.20 by (rule subsetD)
309.21 @@ -504,13 +504,13 @@
309.22 \medskip Converts @{prop "A \<subseteq> B"} to @{prop "x \<in> A ==> x \<in> B"}.
309.23 *}
309.24
309.25 -lemma subsetCE [no_atp,elim]: "A \<subseteq> B ==> (c \<notin> A ==> P) ==> (c \<in> B ==> P) ==> P"
309.26 +lemma subsetCE [elim]: "A \<subseteq> B ==> (c \<notin> A ==> P) ==> (c \<in> B ==> P) ==> P"
309.27 -- {* Classical elimination rule. *}
309.28 by (auto simp add: less_eq_set_def le_fun_def)
309.29
309.30 -lemma subset_eq [no_atp]: "A \<le> B = (\<forall>x\<in>A. x \<in> B)" by blast
309.31 -
309.32 -lemma contra_subsetD [no_atp]: "A \<subseteq> B ==> c \<notin> B ==> c \<notin> A"
309.33 +lemma subset_eq: "A \<le> B = (\<forall>x\<in>A. x \<in> B)" by blast
309.34 +
309.35 +lemma contra_subsetD: "A \<subseteq> B ==> c \<notin> B ==> c \<notin> A"
309.36 by blast
309.37
309.38 lemma subset_refl: "A \<subseteq> A"
309.39 @@ -845,11 +845,11 @@
309.40
309.41 subsubsection {* Singletons, using insert *}
309.42
309.43 -lemma singletonI [intro!,no_atp]: "a : {a}"
309.44 +lemma singletonI [intro!]: "a : {a}"
309.45 -- {* Redundant? But unlike @{text insertCI}, it proves the subgoal immediately! *}
309.46 by (rule insertI1)
309.47
309.48 -lemma singletonD [dest!,no_atp]: "b : {a} ==> b = a"
309.49 +lemma singletonD [dest!]: "b : {a} ==> b = a"
309.50 by blast
309.51
309.52 lemmas singletonE = singletonD [elim_format]
309.53 @@ -860,11 +860,11 @@
309.54 lemma singleton_inject [dest!]: "{a} = {b} ==> a = b"
309.55 by blast
309.56
309.57 -lemma singleton_insert_inj_eq [iff,no_atp]:
309.58 +lemma singleton_insert_inj_eq [iff]:
309.59 "({b} = insert a A) = (a = b & A \<subseteq> {b})"
309.60 by blast
309.61
309.62 -lemma singleton_insert_inj_eq' [iff,no_atp]:
309.63 +lemma singleton_insert_inj_eq' [iff]:
309.64 "(insert a A = {b}) = (a = b & A \<subseteq> {b})"
309.65 by blast
309.66
309.67 @@ -898,7 +898,7 @@
309.68 *}
309.69
309.70 definition image :: "('a => 'b) => 'a set => 'b set" (infixr "`" 90) where
309.71 - image_def [no_atp]: "f ` A = {y. EX x:A. y = f(x)}"
309.72 + image_def: "f ` A = {y. EX x:A. y = f(x)}"
309.73
309.74 abbreviation
309.75 range :: "('a => 'b) => 'b set" where -- "of function"
309.76 @@ -930,7 +930,7 @@
309.77 lemma image_iff: "(z : f`A) = (EX x:A. z = f x)"
309.78 by blast
309.79
309.80 -lemma image_subset_iff [no_atp]: "(f`A \<subseteq> B) = (\<forall>x\<in>A. f x \<in> B)"
309.81 +lemma image_subset_iff: "(f`A \<subseteq> B) = (\<forall>x\<in>A. f x \<in> B)"
309.82 -- {* This rewrite rule would confuse users if made default. *}
309.83 by blast
309.84
309.85 @@ -1009,10 +1009,10 @@
309.86
309.87 subsubsection {* The ``proper subset'' relation *}
309.88
309.89 -lemma psubsetI [intro!,no_atp]: "A \<subseteq> B ==> A \<noteq> B ==> A \<subset> B"
309.90 +lemma psubsetI [intro!]: "A \<subseteq> B ==> A \<noteq> B ==> A \<subset> B"
309.91 by (unfold less_le) blast
309.92
309.93 -lemma psubsetE [elim!,no_atp]:
309.94 +lemma psubsetE [elim!]:
309.95 "[|A \<subset> B; [|A \<subseteq> B; ~ (B\<subseteq>A)|] ==> R|] ==> R"
309.96 by (unfold less_le) blast
309.97
309.98 @@ -1184,12 +1184,12 @@
309.99 lemma insert_inter_insert[simp]: "insert a A \<inter> insert a B = insert a (A \<inter> B)"
309.100 by blast
309.101
309.102 -lemma insert_disjoint [simp,no_atp]:
309.103 +lemma insert_disjoint [simp]:
309.104 "(insert a A \<inter> B = {}) = (a \<notin> B \<and> A \<inter> B = {})"
309.105 "({} = insert a A \<inter> B) = (a \<notin> B \<and> {} = A \<inter> B)"
309.106 by auto
309.107
309.108 -lemma disjoint_insert [simp,no_atp]:
309.109 +lemma disjoint_insert [simp]:
309.110 "(B \<inter> insert a A = {}) = (a \<notin> B \<and> B \<inter> A = {})"
309.111 "({} = A \<inter> insert b B) = (b \<notin> A \<and> {} = A \<inter> B)"
309.112 by auto
309.113 @@ -1221,7 +1221,7 @@
309.114 by blast
309.115
309.116
309.117 -lemma image_Collect [no_atp]: "f ` {x. P x} = {f x | x. P x}"
309.118 +lemma image_Collect: "f ` {x. P x} = {f x | x. P x}"
309.119 -- {* NOT suitable as a default simprule: the RHS isn't simpler than the LHS,
309.120 with its implicit quantifier and conjunction. Also image enjoys better
309.121 equational properties than does the RHS. *}
309.122 @@ -1244,7 +1244,7 @@
309.123
309.124 text {* \medskip @{text range}. *}
309.125
309.126 -lemma full_SetCompr_eq [no_atp]: "{u. \<exists>x. u = f x} = range f"
309.127 +lemma full_SetCompr_eq: "{u. \<exists>x. u = f x} = range f"
309.128 by auto
309.129
309.130 lemma range_composition: "range (\<lambda>x. f (g x)) = f`range g"
309.131 @@ -1301,10 +1301,10 @@
309.132 lemma Int_Un_distrib2: "(B \<union> C) \<inter> A = (B \<inter> A) \<union> (C \<inter> A)"
309.133 by (fact inf_sup_distrib2)
309.134
309.135 -lemma Int_UNIV [simp,no_atp]: "(A \<inter> B = UNIV) = (A = UNIV & B = UNIV)"
309.136 +lemma Int_UNIV [simp]: "(A \<inter> B = UNIV) = (A = UNIV & B = UNIV)"
309.137 by (fact inf_eq_top_iff) (* already simp *)
309.138
309.139 -lemma Int_subset_iff [no_atp, simp]: "(C \<subseteq> A \<inter> B) = (C \<subseteq> A & C \<subseteq> B)"
309.140 +lemma Int_subset_iff [simp]: "(C \<subseteq> A \<inter> B) = (C \<subseteq> A & C \<subseteq> B)"
309.141 by (fact le_inf_iff)
309.142
309.143 lemma Int_Collect: "(x \<in> A \<inter> {x. P x}) = (x \<in> A & P x)"
309.144 @@ -1395,7 +1395,7 @@
309.145 lemma Un_empty [iff]: "(A \<union> B = {}) = (A = {} & B = {})"
309.146 by (fact sup_eq_bot_iff) (* FIXME: already simp *)
309.147
309.148 -lemma Un_subset_iff [no_atp, simp]: "(A \<union> B \<subseteq> C) = (A \<subseteq> C & B \<subseteq> C)"
309.149 +lemma Un_subset_iff [simp]: "(A \<union> B \<subseteq> C) = (A \<subseteq> C & B \<subseteq> C)"
309.150 by (fact le_sup_iff)
309.151
309.152 lemma Un_Diff_Int: "(A - B) \<union> (A \<inter> B) = A"
309.153 @@ -1467,7 +1467,7 @@
309.154 lemma Diff_eq: "A - B = A \<inter> (-B)"
309.155 by blast
309.156
309.157 -lemma Diff_eq_empty_iff [simp,no_atp]: "(A - B = {}) = (A \<subseteq> B)"
309.158 +lemma Diff_eq_empty_iff [simp]: "(A - B = {}) = (A \<subseteq> B)"
309.159 by blast
309.160
309.161 lemma Diff_cancel [simp]: "A - A = {}"
309.162 @@ -1488,7 +1488,7 @@
309.163 lemma Diff_UNIV [simp]: "A - UNIV = {}"
309.164 by blast
309.165
309.166 -lemma Diff_insert0 [simp,no_atp]: "x \<notin> A ==> A - insert x B = A - B"
309.167 +lemma Diff_insert0 [simp]: "x \<notin> A ==> A - insert x B = A - B"
309.168 by blast
309.169
309.170 lemma Diff_insert: "A - insert a B = A - B - {a}"
309.171 @@ -1568,7 +1568,7 @@
309.172 lemma ex_bool_eq: "(\<exists>b. P b) \<longleftrightarrow> P True \<or> P False"
309.173 by (auto intro: bool_contrapos)
309.174
309.175 -lemma UNIV_bool [no_atp]: "UNIV = {False, True}"
309.176 +lemma UNIV_bool: "UNIV = {False, True}"
309.177 by (auto intro: bool_induct)
309.178
309.179 text {* \medskip @{text Pow} *}
309.180 @@ -1597,7 +1597,7 @@
309.181 lemma set_eq_subset: "(A = B) = (A \<subseteq> B & B \<subseteq> A)"
309.182 by blast
309.183
309.184 -lemma subset_iff [no_atp]: "(A \<subseteq> B) = (\<forall>t. t \<in> A --> t \<in> B)"
309.185 +lemma subset_iff: "(A \<subseteq> B) = (\<forall>t. t \<in> A --> t \<in> B)"
309.186 by blast
309.187
309.188 lemma subset_iff_psubset_eq: "(A \<subseteq> B) = ((A \<subset> B) | (A = B))"
309.189 @@ -1754,7 +1754,7 @@
309.190 -- {* monotonicity *}
309.191 by blast
309.192
309.193 -lemma vimage_image_eq [no_atp]: "f -` (f ` A) = {y. EX x:A. f x = f y}"
309.194 +lemma vimage_image_eq: "f -` (f ` A) = {y. EX x:A. f x = f y}"
309.195 by (blast intro: sym)
309.196
309.197 lemma image_vimage_subset: "f ` (f -` A) <= A"
310.1 --- a/src/HOL/Set_Interval.thy Thu Dec 05 17:52:12 2013 +0100
310.2 +++ b/src/HOL/Set_Interval.thy Thu Dec 05 17:58:03 2013 +0100
310.3 @@ -14,7 +14,7 @@
310.4 header {* Set intervals *}
310.5
310.6 theory Set_Interval
310.7 -imports Int Nat_Transfer
310.8 +imports Nat_Transfer
310.9 begin
310.10
310.11 context ord
310.12 @@ -180,19 +180,19 @@
310.13 context ord
310.14 begin
310.15
310.16 -lemma greaterThanLessThan_iff [simp,no_atp]:
310.17 +lemma greaterThanLessThan_iff [simp]:
310.18 "(i : {l<..<u}) = (l < i & i < u)"
310.19 by (simp add: greaterThanLessThan_def)
310.20
310.21 -lemma atLeastLessThan_iff [simp,no_atp]:
310.22 +lemma atLeastLessThan_iff [simp]:
310.23 "(i : {l..<u}) = (l <= i & i < u)"
310.24 by (simp add: atLeastLessThan_def)
310.25
310.26 -lemma greaterThanAtMost_iff [simp,no_atp]:
310.27 +lemma greaterThanAtMost_iff [simp]:
310.28 "(i : {l<..u}) = (l < i & i <= u)"
310.29 by (simp add: greaterThanAtMost_def)
310.30
310.31 -lemma atLeastAtMost_iff [simp,no_atp]:
310.32 +lemma atLeastAtMost_iff [simp]:
310.33 "(i : {l..u}) = (l <= i & i <= u)"
310.34 by (simp add: atLeastAtMost_def)
310.35
310.36 @@ -1196,7 +1196,7 @@
310.37
310.38 subsubsection {* Some Subset Conditions *}
310.39
310.40 -lemma ivl_subset [simp,no_atp]:
310.41 +lemma ivl_subset [simp]:
310.42 "({i..<j} \<subseteq> {m..<n}) = (j \<le> i | m \<le> i & j \<le> (n::'a::linorder))"
310.43 apply(auto simp:linorder_not_le)
310.44 apply(rule ccontr)
311.1 --- a/src/HOL/String.thy Thu Dec 05 17:52:12 2013 +0100
311.2 +++ b/src/HOL/String.thy Thu Dec 05 17:58:03 2013 +0100
311.3 @@ -358,6 +358,8 @@
311.4 typedef literal = "UNIV :: string set"
311.5 morphisms explode STR ..
311.6
311.7 +setup_lifting (no_code) type_definition_literal
311.8 +
311.9 instantiation literal :: size
311.10 begin
311.11
311.12 @@ -372,16 +374,14 @@
311.13 instantiation literal :: equal
311.14 begin
311.15
311.16 -definition equal_literal :: "literal \<Rightarrow> literal \<Rightarrow> bool"
311.17 -where
311.18 - "equal_literal s1 s2 \<longleftrightarrow> explode s1 = explode s2"
311.19 +lift_definition equal_literal :: "literal \<Rightarrow> literal \<Rightarrow> bool" is "op =" .
311.20
311.21 -instance
311.22 -proof
311.23 -qed (auto simp add: equal_literal_def explode_inject)
311.24 +instance by intro_classes (transfer, simp)
311.25
311.26 end
311.27
311.28 +declare equal_literal.rep_eq[code]
311.29 +
311.30 lemma [code nbe]:
311.31 fixes s :: "String.literal"
311.32 shows "HOL.equal s s \<longleftrightarrow> True"
311.33 @@ -391,7 +391,6 @@
311.34 "STR xs = STR ys \<longleftrightarrow> xs = ys"
311.35 by (simp add: STR_inject)
311.36
311.37 -
311.38 subsection {* Code generator *}
311.39
311.40 ML_file "Tools/string_code.ML"
312.1 --- a/src/HOL/TPTP/MaSh_Export.thy Thu Dec 05 17:52:12 2013 +0100
312.2 +++ b/src/HOL/TPTP/MaSh_Export.thy Thu Dec 05 17:58:03 2013 +0100
312.3 @@ -63,7 +63,7 @@
312.4
312.5 ML {*
312.6 if do_it then
312.7 - generate_isar_dependencies @{context} thys linearize
312.8 + generate_isar_dependencies @{context} range thys linearize
312.9 (prefix ^ "mash_dependencies")
312.10 else
312.11 ()
313.1 --- a/src/HOL/TPTP/atp_problem_import.ML Thu Dec 05 17:52:12 2013 +0100
313.2 +++ b/src/HOL/TPTP/atp_problem_import.ML Thu Dec 05 17:58:03 2013 +0100
313.3 @@ -7,23 +7,20 @@
313.4
313.5 signature ATP_PROBLEM_IMPORT =
313.6 sig
313.7 - val read_tptp_file :
313.8 - theory -> (term -> term) -> string
313.9 - -> term list * (term list * term list) * Proof.context
313.10 + val read_tptp_file : theory -> (string * term -> 'a) -> string ->
313.11 + 'a list * ('a list * 'a list) * Proof.context
313.12 val nitpick_tptp_file : theory -> int -> string -> unit
313.13 val refute_tptp_file : theory -> int -> string -> unit
313.14 val can_tac : Proof.context -> tactic -> term -> bool
313.15 val SOLVE_TIMEOUT : int -> string -> tactic -> tactic
313.16 - val atp_tac :
313.17 - Proof.context -> int -> (string * string) list -> int -> string -> int
313.18 - -> tactic
313.19 + val atp_tac : Proof.context -> int -> (string * string) list -> int -> string -> int -> tactic
313.20 val smt_solver_tac : string -> Proof.context -> int -> tactic
313.21 val freeze_problem_consts : theory -> term -> term
313.22 val make_conj : term list * term list -> term list -> term
313.23 val sledgehammer_tptp_file : theory -> int -> string -> unit
313.24 val isabelle_tptp_file : theory -> int -> string -> unit
313.25 val isabelle_hot_tptp_file : theory -> int -> string -> unit
313.26 - val translate_tptp_file : string -> string -> string -> unit
313.27 + val translate_tptp_file : theory -> string -> string -> unit
313.28 end;
313.29
313.30 structure ATP_Problem_Import : ATP_PROBLEM_IMPORT =
313.31 @@ -32,6 +29,8 @@
313.32 open ATP_Util
313.33 open ATP_Problem
313.34 open ATP_Proof
313.35 +open ATP_Problem_Generate
313.36 +open ATP_Systems
313.37
313.38 val debug = false
313.39 val overlord = false
313.40 @@ -39,16 +38,18 @@
313.41
313.42 (** TPTP parsing **)
313.43
313.44 +fun exploded_absolute_path file_name =
313.45 + Path.explode file_name
313.46 + |> (fn path => path |> not (Path.is_absolute path) ? Path.append (Path.explode "$PWD"))
313.47 +
313.48 fun read_tptp_file thy postproc file_name =
313.49 let
313.50 fun has_role role (_, role', _, _) = (role' = role)
313.51 - fun get_prop (_, _, P, _) =
313.52 - P |> Logic.varify_global |> close_form |> postproc
313.53 - val path =
313.54 - Path.explode file_name
313.55 - |> (fn path =>
313.56 - path |> not (Path.is_absolute path)
313.57 - ? Path.append (Path.explode "$PWD"))
313.58 + fun get_prop (name, role, P, info) =
313.59 + let val P' = P |> Logic.varify_global |> close_form in
313.60 + (name, P') |> postproc
313.61 + end
313.62 + val path = exploded_absolute_path file_name
313.63 val ((_, _, problem), thy) =
313.64 TPTP_Interpret.interpret_file true [Path.dir path, Path.explode "$TPTP"]
313.65 path [] [] thy
313.66 @@ -68,7 +69,7 @@
313.67
313.68 fun nitpick_tptp_file thy timeout file_name =
313.69 let
313.70 - val (conjs, (defs, nondefs), ctxt) = read_tptp_file thy I file_name
313.71 + val (conjs, (defs, nondefs), ctxt) = read_tptp_file thy snd file_name
313.72 val thy = Proof_Context.theory_of ctxt
313.73 val (defs, pseudo_defs) =
313.74 defs |> map (ATP_Util.abs_extensionalize_term ctxt
313.75 @@ -115,7 +116,7 @@
313.76 else
313.77 "Unknown")
313.78 |> Output.urgent_message
313.79 - val (conjs, (defs, nondefs), ctxt) = read_tptp_file thy I file_name
313.80 + val (conjs, (defs, nondefs), ctxt) = read_tptp_file thy snd file_name
313.81 val params =
313.82 [("maxtime", string_of_int timeout),
313.83 ("maxvars", "100000")]
313.84 @@ -272,7 +273,7 @@
313.85 fun sledgehammer_tptp_file thy timeout file_name =
313.86 let
313.87 val (conjs, assms, ctxt) =
313.88 - read_tptp_file thy (freeze_problem_consts thy) file_name
313.89 + read_tptp_file thy (freeze_problem_consts thy o snd) file_name
313.90 val conj = make_conj assms conjs
313.91 in
313.92 can_tac ctxt (sledgehammer_tac true ctxt timeout 1) conj
313.93 @@ -282,7 +283,7 @@
313.94 fun generic_isabelle_tptp_file demo thy timeout file_name =
313.95 let
313.96 val (conjs, assms, ctxt) =
313.97 - read_tptp_file thy (freeze_problem_consts thy) file_name
313.98 + read_tptp_file thy (freeze_problem_consts thy o snd) file_name
313.99 val conj = make_conj assms conjs
313.100 val (last_hope_atp, last_hope_completeness) =
313.101 if demo then (ATP_Systems.satallaxN, 0) else (ATP_Systems.vampireN, 2)
313.102 @@ -300,6 +301,33 @@
313.103
313.104 (** Translator between TPTP(-like) file formats **)
313.105
313.106 -fun translate_tptp_file format in_file_name out_file_name = ()
313.107 +fun translate_tptp_file thy format_str file_name =
313.108 + let
313.109 + val (conjs, (defs, nondefs), ctxt) = read_tptp_file thy I file_name
313.110 + val conj = make_conj ([], []) (map snd conjs)
313.111 +
313.112 + val (format, type_enc, lam_trans) =
313.113 + (case format_str of
313.114 + "FOF" => (FOF, "mono_guards??", liftingN)
313.115 + | "TF0" => (TFF Monomorphic, "mono_native", liftingN)
313.116 + | "TH0" => (THF (Monomorphic, THF_Without_Choice), "mono_native_higher", keep_lamsN)
313.117 + | "DFG" => (DFG Monomorphic, "mono_native", liftingN)
313.118 + | _ => error ("Unknown format " ^ quote format_str ^
313.119 + " (expected \"FOF\", \"TF0\", \"TH0\", or \"DFG\")"))
313.120 + val uncurried_aliases = false
313.121 + val readable_names = true
313.122 + val presimp = true
313.123 + val facts = map (apfst (rpair (Global, Non_Rec_Def))) defs @
313.124 + map (apfst (rpair (Global, General))) nondefs
313.125 + val (atp_problem, _, _, _, _) =
313.126 + prepare_atp_problem ctxt format Hypothesis (type_enc_of_string Strict type_enc) Translator
313.127 + lam_trans uncurried_aliases readable_names presimp [] conj facts
313.128 +
313.129 + val ord = effective_term_order ctxt spassN
313.130 + val ord_info = K []
313.131 + val lines = lines_of_atp_problem format ord ord_info atp_problem
313.132 + in
313.133 + List.app Output.physical_stdout lines
313.134 + end
313.135
313.136 end;
314.1 --- a/src/HOL/TPTP/atp_theory_export.ML Thu Dec 05 17:52:12 2013 +0100
314.2 +++ b/src/HOL/TPTP/atp_theory_export.ML Thu Dec 05 17:58:03 2013 +0100
314.3 @@ -34,8 +34,8 @@
314.4 val prefix = Library.prefix
314.5 val fact_name_of = prefix fact_prefix o ascii_of
314.6
314.7 -fun atp_of_format (THF (Polymorphic, _, _)) = dummy_thfN
314.8 - | atp_of_format (THF (Monomorphic, _, _)) = satallaxN
314.9 +fun atp_of_format (THF (Polymorphic, _)) = dummy_thfN
314.10 + | atp_of_format (THF (Monomorphic, _)) = satallaxN
314.11 | atp_of_format (DFG Polymorphic) = spass_polyN
314.12 | atp_of_format (DFG Monomorphic) = spassN
314.13 | atp_of_format (TFF Polymorphic) = alt_ergoN
315.1 --- a/src/HOL/TPTP/lib/Tools/tptp_isabelle Thu Dec 05 17:52:12 2013 +0100
315.2 +++ b/src/HOL/TPTP/lib/Tools/tptp_isabelle Thu Dec 05 17:58:03 2013 +0100
315.3 @@ -29,5 +29,5 @@
315.4 echo "theory $SCRATCH imports \"$TPTP_HOME/ATP_Problem_Import\" begin \
315.5 ML {* ATP_Problem_Import.isabelle_tptp_file @{theory} ($TIMEOUT) \"$FILE\" *} end;" \
315.6 > /tmp/$SCRATCH.thy
315.7 - "$ISABELLE_PROCESS" -q -e "use_thy \"/tmp/$SCRATCH\"; exit 1;" HOL-TPTP | grep --line-buffered -v "^###\|^PROOF FAILED for depth\|^Failure node\|inferences so far. Searching to depth\|^val it = (): unit"
315.8 + "$ISABELLE_PROCESS" -q -e "use_thy \"/tmp/$SCRATCH\"; exit 1;" HOL-TPTP | grep --line-buffered -v "^###\|^PROOF FAILED for depth\|^Failure node\|inferences so far. Searching to depth\|^val \|^Loading theory"
315.9 done
316.1 --- a/src/HOL/TPTP/lib/Tools/tptp_isabelle_hot Thu Dec 05 17:52:12 2013 +0100
316.2 +++ b/src/HOL/TPTP/lib/Tools/tptp_isabelle_hot Thu Dec 05 17:58:03 2013 +0100
316.3 @@ -29,5 +29,5 @@
316.4 echo "theory $SCRATCH imports \"$TPTP_HOME/ATP_Problem_Import\" begin \
316.5 ML {* ATP_Problem_Import.isabelle_hot_tptp_file @{theory} ($TIMEOUT) \"$FILE\" *} end;" \
316.6 > /tmp/$SCRATCH.thy
316.7 - "$ISABELLE_PROCESS" -q -e "use_thy \"/tmp/$SCRATCH\"; exit 1;" HOL-TPTP | grep --line-buffered -v "^###\|^PROOF FAILED for depth\|^Failure node\|inferences so far. Searching to depth\|^val it = (): unit"
316.8 + "$ISABELLE_PROCESS" -q -e "use_thy \"/tmp/$SCRATCH\"; exit 1;" HOL-TPTP | grep --line-buffered -v "^###\|^PROOF FAILED for depth\|^Failure node\|inferences so far. Searching to depth\|^val \|^Loading theory"
316.9 done
317.1 --- a/src/HOL/TPTP/lib/Tools/tptp_nitpick Thu Dec 05 17:52:12 2013 +0100
317.2 +++ b/src/HOL/TPTP/lib/Tools/tptp_nitpick Thu Dec 05 17:58:03 2013 +0100
317.3 @@ -29,5 +29,5 @@
317.4 echo "theory $SCRATCH imports \"$TPTP_HOME/ATP_Problem_Import\" begin \
317.5 ML {* ATP_Problem_Import.nitpick_tptp_file @{theory} ($TIMEOUT) \"$FILE\" *} end;" \
317.6 > /tmp/$SCRATCH.thy
317.7 - "$ISABELLE_PROCESS" -q -e "use_thy \"/tmp/$SCRATCH\"; exit 1;" HOL-TPTP | grep --line-buffered -v "^###\|^PROOF FAILED for depth\|^Failure node\|inferences so far. Searching to depth\|^val it = (): unit"
317.8 + "$ISABELLE_PROCESS" -q -e "use_thy \"/tmp/$SCRATCH\"; exit 1;" HOL-TPTP | grep --line-buffered -v "^###\|^PROOF FAILED for depth\|^Failure node\|inferences so far. Searching to depth\|^val \|^Loading theory"
317.9 done
318.1 --- a/src/HOL/TPTP/lib/Tools/tptp_refute Thu Dec 05 17:52:12 2013 +0100
318.2 +++ b/src/HOL/TPTP/lib/Tools/tptp_refute Thu Dec 05 17:58:03 2013 +0100
318.3 @@ -28,5 +28,5 @@
318.4 echo "theory $SCRATCH imports \"$TPTP_HOME/ATP_Problem_Import\" begin \
318.5 ML {* ATP_Problem_Import.refute_tptp_file @{theory} ($TIMEOUT) \"$FILE\" *} end;" \
318.6 > /tmp/$SCRATCH.thy
318.7 - "$ISABELLE_PROCESS" -q -e "use_thy \"/tmp/$SCRATCH\"; exit 1;" HOL-TPTP | grep --line-buffered -v "^###\|^PROOF FAILED for depth\|^Failure node\|inferences so far. Searching to depth\|^val it = (): unit"
318.8 + "$ISABELLE_PROCESS" -q -e "use_thy \"/tmp/$SCRATCH\"; exit 1;" HOL-TPTP | grep --line-buffered -v "^###\|^PROOF FAILED for depth\|^Failure node\|inferences so far. Searching to depth\|^val \|^Loading theory"
318.9 done
319.1 --- a/src/HOL/TPTP/lib/Tools/tptp_sledgehammer Thu Dec 05 17:52:12 2013 +0100
319.2 +++ b/src/HOL/TPTP/lib/Tools/tptp_sledgehammer Thu Dec 05 17:58:03 2013 +0100
319.3 @@ -29,5 +29,5 @@
319.4 echo "theory $SCRATCH imports \"$TPTP_HOME/ATP_Problem_Import\" begin \
319.5 ML {* ATP_Problem_Import.sledgehammer_tptp_file @{theory} ($TIMEOUT) \"$FILE\" *} end;" \
319.6 > /tmp/$SCRATCH.thy
319.7 - "$ISABELLE_PROCESS" -q -e "use_thy \"/tmp/$SCRATCH\"; exit 1;" HOL-TPTP | grep --line-buffered -v "^###\|^PROOF FAILED for depth\|^Failure node\|inferences so far. Searching to depth\|^val it = (): unit"
319.8 + "$ISABELLE_PROCESS" -q -e "use_thy \"/tmp/$SCRATCH\"; exit 1;" HOL-TPTP | grep --line-buffered -v "^###\|^PROOF FAILED for depth\|^Failure node\|inferences so far. Searching to depth\|^val \|^Loading theory"
319.9 done
320.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
320.2 +++ b/src/HOL/TPTP/lib/Tools/tptp_translate Thu Dec 05 17:58:03 2013 +0100
320.3 @@ -0,0 +1,29 @@
320.4 +#!/usr/bin/env bash
320.5 +#
320.6 +# Author: Jasmin Blanchette
320.7 +#
320.8 +# DESCRIPTION: translate between TPTP formats
320.9 +
320.10 +
320.11 +PRG="$(basename "$0")"
320.12 +
320.13 +function usage() {
320.14 + echo
320.15 + echo "Usage: isabelle $PRG FORMAT FILE"
320.16 + echo
320.17 + echo " Translates TPTP input file to the specified format (\"FOF\", \"TF0\", \"TH0\", or \"DFG\")."
320.18 + echo " Emits the result to standard output."
320.19 + echo
320.20 + exit 1
320.21 +}
320.22 +
320.23 +[ "$#" -ne 2 -o "$1" = "-?" ] && usage
320.24 +
320.25 +SCRATCH="Scratch_${PRG}_$$_${RANDOM}"
320.26 +
320.27 +args=("$@")
320.28 +
320.29 +echo "theory $SCRATCH imports \"$TPTP_HOME/ATP_Problem_Import\" begin \
320.30 +ML {* ATP_Problem_Import.translate_tptp_file @{theory} \"${args[0]}\" \"${args[1]}\" *} end;" \
320.31 + > /tmp/$SCRATCH.thy
320.32 +"$ISABELLE_PROCESS" -q -e "use_thy \"/tmp/$SCRATCH\"; exit 1;" HOL-TPTP | grep --line-buffered -v "^###\|^PROOF FAILED for depth\|^Failure node\|inferences so far. Searching to depth\|^val \|^Loading theory"
321.1 --- a/src/HOL/TPTP/mash_eval.ML Thu Dec 05 17:52:12 2013 +0100
321.2 +++ b/src/HOL/TPTP/mash_eval.ML Thu Dec 05 17:58:03 2013 +0100
321.3 @@ -147,7 +147,7 @@
321.4 |> map fact_of_raw_fact
321.5 val ctxt = ctxt |> set_file_name method prob_dir_name
321.6 val res as {outcome, ...} =
321.7 - run_prover_for_mash ctxt params prover facts goal
321.8 + run_prover_for_mash ctxt params prover name facts goal
321.9 val ok = if is_none outcome then 1 else 0
321.10 in (str_of_result method facts res, ok) end
321.11 val ress =
322.1 --- a/src/HOL/TPTP/mash_export.ML Thu Dec 05 17:52:12 2013 +0100
322.2 +++ b/src/HOL/TPTP/mash_export.ML Thu Dec 05 17:58:03 2013 +0100
322.3 @@ -14,7 +14,7 @@
322.4 val generate_features :
322.5 Proof.context -> string -> theory list -> string -> unit
322.6 val generate_isar_dependencies :
322.7 - Proof.context -> theory list -> bool -> string -> unit
322.8 + Proof.context -> int * int option -> theory list -> bool -> string -> unit
322.9 val generate_prover_dependencies :
322.10 Proof.context -> params -> int * int option -> theory list -> bool -> string
322.11 -> unit
322.12 @@ -79,9 +79,7 @@
322.13 let
322.14 val name = nickname_of_thm th
322.15 val feats =
322.16 - features_of ctxt prover (theory_of_thm th) 0 Symtab.empty stature
322.17 - [prop_of th]
322.18 - |> map fst
322.19 + features_of ctxt (theory_of_thm th) 0 Symtab.empty stature [prop_of th] |> map fst
322.20 val s =
322.21 encode_str name ^ ": " ^ encode_strs (sort string_ord feats) ^ "\n"
322.22 in File.append path s end
322.23 @@ -136,7 +134,7 @@
322.24 in File.write_list path lines end
322.25
322.26 fun generate_isar_dependencies ctxt =
322.27 - generate_isar_or_prover_dependencies ctxt NONE (1, NONE)
322.28 + generate_isar_or_prover_dependencies ctxt NONE
322.29
322.30 fun generate_prover_dependencies ctxt params =
322.31 generate_isar_or_prover_dependencies ctxt (SOME params)
322.32 @@ -164,8 +162,7 @@
322.33 val isar_deps = isar_dependencies_of name_tabs th
322.34 val do_query = not (is_bad_query ctxt ho_atp step j th isar_deps)
322.35 val goal_feats =
322.36 - features_of ctxt prover (theory_of_thm th) (num_old_facts + j)
322.37 - const_tab stature [prop_of th]
322.38 + features_of ctxt (theory_of_thm th) (num_old_facts + j) const_tab stature [prop_of th]
322.39 |> sort_wrt fst
322.40 val access_facts =
322.41 (if linearize then take (j - 1) new_facts
322.42 @@ -176,8 +173,7 @@
322.43 val parents = if linearize then prevs else parents
322.44 fun extra_features_of (((_, stature), th), weight) =
322.45 [prop_of th]
322.46 - |> features_of ctxt prover (theory_of_thm th) (num_old_facts + j)
322.47 - const_tab stature
322.48 + |> features_of ctxt (theory_of_thm th) (num_old_facts + j) const_tab stature
322.49 |> map (apsnd (fn r => weight * extra_feature_factor * r))
322.50 val query =
322.51 if do_query then
322.52 @@ -249,8 +245,8 @@
322.53 val suggs =
322.54 old_facts
322.55 |> linearize ? filter_accessible_from th
322.56 - |> Sledgehammer_MePo.mepo_suggested_facts ctxt params prover
322.57 - max_suggs NONE hyp_ts concl_t
322.58 + |> Sledgehammer_Fact.drop_duplicate_facts
322.59 + |> Sledgehammer_MePo.mepo_suggested_facts ctxt params max_suggs NONE hyp_ts concl_t
322.60 |> map (nickname_of_thm o snd)
322.61 in encode_str name ^ ": " ^ encode_strs suggs ^ "\n" end
322.62 end
323.1 --- a/src/HOL/TPTP/sledgehammer_tactics.ML Thu Dec 05 17:52:12 2013 +0100
323.2 +++ b/src/HOL/TPTP/sledgehammer_tactics.ML Thu Dec 05 17:58:03 2013 +0100
323.3 @@ -27,24 +27,22 @@
323.4 fun run_prover override_params fact_override i n ctxt goal =
323.5 let
323.6 val mode = Normal
323.7 - val params as {provers, max_facts, slice, ...} =
323.8 - default_params ctxt override_params
323.9 + val params as {provers, max_facts, ...} = default_params ctxt override_params
323.10 val name = hd provers
323.11 val prover = get_prover ctxt mode name
323.12 - val default_max_facts = default_max_facts_of_prover ctxt slice name
323.13 + val default_max_facts = default_max_facts_of_prover ctxt name
323.14 val (_, hyp_ts, concl_t) = ATP_Util.strip_subgoal goal i ctxt
323.15 val ho_atp = exists (is_ho_atp ctxt) provers
323.16 val reserved = reserved_isar_keyword_table ()
323.17 val css_table = clasimpset_rule_table_of ctxt
323.18 val facts =
323.19 - nearly_all_facts ctxt ho_atp fact_override reserved css_table [] hyp_ts
323.20 - concl_t
323.21 + nearly_all_facts ctxt ho_atp fact_override reserved css_table [] hyp_ts concl_t
323.22 |> relevant_facts ctxt params name
323.23 (the_default default_max_facts max_facts) fact_override hyp_ts
323.24 concl_t
323.25 |> hd |> snd
323.26 val problem =
323.27 - {state = Proof.init ctxt, goal = goal, subgoal = i, subgoal_count = n,
323.28 + {comment = "", state = Proof.init ctxt, goal = goal, subgoal = i, subgoal_count = n,
323.29 factss = [("", facts)]}
323.30 in
323.31 (case prover params (K (K (K ""))) problem of
324.1 --- a/src/HOL/Tools/ATP/atp_problem.ML Thu Dec 05 17:52:12 2013 +0100
324.2 +++ b/src/HOL/Tools/ATP/atp_problem.ML Thu Dec 05 17:58:03 2013 +0100
324.3 @@ -33,14 +33,13 @@
324.4
324.5 datatype polymorphism = Monomorphic | Polymorphic
324.6 datatype thf_choice = THF_Without_Choice | THF_With_Choice
324.7 - datatype thf_defs = THF_Without_Defs | THF_With_Defs
324.8
324.9 datatype atp_format =
324.10 CNF |
324.11 CNF_UEQ |
324.12 FOF |
324.13 TFF of polymorphism |
324.14 - THF of polymorphism * thf_choice * thf_defs |
324.15 + THF of polymorphism * thf_choice |
324.16 DFG of polymorphism
324.17
324.18 datatype atp_formula_role =
324.19 @@ -179,14 +178,13 @@
324.20
324.21 datatype polymorphism = Monomorphic | Polymorphic
324.22 datatype thf_choice = THF_Without_Choice | THF_With_Choice
324.23 -datatype thf_defs = THF_Without_Defs | THF_With_Defs
324.24
324.25 datatype atp_format =
324.26 CNF |
324.27 CNF_UEQ |
324.28 FOF |
324.29 TFF of polymorphism |
324.30 - THF of polymorphism * thf_choice * thf_defs |
324.31 + THF of polymorphism * thf_choice |
324.32 DFG of polymorphism
324.33
324.34 datatype atp_formula_role =
325.1 --- a/src/HOL/Tools/ATP/atp_problem_generate.ML Thu Dec 05 17:52:12 2013 +0100
325.2 +++ b/src/HOL/Tools/ATP/atp_problem_generate.ML Thu Dec 05 17:58:03 2013 +0100
325.3 @@ -15,7 +15,7 @@
325.4 type atp_formula_role = ATP_Problem.atp_formula_role
325.5 type 'a atp_problem = 'a ATP_Problem.atp_problem
325.6
325.7 - datatype mode = Metis | Sledgehammer | Sledgehammer_Completish | Exporter
325.8 + datatype mode = Metis | Sledgehammer | Sledgehammer_Completish | Exporter | Translator
325.9
325.10 datatype scope = Global | Local | Assum | Chained
325.11 datatype status =
325.12 @@ -91,6 +91,8 @@
325.13 val atp_logical_consts : string list
325.14 val atp_irrelevant_consts : string list
325.15 val atp_widely_irrelevant_consts : string list
325.16 + val is_irrelevant_const : string -> bool
325.17 + val is_widely_irrelevant_const : string -> bool
325.18 val atp_schematic_consts_of : term -> typ list Symtab.table
325.19 val is_type_enc_higher_order : type_enc -> bool
325.20 val is_type_enc_polymorphic : type_enc -> bool
325.21 @@ -125,7 +127,7 @@
325.22 open ATP_Util
325.23 open ATP_Problem
325.24
325.25 -datatype mode = Metis | Sledgehammer | Sledgehammer_Completish | Exporter
325.26 +datatype mode = Metis | Sledgehammer | Sledgehammer_Completish | Exporter | Translator
325.27
325.28 datatype scope = Global | Local | Assum | Chained
325.29 datatype status =
325.30 @@ -333,9 +335,7 @@
325.31 (* Readable names for the more common symbolic functions. Do not mess with the
325.32 table unless you know what you are doing. *)
325.33 val const_trans_table =
325.34 - [(@{type_name Product_Type.prod}, "prod"),
325.35 - (@{type_name Sum_Type.sum}, "sum"),
325.36 - (@{const_name False}, "False"),
325.37 + [(@{const_name False}, "False"),
325.38 (@{const_name True}, "True"),
325.39 (@{const_name Not}, "Not"),
325.40 (@{const_name conj}, "conj"),
325.41 @@ -405,19 +405,25 @@
325.42 (* These are ignored anyway by the relevance filter (unless they appear in
325.43 higher-order places) but not by the monomorphizer. *)
325.44 val atp_logical_consts =
325.45 - [@{const_name all}, @{const_name "==>"}, @{const_name "=="},
325.46 - @{const_name Trueprop}, @{const_name All}, @{const_name Ex},
325.47 + [@{const_name prop}, @{const_name Pure.conjunction}, @{const_name all}, @{const_name "==>"},
325.48 + @{const_name "=="}, @{const_name Trueprop}, @{const_name All}, @{const_name Ex},
325.49 @{const_name Ex1}, @{const_name Ball}, @{const_name Bex}]
325.50
325.51 (* These are either simplified away by "Meson.presimplify" (most of the time) or
325.52 handled specially via "fFalse", "fTrue", ..., "fequal". *)
325.53 val atp_irrelevant_consts =
325.54 - [@{const_name False}, @{const_name True}, @{const_name Not},
325.55 - @{const_name conj}, @{const_name disj}, @{const_name implies},
325.56 - @{const_name HOL.eq}, @{const_name If}, @{const_name Let}]
325.57 + [@{const_name False}, @{const_name True}, @{const_name Not}, @{const_name conj},
325.58 + @{const_name disj}, @{const_name implies}, @{const_name HOL.eq}, @{const_name If},
325.59 + @{const_name Let}]
325.60
325.61 val atp_widely_irrelevant_consts = atp_logical_consts @ atp_irrelevant_consts
325.62
325.63 +val atp_irrelevant_const_tab = Symtab.make (map (rpair ()) atp_irrelevant_consts)
325.64 +val atp_widely_irrelevant_const_tab = Symtab.make (map (rpair ()) atp_widely_irrelevant_consts)
325.65 +
325.66 +val is_irrelevant_const = Symtab.defined atp_irrelevant_const_tab
325.67 +val is_widely_irrelevant_const = Symtab.defined atp_widely_irrelevant_const_tab
325.68 +
325.69 fun add_schematic_const (x as (_, T)) =
325.70 Monomorph.typ_has_tvars T ? Symtab.insert_list (op =) x
325.71 val add_schematic_consts_of =
325.72 @@ -689,11 +695,9 @@
325.73 Raw_Polymorphic With_Phantom_Type_Vars
325.74 | no_type_classes poly = poly
325.75
325.76 -fun adjust_type_enc (THF (Polymorphic, choice, _))
325.77 - (Native (order, poly, level)) =
325.78 +fun adjust_type_enc (THF (Polymorphic, choice)) (Native (order, poly, level)) =
325.79 Native (adjust_order choice order, no_type_classes poly, level)
325.80 - | adjust_type_enc (THF (Monomorphic, choice, _))
325.81 - (Native (order, _, level)) =
325.82 + | adjust_type_enc (THF (Monomorphic, choice)) (Native (order, _, level)) =
325.83 Native (adjust_order choice order, Mangled_Monomorphic, level)
325.84 | adjust_type_enc (TFF Monomorphic) (Native (_, _, level)) =
325.85 Native (First_Order, Mangled_Monomorphic, level)
325.86 @@ -1309,7 +1313,7 @@
325.87 atomic_types = atomic_Ts}
325.88 end
325.89
325.90 -fun is_format_with_defs (THF (_, _, THF_With_Defs)) = true
325.91 +fun is_format_with_defs (THF _) = true
325.92 | is_format_with_defs _ = false
325.93
325.94 fun make_fact ctxt format type_enc iff_for_eq
325.95 @@ -1557,8 +1561,7 @@
325.96 end
325.97 | NONE =>
325.98 let
325.99 - val pred_sym = top_level andalso not bool_vars
325.100 - val ary =
325.101 + val max_ary =
325.102 case unprefix_and_unascii const_prefix s of
325.103 SOME s =>
325.104 (if String.isSubstring uncurried_alias_sep s then
325.105 @@ -1568,15 +1571,16 @@
325.106 SOME ary0 => Int.min (ary0, ary)
325.107 | NONE => ary)
325.108 | NONE => ary
325.109 + val pred_sym = top_level andalso max_ary = ary andalso not bool_vars
325.110 val min_ary =
325.111 case app_op_level of
325.112 - Min_App_Op => ary
325.113 + Min_App_Op => max_ary
325.114 | Full_App_Op_And_Predicator => 0
325.115 - | _ => fold (consider_var_ary T) fun_var_Ts ary
325.116 + | _ => fold (consider_var_ary T) fun_var_Ts max_ary
325.117 in
325.118 Symtab.update_new (s,
325.119 {pred_sym = pred_sym, min_ary = min_ary,
325.120 - max_ary = ary, types = [T], in_conj = conj_fact})
325.121 + max_ary = max_ary, types = [T], in_conj = conj_fact})
325.122 sym_tab
325.123 end)
325.124 end
325.125 @@ -2732,61 +2736,37 @@
325.126 syms []
325.127 in (heading, decls) :: problem end
325.128
325.129 -val typ_of_dtyp = Logic.varifyT_global oo Datatype_Aux.typ_of_dtyp
325.130 -
325.131 -fun ctrs_of_datatype descr (_, (s, Ds, ctrs)) =
325.132 - if forall (can Datatype_Aux.dest_DtTFree) Ds then
325.133 - let val dataT = Type (s, map (typ_of_dtyp descr) Ds) in
325.134 - SOME (map (fn (s, Ds) => (s, map (typ_of_dtyp descr) Ds ---> dataT)) ctrs)
325.135 - end
325.136 - else
325.137 - NONE
325.138 -
325.139 -fun ctrss_of_descr descr =
325.140 - map_filter (ctrs_of_datatype descr) descr
325.141 -
325.142 -fun all_ctrss_of_datatypes thy =
325.143 - Symtab.fold (snd #> #descr #> ctrss_of_descr #> append) (Datatype.get_all thy)
325.144 - []
325.145 +fun all_ctrss_of_datatypes ctxt =
325.146 + map (map_filter (try dest_Const) o #ctrs) (Ctr_Sugar.ctr_sugars_of ctxt)
325.147
325.148 val app_op_and_predicator_threshold = 45
325.149
325.150 fun prepare_atp_problem ctxt format prem_role type_enc mode lam_trans
325.151 - uncurried_aliases readable_names preproc hyp_ts concl_t
325.152 + uncurried_aliases readable_names presimp hyp_ts concl_t
325.153 facts =
325.154 let
325.155 val thy = Proof_Context.theory_of ctxt
325.156 val type_enc = type_enc |> adjust_type_enc format
325.157 + val completish = (mode = Sledgehammer_Completish)
325.158 (* Forcing explicit applications is expensive for polymorphic encodings,
325.159 because it takes only one existential variable ranging over "'a => 'b" to
325.160 ruin everything. Hence we do it only if there are few facts (which is
325.161 normally the case for "metis" and the minimizer). *)
325.162 val app_op_level =
325.163 - if mode = Sledgehammer_Completish then
325.164 + if completish then
325.165 Full_App_Op_And_Predicator
325.166 - else if length facts + length hyp_ts
325.167 - > app_op_and_predicator_threshold then
325.168 - if is_type_enc_polymorphic type_enc then Min_App_Op
325.169 - else Sufficient_App_Op
325.170 + else if length facts + length hyp_ts >= app_op_and_predicator_threshold then
325.171 + if is_type_enc_polymorphic type_enc then Min_App_Op else Sufficient_App_Op
325.172 else
325.173 Sufficient_App_Op_And_Predicator
325.174 - val exporter = (mode = Exporter)
325.175 - val completish = (mode = Sledgehammer_Completish)
325.176 val lam_trans =
325.177 - if lam_trans = keep_lamsN andalso
325.178 - not (is_type_enc_higher_order type_enc) then
325.179 - liftingN
325.180 - else
325.181 - lam_trans
325.182 - val (fact_names, classes, conjs, facts, subclass_pairs, tcon_clauses,
325.183 - lifted) =
325.184 - translate_formulas ctxt prem_role format type_enc lam_trans preproc hyp_ts
325.185 - concl_t facts
325.186 - val (_, sym_tab0) =
325.187 - sym_table_of_facts ctxt type_enc app_op_level conjs facts
325.188 - val mono =
325.189 - conjs @ facts |> mononotonicity_info_of_facts ctxt type_enc completish
325.190 - val ctrss = all_ctrss_of_datatypes thy
325.191 + if lam_trans = keep_lamsN andalso not (is_type_enc_higher_order type_enc) then liftingN
325.192 + else lam_trans
325.193 + val (fact_names, classes, conjs, facts, subclass_pairs, tcon_clauses, lifted) =
325.194 + translate_formulas ctxt prem_role format type_enc lam_trans presimp hyp_ts concl_t facts
325.195 + val (_, sym_tab0) = sym_table_of_facts ctxt type_enc app_op_level conjs facts
325.196 + val mono = conjs @ facts |> mononotonicity_info_of_facts ctxt type_enc completish
325.197 + val ctrss = all_ctrss_of_datatypes ctxt
325.198 fun firstorderize in_helper =
325.199 firstorderize_fact thy ctrss type_enc
325.200 (uncurried_aliases andalso not in_helper) completish sym_tab0
325.201 @@ -2816,10 +2796,12 @@
325.202 val datatype_decl_lines = map decl_line_of_datatype datatypes
325.203 val decl_lines = class_decl_lines @ sym_decl_lines @ datatype_decl_lines
325.204 val num_facts = length facts
325.205 + val freshen = mode <> Exporter andalso mode <> Translator
325.206 + val pos = mode <> Exporter
325.207 + val rank_of = rank_of_fact_num num_facts
325.208 val fact_lines =
325.209 - map (line_of_fact ctxt fact_prefix ascii_of I (not exporter)
325.210 - (not exporter) mono type_enc (rank_of_fact_num num_facts))
325.211 - (0 upto num_facts - 1 ~~ facts)
325.212 + map (line_of_fact ctxt fact_prefix ascii_of I freshen pos mono type_enc rank_of)
325.213 + (0 upto num_facts - 1 ~~ facts)
325.214 val subclass_lines = maps (lines_of_subclass_pair type_enc) subclass_pairs
325.215 val tcon_lines = map (line_of_tcon_clause type_enc) tcon_clauses
325.216 val helper_lines =
326.1 --- a/src/HOL/Tools/ATP/atp_proof_reconstruct.ML Thu Dec 05 17:52:12 2013 +0100
326.2 +++ b/src/HOL/Tools/ATP/atp_proof_reconstruct.ML Thu Dec 05 17:58:03 2013 +0100
326.3 @@ -10,6 +10,9 @@
326.4 sig
326.5 type ('a, 'b) atp_term = ('a, 'b) ATP_Problem.atp_term
326.6 type ('a, 'b, 'c, 'd) atp_formula = ('a, 'b, 'c, 'd) ATP_Problem.atp_formula
326.7 + type stature = ATP_Problem_Generate.stature
326.8 + type ('a, 'b) atp_step = ('a, 'b) ATP_Proof.atp_step
326.9 + type 'a atp_proof = 'a ATP_Proof.atp_proof
326.10
326.11 val metisN : string
326.12 val full_typesN : string
326.13 @@ -21,17 +24,26 @@
326.14 val no_type_enc : string
326.15 val full_type_encs : string list
326.16 val partial_type_encs : string list
326.17 - val metis_default_lam_trans : string
326.18 + val default_metis_lam_trans : string
326.19 val metis_call : string -> string -> string
326.20 val forall_of : term -> term -> term
326.21 val exists_of : term -> term -> term
326.22 val unalias_type_enc : string -> string list
326.23 - val term_of_atp :
326.24 - Proof.context -> bool -> int Symtab.table -> typ option ->
326.25 + val term_of_atp : Proof.context -> bool -> int Symtab.table -> typ option ->
326.26 (string, string) atp_term -> term
326.27 - val prop_of_atp :
326.28 - Proof.context -> bool -> int Symtab.table ->
326.29 + val prop_of_atp : Proof.context -> bool -> int Symtab.table ->
326.30 (string, string, (string, string) atp_term, string) atp_formula -> term
326.31 +
326.32 + val used_facts_in_atp_proof :
326.33 + Proof.context -> (string * stature) list vector -> string atp_proof -> (string * stature) list
326.34 + val used_facts_in_unsound_atp_proof : Proof.context -> (string * stature) list vector ->
326.35 + 'a atp_proof -> string list option
326.36 + val lam_trans_of_atp_proof : string atp_proof -> string -> string
326.37 + val is_typed_helper_used_in_atp_proof : string atp_proof -> bool
326.38 + val termify_atp_proof : Proof.context -> string Symtab.table -> (string * term) list ->
326.39 + int Symtab.table -> string atp_proof -> (term, string) atp_step list
326.40 + val factify_atp_proof : (string * 'a) list vector -> term list -> term ->
326.41 + (term, string) atp_step list -> (term, string) atp_step list
326.42 end;
326.43
326.44 structure ATP_Proof_Reconstruct : ATP_PROOF_RECONSTRUCT =
326.45 @@ -64,7 +76,7 @@
326.46 fun unalias_type_enc s =
326.47 AList.lookup (op =) type_enc_aliases s |> the_default [s]
326.48
326.49 -val metis_default_lam_trans = combsN
326.50 +val default_metis_lam_trans = combsN
326.51
326.52 fun metis_call type_enc lam_trans =
326.53 let
326.54 @@ -74,7 +86,7 @@
326.55 [alias] => alias
326.56 | _ => type_enc
326.57 val opts = [] |> type_enc <> partial_typesN ? cons type_enc
326.58 - |> lam_trans <> metis_default_lam_trans ? cons lam_trans
326.59 + |> lam_trans <> default_metis_lam_trans ? cons lam_trans
326.60 in metisN ^ (if null opts then "" else " (" ^ commas opts ^ ")") end
326.61
326.62 fun term_name' (Var ((s, _), _)) = perhaps (try Name.dest_skolem) s
326.63 @@ -339,4 +351,205 @@
326.64 | _ => raise ATP_FORMULA [phi]
326.65 in repair_tvar_sorts (do_formula true phi Vartab.empty) end
326.66
326.67 +fun find_first_in_list_vector vec key =
326.68 + Vector.foldl (fn (ps, NONE) => AList.lookup (op =) ps key
326.69 + | (_, value) => value) NONE vec
326.70 +
326.71 +val unprefix_fact_number = space_implode "_" o tl o space_explode "_"
326.72 +
326.73 +fun resolve_one_named_fact fact_names s =
326.74 + case try (unprefix fact_prefix) s of
326.75 + SOME s' =>
326.76 + let val s' = s' |> unprefix_fact_number |> unascii_of in
326.77 + s' |> find_first_in_list_vector fact_names |> Option.map (pair s')
326.78 + end
326.79 + | NONE => NONE
326.80 +
326.81 +fun resolve_fact fact_names = map_filter (resolve_one_named_fact fact_names)
326.82 +
326.83 +fun resolve_one_named_conjecture s =
326.84 + case try (unprefix conjecture_prefix) s of
326.85 + SOME s' => Int.fromString s'
326.86 + | NONE => NONE
326.87 +
326.88 +val resolve_conjecture = map_filter resolve_one_named_conjecture
326.89 +
326.90 +fun is_axiom_used_in_proof pred =
326.91 + exists (fn ((_, ss), _, _, _, []) => exists pred ss | _ => false)
326.92 +
326.93 +fun add_non_rec_defs fact_names accum =
326.94 + Vector.foldl (fn (facts, facts') =>
326.95 + union (op =) (filter (fn (_, (_, status)) => status = Non_Rec_Def) facts)
326.96 + facts')
326.97 + accum fact_names
326.98 +
326.99 +val isa_ext = Thm.get_name_hint @{thm ext}
326.100 +val isa_short_ext = Long_Name.base_name isa_ext
326.101 +
326.102 +fun ext_name ctxt =
326.103 + if Thm.eq_thm_prop (@{thm ext},
326.104 + singleton (Attrib.eval_thms ctxt) (Facts.named isa_short_ext, [])) then
326.105 + isa_short_ext
326.106 + else
326.107 + isa_ext
326.108 +
326.109 +val leo2_extcnf_equal_neg_rule = "extcnf_equal_neg"
326.110 +val leo2_unfold_def_rule = "unfold_def"
326.111 +
326.112 +fun add_fact ctxt fact_names ((_, ss), _, _, rule, deps) =
326.113 + (if rule = leo2_extcnf_equal_neg_rule then
326.114 + insert (op =) (ext_name ctxt, (Global, General))
326.115 + else if rule = leo2_unfold_def_rule then
326.116 + (* LEO 1.3.3 does not record definitions properly, leading to missing
326.117 + dependencies in the TSTP proof. Remove the next line once this is
326.118 + fixed. *)
326.119 + add_non_rec_defs fact_names
326.120 + else if rule = agsyhol_coreN orelse rule = satallax_coreN then
326.121 + (fn [] =>
326.122 + (* agsyHOL and Satallax don't include definitions in their
326.123 + unsatisfiable cores, so we assume the worst and include them all
326.124 + here. *)
326.125 + [(ext_name ctxt, (Global, General))] |> add_non_rec_defs fact_names
326.126 + | facts => facts)
326.127 + else
326.128 + I)
326.129 + #> (if null deps then union (op =) (resolve_fact fact_names ss) else I)
326.130 +
326.131 +fun used_facts_in_atp_proof ctxt fact_names atp_proof =
326.132 + if null atp_proof then Vector.foldl (uncurry (union (op =))) [] fact_names
326.133 + else fold (add_fact ctxt fact_names) atp_proof []
326.134 +
326.135 +fun used_facts_in_unsound_atp_proof _ _ [] = NONE
326.136 + | used_facts_in_unsound_atp_proof ctxt fact_names atp_proof =
326.137 + let val used_facts = used_facts_in_atp_proof ctxt fact_names atp_proof in
326.138 + if forall (fn (_, (sc, _)) => sc = Global) used_facts andalso
326.139 + not (is_axiom_used_in_proof (not o null o resolve_conjecture o single) atp_proof) then
326.140 + SOME (map fst used_facts)
326.141 + else
326.142 + NONE
326.143 + end
326.144 +
326.145 +val ascii_of_lam_fact_prefix = ascii_of lam_fact_prefix
326.146 +
326.147 +(* overapproximation (good enough) *)
326.148 +fun is_lam_lifted s =
326.149 + String.isPrefix fact_prefix s andalso
326.150 + String.isSubstring ascii_of_lam_fact_prefix s
326.151 +
326.152 +val is_combinator_def = String.isPrefix (helper_prefix ^ combinator_prefix)
326.153 +
326.154 +fun lam_trans_of_atp_proof atp_proof default =
326.155 + case (is_axiom_used_in_proof is_combinator_def atp_proof,
326.156 + is_axiom_used_in_proof is_lam_lifted atp_proof) of
326.157 + (false, false) => default
326.158 + | (false, true) => liftingN
326.159 +(* | (true, true) => combs_and_liftingN -- not supported by "metis" *)
326.160 + | (true, _) => combsN
326.161 +
326.162 +val is_typed_helper_name =
326.163 + String.isPrefix helper_prefix andf String.isSuffix typed_helper_suffix
326.164 +
326.165 +fun is_typed_helper_used_in_atp_proof atp_proof =
326.166 + is_axiom_used_in_proof is_typed_helper_name atp_proof
326.167 +
326.168 +fun repair_name "$true" = "c_True"
326.169 + | repair_name "$false" = "c_False"
326.170 + | repair_name "$$e" = tptp_equal (* seen in Vampire proofs *)
326.171 + | repair_name s =
326.172 + if is_tptp_equal s orelse
326.173 + (* seen in Vampire proofs *)
326.174 + (String.isPrefix "sQ" s andalso String.isSuffix "_eqProxy" s) then
326.175 + tptp_equal
326.176 + else
326.177 + s
326.178 +
326.179 +fun infer_formula_types ctxt =
326.180 + Type.constraint HOLogic.boolT
326.181 + #> Syntax.check_term
326.182 + (Proof_Context.set_mode Proof_Context.mode_schematic ctxt)
326.183 +
326.184 +val combinator_table =
326.185 + [(@{const_name Meson.COMBI}, @{thm Meson.COMBI_def [abs_def]}),
326.186 + (@{const_name Meson.COMBK}, @{thm Meson.COMBK_def [abs_def]}),
326.187 + (@{const_name Meson.COMBB}, @{thm Meson.COMBB_def [abs_def]}),
326.188 + (@{const_name Meson.COMBC}, @{thm Meson.COMBC_def [abs_def]}),
326.189 + (@{const_name Meson.COMBS}, @{thm Meson.COMBS_def [abs_def]})]
326.190 +
326.191 +fun uncombine_term thy =
326.192 + let
326.193 + fun aux (t1 $ t2) = betapply (pairself aux (t1, t2))
326.194 + | aux (Abs (s, T, t')) = Abs (s, T, aux t')
326.195 + | aux (t as Const (x as (s, _))) =
326.196 + (case AList.lookup (op =) combinator_table s of
326.197 + SOME thm => thm |> prop_of |> specialize_type thy x
326.198 + |> Logic.dest_equals |> snd
326.199 + | NONE => t)
326.200 + | aux t = t
326.201 + in aux end
326.202 +
326.203 +fun unlift_term lifted =
326.204 + map_aterms (fn t as Const (s, _) =>
326.205 + if String.isPrefix lam_lifted_prefix s then
326.206 + case AList.lookup (op =) lifted s of
326.207 + SOME t =>
326.208 + (* FIXME: do something about the types *)
326.209 + unlift_term lifted t
326.210 + | NONE => t
326.211 + else
326.212 + t
326.213 + | t => t)
326.214 +
326.215 +fun decode_line ctxt lifted sym_tab (name, role, u, rule, deps) =
326.216 + let
326.217 + val thy = Proof_Context.theory_of ctxt
326.218 + val t =
326.219 + u |> prop_of_atp ctxt true sym_tab
326.220 + |> uncombine_term thy
326.221 + |> unlift_term lifted
326.222 + |> infer_formula_types ctxt
326.223 + in (name, role, t, rule, deps) end
326.224 +
326.225 +val waldmeister_conjecture_num = "1.0.0.0"
326.226 +
326.227 +fun repair_waldmeister_endgame arg =
326.228 + let
326.229 + fun do_tail (name, _, t, rule, deps) =
326.230 + (name, Negated_Conjecture, s_not t, rule, deps)
326.231 + fun do_body [] = []
326.232 + | do_body ((line as ((num, _), _, _, _, _)) :: lines) =
326.233 + if num = waldmeister_conjecture_num then map do_tail (line :: lines)
326.234 + else line :: do_body lines
326.235 + in do_body arg end
326.236 +
326.237 +fun termify_atp_proof ctxt pool lifted sym_tab =
326.238 + clean_up_atp_proof_dependencies
326.239 + #> nasty_atp_proof pool
326.240 + #> map_term_names_in_atp_proof repair_name
326.241 + #> map (decode_line ctxt lifted sym_tab)
326.242 + #> repair_waldmeister_endgame
326.243 +
326.244 +fun factify_atp_proof fact_names hyp_ts concl_t atp_proof =
326.245 + let
326.246 + fun factify_step ((num, ss), role, t, rule, deps) =
326.247 + let
326.248 + val (ss', role', t') =
326.249 + (case resolve_conjecture ss of
326.250 + [j] =>
326.251 + if j = length hyp_ts then ([], Conjecture, concl_t) else ([], Hypothesis, nth hyp_ts j)
326.252 + | _ =>
326.253 + (case resolve_fact fact_names ss of
326.254 + [] => (ss, Plain, t)
326.255 + | facts => (map fst facts, Axiom, t)))
326.256 + in
326.257 + ((num, ss'), role', t', rule, deps)
326.258 + end
326.259 +
326.260 + val atp_proof = map factify_step atp_proof
326.261 + val names = map #1 atp_proof
326.262 +
326.263 + fun repair_dep (num, ss) = (num, the_default ss (AList.lookup (op =) names num))
326.264 + fun repair_deps (name, role, t, rule, deps) = (name, role, t, rule, map repair_dep deps)
326.265 +
326.266 + in map repair_deps atp_proof end
326.267 +
326.268 end;
327.1 --- a/src/HOL/Tools/ATP/atp_systems.ML Thu Dec 05 17:52:12 2013 +0100
327.2 +++ b/src/HOL/Tools/ATP/atp_systems.ML Thu Dec 05 17:58:03 2013 +0100
327.3 @@ -211,7 +211,7 @@
327.4
327.5 (* agsyHOL *)
327.6
327.7 -val agsyhol_thf0 = THF (Monomorphic, THF_Without_Choice, THF_With_Defs)
327.8 +val agsyhol_thf0 = THF (Monomorphic, THF_Without_Choice)
327.9
327.10 val agsyhol_config : atp_config =
327.11 {exec = K (["AGSYHOL_HOME"], ["agsyHOL"]),
327.12 @@ -461,7 +461,7 @@
327.13
327.14 (* LEO-II supports definitions, but it performs significantly better on our
327.15 benchmarks when they are not used. *)
327.16 -val leo2_thf0 = THF (Monomorphic, THF_Without_Choice, THF_Without_Defs)
327.17 +val leo2_thf0 = THF (Monomorphic, THF_Without_Choice)
327.18
327.19 val leo2_config : atp_config =
327.20 {exec = K (["LEO2_HOME"], ["leo.opt", "leo"]),
327.21 @@ -488,7 +488,7 @@
327.22 (* Satallax *)
327.23
327.24 (* Choice is disabled until there is proper reconstruction for it. *)
327.25 -val satallax_thf0 = THF (Monomorphic, THF_Without_Choice, THF_With_Defs)
327.26 +val satallax_thf0 = THF (Monomorphic, THF_Without_Choice)
327.27
327.28 val satallax_config : atp_config =
327.29 {exec = K (["SATALLAX_HOME"], ["satallax.opt", "satallax"]),
327.30 @@ -653,7 +653,7 @@
327.31 best_max_mono_iters = default_max_mono_iters,
327.32 best_max_new_mono_instances = default_max_new_mono_instances}
327.33
327.34 -val dummy_thf_format = THF (Polymorphic, THF_With_Choice, THF_With_Defs)
327.35 +val dummy_thf_format = THF (Polymorphic, THF_With_Choice)
327.36 val dummy_thf_config =
327.37 dummy_config Hypothesis dummy_thf_format "poly_native_higher" false
327.38 val dummy_thf = (dummy_thfN, fn () => dummy_thf_config)
328.1 --- a/src/HOL/Tools/ATP/atp_util.ML Thu Dec 05 17:52:12 2013 +0100
328.2 +++ b/src/HOL/Tools/ATP/atp_util.ML Thu Dec 05 17:58:03 2013 +0100
328.3 @@ -29,7 +29,6 @@
328.4 val varify_type : Proof.context -> typ -> typ
328.5 val instantiate_type : theory -> typ -> typ -> typ -> typ
328.6 val varify_and_instantiate_type : Proof.context -> typ -> typ -> typ -> typ
328.7 - val typ_of_dtyp : Datatype.descr -> (Datatype.dtyp * typ) list -> Datatype.dtyp -> typ
328.8 val is_type_surely_finite : Proof.context -> typ -> bool
328.9 val is_type_surely_infinite : Proof.context -> bool -> typ list -> typ -> bool
328.10 val s_not : term -> term
328.11 @@ -191,24 +190,11 @@
328.12 instantiate_type thy (varify_type ctxt T1) T1' (varify_type ctxt T2)
328.13 end
328.14
328.15 -fun typ_of_dtyp _ typ_assoc (Datatype.DtTFree a) =
328.16 - the (AList.lookup (op =) typ_assoc (Datatype.DtTFree a))
328.17 - | typ_of_dtyp descr typ_assoc (Datatype.DtType (s, Us)) =
328.18 - Type (s, map (typ_of_dtyp descr typ_assoc) Us)
328.19 - | typ_of_dtyp descr typ_assoc (Datatype.DtRec i) =
328.20 - let val (s, ds, _) = the (AList.lookup (op =) descr i) in
328.21 - Type (s, map (typ_of_dtyp descr typ_assoc) ds)
328.22 - end
328.23 -
328.24 -fun datatype_constrs thy (T as Type (s, Ts)) =
328.25 - (case Datatype.get_info thy s of
328.26 - SOME {index, descr, ...} =>
328.27 - let val (_, dtyps, constrs) = AList.lookup (op =) descr index |> the in
328.28 - map (apsnd (fn Us => map (typ_of_dtyp descr (dtyps ~~ Ts)) Us ---> T))
328.29 - constrs
328.30 - end
328.31 - | NONE => [])
328.32 - | datatype_constrs _ _ = []
328.33 +fun free_constructors_of ctxt (Type (s, Ts)) =
328.34 + (case Ctr_Sugar.ctr_sugar_of ctxt s of
328.35 + SOME {ctrs, ...} => map_filter (try dest_Const o Ctr_Sugar.mk_ctr Ts) ctrs
328.36 + | NONE => [])
328.37 + | free_constructors_of _ _ = []
328.38
328.39 (* Similar to "Nitpick_HOL.bounded_exact_card_of_type".
328.40 0 means infinite type, 1 means singleton type (e.g., "unit"), and 2 means
328.41 @@ -239,12 +225,11 @@
328.42 | @{typ nat} => 0 (* optimization *)
328.43 | Type ("Int.int", []) => 0 (* optimization *)
328.44 | Type (s, _) =>
328.45 - (case datatype_constrs thy T of
328.46 + (case free_constructors_of ctxt T of
328.47 constrs as _ :: _ =>
328.48 let
328.49 val constr_cards =
328.50 - map (Integer.prod o map (aux slack (T :: avoid)) o binder_types
328.51 - o snd) constrs
328.52 + map (Integer.prod o map (aux slack (T :: avoid)) o binder_types o snd) constrs
328.53 in
328.54 if exists (curry (op =) 0) constr_cards then 0
328.55 else Int.min (max, Integer.sum constr_cards)
328.56 @@ -270,10 +255,10 @@
328.57 else
328.58 default_card
328.59 | [] => default_card)
328.60 + | TFree _ =>
328.61 (* Very slightly unsound: Type variables are assumed not to be
328.62 constrained to cardinality 1. (In practice, the user would most
328.63 likely have used "unit" directly anyway.) *)
328.64 - | TFree _ =>
328.65 if not sound andalso default_card = 1 then 2 else default_card
328.66 | TVar _ => default_card
328.67 in Int.min (max, aux false [] T) end
329.1 --- a/src/HOL/Tools/Datatype/datatype_codegen.ML Thu Dec 05 17:52:12 2013 +0100
329.2 +++ b/src/HOL/Tools/Datatype/datatype_codegen.ML Thu Dec 05 17:58:03 2013 +0100
329.3 @@ -6,152 +6,24 @@
329.4
329.5 signature DATATYPE_CODEGEN =
329.6 sig
329.7 - val setup: theory -> theory
329.8 end;
329.9
329.10 structure Datatype_Codegen : DATATYPE_CODEGEN =
329.11 struct
329.12
329.13 -(** generic code generator **)
329.14 +fun add_code_for_datatype fcT_name thy =
329.15 + let
329.16 + val (As', ctr_specs) = Datatype_Data.the_spec thy fcT_name;
329.17 + val {inject = inject_thms, distinct = distinct_thms, case_rewrites = case_thms, ...} =
329.18 + Datatype_Data.the_info thy fcT_name;
329.19
329.20 -(* liberal addition of code data for datatypes *)
329.21 -
329.22 -fun mk_constr_consts thy vs tyco cos =
329.23 - let
329.24 - val cs = map (fn (c, tys) => (c, tys ---> Type (tyco, map TFree vs))) cos;
329.25 - val cs' = map (fn c_ty as (_, ty) => (Axclass.unoverload_const thy c_ty, ty)) cs;
329.26 + val As = map TFree As';
329.27 + val fcT = Type (fcT_name, As);
329.28 + val ctrs = map (fn (c, arg_Ts) => (c, arg_Ts ---> fcT)) ctr_specs;
329.29 in
329.30 - if is_some (try (Code.constrset_of_consts thy) cs')
329.31 - then SOME cs
329.32 - else NONE
329.33 + Ctr_Sugar_Code.add_ctr_code fcT_name As ctrs inject_thms distinct_thms case_thms thy
329.34 end;
329.35
329.36 -
329.37 -(* case certificates *)
329.38 -
329.39 -fun mk_case_cert thy tyco =
329.40 - let
329.41 - val raw_thms = #case_rewrites (Datatype_Data.the_info thy tyco);
329.42 - val thms as hd_thm :: _ = raw_thms
329.43 - |> Conjunction.intr_balanced
329.44 - |> Thm.unvarify_global
329.45 - |> Conjunction.elim_balanced (length raw_thms)
329.46 - |> map Simpdata.mk_meta_eq
329.47 - |> map Drule.zero_var_indexes;
329.48 - val params = fold_aterms (fn (Free (v, _)) => insert (op =) v | _ => I) (Thm.prop_of hd_thm) [];
329.49 - val rhs = hd_thm
329.50 - |> Thm.prop_of
329.51 - |> Logic.dest_equals
329.52 - |> fst
329.53 - |> Term.strip_comb
329.54 - |> apsnd (fst o split_last)
329.55 - |> list_comb;
329.56 - val lhs = Free (singleton (Name.variant_list params) "case", Term.fastype_of rhs);
329.57 - val asm = Thm.cterm_of thy (Logic.mk_equals (lhs, rhs));
329.58 - in
329.59 - thms
329.60 - |> Conjunction.intr_balanced
329.61 - |> rewrite_rule [Thm.symmetric (Thm.assume asm)]
329.62 - |> Thm.implies_intr asm
329.63 - |> Thm.generalize ([], params) 0
329.64 - |> Axclass.unoverload thy
329.65 - |> Thm.varifyT_global
329.66 - end;
329.67 -
329.68 -
329.69 -(* equality *)
329.70 -
329.71 -fun mk_eq_eqns thy tyco =
329.72 - let
329.73 - val (vs, cos) = Datatype_Data.the_spec thy tyco;
329.74 - val {descr, index, inject = inject_thms, distinct = distinct_thms, ...} =
329.75 - Datatype_Data.the_info thy tyco;
329.76 - val ty = Type (tyco, map TFree vs);
329.77 - fun mk_eq (t1, t2) = Const (@{const_name HOL.equal}, ty --> ty --> HOLogic.boolT) $ t1 $ t2;
329.78 - fun true_eq t12 = HOLogic.mk_eq (mk_eq t12, @{term True});
329.79 - fun false_eq t12 = HOLogic.mk_eq (mk_eq t12, @{term False});
329.80 - val triv_injects =
329.81 - map_filter
329.82 - (fn (c, []) => SOME (HOLogic.mk_Trueprop (true_eq (Const (c, ty), Const (c, ty))))
329.83 - | _ => NONE) cos;
329.84 - fun prep_inject (trueprop $ (equiv $ (_ $ t1 $ t2) $ rhs)) =
329.85 - trueprop $ (equiv $ mk_eq (t1, t2) $ rhs);
329.86 - val injects = map prep_inject (nth (Datatype_Prop.make_injs [descr]) index);
329.87 - fun prep_distinct (trueprop $ (not $ (_ $ t1 $ t2))) =
329.88 - [trueprop $ false_eq (t1, t2), trueprop $ false_eq (t2, t1)];
329.89 - val distincts = maps prep_distinct (nth (Datatype_Prop.make_distincts [descr]) index);
329.90 - val refl = HOLogic.mk_Trueprop (true_eq (Free ("x", ty), Free ("x", ty)));
329.91 - val simp_ctxt =
329.92 - Simplifier.global_context thy HOL_basic_ss
329.93 - addsimps (map Simpdata.mk_eq (@{thms equal eq_True} @ inject_thms @ distinct_thms));
329.94 - fun prove prop =
329.95 - Goal.prove_sorry_global thy [] [] prop (K (ALLGOALS (simp_tac simp_ctxt)))
329.96 - |> Simpdata.mk_eq;
329.97 - in (map prove (triv_injects @ injects @ distincts), prove refl) end;
329.98 -
329.99 -fun add_equality vs tycos thy =
329.100 - let
329.101 - fun add_def tyco lthy =
329.102 - let
329.103 - val ty = Type (tyco, map TFree vs);
329.104 - fun mk_side const_name =
329.105 - Const (const_name, ty --> ty --> HOLogic.boolT) $ Free ("x", ty) $ Free ("y", ty);
329.106 - val def =
329.107 - HOLogic.mk_Trueprop (HOLogic.mk_eq
329.108 - (mk_side @{const_name HOL.equal}, mk_side @{const_name HOL.eq}));
329.109 - val def' = Syntax.check_term lthy def;
329.110 - val ((_, (_, thm)), lthy') =
329.111 - Specification.definition (NONE, (Attrib.empty_binding, def')) lthy;
329.112 - val ctxt_thy = Proof_Context.init_global (Proof_Context.theory_of lthy);
329.113 - val thm' = singleton (Proof_Context.export lthy' ctxt_thy) thm;
329.114 - in (thm', lthy') end;
329.115 - fun tac thms = Class.intro_classes_tac [] THEN ALLGOALS (Proof_Context.fact_tac thms);
329.116 - fun prefix tyco =
329.117 - Binding.qualify true (Long_Name.base_name tyco) o Binding.qualify true "eq" o Binding.name;
329.118 - fun add_eq_thms tyco =
329.119 - `(fn thy => mk_eq_eqns thy tyco)
329.120 - #-> (fn (thms, thm) =>
329.121 - Global_Theory.note_thmss Thm.lemmaK
329.122 - [((prefix tyco "refl", [Code.add_nbe_default_eqn_attribute]), [([thm], [])]),
329.123 - ((prefix tyco "simps", [Code.add_default_eqn_attribute]), [(rev thms, [])])])
329.124 - #> snd;
329.125 - in
329.126 - thy
329.127 - |> Class.instantiation (tycos, vs, [HOLogic.class_equal])
329.128 - |> fold_map add_def tycos
329.129 - |-> (fn def_thms => Class.prove_instantiation_exit_result (map o Morphism.thm)
329.130 - (fn _ => fn def_thms => tac def_thms) def_thms)
329.131 - |-> (fn def_thms => fold Code.del_eqn def_thms)
329.132 - |> fold add_eq_thms tycos
329.133 - end;
329.134 -
329.135 -
329.136 -(* register a datatype etc. *)
329.137 -
329.138 -fun add_all_code config tycos thy =
329.139 - let
329.140 - val (vs :: _, coss) = split_list (map (Datatype_Data.the_spec thy) tycos);
329.141 - val any_css = map2 (mk_constr_consts thy vs) tycos coss;
329.142 - val css = if exists is_none any_css then [] else map_filter I any_css;
329.143 - val case_rewrites = maps (#case_rewrites o Datatype_Data.the_info thy) tycos;
329.144 - val certs = map (mk_case_cert thy) tycos;
329.145 - val tycos_eq =
329.146 - filter_out
329.147 - (fn tyco => Sorts.has_instance (Sign.classes_of thy) tyco [HOLogic.class_equal]) tycos;
329.148 - in
329.149 - if null css then thy
329.150 - else
329.151 - thy
329.152 - |> tap (fn _ => Datatype_Aux.message config "Registering datatype for code generator ...")
329.153 - |> fold Code.add_datatype css
329.154 - |> fold_rev Code.add_default_eqn case_rewrites
329.155 - |> fold Code.add_case certs
329.156 - |> not (null tycos_eq) ? add_equality vs tycos_eq
329.157 - end;
329.158 -
329.159 -
329.160 -(** theory setup **)
329.161 -
329.162 -val setup = Datatype_Data.interpretation add_all_code;
329.163 +val _ = Theory.setup (Datatype_Data.interpretation (K (fold add_code_for_datatype)));
329.164
329.165 end;
330.1 --- a/src/HOL/Tools/Datatype/datatype_data.ML Thu Dec 05 17:52:12 2013 +0100
330.2 +++ b/src/HOL/Tools/Datatype/datatype_data.ML Thu Dec 05 17:58:03 2013 +0100
330.3 @@ -86,16 +86,50 @@
330.4
330.5 val info_of_case = Symtab.lookup o #cases o Data.get;
330.6
330.7 -fun register (dt_infos : (string * Datatype_Aux.info) list) =
330.8 +fun ctrs_of_exhaust exhaust =
330.9 + Logic.strip_imp_prems (prop_of exhaust) |>
330.10 + map (head_of o snd o HOLogic.dest_eq o HOLogic.dest_Trueprop o the_single
330.11 + o Logic.strip_assums_hyp);
330.12 +
330.13 +fun case_of_case_rewrite case_rewrite =
330.14 + head_of (fst (HOLogic.dest_eq (HOLogic.dest_Trueprop (prop_of case_rewrite))));
330.15 +
330.16 +fun ctr_sugar_of_info ({exhaust, nchotomy, inject, distinct, case_rewrites, case_cong,
330.17 + weak_case_cong, split, split_asm, ...} : Datatype_Aux.info) =
330.18 + {ctrs = ctrs_of_exhaust exhaust,
330.19 + casex = case_of_case_rewrite (hd case_rewrites),
330.20 + discs = [],
330.21 + selss = [],
330.22 + exhaust = exhaust,
330.23 + nchotomy = nchotomy,
330.24 + injects = inject,
330.25 + distincts = distinct,
330.26 + case_thms = case_rewrites,
330.27 + case_cong = case_cong,
330.28 + weak_case_cong = weak_case_cong,
330.29 + split = split,
330.30 + split_asm = split_asm,
330.31 + disc_thmss = [],
330.32 + discIs = [],
330.33 + sel_thmss = [],
330.34 + disc_exhausts = [],
330.35 + sel_exhausts = [],
330.36 + collapses = [],
330.37 + expands = [],
330.38 + sel_splits = [],
330.39 + sel_split_asms = [],
330.40 + case_eq_ifs = []};
330.41 +
330.42 +fun register dt_infos =
330.43 Data.map (fn {types, constrs, cases} =>
330.44 {types = types |> fold Symtab.update dt_infos,
330.45 constrs = constrs |> fold (fn (constr, dtname_info) =>
330.46 Symtab.map_default (constr, []) (cons dtname_info))
330.47 (maps (fn (dtname, info as {descr, index, ...}) =>
330.48 - map (rpair (dtname, info) o fst)
330.49 - (#3 (the (AList.lookup op = descr index)))) dt_infos),
330.50 + map (rpair (dtname, info) o fst) (#3 (the (AList.lookup op = descr index)))) dt_infos),
330.51 cases = cases |> fold Symtab.update
330.52 - (map (fn (_, info as {case_name, ...}) => (case_name, info)) dt_infos)});
330.53 + (map (fn (_, info as {case_name, ...}) => (case_name, info)) dt_infos)}) #>
330.54 + fold (fn (key, info) => Ctr_Sugar.register_ctr_sugar_global key (ctr_sugar_of_info info)) dt_infos;
330.55
330.56
330.57 (* complex queries *)
331.1 --- a/src/HOL/Tools/Datatype/datatype_prop.ML Thu Dec 05 17:52:12 2013 +0100
331.2 +++ b/src/HOL/Tools/Datatype/datatype_prop.ML Thu Dec 05 17:58:03 2013 +0100
331.3 @@ -29,17 +29,8 @@
331.4 type descr = Datatype_Aux.descr;
331.5
331.6
331.7 -fun indexify_names names =
331.8 - let
331.9 - fun index (x :: xs) tab =
331.10 - (case AList.lookup (op =) tab x of
331.11 - NONE =>
331.12 - if member (op =) xs x
331.13 - then (x ^ "1") :: index xs ((x, 2) :: tab)
331.14 - else x :: index xs tab
331.15 - | SOME i => (x ^ string_of_int i) :: index xs ((x, i + 1) :: tab))
331.16 - | index [] _ = [];
331.17 - in index names [] end;
331.18 +val indexify_names = Case_Translation.indexify_names;
331.19 +val make_tnames = Case_Translation.make_tnames;
331.20
331.21 fun make_tnames Ts =
331.22 let
332.1 --- a/src/HOL/Tools/Function/fun.ML Thu Dec 05 17:52:12 2013 +0100
332.2 +++ b/src/HOL/Tools/Function/fun.ML Thu Dec 05 17:58:03 2013 +0100
332.3 @@ -37,12 +37,17 @@
332.4 let
332.5 val (hd, args) = strip_comb t
332.6 in
332.7 - (((case Datatype.info_of_constr thy (dest_Const hd) of
332.8 - SOME _ => ()
332.9 - | NONE => err "Non-constructor pattern")
332.10 - handle TERM ("dest_Const", _) => err "Non-constructor patterns");
332.11 - map check_constr_pattern args;
332.12 - ())
332.13 + (case hd of
332.14 + Const (hd_s, hd_T) =>
332.15 + (case body_type hd_T of
332.16 + Type (Tname, _) =>
332.17 + (case Ctr_Sugar.ctr_sugar_of ctxt Tname of
332.18 + SOME {ctrs, ...} => exists (fn Const (s, _) => s = hd_s) ctrs
332.19 + | NONE => false)
332.20 + | _ => false)
332.21 + | _ => false) orelse err "Non-constructor pattern";
332.22 + map check_constr_pattern args;
332.23 + ()
332.24 end
332.25
332.26 val (_, qs, gs, args, _) = split_def ctxt (K true) geq
333.1 --- a/src/HOL/Tools/Function/function_common.ML Thu Dec 05 17:52:12 2013 +0100
333.2 +++ b/src/HOL/Tools/Function/function_common.ML Thu Dec 05 17:58:03 2013 +0100
333.3 @@ -119,7 +119,7 @@
333.4
333.5 fun PROFILE msg = if !profile then timeap_msg msg else I
333.6
333.7 -val acc_const_name = @{const_name accp}
333.8 +val acc_const_name = @{const_name Wellfounded.accp}
333.9 fun mk_acc domT R =
333.10 Const (acc_const_name, (domT --> domT --> HOLogic.boolT) --> domT --> HOLogic.boolT) $ R
333.11
334.1 --- a/src/HOL/Tools/Function/function_lib.ML Thu Dec 05 17:52:12 2013 +0100
334.2 +++ b/src/HOL/Tools/Function/function_lib.ML Thu Dec 05 17:58:03 2013 +0100
334.3 @@ -27,6 +27,8 @@
334.4 val dest_binop_list: string -> term -> term list
334.5 val regroup_conv: string -> string -> thm list -> int list -> conv
334.6 val regroup_union_conv: int list -> conv
334.7 +
334.8 + val inst_constrs_of: Proof.context -> typ -> term list
334.9 end
334.10
334.11 structure Function_Lib: FUNCTION_LIB =
334.12 @@ -48,9 +50,7 @@
334.13 | dest_all_all t = ([],t)
334.14
334.15
334.16 -fun map4 _ [] [] [] [] = []
334.17 - | map4 f (x :: xs) (y :: ys) (z :: zs) (u :: us) = f x y z u :: map4 f xs ys zs us
334.18 - | map4 _ _ _ _ _ = raise ListPair.UnequalLengths;
334.19 +fun map4 f = Ctr_Sugar_Util.map4 f
334.20
334.21 fun map7 _ [] [] [] [] [] [] [] = []
334.22 | map7 f (x :: xs) (y :: ys) (z :: zs) (u :: us) (v :: vs) (w :: ws) (b :: bs) = f x y z u v w b :: map7 f xs ys zs us vs ws bs
334.23 @@ -133,4 +133,8 @@
334.24 (@{thms Un_ac} @ @{thms Un_empty_right} @ @{thms Un_empty_left}))
334.25
334.26
334.27 +fun inst_constrs_of ctxt (Type (name, Ts)) =
334.28 + map (Ctr_Sugar.mk_ctr Ts) (#ctrs (the (Ctr_Sugar.ctr_sugar_of ctxt name)))
334.29 + | inst_constrs_of _ _ = raise Match
334.30 +
334.31 end
335.1 --- a/src/HOL/Tools/Function/mutual.ML Thu Dec 05 17:52:12 2013 +0100
335.2 +++ b/src/HOL/Tools/Function/mutual.ML Thu Dec 05 17:58:03 2013 +0100
335.3 @@ -187,8 +187,10 @@
335.4 | [cond] => (Thm.implies_elim psimp (Thm.assume cond), Thm.implies_intr cond)
335.5 | _ => raise General.Fail "Too many conditions"
335.6
335.7 + val (_, simp_ctxt) = ctxt
335.8 + |> Assumption.add_assumes (#hyps (Thm.crep_thm simp))
335.9 in
335.10 - Goal.prove ctxt [] []
335.11 + Goal.prove simp_ctxt [] []
335.12 (HOLogic.Trueprop $ HOLogic.mk_eq (list_comb (f, args), rhs))
335.13 (fn _ =>
335.14 Local_Defs.unfold_tac ctxt all_orig_fdefs
336.1 --- a/src/HOL/Tools/Function/partial_function.ML Thu Dec 05 17:52:12 2013 +0100
336.2 +++ b/src/HOL/Tools/Function/partial_function.ML Thu Dec 05 17:58:03 2013 +0100
336.3 @@ -70,18 +70,18 @@
336.4 Subgoal.FOCUS (fn {context = ctxt', prems, ...} =>
336.5 Local_Defs.unfold_tac ctxt' [nth prems k]) ctxt;
336.6
336.7 -fun dest_case thy t =
336.8 +fun dest_case ctxt t =
336.9 case strip_comb t of
336.10 (Const (case_comb, _), args) =>
336.11 - (case Datatype.info_of_case thy case_comb of
336.12 + (case Ctr_Sugar.ctr_sugar_of_case ctxt case_comb of
336.13 NONE => NONE
336.14 - | SOME {case_rewrites, ...} =>
336.15 + | SOME {case_thms, ...} =>
336.16 let
336.17 - val lhs = prop_of (hd case_rewrites)
336.18 + val lhs = prop_of (hd case_thms)
336.19 |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> fst;
336.20 val arity = length (snd (strip_comb lhs));
336.21 val conv = funpow (length args - arity) Conv.fun_conv
336.22 - (Conv.rewrs_conv (map mk_meta_eq case_rewrites));
336.23 + (Conv.rewrs_conv (map mk_meta_eq case_thms));
336.24 in
336.25 SOME (nth args (arity - 1), conv)
336.26 end)
336.27 @@ -91,7 +91,7 @@
336.28 val split_cases_tac = Subgoal.FOCUS_PARAMS (fn {context=ctxt, ...} =>
336.29 SUBGOAL (fn (t, i) => case t of
336.30 _ $ (_ $ Abs (_, _, body)) =>
336.31 - (case dest_case (Proof_Context.theory_of ctxt) body of
336.32 + (case dest_case ctxt body of
336.33 NONE => no_tac
336.34 | SOME (arg, conv) =>
336.35 let open Conv in
336.36 @@ -168,6 +168,9 @@
336.37 simpset_of (put_simpset HOL_basic_ss @{context}
336.38 addsimps [@{thm Product_Type.split_conv}]);
336.39
336.40 +val curry_K_ss =
336.41 + simpset_of (put_simpset HOL_basic_ss @{context}
336.42 + addsimps [@{thm Product_Type.curry_K}]);
336.43
336.44 (* instantiate generic fixpoint induction and eliminate the canonical assumptions;
336.45 curry induction predicate *)
336.46 @@ -181,7 +184,8 @@
336.47 |> cterm_instantiate' [SOME (cert uncurry), NONE, SOME (cert curry), NONE, SOME (cert P_inst)]
336.48 |> Tactic.rule_by_tactic ctxt
336.49 (Simplifier.simp_tac (put_simpset curry_uncurry_ss ctxt) 3 (* discharge U (C f) = f *)
336.50 - THEN Simplifier.full_simp_tac (put_simpset curry_uncurry_ss ctxt) 4) (* simplify induction step *)
336.51 + THEN Simplifier.simp_tac (put_simpset curry_K_ss ctxt) 4 (* simplify bot case *)
336.52 + THEN Simplifier.full_simp_tac (put_simpset curry_uncurry_ss ctxt) 5) (* simplify induction step *)
336.53 |> (fn thm => thm OF [mono_thm, f_def])
336.54 |> Conv.fconv_rule (Conv.concl_conv ~1 (* simplify conclusion *)
336.55 (Raw_Simplifier.rewrite false [mk_meta_eq @{thm Product_Type.curry_split}]))
337.1 --- a/src/HOL/Tools/Function/pat_completeness.ML Thu Dec 05 17:52:12 2013 +0100
337.2 +++ b/src/HOL/Tools/Function/pat_completeness.ML Thu Dec 05 17:58:03 2013 +0100
337.3 @@ -6,9 +6,9 @@
337.4
337.5 signature PAT_COMPLETENESS =
337.6 sig
337.7 - val pat_completeness_tac: Proof.context -> int -> tactic
337.8 - val prove_completeness : Proof.context -> term list -> term -> term list list ->
337.9 - term list list -> thm
337.10 + val pat_completeness_tac: Proof.context -> int -> tactic
337.11 + val prove_completeness: Proof.context -> term list -> term -> term list list ->
337.12 + term list list -> thm
337.13 end
337.14
337.15 structure Pat_Completeness : PAT_COMPLETENESS =
337.16 @@ -54,13 +54,6 @@
337.17 else filter_pats thy cons pvars pts
337.18
337.19
337.20 -fun inst_constrs_of thy (T as Type (name, _)) =
337.21 - map (fn (Cn,CT) =>
337.22 - Envir.subst_term_types (Sign.typ_match thy (body_type CT, T) Vartab.empty) (Const (Cn, CT)))
337.23 - (the (Datatype.get_constrs thy name))
337.24 - | inst_constrs_of thy _ = raise Match
337.25 -
337.26 -
337.27 fun transform_pat _ avars c_assum ([] , thm) = raise Match
337.28 | transform_pat ctxt avars c_assum (pat :: pats, thm) =
337.29 let
337.30 @@ -101,10 +94,9 @@
337.31 else (* Cons case *)
337.32 let
337.33 val thy = Proof_Context.theory_of ctxt
337.34 - val T = fastype_of v
337.35 - val (tname, _) = dest_Type T
337.36 - val {exhaust=case_thm, ...} = Datatype.the_info thy tname
337.37 - val constrs = inst_constrs_of thy T
337.38 + val T as Type (tname, _) = fastype_of v
337.39 + val SOME {exhaust=case_thm, ...} = Ctr_Sugar.ctr_sugar_of ctxt tname
337.40 + val constrs = inst_constrs_of ctxt T
337.41 val c_cases = map (constr_case ctxt P idx (v :: vs) pts) constrs
337.42 in
337.43 inst_case_thm thy v P case_thm
338.1 --- a/src/HOL/Tools/Function/pattern_split.ML Thu Dec 05 17:52:12 2013 +0100
338.2 +++ b/src/HOL/Tools/Function/pattern_split.ML Thu Dec 05 17:58:03 2013 +0100
338.3 @@ -30,14 +30,6 @@
338.4 (binder_types (fastype_of t)) (vs, t)
338.5
338.6
338.7 -(* This is copied from "pat_completeness.ML" *)
338.8 -fun inst_constrs_of thy (T as Type (name, _)) =
338.9 - map (fn (Cn,CT) =>
338.10 - Envir.subst_term_types (Sign.typ_match thy (body_type CT, T) Vartab.empty) (Const (Cn, CT)))
338.11 - (the (Datatype.get_constrs thy name))
338.12 - | inst_constrs_of thy T = raise TYPE ("inst_constrs_of", [T], [])
338.13 -
338.14 -
338.15 fun join ((vs1,sub1), (vs2,sub2)) = (merge (op aconv) (vs1,vs2), sub1 @ sub2)
338.16 fun join_product (xs, ys) = map_product (curry join) xs ys
338.17
338.18 @@ -49,7 +41,7 @@
338.19 fun pattern_subtract_subst_aux vs _ (Free v2) = []
338.20 | pattern_subtract_subst_aux vs (v as (Free (_, T))) t' =
338.21 let
338.22 - fun foo constr =
338.23 + fun aux constr =
338.24 let
338.25 val (vs', t) = saturate ctxt vs constr
338.26 val substs = pattern_subtract_subst ctxt vs' t t'
338.27 @@ -57,7 +49,7 @@
338.28 map (fn (vs, subst) => (vs, (v,t)::subst)) substs
338.29 end
338.30 in
338.31 - maps foo (inst_constrs_of (Proof_Context.theory_of ctxt) T)
338.32 + maps aux (inst_constrs_of ctxt T)
338.33 end
338.34 | pattern_subtract_subst_aux vs t t' =
338.35 let
339.1 --- a/src/HOL/Tools/Metis/metis_reconstruct.ML Thu Dec 05 17:52:12 2013 +0100
339.2 +++ b/src/HOL/Tools/Metis/metis_reconstruct.ML Thu Dec 05 17:58:03 2013 +0100
339.3 @@ -376,7 +376,7 @@
339.4 val _ = trace_msg ctxt (fn () => "abstraction: " ^ Syntax.string_of_term ctxt tm_abs)
339.5 val _ = trace_msg ctxt (fn () => "i_tm: " ^ Syntax.string_of_term ctxt i_tm)
339.6 val _ = trace_msg ctxt (fn () => "located term: " ^ Syntax.string_of_term ctxt tm_subst)
339.7 - val imax = maxidx_of_term (i_tm $ tm_abs $ tm_subst) (*ill typed but gives right max*)
339.8 + val imax = maxidx_of_term (i_tm $ tm_abs $ tm_subst) (*ill-typed but gives right max*)
339.9 val subst' = Thm.incr_indexes (imax+1) (if pos then subst_em else ssubst_em)
339.10 val _ = trace_msg ctxt (fn () => "subst' " ^ Display.string_of_thm ctxt subst')
339.11 val eq_terms = map (pairself (cterm_of thy))
340.1 --- a/src/HOL/Tools/Metis/metis_tactic.ML Thu Dec 05 17:52:12 2013 +0100
340.2 +++ b/src/HOL/Tools/Metis/metis_tactic.ML Thu Dec 05 17:58:03 2013 +0100
340.3 @@ -294,7 +294,7 @@
340.4 ()
340.5 val (schem_facts, nonschem_facts) = List.partition has_tvar facts
340.6 val type_encs = override_type_encs |> the_default default_type_encs
340.7 - val lam_trans = lam_trans |> the_default metis_default_lam_trans
340.8 + val lam_trans = lam_trans |> the_default default_metis_lam_trans
340.9 in
340.10 HEADGOAL (Method.insert_tac nonschem_facts THEN'
340.11 CHANGED_PROP o generic_metis_tac type_encs lam_trans ctxt
341.1 --- a/src/HOL/Tools/Nitpick/kodkod_sat.ML Thu Dec 05 17:52:12 2013 +0100
341.2 +++ b/src/HOL/Tools/Nitpick/kodkod_sat.ML Thu Dec 05 17:58:03 2013 +0100
341.3 @@ -31,7 +31,6 @@
341.4 (* for compatibility with "SatSolver" *)
341.5 val berkmin_exec = getenv "BERKMIN_EXE"
341.6
341.7 -(* (string * sat_solver_info) list *)
341.8 val static_list =
341.9 [("Lingeling_JNI", Internal (JNI [1, 5], Batch, ["Lingeling"])),
341.10 ("CryptoMiniSat", External ("CRYPTOMINISAT_HOME", "cryptominisat", [])),
341.11 @@ -44,6 +43,7 @@
341.12 "Instance Unsatisfiable")),
341.13 ("RSat", ExternalV2 (ToStdout, "RSAT_HOME", "rsat", ["-s"],
341.14 "s SATISFIABLE", "v ", "s UNSATISFIABLE")),
341.15 + ("Riss3g", External ("RISS3G_HOME", "riss3g", [])),
341.16 ("BerkMin", ExternalV2 (ToStdout, "BERKMIN_HOME",
341.17 if berkmin_exec = "" then "BerkMin561"
341.18 else berkmin_exec, [], "Satisfiable !!",
342.1 --- a/src/HOL/Tools/Nitpick/nitpick_hol.ML Thu Dec 05 17:52:12 2013 +0100
342.2 +++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML Thu Dec 05 17:58:03 2013 +0100
342.3 @@ -1645,11 +1645,10 @@
342.4 (hol_ctxt as {thy, ctxt, stds, whacks, total_consts, case_names,
342.5 def_tables, ground_thm_table, ersatz_table, ...}) =
342.6 let
342.7 - fun do_numeral depth Ts mult T t0 t1 =
342.8 + fun do_numeral depth Ts mult T some_t0 t1 t2 =
342.9 (if is_number_type ctxt T then
342.10 let
342.11 - val j = mult * (HOLogic.dest_num t1)
342.12 - |> T = nat_T ? Integer.max 0
342.13 + val j = mult * HOLogic.dest_num t2
342.14 in
342.15 if j = 1 then
342.16 raise SAME ()
342.17 @@ -1668,15 +1667,16 @@
342.18 handle TERM _ => raise SAME ()
342.19 else
342.20 raise SAME ())
342.21 - handle SAME () => s_betapply [] (do_term depth Ts t0, do_term depth Ts t1)
342.22 + handle SAME () => (case some_t0 of NONE => s_betapply [] (do_term depth Ts t1, do_term depth Ts t2)
342.23 + | SOME t0 => s_betapply [] (do_term depth Ts t0, s_betapply [] (do_term depth Ts t1, do_term depth Ts t2)))
342.24 and do_term depth Ts t =
342.25 case t of
342.26 - (t0 as Const (@{const_name Num.neg_numeral_class.neg_numeral},
342.27 - Type (@{type_name fun}, [_, ran_T]))) $ t1 =>
342.28 - do_numeral depth Ts ~1 ran_T t0 t1
342.29 - | (t0 as Const (@{const_name Num.numeral_class.numeral},
342.30 - Type (@{type_name fun}, [_, ran_T]))) $ t1 =>
342.31 - do_numeral depth Ts 1 ran_T t0 t1
342.32 + (t0 as Const (@{const_name uminus}, _) $ ((t1 as Const (@{const_name numeral},
342.33 + Type (@{type_name fun}, [_, ran_T]))) $ t2)) =>
342.34 + do_numeral depth Ts ~1 ran_T (SOME t0) t1 t2
342.35 + | (t1 as Const (@{const_name numeral},
342.36 + Type (@{type_name fun}, [_, ran_T]))) $ t2 =>
342.37 + do_numeral depth Ts 1 ran_T NONE t1 t2
342.38 | Const (@{const_name refl_on}, T) $ Const (@{const_name top}, _) $ t2 =>
342.39 do_const depth Ts t (@{const_name refl'}, range_type T) [t2]
342.40 | (t0 as Const (@{const_name Sigma}, Type (_, [T1, Type (_, [T2, T3])])))
343.1 --- a/src/HOL/Tools/Nitpick/nitpick_isar.ML Thu Dec 05 17:52:12 2013 +0100
343.2 +++ b/src/HOL/Tools/Nitpick/nitpick_isar.ML Thu Dec 05 17:58:03 2013 +0100
343.3 @@ -144,10 +144,7 @@
343.4 structure Data = Theory_Data
343.5 (
343.6 type T = raw_param list
343.7 - val empty =
343.8 - default_default_params
343.9 - |> getenv "NITPICK_SPY" = "yes" ? AList.update (op =) ("spy", "true")
343.10 - |> map (apsnd single)
343.11 + val empty = default_default_params |> map (apsnd single)
343.12 val extend = I
343.13 fun merge data = AList.merge (op =) (K true) data
343.14 )
343.15 @@ -258,7 +255,7 @@
343.16 val debug = (mode <> Auto_Try andalso lookup_bool "debug")
343.17 val verbose = debug orelse (mode <> Auto_Try andalso lookup_bool "verbose")
343.18 val overlord = lookup_bool "overlord"
343.19 - val spy = lookup_bool "spy"
343.20 + val spy = getenv "NITPICK_SPY" = "yes" orelse lookup_bool "spy"
343.21 val user_axioms = lookup_bool_option "user_axioms"
343.22 val assms = lookup_bool "assms"
343.23 val whacks = lookup_term_list_option_polymorphic "whack" |> these
344.1 --- a/src/HOL/Tools/Nitpick/nitpick_kodkod.ML Thu Dec 05 17:52:12 2013 +0100
344.2 +++ b/src/HOL/Tools/Nitpick/nitpick_kodkod.ML Thu Dec 05 17:58:03 2013 +0100
344.3 @@ -1545,16 +1545,16 @@
344.4 |> Typ_Graph.strong_conn
344.5 |> map (fn keys => filter (member (op =) keys o fst) nfa)
344.6
344.7 -fun acyclicity_axiom_for_datatype (kk as {kk_no, kk_intersect, ...}) nfa
344.8 - start_T =
344.9 - kk_no (kk_intersect
344.10 - (loop_path_rel_expr kk nfa (pull start_T (map fst nfa)) start_T)
344.11 - KK.Iden)
344.12 (* Cycle breaking in the bounds takes care of singly recursive datatypes, hence
344.13 the first equation. *)
344.14 -fun acyclicity_axioms_for_datatypes _ [_] = []
344.15 - | acyclicity_axioms_for_datatypes kk nfas =
344.16 - maps (fn nfa => map (acyclicity_axiom_for_datatype kk nfa o fst) nfa) nfas
344.17 +fun acyclicity_axioms_for_datatype _ [_] _ = []
344.18 + | acyclicity_axioms_for_datatype (kk as {kk_no, kk_intersect, ...}) nfa
344.19 + start_T =
344.20 + [kk_no (kk_intersect
344.21 + (loop_path_rel_expr kk nfa (pull start_T (map fst nfa)) start_T)
344.22 + KK.Iden)]
344.23 +fun acyclicity_axioms_for_datatypes kk =
344.24 + maps (fn nfa => maps (acyclicity_axioms_for_datatype kk nfa o fst) nfa)
344.25
344.26 fun atom_equation_for_nut ofs kk (u, j) =
344.27 let val dummy_u = RelReg (0, type_of u, rep_of u) in
345.1 --- a/src/HOL/Tools/Nitpick/nitpick_util.ML Thu Dec 05 17:52:12 2013 +0100
345.2 +++ b/src/HOL/Tools/Nitpick/nitpick_util.ML Thu Dec 05 17:58:03 2013 +0100
345.3 @@ -269,7 +269,15 @@
345.4 | NONE => false)
345.5 | _ => false
345.6
345.7 -val typ_of_dtyp = ATP_Util.typ_of_dtyp
345.8 +fun typ_of_dtyp _ typ_assoc (Datatype.DtTFree a) =
345.9 + the (AList.lookup (op =) typ_assoc (Datatype.DtTFree a))
345.10 + | typ_of_dtyp descr typ_assoc (Datatype.DtType (s, Us)) =
345.11 + Type (s, map (typ_of_dtyp descr typ_assoc) Us)
345.12 + | typ_of_dtyp descr typ_assoc (Datatype.DtRec i) =
345.13 + let val (s, ds, _) = the (AList.lookup (op =) descr i) in
345.14 + Type (s, map (typ_of_dtyp descr typ_assoc) ds)
345.15 + end
345.16 +
345.17 val varify_type = ATP_Util.varify_type
345.18 val instantiate_type = ATP_Util.instantiate_type
345.19 val varify_and_instantiate_type = ATP_Util.varify_and_instantiate_type
346.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_fun.ML Thu Dec 05 17:52:12 2013 +0100
346.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_fun.ML Thu Dec 05 17:58:03 2013 +0100
346.3 @@ -280,13 +280,15 @@
346.4 |> map (fn (resultt, (_, prems)) =>
346.5 Logic.list_implies (prems, HOLogic.mk_Trueprop (list_comb (pred, args @ [resultt]))))
346.6 end
346.7 - val intr_ts = maps mk_intros ((funs ~~ preds) ~~ (argss' ~~ rhss))
346.8 + val intr_tss = map mk_intros ((funs ~~ preds) ~~ (argss' ~~ rhss))
346.9 val (intrs, thy') = thy
346.10 |> Sign.add_consts_i
346.11 (map (fn Const (name, T) => (Binding.name (Long_Name.base_name name), T, NoSyn))
346.12 dst_preds)
346.13 |> fold_map Specification.axiom
346.14 - (map (fn t => ((Binding.name ("unnamed_axiom_" ^ serial_string ()), []), t)) intr_ts)
346.15 + (map_index (fn (j, (predname, t)) =>
346.16 + ((Binding.name (Long_Name.base_name predname ^ "_intro_" ^ string_of_int (j + 1)), []), t))
346.17 + (maps (uncurry (map o pair)) (prednames ~~ intr_tss)))
346.18 val specs = map (fn predname => (predname,
346.19 map Drule.export_without_context (filter (Predicate_Compile_Aux.is_intro predname) intrs)))
346.20 dst_prednames
347.1 --- a/src/HOL/Tools/Qelim/cooper.ML Thu Dec 05 17:52:12 2013 +0100
347.2 +++ b/src/HOL/Tools/Qelim/cooper.ML Thu Dec 05 17:58:03 2013 +0100
347.3 @@ -42,7 +42,6 @@
347.4 @{term "nat"}, @{term "int"},
347.5 @{term "Num.One"}, @{term "Num.Bit0"}, @{term "Num.Bit1"},
347.6 @{term "Num.numeral :: num => int"}, @{term "Num.numeral :: num => nat"},
347.7 - @{term "Num.neg_numeral :: num => int"},
347.8 @{term "0::int"}, @{term "1::int"}, @{term "0::nat"}, @{term "1::nat"},
347.9 @{term "True"}, @{term "False"}];
347.10
347.11 @@ -610,8 +609,6 @@
347.12 | num_of_term vs @{term "1::int"} = Proc.C (Proc.Int_of_integer 1)
347.13 | num_of_term vs (t as Const (@{const_name numeral}, _) $ _) =
347.14 Proc.C (Proc.Int_of_integer (dest_number t))
347.15 - | num_of_term vs (t as Const (@{const_name neg_numeral}, _) $ _) =
347.16 - Proc.Neg (Proc.C (Proc.Int_of_integer (dest_number t)))
347.17 | num_of_term vs (Const (@{const_name Groups.uminus}, _) $ t') =
347.18 Proc.Neg (num_of_term vs t')
347.19 | num_of_term vs (Const (@{const_name Groups.plus}, _) $ t1 $ t2) =
348.1 --- a/src/HOL/Tools/Qelim/qelim.ML Thu Dec 05 17:52:12 2013 +0100
348.2 +++ b/src/HOL/Tools/Qelim/qelim.ML Thu Dec 05 17:58:03 2013 +0100
348.3 @@ -37,7 +37,7 @@
348.4 val th = Thm.abstract_rule s x ((conv env' then_conv ncv env') p')
348.5 |> Drule.arg_cong_rule e
348.6 val th' = simpex_conv (Thm.rhs_of th)
348.7 - val (l,r) = Thm.dest_equals (cprop_of th')
348.8 + val (_, r) = Thm.dest_equals (cprop_of th')
348.9 in if Thm.is_reflexive th' then Thm.transitive th (qcv env (Thm.rhs_of th))
348.10 else Thm.transitive (Thm.transitive th th') (conv env r) end
348.11 | Const(@{const_name Ex},_)$ _ => (Thm.eta_long_conversion then_conv conv env) p
349.1 --- a/src/HOL/Tools/SMT/smt_builtin.ML Thu Dec 05 17:52:12 2013 +0100
349.2 +++ b/src/HOL/Tools/SMT/smt_builtin.ML Thu Dec 05 17:58:03 2013 +0100
349.3 @@ -144,9 +144,10 @@
349.4 (case try HOLogic.dest_number t of
349.5 NONE => NONE
349.6 | SOME (T, i) =>
349.7 - (case lookup_builtin_typ ctxt T of
349.8 - SOME (_, Int (_, g)) => g T i |> Option.map (rpair T)
349.9 - | _ => NONE))
349.10 + if i < 0 then NONE else
349.11 + (case lookup_builtin_typ ctxt T of
349.12 + SOME (_, Int (_, g)) => g T i |> Option.map (rpair T)
349.13 + | _ => NONE))
349.14
349.15 val is_builtin_num = is_some oo dest_builtin_num
349.16
350.1 --- a/src/HOL/Tools/SMT/smt_normalize.ML Thu Dec 05 17:52:12 2013 +0100
350.2 +++ b/src/HOL/Tools/SMT/smt_normalize.ML Thu Dec 05 17:58:03 2013 +0100
350.3 @@ -526,25 +526,26 @@
350.4
350.5 local
350.6 (*
350.7 - rewrite negative numerals into positive numerals,
350.8 - rewrite Numeral0 into 0
350.9 rewrite Numeral1 into 1
350.10 + rewrite - 0 into 0
350.11 *)
350.12
350.13 - fun is_strange_number ctxt (t as Const (@{const_name neg_numeral}, _) $ _) =
350.14 - (case try HOLogic.dest_number t of
350.15 - SOME (_, i) => SMT_Builtin.is_builtin_num ctxt t andalso i < 2
350.16 - | NONE => false)
350.17 - | is_strange_number _ _ = false
350.18 + fun is_irregular_number (Const (@{const_name numeral}, _) $ Const (@{const_name num.One}, _)) =
350.19 + true
350.20 + | is_irregular_number (Const (@{const_name uminus}, _) $ Const (@{const_name Groups.zero}, _)) =
350.21 + true
350.22 + | is_irregular_number _ =
350.23 + false;
350.24
350.25 - val pos_num_ss =
350.26 + fun is_strange_number ctxt t = is_irregular_number t andalso SMT_Builtin.is_builtin_num ctxt t;
350.27 +
350.28 + val proper_num_ss =
350.29 simpset_of (put_simpset HOL_ss @{context}
350.30 - addsimps [@{thm Num.numeral_One}]
350.31 - addsimps [@{thm Num.neg_numeral_def}])
350.32 + addsimps @{thms Num.numeral_One minus_zero})
350.33
350.34 fun norm_num_conv ctxt =
350.35 SMT_Utils.if_conv (is_strange_number ctxt)
350.36 - (Simplifier.rewrite (put_simpset pos_num_ss ctxt)) Conv.no_conv
350.37 + (Simplifier.rewrite (put_simpset proper_num_ss ctxt)) Conv.no_conv
350.38 in
350.39
350.40 fun normalize_numerals_conv ctxt =
351.1 --- a/src/HOL/Tools/SMT/smt_utils.ML Thu Dec 05 17:52:12 2013 +0100
351.2 +++ b/src/HOL/Tools/SMT/smt_utils.ML Thu Dec 05 17:58:03 2013 +0100
351.3 @@ -140,7 +140,6 @@
351.4 is_num env t andalso is_num env u
351.5 | is_num env (Const (@{const_name Let}, _) $ t $ Abs (_, _, u)) =
351.6 is_num (t :: env) u
351.7 - | is_num env (Const (@{const_name uminus}, _) $ t) = is_num env t
351.8 | is_num env (Bound i) = i < length env andalso is_num env (nth env i)
351.9 | is_num _ t = can HOLogic.dest_number t
351.10 in is_num [] end
352.1 --- a/src/HOL/Tools/Sledgehammer/MaSh/etc/settings Thu Dec 05 17:52:12 2013 +0100
352.2 +++ b/src/HOL/Tools/Sledgehammer/MaSh/etc/settings Thu Dec 05 17:58:03 2013 +0100
352.3 @@ -3,4 +3,6 @@
352.4 ISABELLE_SLEDGEHAMMER_MASH="$COMPONENT"
352.5
352.6 # MASH=yes
352.7 -MASH_PORT=9255
352.8 +if [ -z "$MASH_PORT" ]; then
352.9 + MASH_PORT=9255
352.10 +fi
353.1 --- a/src/HOL/Tools/Sledgehammer/MaSh/src/dictionaries.py Thu Dec 05 17:52:12 2013 +0100
353.2 +++ b/src/HOL/Tools/Sledgehammer/MaSh/src/dictionaries.py Thu Dec 05 17:58:03 2013 +0100
353.3 @@ -4,11 +4,12 @@
353.4 #
353.5 # Persistent dictionaries: accessibility, dependencies, and features.
353.6
353.7 -import logging,sys
353.8 +import sys
353.9 from os.path import join
353.10 from Queue import Queue
353.11 from readData import create_accessible_dict,create_dependencies_dict
353.12 from cPickle import load,dump
353.13 +from exceptions import LookupError
353.14
353.15 class Dictionaries(object):
353.16 '''
353.17 @@ -21,7 +22,7 @@
353.18 self.nameIdDict = {}
353.19 self.idNameDict = {}
353.20 self.featureIdDict={}
353.21 - self.maxNameId = 0
353.22 + self.maxNameId = 1
353.23 self.maxFeatureId = 0
353.24 self.featureDict = {}
353.25 self.dependenciesDict = {}
353.26 @@ -29,6 +30,9 @@
353.27 self.expandedAccessibles = {}
353.28 self.accFile = ''
353.29 self.changed = True
353.30 + # Unnamed facts
353.31 + self.nameIdDict[''] = 0
353.32 + self.idNameDict[0] = 'Unnamed Fact'
353.33
353.34 """
353.35 Init functions. nameIdDict, idNameDict, featureIdDict, articleDict get filled!
353.36 @@ -56,7 +60,6 @@
353.37 self.changed = True
353.38
353.39 def create_feature_dict(self,inputFile):
353.40 - logger = logging.getLogger('create_feature_dict')
353.41 self.featureDict = {}
353.42 IS = open(inputFile,'r')
353.43 for line in IS:
353.44 @@ -64,7 +67,7 @@
353.45 name = line[0]
353.46 # Name Id
353.47 if self.nameIdDict.has_key(name):
353.48 - logger.warning('%s appears twice in the feature file. Aborting.',name)
353.49 + raise LookupError('%s appears twice in the feature file. Aborting.'% name)
353.50 sys.exit(-1)
353.51 else:
353.52 self.nameIdDict[name] = self.maxNameId
353.53 @@ -134,6 +137,13 @@
353.54 unexpandedQueue.put(a)
353.55 return list(accessibles)
353.56
353.57 + def parse_unExpAcc(self,line):
353.58 + try:
353.59 + unExpAcc = [self.nameIdDict[a.strip()] for a in line.split()]
353.60 + except:
353.61 + raise LookupError('Cannot find the accessibles:%s. Accessibles need to be introduced before referring to them.' % line)
353.62 + return unExpAcc
353.63 +
353.64 def parse_fact(self,line):
353.65 """
353.66 Parses a single line, extracting accessibles, features, and dependencies.
353.67 @@ -146,12 +156,18 @@
353.68 name = line[0].strip()
353.69 nameId = self.get_name_id(name)
353.70 line = line[1].split(';')
353.71 - # Accessible Ids
353.72 - unExpAcc = [self.nameIdDict[a.strip()] for a in line[0].split()]
353.73 - self.accessibleDict[nameId] = unExpAcc
353.74 features = self.get_features(line)
353.75 self.featureDict[nameId] = features
353.76 - self.dependenciesDict[nameId] = [self.nameIdDict[d.strip()] for d in line[2].split()]
353.77 + try:
353.78 + self.dependenciesDict[nameId] = [self.nameIdDict[d.strip()] for d in line[2].split()]
353.79 + except:
353.80 + unknownDeps = []
353.81 + for d in line[2].split():
353.82 + if not self.nameIdDict.has_key(d):
353.83 + unknownDeps.append(d)
353.84 + raise LookupError('Unknown fact used as dependency: %s. Facts need to be introduced before being used as depedency.' % ','.join(unknownDeps))
353.85 + self.accessibleDict[nameId] = self.parse_unExpAcc(line[0])
353.86 +
353.87 self.changed = True
353.88 return nameId
353.89
353.90 @@ -165,9 +181,18 @@
353.91 # line = name:dependencies
353.92 line = line.split(':')
353.93 name = line[0].strip()
353.94 - nameId = self.get_name_id(name)
353.95 -
353.96 - dependencies = [self.nameIdDict[d.strip()] for d in line[1].split()]
353.97 + try:
353.98 + nameId = self.nameIdDict[name]
353.99 + except:
353.100 + raise LookupError('Trying to overwrite dependencies for unknown fact: %s. Facts need to be introduced before overwriting them.' % name)
353.101 + try:
353.102 + dependencies = [self.nameIdDict[d.strip()] for d in line[1].split()]
353.103 + except:
353.104 + unknownDeps = []
353.105 + for d in line[1].split():
353.106 + if not self.nameIdDict.has_key(d):
353.107 + unknownDeps.append(d)
353.108 + raise LookupError('Unknown fact used as dependency: %s. Facts need to be introduced before being used as depedency.' % ','.join(unknownDeps))
353.109 self.changed = True
353.110 return nameId,dependencies
353.111
353.112 @@ -180,7 +205,7 @@
353.113 name = None
353.114 numberOfPredictions = None
353.115
353.116 - # Check whether there is a problem name:
353.117 + # How many predictions should be returned:
353.118 tmp = line.split('#')
353.119 if len(tmp) == 2:
353.120 numberOfPredictions = int(tmp[0].strip())
353.121 @@ -194,8 +219,11 @@
353.122
353.123 # line = accessibles;features
353.124 line = line.split(';')
353.125 + features = self.get_features(line)
353.126 +
353.127 # Accessible Ids, expand and store the accessibles.
353.128 - unExpAcc = [self.nameIdDict[a.strip()] for a in line[0].split()]
353.129 + #unExpAcc = [self.nameIdDict[a.strip()] for a in line[0].split()]
353.130 + unExpAcc = self.parse_unExpAcc(line[0])
353.131 if len(self.expandedAccessibles.keys())>=100:
353.132 self.expandedAccessibles = {}
353.133 self.changed = True
353.134 @@ -205,7 +233,7 @@
353.135 self.expandedAccessibles[accId] = self.expand_accessibles(accIdAcc)
353.136 self.changed = True
353.137 accessibles = self.expand_accessibles(unExpAcc)
353.138 - features = self.get_features(line)
353.139 +
353.140 # Get hints:
353.141 if len(line) == 3:
353.142 hints = [self.nameIdDict[d.strip()] for d in line[2].split()]
354.1 --- a/src/HOL/Tools/Sledgehammer/MaSh/src/mash.py Thu Dec 05 17:52:12 2013 +0100
354.2 +++ b/src/HOL/Tools/Sledgehammer/MaSh/src/mash.py Thu Dec 05 17:58:03 2013 +0100
354.3 @@ -22,13 +22,25 @@
354.4 from parameters import init_parser
354.5
354.6 def communicate(data,host,port):
354.7 - sock = socket.socket(socket.AF_INET, socket.SOCK_STREAM)
354.8 + logger = logging.getLogger('communicate')
354.9 + sock = socket.socket(socket.AF_INET, socket.SOCK_STREAM)
354.10 try:
354.11 sock.connect((host,port))
354.12 - sock.sendall(data)
354.13 - received = sock.recv(4194304)
354.14 - except:
354.15 - logger = logging.getLogger('communicate')
354.16 + sock.sendall(data+'\n')
354.17 + received = ''
354.18 + cont = True
354.19 + counter = 0
354.20 + while cont and counter < 100000:
354.21 + rec = sock.recv(4096)
354.22 + if rec.endswith('stop'):
354.23 + cont = False
354.24 + received += rec[:-4]
354.25 + else:
354.26 + received += rec
354.27 + counter += 1
354.28 + if rec == '':
354.29 + logger.warning('No response from server. Check server log for details.')
354.30 + except:
354.31 logger.warning('Communication with server failed.')
354.32 received = -1
354.33 finally:
355.1 --- a/src/HOL/Tools/Sledgehammer/MaSh/src/readData.py Thu Dec 05 17:52:12 2013 +0100
355.2 +++ b/src/HOL/Tools/Sledgehammer/MaSh/src/readData.py Thu Dec 05 17:58:03 2013 +0100
355.3 @@ -29,7 +29,10 @@
355.4 nameId = nameIdDict[name]
355.5 dependenciesIds = [nameIdDict[f.strip()] for f in line[1].split()]
355.6 # Store results, add p proves p
355.7 - dependenciesDict[nameId] = [nameId] + dependenciesIds
355.8 + if nameId == 0:
355.9 + dependenciesDict[nameId] = dependenciesIds
355.10 + else:
355.11 + dependenciesDict[nameId] = [nameId] + dependenciesIds
355.12 IS.close()
355.13 return dependenciesDict
355.14
356.1 --- a/src/HOL/Tools/Sledgehammer/MaSh/src/server.py Thu Dec 05 17:52:12 2013 +0100
356.2 +++ b/src/HOL/Tools/Sledgehammer/MaSh/src/server.py Thu Dec 05 17:58:03 2013 +0100
356.3 @@ -14,12 +14,14 @@
356.4 from sparseNaiveBayes import sparseNBClassifier
356.5 from KNN import KNN,euclidean
356.6 from KNNs import KNNAdaptPointFeatures,KNNUrban
356.7 +#from bayesPlusMetric import sparseNBPlusClassifier
356.8 from predefined import Predefined
356.9 from ExpandFeatures import ExpandFeatures
356.10 from stats import Statistics
356.11
356.12
356.13 -class ThreadingTCPServer(SocketServer.ThreadingTCPServer):
356.14 +class ThreadingTCPServer(SocketServer.ThreadingTCPServer):
356.15 +
356.16 def __init__(self, *args, **kwargs):
356.17 SocketServer.ThreadingTCPServer.__init__(self,*args, **kwargs)
356.18 self.manager = Manager()
356.19 @@ -27,8 +29,17 @@
356.20 self.idle_timeout = 28800.0 # 8 hours in seconds
356.21 self.idle_timer = Timer(self.idle_timeout, self.shutdown)
356.22 self.idle_timer.start()
356.23 + self.model = None
356.24 + self.dicts = None
356.25 + self.callCounter = 0
356.26
356.27 def save(self):
356.28 + if self.model == None or self.dicts == None:
356.29 + try:
356.30 + self.logger.warning('Cannot save nonexisting models.')
356.31 + except:
356.32 + pass
356.33 + return
356.34 # Save Models
356.35 self.model.save(self.args.modelFile)
356.36 self.dicts.save(self.args.dictsFile)
356.37 @@ -40,7 +51,7 @@
356.38 self.save()
356.39 self.shutdown()
356.40
356.41 -class MaShHandler(SocketServer.BaseRequestHandler):
356.42 +class MaShHandler(SocketServer.StreamRequestHandler):
356.43
356.44 def init(self,argv):
356.45 if argv == '':
356.46 @@ -48,15 +59,28 @@
356.47 else:
356.48 argv = argv.split(';')
356.49 self.server.args = init_parser(argv)
356.50 +
356.51 + # Set up logging
356.52 + logging.basicConfig(level=logging.DEBUG,
356.53 + format='%(asctime)s %(name)-12s %(levelname)-8s %(message)s',
356.54 + datefmt='%d-%m %H:%M:%S',
356.55 + filename=self.server.args.log+'server',
356.56 + filemode='w')
356.57 + self.server.logger = logging.getLogger('server')
356.58 +
356.59 # Load all data
356.60 self.server.dicts = Dictionaries()
356.61 if os.path.isfile(self.server.args.dictsFile):
356.62 - self.server.dicts.load(self.server.args.dictsFile)
356.63 + self.server.dicts.load(self.server.args.dictsFile)
356.64 + #elif not self.server.args.dictsFile == '../tmp/dict.pickle':
356.65 + # raise IOError('Cannot find dictsFile at %s '% self.server.args.dictsFile)
356.66 elif self.server.args.init:
356.67 self.server.dicts.init_all(self.server.args)
356.68 # Pick model
356.69 if self.server.args.algorithm == 'nb':
356.70 - self.server.model = sparseNBClassifier(self.server.args.NBDefaultPriorWeight,self.server.args.NBPosWeight,self.server.args.NBDefVal)
356.71 + ###TODO: !!
356.72 + self.server.model = sparseNBClassifier(self.server.args.NBDefaultPriorWeight,self.server.args.NBPosWeight,self.server.args.NBDefVal)
356.73 + #self.server.model = sparseNBPlusClassifier(self.server.args.NBDefaultPriorWeight,self.server.args.NBPosWeight,self.server.args.NBDefVal)
356.74 elif self.server.args.algorithm == 'KNN':
356.75 #self.server.model = KNN(self.server.dicts)
356.76 self.server.model = KNNAdaptPointFeatures(self.server.dicts)
356.77 @@ -70,6 +94,8 @@
356.78 # Create Model
356.79 if os.path.isfile(self.server.args.modelFile):
356.80 self.server.model.load(self.server.args.modelFile)
356.81 + #elif not self.server.args.modelFile == '../tmp/model.pickle':
356.82 + # raise IOError('Cannot find modelFile at %s '% self.server.args.modelFile)
356.83 elif self.server.args.init:
356.84 trainData = self.server.dicts.featureDict.keys()
356.85 self.server.model.initializeModel(trainData,self.server.dicts)
356.86 @@ -79,13 +105,6 @@
356.87 self.server.statementCounter = 1
356.88 self.server.computeStats = False
356.89
356.90 - # Set up logging
356.91 - logging.basicConfig(level=logging.DEBUG,
356.92 - format='%(asctime)s %(name)-12s %(levelname)-8s %(message)s',
356.93 - datefmt='%d-%m %H:%M:%S',
356.94 - filename=self.server.args.log+'server',
356.95 - filemode='w')
356.96 - self.server.logger = logging.getLogger('server')
356.97 self.server.logger.debug('Initialized in '+str(round(time()-self.startTime,2))+' seconds.')
356.98 self.request.sendall('Server initialized in '+str(round(time()-self.startTime,2))+' seconds.')
356.99 self.server.callCounter = 1
356.100 @@ -107,8 +126,11 @@
356.101 if self.server.args.expandFeatures:
356.102 self.server.expandFeatures.update(self.server.dicts.featureDict[problemId],self.server.dicts.dependenciesDict[problemId])
356.103 # Update Dependencies, p proves p
356.104 - self.server.dicts.dependenciesDict[problemId] = [problemId]+self.server.dicts.dependenciesDict[problemId]
356.105 + if not problemId == 0:
356.106 + self.server.dicts.dependenciesDict[problemId] = [problemId]+self.server.dicts.dependenciesDict[problemId]
356.107 + ###TODO:
356.108 self.server.model.update(problemId,self.server.dicts.featureDict[problemId],self.server.dicts.dependenciesDict[problemId])
356.109 + #self.server.model.update(problemId,self.server.dicts.featureDict[problemId],self.server.dicts.dependenciesDict[problemId],self.server.dicts)
356.110
356.111 def overwrite(self):
356.112 # Overwrite old proof.
356.113 @@ -140,7 +162,7 @@
356.114 #predictionValues = [str(x) for x in predictionValues[:numberOfPredictions]]
356.115 #predictionsStringList = ['%s=%s' % (predictionNames[i],predictionValues[i]) for i in range(len(predictionNames))]
356.116 #predictionsString = string.join(predictionsStringList,' ')
356.117 - predictionsString = string.join(predictionNames,' ')
356.118 + predictionsString = string.join(predictionNames,' ')
356.119 outString = '%s: %s' % (name,predictionsString)
356.120 self.request.sendall(outString)
356.121
356.122 @@ -154,15 +176,15 @@
356.123
356.124 def handle(self):
356.125 # self.request is the TCP socket connected to the client
356.126 - self.data = self.request.recv(4194304).strip()
356.127 self.server.lock.acquire()
356.128 + self.data = self.rfile.readline().strip()
356.129 try:
356.130 # Update idle shutdown timer
356.131 self.server.idle_timer.cancel()
356.132 self.server.idle_timer = Timer(self.server.idle_timeout, self.server.save_and_shutdown)
356.133 self.server.idle_timer.start()
356.134
356.135 - self.startTime = time()
356.136 + self.startTime = time()
356.137 if self.data == 'shutdown':
356.138 self.shutdown()
356.139 elif self.data == 'save':
356.140 @@ -189,12 +211,19 @@
356.141 else:
356.142 self.request.sendall('Unspecified input format: \n%s',self.data)
356.143 self.server.callCounter += 1
356.144 + self.request.sendall('stop')
356.145 + except: # catch exceptions
356.146 + #print 'Caught an error. Check %s for more details' % (self.server.args.log+'server')
356.147 + logging.exception('')
356.148 finally:
356.149 self.server.lock.release()
356.150
356.151 if __name__ == "__main__":
356.152 - HOST, PORT = sys.argv[1:]
356.153 - #HOST, PORT = "localhost", 9255
356.154 + if not len(sys.argv[1:]) == 2:
356.155 + print 'No Arguments for HOST and PORT found. Using localhost and 9255'
356.156 + HOST, PORT = "localhost", 9255
356.157 + else:
356.158 + HOST, PORT = sys.argv[1:]
356.159 SocketServer.TCPServer.allow_reuse_address = True
356.160 server = ThreadingTCPServer((HOST, int(PORT)), MaShHandler)
356.161 server.serve_forever()
357.1 --- a/src/HOL/Tools/Sledgehammer/MaSh/src/sparseNaiveBayes.py Thu Dec 05 17:52:12 2013 +0100
357.2 +++ b/src/HOL/Tools/Sledgehammer/MaSh/src/sparseNaiveBayes.py Thu Dec 05 17:58:03 2013 +0100
357.3 @@ -41,10 +41,11 @@
357.4 self.counts[d] = [self.defaultPriorWeight,dFeatureCounts]
357.5
357.6 for key,keyDeps in dicts.dependenciesDict.iteritems():
357.7 + keyFeatures = dicts.featureDict[key]
357.8 for dep in keyDeps:
357.9 self.counts[dep][0] += 1
357.10 - depFeatures = dicts.featureDict[key]
357.11 - for f in depFeatures.iterkeys():
357.12 + #depFeatures = dicts.featureDict[key]
357.13 + for f in keyFeatures.iterkeys():
357.14 if self.counts[dep][1].has_key(f):
357.15 self.counts[dep][1][f] += 1
357.16 else:
357.17 @@ -55,7 +56,7 @@
357.18 """
357.19 Updates the Model.
357.20 """
357.21 - if not self.counts.has_key(dataPoint):
357.22 + if (not self.counts.has_key(dataPoint)) and (not dataPoint == 0):
357.23 dFeatureCounts = {}
357.24 # Give p |- p a higher weight
357.25 if not self.defaultPriorWeight == 0:
357.26 @@ -78,13 +79,18 @@
357.27 self.counts[dep][0] -= 1
357.28 for f,_w in features.items():
357.29 self.counts[dep][1][f] -= 1
357.30 + if self.counts[dep][1][f] == 0:
357.31 + del self.counts[dep][1][f]
357.32
357.33
357.34 def overwrite(self,problemId,newDependencies,dicts):
357.35 """
357.36 Deletes the old dependencies of problemId and replaces them with the new ones. Updates the model accordingly.
357.37 """
357.38 - assert self.counts.has_key(problemId)
357.39 + try:
357.40 + assert self.counts.has_key(problemId)
357.41 + except:
357.42 + raise LookupError('Trying to overwrite dependencies for unknown fact: %s. Facts need to be introduced before overwriting them.' % dicts.idNameDict[problemId])
357.43 oldDeps = dicts.dependenciesDict[problemId]
357.44 features = dicts.featureDict[problemId]
357.45 self.delete(problemId,features,oldDeps)
358.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_annotate.ML Thu Dec 05 17:52:12 2013 +0100
358.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_annotate.ML Thu Dec 05 17:58:03 2013 +0100
358.3 @@ -17,7 +17,7 @@
358.4 signature SLEDGEHAMMER_ANNOTATE =
358.5 sig
358.6 val annotate_types : Proof.context -> term -> term
358.7 -end
358.8 +end;
358.9
358.10 structure Sledgehammer_Annotate : SLEDGEHAMMER_ANNOTATE =
358.11 struct
358.12 @@ -215,4 +215,4 @@
358.13 |> sort int_ord
358.14 in introduce_annotations subst typing_spots t t' end
358.15
358.16 -end
358.17 +end;
359.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_compress.ML Thu Dec 05 17:52:12 2013 +0100
359.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_compress.ML Thu Dec 05 17:58:03 2013 +0100
359.3 @@ -15,8 +15,7 @@
359.4 type preplay_interface = Sledgehammer_Preplay.preplay_interface
359.5
359.6 val compress_proof : real -> preplay_interface -> isar_proof -> isar_proof
359.7 -end
359.8 -
359.9 +end;
359.10
359.11 structure Sledgehammer_Compress : SLEDGEHAMMER_COMPRESS =
359.12 struct
359.13 @@ -148,10 +147,9 @@
359.14 val (get_successors : label -> label list,
359.15 replace_successor: label -> label list -> label -> unit) =
359.16 let
359.17 -
359.18 fun add_refs (Let _) tab = tab
359.19 - | add_refs (Prove (_, _, l as v, _, _, By ((lfs, _), _))) tab =
359.20 - fold (fn lf as key => Canonical_Lbl_Tab.cons_list (key, v)) lfs tab
359.21 + | add_refs (Prove (_, _, v, _, _, By ((lfs, _), _))) tab =
359.22 + fold (fn key => Canonical_Lbl_Tab.cons_list (key, v)) lfs tab
359.23
359.24 val tab =
359.25 Canonical_Lbl_Tab.empty
359.26 @@ -180,7 +178,7 @@
359.27 if null subs orelse not (compress_further ()) then
359.28 (set_preplay_time l (false, time);
359.29 Prove (qs, fix, l, t, List.revAppend (nontriv_subs, subs),
359.30 - By_Metis (lfs, gfs)) )
359.31 + By ((lfs, gfs), MetisM)))
359.32 else
359.33 case subs of
359.34 ((sub as Proof(_, Assume assms, sub_steps)) :: subs) =>
359.35 @@ -199,7 +197,7 @@
359.36 subtract (op =) (map fst assms) lfs'
359.37 |> union (op =) lfs
359.38 val gfs'' = union (op =) gfs' gfs
359.39 - val by = By_Metis (lfs'', gfs'')
359.40 + val by = By ((lfs'', gfs''), MetisM)
359.41 val step'' = Prove (qs, fix, l, t, subs'', by)
359.42
359.43 (* check if the modified step can be preplayed fast enough *)
359.44 @@ -251,7 +249,7 @@
359.45
359.46 val candidates =
359.47 let
359.48 - fun add_cand (i, Let _) = I
359.49 + fun add_cand (_, Let _) = I
359.50 | add_cand (i, Prove (_, _, l, t, _, _)) =
359.51 cons (i, l, size_of_term t)
359.52 in
359.53 @@ -260,7 +258,7 @@
359.54 |> fold_index add_cand) []
359.55 end
359.56
359.57 - fun try_eliminate (cand as (i, l, _)) succ_lbls steps =
359.58 + fun try_eliminate (i, l, _) succ_lbls steps =
359.59 let
359.60 (* only touch steps that can be preplayed successfully *)
359.61 val (false, time) = get_preplay_time l
359.62 @@ -371,5 +369,4 @@
359.63 do_proof proof
359.64 end
359.65
359.66 -
359.67 -end
359.68 +end;
360.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_fact.ML Thu Dec 05 17:52:12 2013 +0100
360.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_fact.ML Thu Dec 05 17:58:03 2013 +0100
360.3 @@ -39,6 +39,7 @@
360.4 val nearly_all_facts :
360.5 Proof.context -> bool -> fact_override -> unit Symtab.table
360.6 -> status Termtab.table -> thm list -> term list -> term -> raw_fact list
360.7 + val drop_duplicate_facts : raw_fact list -> raw_fact list
360.8 end;
360.9
360.10 structure Sledgehammer_Fact : SLEDGEHAMMER_FACT =
360.11 @@ -57,6 +58,11 @@
360.12 del : (Facts.ref * Attrib.src list) list,
360.13 only : bool}
360.14
360.15 +(* gracefully handle huge background theories *)
360.16 +val max_facts_for_duplicates = 50000
360.17 +val max_facts_for_complex_check = 25000
360.18 +val max_simps_for_clasimpset = 10000
360.19 +
360.20 (* experimental feature *)
360.21 val instantiate_inducts =
360.22 Attrib.setup_config_bool @{binding sledgehammer_instantiate_inducts} (K false)
360.23 @@ -102,6 +108,7 @@
360.24 body_type T = @{typ bool}
360.25 | _ => false)
360.26
360.27 +(* TODO: get rid of *)
360.28 fun normalize_vars t =
360.29 let
360.30 fun normT (Type (s, Ts)) = fold_map normT Ts #>> curry Type s
360.31 @@ -126,25 +133,31 @@
360.32 in fst (norm t (([], 0), ([], 0))) end
360.33
360.34 fun status_of_thm css name th =
360.35 - let val t = normalize_vars (prop_of th) in
360.36 - (* FIXME: use structured name *)
360.37 - if String.isSubstring ".induct" name andalso may_be_induction t then
360.38 - Induction
360.39 - else case Termtab.lookup css t of
360.40 - SOME status => status
360.41 - | NONE =>
360.42 - let val concl = Logic.strip_imp_concl t in
360.43 - case try (HOLogic.dest_eq o HOLogic.dest_Trueprop) concl of
360.44 - SOME lrhss =>
360.45 - let
360.46 - val prems = Logic.strip_imp_prems t
360.47 - val t' = Logic.list_implies (prems, Logic.mk_equals lrhss)
360.48 - in
360.49 - Termtab.lookup css t' |> the_default General
360.50 - end
360.51 - | NONE => General
360.52 - end
360.53 - end
360.54 + if Termtab.is_empty css then
360.55 + General
360.56 + else
360.57 + let val t = prop_of th in
360.58 + (* FIXME: use structured name *)
360.59 + if String.isSubstring ".induct" name andalso may_be_induction t then
360.60 + Induction
360.61 + else
360.62 + let val t = normalize_vars t in
360.63 + case Termtab.lookup css t of
360.64 + SOME status => status
360.65 + | NONE =>
360.66 + let val concl = Logic.strip_imp_concl t in
360.67 + case try (HOLogic.dest_eq o HOLogic.dest_Trueprop) concl of
360.68 + SOME lrhss =>
360.69 + let
360.70 + val prems = Logic.strip_imp_prems t
360.71 + val t' = Logic.list_implies (prems, Logic.mk_equals lrhss)
360.72 + in
360.73 + Termtab.lookup css t' |> the_default General
360.74 + end
360.75 + | NONE => General
360.76 + end
360.77 + end
360.78 + end
360.79
360.80 fun stature_of_thm global assms chained css name th =
360.81 (scope_of_thm global assms chained th, status_of_thm css name th)
360.82 @@ -219,10 +232,11 @@
360.83
360.84 val sep_that = Long_Name.separator ^ Obtain.thatN
360.85
360.86 +val skolem_thesis = Name.skolem Auto_Bind.thesisN
360.87 +
360.88 fun is_that_fact th =
360.89 - String.isSuffix sep_that (Thm.get_name_hint th)
360.90 - andalso exists_subterm (fn Free (s, _) => s = Name.skolem Auto_Bind.thesisN
360.91 - | _ => false) (prop_of th)
360.92 + exists_subterm (fn Free (s, _) => s = skolem_thesis | _ => false) (prop_of th)
360.93 + andalso String.isSuffix sep_that (Thm.get_name_hint th)
360.94
360.95 datatype interest = Deal_Breaker | Interesting | Boring
360.96
360.97 @@ -295,9 +309,7 @@
360.98 fun backquote_term ctxt = close_form #> hackish_string_of_term ctxt #> backquote
360.99 fun backquote_thm ctxt = backquote_term ctxt o prop_of
360.100
360.101 -(* gracefully handle huge background theories *)
360.102 -val max_simps_for_clasimpset = 10000
360.103 -
360.104 +(* TODO: rewrite to use nets and/or to reuse existing data structures *)
360.105 fun clasimpset_rule_table_of ctxt =
360.106 let val simps = ctxt |> simpset_of |> dest_ss |> #simps in
360.107 if length simps >= max_simps_for_clasimpset then
360.108 @@ -336,18 +348,16 @@
360.109 end
360.110 end
360.111
360.112 -fun normalize_eq (t as @{const Trueprop}
360.113 - $ ((t0 as Const (@{const_name HOL.eq}, _)) $ t1 $ t2)) =
360.114 - if Term_Ord.fast_term_ord (t1, t2) <> GREATER then t
360.115 - else HOLogic.mk_Trueprop (t0 $ t2 $ t1)
360.116 - | normalize_eq (t as @{const Trueprop} $ (@{const Not}
360.117 +fun normalize_eq (@{const Trueprop} $ (t as (t0 as Const (@{const_name HOL.eq}, _)) $ t1 $ t2)) =
360.118 + if Term_Ord.fast_term_ord (t1, t2) <> GREATER then t else t0 $ t2 $ t1
360.119 + | normalize_eq (@{const Trueprop} $ (t as @{const Not}
360.120 $ ((t0 as Const (@{const_name HOL.eq}, _)) $ t1 $ t2))) =
360.121 - if Term_Ord.fast_term_ord (t1, t2) <> GREATER then t
360.122 - else HOLogic.mk_Trueprop (HOLogic.mk_not (t0 $ t2 $ t1))
360.123 + if Term_Ord.fast_term_ord (t1, t2) <> GREATER then t else HOLogic.mk_not (t0 $ t2 $ t1)
360.124 + | normalize_eq (Const (@{const_name "=="}, Type (_, [T, _])) $ t1 $ t2) =
360.125 + (if Term_Ord.fast_term_ord (t1, t2) <> GREATER then (t1, t2) else (t2, t1))
360.126 + |> (fn (t1, t2) => HOLogic.eq_const T $ t1 $ t2)
360.127 | normalize_eq t = t
360.128
360.129 -val normalize_eq_vars = normalize_eq #> normalize_vars
360.130 -
360.131 fun if_thm_before th th' =
360.132 if Theory.subthy (pairself Thm.theory_of_thm (th, th')) then th else th'
360.133
360.134 @@ -361,30 +371,22 @@
360.135
360.136 fun build_name_tables name_of facts =
360.137 let
360.138 - fun cons_thm (_, th) =
360.139 - Termtab.cons_list (normalize_eq_vars (prop_of th), th)
360.140 + fun cons_thm (_, th) = Termtab.cons_list (normalize_vars (normalize_eq (prop_of th)), th)
360.141 fun add_plain canon alias =
360.142 - Symtab.update (Thm.get_name_hint alias,
360.143 - name_of (if_thm_before canon alias))
360.144 + Symtab.update (Thm.get_name_hint alias, name_of (if_thm_before canon alias))
360.145 fun add_plains (_, aliases as canon :: _) = fold (add_plain canon) aliases
360.146 - fun add_inclass (name, target) =
360.147 - fold (fn s => Symtab.update (s, target)) (un_class_ify name)
360.148 + fun add_inclass (name, target) = fold (fn s => Symtab.update (s, target)) (un_class_ify name)
360.149 val prop_tab = fold cons_thm facts Termtab.empty
360.150 val plain_name_tab = Termtab.fold add_plains prop_tab Symtab.empty
360.151 val inclass_name_tab = Symtab.fold add_inclass plain_name_tab Symtab.empty
360.152 in (plain_name_tab, inclass_name_tab) end
360.153
360.154 -fun keyed_distinct key_of xs =
360.155 - let val tab = fold (Termtab.default o `key_of) xs Termtab.empty in
360.156 - Termtab.fold (cons o snd) tab []
360.157 - end
360.158 -
360.159 -fun hashed_keyed_distinct hash_of key_of xs =
360.160 - let
360.161 - val ys = map (`hash_of) xs
360.162 - val sorted_ys = sort (int_ord o pairself fst) ys
360.163 - val grouped_ys = AList.coalesce (op =) sorted_ys
360.164 - in maps (keyed_distinct key_of o snd) grouped_ys end
360.165 +fun fact_distinct eq facts =
360.166 + fold (fn fact as (_, th) =>
360.167 + Net.insert_term_safe (eq o pairself (normalize_eq o prop_of o snd))
360.168 + (normalize_eq (prop_of th), fact))
360.169 + facts Net.empty
360.170 + |> Net.entries
360.171
360.172 fun struct_induct_rule_on th =
360.173 case Logic.strip_horn (prop_of th) of
360.174 @@ -447,9 +449,6 @@
360.175
360.176 fun fact_count facts = Facts.fold_static (K (Integer.add 1)) facts 0
360.177
360.178 -(* gracefully handle huge background theories *)
360.179 -val max_facts_for_complex_check = 25000
360.180 -
360.181 fun all_facts ctxt generous ho_atp reserved add_ths chained css =
360.182 let
360.183 val thy = Proof_Context.theory_of ctxt
360.184 @@ -473,12 +472,12 @@
360.185 Name_Space.merge (Facts.space_of global_facts, Facts.space_of local_facts)
360.186 val is_blacklisted_or_something = is_blacklisted_or_something ctxt ho_atp
360.187 fun add_facts global foldx facts =
360.188 - foldx (fn (name0, ths) =>
360.189 + foldx (fn (name0, ths) => fn accum =>
360.190 if name0 <> "" andalso
360.191 forall (not o member Thm.eq_thm_prop add_ths) ths andalso
360.192 (Facts.is_concealed facts name0 orelse
360.193 (not generous andalso is_blacklisted_or_something name0)) then
360.194 - I
360.195 + accum
360.196 else
360.197 let
360.198 val n = length ths
360.199 @@ -488,32 +487,30 @@
360.200 NONE => false
360.201 | SOME ths' => eq_list Thm.eq_thm_prop (ths, ths')
360.202 in
360.203 - pair n
360.204 - #> fold_rev (fn th => fn (j, accum) =>
360.205 - (j - 1,
360.206 - if not (member Thm.eq_thm_prop add_ths th) andalso
360.207 - (is_likely_tautology_too_meta_or_too_technical th orelse
360.208 - is_too_complex (prop_of th)) then
360.209 - accum
360.210 - else
360.211 - let
360.212 - val new =
360.213 - (((fn () =>
360.214 - if name0 = "" then
360.215 - backquote_thm ctxt th
360.216 - else
360.217 - [Facts.extern ctxt facts name0,
360.218 - Name_Space.extern ctxt full_space name0]
360.219 - |> distinct (op =)
360.220 - |> find_first check_thms
360.221 - |> the_default name0
360.222 - |> make_name reserved multi j),
360.223 - stature_of_thm global assms chained css name0 th),
360.224 - th)
360.225 - in
360.226 - accum |> (if multi then apsnd else apfst) (cons new)
360.227 - end)) ths
360.228 - #> snd
360.229 + snd (fold_rev (fn th => fn (j, accum as (uni_accum, multi_accum)) =>
360.230 + (j - 1,
360.231 + if not (member Thm.eq_thm_prop add_ths th) andalso
360.232 + (is_likely_tautology_too_meta_or_too_technical th orelse
360.233 + is_too_complex (prop_of th)) then
360.234 + accum
360.235 + else
360.236 + let
360.237 + val new =
360.238 + (((fn () =>
360.239 + if name0 = "" then
360.240 + backquote_thm ctxt th
360.241 + else
360.242 + [Facts.extern ctxt facts name0,
360.243 + Name_Space.extern ctxt full_space name0]
360.244 + |> find_first check_thms
360.245 + |> the_default name0
360.246 + |> make_name reserved multi j),
360.247 + stature_of_thm global assms chained css name0 th),
360.248 + th)
360.249 + in
360.250 + if multi then (uni_accum, new :: multi_accum)
360.251 + else (new :: uni_accum, multi_accum)
360.252 + end)) ths (n, accum))
360.253 end)
360.254 in
360.255 (* The single-theorem names go before the multiple-theorem ones (e.g.,
360.256 @@ -538,14 +535,21 @@
360.257 maps (map (fn ((name, stature), th) => ((K name, stature), th))
360.258 o fact_of_ref ctxt reserved chained css) add
360.259 else
360.260 - let val (add, del) = pairself (Attrib.eval_thms ctxt) (add, del) in
360.261 - all_facts ctxt false ho_atp reserved add chained css
360.262 - |> filter_out
360.263 - ((member Thm.eq_thm_prop del orf No_ATPs.member ctxt) o snd)
360.264 - |> hashed_keyed_distinct (size_of_term o prop_of o snd)
360.265 - (normalize_eq_vars o prop_of o snd)
360.266 + let
360.267 + val (add, del) = pairself (Attrib.eval_thms ctxt) (add, del)
360.268 + val facts =
360.269 + all_facts ctxt false ho_atp reserved add chained css
360.270 + |> filter_out ((member Thm.eq_thm_prop del orf
360.271 + (No_ATPs.member ctxt andf not o member Thm.eq_thm_prop add)) o snd)
360.272 + in
360.273 + facts
360.274 end)
360.275 |> maybe_instantiate_inducts ctxt hyp_ts concl_t
360.276 end
360.277
360.278 +fun drop_duplicate_facts facts =
360.279 + let val num_facts = length facts in
360.280 + facts |> num_facts <= max_facts_for_duplicates ? fact_distinct (op aconv)
360.281 + end
360.282 +
360.283 end;
361.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML Thu Dec 05 17:52:12 2013 +0100
361.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML Thu Dec 05 17:58:03 2013 +0100
361.3 @@ -183,35 +183,35 @@
361.4 read correctly. *)
361.5 val implode_param = strip_spaces_except_between_idents o space_implode " "
361.6
361.7 +(* FIXME: use "Generic_Data" *)
361.8 structure Data = Theory_Data
361.9 (
361.10 type T = raw_param list
361.11 - val empty =
361.12 - default_default_params
361.13 - |> getenv "SLEDGEHAMMER_SPY" = "yes" ? AList.update (op =) ("spy", "true")
361.14 - |> map (apsnd single)
361.15 + val empty = default_default_params |> map (apsnd single)
361.16 val extend = I
361.17 fun merge data : T = AList.merge (op =) (K true) data
361.18 )
361.19
361.20 (* The first ATP of the list is used by Auto Sledgehammer. Because of the low
361.21 timeout, it makes sense to put E first. *)
361.22 -fun default_provers_param_value ctxt =
361.23 - [eN, spassN, vampireN, z3N, e_sineN, yicesN]
361.24 +fun default_provers_param_value mode ctxt =
361.25 + [eN, spassN, z3N, vampireN, e_sineN, yicesN]
361.26 |> map_filter (remotify_prover_if_not_installed ctxt)
361.27 - |> take (Multithreading.max_threads_value ())
361.28 + (* In "try" mode, leave at least one thread to another slow tool (e.g. Nitpick) *)
361.29 + |> take (Multithreading.max_threads_value () - (if mode = Try then 1 else 0))
361.30 |> implode_param
361.31
361.32 fun set_default_raw_param param thy =
361.33 let val ctxt = Proof_Context.init_global thy in
361.34 thy |> Data.map (AList.update (op =) (normalize_raw_param ctxt param))
361.35 end
361.36 -fun default_raw_params ctxt =
361.37 +
361.38 +fun default_raw_params mode ctxt =
361.39 let val thy = Proof_Context.theory_of ctxt in
361.40 Data.get thy
361.41 |> fold (AList.default (op =))
361.42 [("provers", [case !provers of
361.43 - "" => default_provers_param_value ctxt
361.44 + "" => default_provers_param_value mode ctxt
361.45 | s => s]),
361.46 ("timeout", let val timeout = Options.default_int @{option sledgehammer_timeout} in
361.47 [if timeout <= 0 then "none"
361.48 @@ -262,7 +262,7 @@
361.49 val debug = mode <> Auto_Try andalso lookup_bool "debug"
361.50 val verbose = debug orelse (mode <> Auto_Try andalso lookup_bool "verbose")
361.51 val overlord = lookup_bool "overlord"
361.52 - val spy = lookup_bool "spy"
361.53 + val spy = getenv "SLEDGEHAMMER_SPY" = "yes" orelse lookup_bool "spy"
361.54 val blocking =
361.55 Isabelle_Process.is_active () orelse mode <> Normal orelse debug orelse
361.56 lookup_bool "blocking"
361.57 @@ -278,7 +278,9 @@
361.58 val lam_trans = lookup_option lookup_string "lam_trans"
361.59 val uncurried_aliases = lookup_option lookup_bool "uncurried_aliases"
361.60 val learn = lookup_bool "learn"
361.61 - val fact_filter = lookup_option lookup_string "fact_filter"
361.62 + val fact_filter =
361.63 + lookup_option lookup_string "fact_filter"
361.64 + |> mode = Auto_Try ? (fn NONE => SOME mepoN | sf => sf)
361.65 val max_facts = lookup_option lookup_int "max_facts"
361.66 val fact_thresholds = lookup_real_pair "fact_thresholds"
361.67 val max_mono_iters = lookup_option lookup_int "max_mono_iters"
361.68 @@ -288,12 +290,10 @@
361.69 val isar_compress = Real.max (1.0, lookup_real "isar_compress")
361.70 val isar_try0 = lookup_bool "isar_try0"
361.71 val slice = mode <> Auto_Try andalso lookup_bool "slice"
361.72 - val minimize =
361.73 - if mode = Auto_Try then NONE else lookup_option lookup_bool "minimize"
361.74 + val minimize = if mode = Auto_Try then NONE else lookup_option lookup_bool "minimize"
361.75 val timeout = if mode = Auto_Try then NONE else lookup_time "timeout"
361.76 val preplay_timeout =
361.77 - if mode = Auto_Try then SOME Time.zeroTime
361.78 - else lookup_time "preplay_timeout"
361.79 + if mode = Auto_Try then SOME Time.zeroTime else lookup_time "preplay_timeout"
361.80 val expect = lookup_string "expect"
361.81 in
361.82 {debug = debug, verbose = verbose, overlord = overlord, spy = spy, blocking = blocking,
361.83 @@ -305,7 +305,7 @@
361.84 timeout = timeout, preplay_timeout = preplay_timeout, expect = expect}
361.85 end
361.86
361.87 -fun get_params mode = extract_params mode o default_raw_params
361.88 +fun get_params mode = extract_params mode o default_raw_params mode
361.89 fun default_params thy = get_params Normal thy o map (apsnd single)
361.90
361.91 (* Sledgehammer the given subgoal *)
361.92 @@ -365,7 +365,7 @@
361.93 val goal = prop_of (#goal (Proof.goal state))
361.94 val facts = nearly_all_facts ctxt false fact_override Symtab.empty
361.95 Termtab.empty [] [] goal
361.96 - fun learn prover = mash_learn_proof ctxt params prover goal facts
361.97 + val learn = mash_learn_proof ctxt params goal facts
361.98 in run_minimize params learn i (#add fact_override) state end
361.99 else if subcommand = messagesN then
361.100 messages opt_i
361.101 @@ -385,6 +385,7 @@
361.102 else
361.103 ();
361.104 mash_learn ctxt
361.105 + (* TODO: Use MaSh mode instead and have the special defaults hardcoded in "get_params" *)
361.106 (get_params Normal ctxt
361.107 ([("timeout",
361.108 [string_of_real default_learn_prover_timeout]),
361.109 @@ -415,7 +416,7 @@
361.110 #> tap (fn thy =>
361.111 let val ctxt = Proof_Context.init_global thy in
361.112 writeln ("Default parameters for Sledgehammer:\n" ^
361.113 - (case default_raw_params ctxt |> rev of
361.114 + (case rev (default_raw_params Normal ctxt) of
361.115 [] => "none"
361.116 | params =>
361.117 params |> map string_of_raw_param
362.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_mash.ML Thu Dec 05 17:52:12 2013 +0100
362.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_mash.ML Thu Dec 05 17:58:03 2013 +0100
362.3 @@ -11,7 +11,6 @@
362.4 type fact = Sledgehammer_Fact.fact
362.5 type fact_override = Sledgehammer_Fact.fact_override
362.6 type params = Sledgehammer_Provers.params
362.7 - type relevance_fudge = Sledgehammer_Provers.relevance_fudge
362.8 type prover_result = Sledgehammer_Provers.prover_result
362.9
362.10 val trace : bool Config.T
362.11 @@ -61,10 +60,10 @@
362.12 val thm_less : thm * thm -> bool
362.13 val goal_of_thm : theory -> thm -> thm
362.14 val run_prover_for_mash :
362.15 - Proof.context -> params -> string -> fact list -> thm -> prover_result
362.16 + Proof.context -> params -> string -> string -> fact list -> thm -> prover_result
362.17 val features_of :
362.18 - Proof.context -> string -> theory -> int -> int Symtab.table -> stature
362.19 - -> term list -> (string * real) list
362.20 + Proof.context -> theory -> int -> int Symtab.table -> stature -> term list ->
362.21 + (string * real) list
362.22 val trim_dependencies : string list -> string list option
362.23 val isar_dependencies_of :
362.24 string Symtab.table * string Symtab.table -> thm -> string list
362.25 @@ -83,11 +82,8 @@
362.26 -> ('b * thm) list -> ('b * thm) list * ('b * thm) list
362.27 val add_const_counts : term -> int Symtab.table -> int Symtab.table
362.28 val mash_suggested_facts :
362.29 - Proof.context -> params -> string -> int -> term list -> term
362.30 - -> raw_fact list -> fact list * fact list
362.31 - val mash_learn_proof :
362.32 - Proof.context -> params -> string -> term -> ('a * thm) list -> thm list
362.33 - -> unit
362.34 + Proof.context -> params -> int -> term list -> term -> raw_fact list -> fact list * fact list
362.35 + val mash_learn_proof : Proof.context -> params -> term -> ('a * thm) list -> thm list -> unit
362.36 val mash_learn :
362.37 Proof.context -> params -> fact_override -> thm list -> bool -> unit
362.38
362.39 @@ -180,11 +176,10 @@
362.40 (if background then " &" else "")
362.41 fun run_on () =
362.42 (Isabelle_System.bash command
362.43 - |> tap (fn _ => trace_msg ctxt (fn () =>
362.44 - case try File.read (Path.explode err_file) of
362.45 - NONE => "Done"
362.46 - | SOME "" => "Done"
362.47 - | SOME s => "Error: " ^ elide_string 1000 s));
362.48 + |> tap (fn _ =>
362.49 + case try File.read (Path.explode err_file) |> the_default "" of
362.50 + "" => trace_msg ctxt (K "Done")
362.51 + | s => warning ("MaSh error: " ^ elide_string 1000 s));
362.52 read_suggs (fn () => try File.read_lines sugg_path |> these))
362.53 fun clean_up () =
362.54 if overlord then ()
362.55 @@ -218,10 +213,6 @@
362.56 val unencode_strs =
362.57 space_explode " " #> filter_out (curry (op =) "") #> map unencode_str
362.58
362.59 -fun freshish_name () =
362.60 - Date.fmt ".%Y%m%d_%H%M%S__" (Date.fromTimeLocal (Time.now ())) ^
362.61 - serial_string ()
362.62 -
362.63 (* Avoid scientific notation *)
362.64 fun safe_str_of_real r =
362.65 if r < 0.00001 then "0.00001"
362.66 @@ -284,10 +275,11 @@
362.67
362.68 fun learn _ _ _ [] = ()
362.69 | learn ctxt overlord save learns =
362.70 - (trace_msg ctxt (fn () => "MaSh learn " ^
362.71 - elide_string 1000 (space_implode " " (map #1 learns)));
362.72 - run_mash_tool ctxt overlord ([] |> save ? cons save_models_arg) false
362.73 - (learns, str_of_learn) (K ()))
362.74 + let val names = elide_string 1000 (space_implode " " (map #1 learns)) in
362.75 + (trace_msg ctxt (fn () => "MaSh learn" ^ (if names = "" then "" else " " ^ names));
362.76 + run_mash_tool ctxt overlord ([] |> save ? cons save_models_arg) false
362.77 + (learns, str_of_learn) (K ()))
362.78 + end
362.79
362.80 fun relearn _ _ _ [] = ()
362.81 | relearn ctxt overlord save relearns =
362.82 @@ -514,20 +506,14 @@
362.83 val mess = mess |> map (apsnd (apfst (normalize_scores max_facts)))
362.84 fun score_in fact (global_weight, (sels, unks)) =
362.85 let
362.86 - fun score_at j =
362.87 - case try (nth sels) j of
362.88 - SOME (_, score) => SOME (global_weight * score)
362.89 - | NONE => NONE
362.90 + val score_at = try (nth sels) #> Option.map (fn (_, score) => global_weight * score)
362.91 in
362.92 case find_index (curry fact_eq fact o fst) sels of
362.93 - ~1 => (case find_index (curry fact_eq fact) unks of
362.94 - ~1 => SOME 0.0
362.95 - | _ => NONE)
362.96 + ~1 => if member fact_eq unks fact then NONE else SOME 0.0
362.97 | rank => score_at rank
362.98 end
362.99 fun weight_of fact = mess |> map_filter (score_in fact) |> scaled_avg
362.100 - val facts =
362.101 - fold (union fact_eq o map fst o take max_facts o fst o snd) mess []
362.102 + val facts = fold (union fact_eq o map fst o take max_facts o fst o snd) mess []
362.103 in
362.104 facts |> map (`weight_of) |> sort (int_ord o swap o pairself fst)
362.105 |> map snd |> take max_facts
362.106 @@ -573,21 +559,17 @@
362.107
362.108 fun goal_of_thm thy = prop_of #> freeze #> cterm_of thy #> Goal.init
362.109
362.110 -fun run_prover_for_mash ctxt params prover facts goal =
362.111 +fun run_prover_for_mash ctxt params prover goal_name facts goal =
362.112 let
362.113 val problem =
362.114 - {state = Proof.init ctxt, goal = goal, subgoal = 1, subgoal_count = 1,
362.115 - factss = [("", facts)]}
362.116 + {comment = "Goal: " ^ goal_name, state = Proof.init ctxt, goal = goal, subgoal = 1,
362.117 + subgoal_count = 1, factss = [("", facts)]}
362.118 in
362.119 - get_minimizing_prover ctxt MaSh (K (K ())) prover params (K (K (K "")))
362.120 - problem
362.121 + get_minimizing_prover ctxt MaSh (K ()) prover params (K (K (K ""))) problem
362.122 end
362.123
362.124 val bad_types = [@{type_name prop}, @{type_name bool}, @{type_name fun}]
362.125
362.126 -val logical_consts =
362.127 - [@{const_name prop}, @{const_name Pure.conjunction}] @ atp_logical_consts
362.128 -
362.129 val pat_tvar_prefix = "_"
362.130 val pat_var_prefix = "_"
362.131
362.132 @@ -608,15 +590,10 @@
362.133
362.134 val max_pat_breadth = 10 (* FUDGE *)
362.135
362.136 -fun term_features_of ctxt prover thy_name num_facts const_tab term_max_depth
362.137 - type_max_depth ts =
362.138 +fun term_features_of ctxt thy_name num_facts const_tab term_max_depth type_max_depth ts =
362.139 let
362.140 val thy = Proof_Context.theory_of ctxt
362.141
362.142 - fun is_built_in (x as (s, _)) args =
362.143 - if member (op =) logical_consts s then (true, args)
362.144 - else is_built_in_const_of_prover ctxt prover x args
362.145 -
362.146 val fixes = map snd (Variable.dest_fixes ctxt)
362.147 val classes = Sign.classes_of thy
362.148
362.149 @@ -660,11 +637,10 @@
362.150 let val count = Symtab.lookup const_tab s |> the_default 1 in
362.151 Real.fromInt num_facts / Real.fromInt count (* FUDGE *)
362.152 end)
362.153 - fun pattify_term _ _ 0 _ = []
362.154 - | pattify_term _ args _ (Const (x as (s, _))) =
362.155 - if fst (is_built_in x args) then []
362.156 - else [(massage_long_name s, weight_of_const s)]
362.157 - | pattify_term _ _ _ (Free (s, T)) =
362.158 + fun pattify_term _ 0 _ = []
362.159 + | pattify_term _ _ (Const (s, _)) =
362.160 + if is_widely_irrelevant_const s then [] else [(massage_long_name s, weight_of_const s)]
362.161 + | pattify_term _ _ (Free (s, T)) =
362.162 maybe_singleton_str pat_var_prefix (crude_str_of_typ T)
362.163 |> map (rpair 0.0)
362.164 |> (if member (op =) fixes s then
362.165 @@ -672,36 +648,31 @@
362.166 (thy_name ^ Long_Name.separator ^ s)))
362.167 else
362.168 I)
362.169 - | pattify_term _ _ _ (Var (_, T)) =
362.170 - maybe_singleton_str pat_var_prefix (crude_str_of_typ T)
362.171 - |> map (rpair 0.0)
362.172 - | pattify_term Ts _ _ (Bound j) =
362.173 - maybe_singleton_str pat_var_prefix (crude_str_of_typ (nth Ts j))
362.174 - |> map (rpair 0.0)
362.175 - | pattify_term Ts args depth (t $ u) =
362.176 + | pattify_term _ _ (Var (_, T)) =
362.177 + maybe_singleton_str pat_var_prefix (crude_str_of_typ T) |> map (rpair 0.0)
362.178 + | pattify_term Ts _ (Bound j) =
362.179 + maybe_singleton_str pat_var_prefix (crude_str_of_typ (nth Ts j)) |> map (rpair 0.0)
362.180 + | pattify_term Ts depth (t $ u) =
362.181 let
362.182 - val ps = take max_pat_breadth (pattify_term Ts (u :: args) depth t)
362.183 - val qs =
362.184 - take max_pat_breadth (("", 0.0) :: pattify_term Ts [] (depth - 1) u)
362.185 + val ps = take max_pat_breadth (pattify_term Ts depth t)
362.186 + val qs = take max_pat_breadth (("", 0.0) :: pattify_term Ts (depth - 1) u)
362.187 in
362.188 map_product (fn ppw as (p, pw) =>
362.189 fn ("", _) => ppw
362.190 | (q, qw) => (p ^ "(" ^ q ^ ")", pw + qw)) ps qs
362.191 end
362.192 - | pattify_term _ _ _ _ = []
362.193 - fun add_term_pat Ts = union (eq_fst (op =)) oo pattify_term Ts []
362.194 + | pattify_term _ _ _ = []
362.195 + fun add_term_pat Ts = union (eq_fst (op =)) oo pattify_term Ts
362.196 fun add_term_pats _ 0 _ = I
362.197 | add_term_pats Ts depth t =
362.198 add_term_pat Ts depth t #> add_term_pats Ts (depth - 1) t
362.199 fun add_term Ts = add_term_pats Ts term_max_depth
362.200 fun add_subterms Ts t =
362.201 case strip_comb t of
362.202 - (Const (x as (_, T)), args) =>
362.203 - let val (built_in, args) = is_built_in x args in
362.204 - (not built_in ? add_term Ts t)
362.205 - #> add_subtypes T
362.206 - #> fold (add_subterms Ts) args
362.207 - end
362.208 + (Const (s, T), args) =>
362.209 + (not (is_widely_irrelevant_const s) ? add_term Ts t)
362.210 + #> add_subtypes T
362.211 + #> fold (add_subterms Ts) args
362.212 | (head, args) =>
362.213 (case head of
362.214 Free (_, T) => add_term Ts t #> add_subtypes T
362.215 @@ -715,11 +686,10 @@
362.216 val type_max_depth = 1
362.217
362.218 (* TODO: Generate type classes for types? *)
362.219 -fun features_of ctxt prover thy num_facts const_tab (scope, _) ts =
362.220 +fun features_of ctxt thy num_facts const_tab (scope, _) ts =
362.221 let val thy_name = Context.theory_name thy in
362.222 thy_feature_of thy_name ::
362.223 - term_features_of ctxt prover thy_name num_facts const_tab term_max_depth
362.224 - type_max_depth ts
362.225 + term_features_of ctxt thy_name num_facts const_tab term_max_depth type_max_depth ts
362.226 |> scope <> Global ? cons local_feature
362.227 end
362.228
362.229 @@ -727,7 +697,7 @@
362.230 isn't much to learn from such proofs. *)
362.231 val max_dependencies = 20
362.232
362.233 -val prover_default_max_facts = 50
362.234 +val prover_default_max_facts = 25
362.235
362.236 (* "type_definition_xxx" facts are characterized by their use of "CollectI". *)
362.237 val typedef_dep = nickname_of_thm @{thm CollectI}
362.238 @@ -785,6 +755,7 @@
362.239 let
362.240 val thy = Proof_Context.theory_of ctxt
362.241 val goal = goal_of_thm thy th
362.242 + val name = nickname_of_thm th
362.243 val (_, hyp_ts, concl_t) = ATP_Util.strip_subgoal goal 1 ctxt
362.244 val facts = facts |> filter (fn (_, th') => thm_less (th', th))
362.245 fun nickify ((_, stature), th) = ((nickname_of_thm th, stature), th)
362.246 @@ -795,24 +766,23 @@
362.247 else case find_first (is_dep dep) facts of
362.248 SOME ((_, status), th) => accum @ [(("", status), th)]
362.249 | NONE => accum (* shouldn't happen *)
362.250 + val mepo_facts =
362.251 + facts
362.252 + |> mepo_suggested_facts ctxt params (max_facts |> the_default prover_default_max_facts) NONE
362.253 + hyp_ts concl_t
362.254 val facts =
362.255 - facts
362.256 - |> mepo_suggested_facts ctxt params prover
362.257 - (max_facts |> the_default prover_default_max_facts) NONE hyp_ts
362.258 - concl_t
362.259 + mepo_facts
362.260 |> fold (add_isar_dep facts) isar_deps
362.261 |> map nickify
362.262 + val num_isar_deps = length isar_deps
362.263 in
362.264 if verbose andalso auto_level = 0 then
362.265 - let val num_facts = length facts in
362.266 - "MaSh: " ^ quote prover ^ " on " ^ quote (nickname_of_thm th) ^
362.267 - " with " ^ string_of_int num_facts ^ " fact" ^ plural_s num_facts ^
362.268 - "."
362.269 - |> Output.urgent_message
362.270 - end
362.271 + "MaSh: " ^ quote prover ^ " on " ^ quote name ^ " with " ^ string_of_int num_isar_deps ^
362.272 + " + " ^ string_of_int (length facts - num_isar_deps) ^ " facts."
362.273 + |> Output.urgent_message
362.274 else
362.275 ();
362.276 - case run_prover_for_mash ctxt params prover facts goal of
362.277 + case run_prover_for_mash ctxt params prover name facts goal of
362.278 {outcome = NONE, used_facts, ...} =>
362.279 (if verbose andalso auto_level = 0 then
362.280 let val num_facts = length used_facts in
362.281 @@ -935,30 +905,28 @@
362.282
362.283 val max_proximity_facts = 100
362.284
362.285 -fun find_mash_suggestions _ _ [] _ _ raw_unknown = ([], raw_unknown)
362.286 - | find_mash_suggestions ctxt max_facts suggs facts chained raw_unknown =
362.287 - let
362.288 - val inter_fact = inter (eq_snd Thm.eq_thm_prop)
362.289 - val raw_mash = find_suggested_facts ctxt facts suggs
362.290 - val proximate = take max_proximity_facts facts
362.291 - val unknown_chained = inter_fact raw_unknown chained
362.292 - val unknown_proximate = inter_fact raw_unknown proximate
362.293 - val mess =
362.294 - [(0.9 (* FUDGE *), (map (rpair 1.0) unknown_chained, [])),
362.295 - (0.4 (* FUDGE *), (weight_facts_smoothly unknown_proximate, [])),
362.296 - (0.1 (* FUDGE *), (weight_facts_steeply raw_mash, raw_unknown))]
362.297 - val unknown =
362.298 - raw_unknown
362.299 - |> fold (subtract (eq_snd Thm.eq_thm_prop))
362.300 - [unknown_chained, unknown_proximate]
362.301 - in (mesh_facts (eq_snd Thm.eq_thm_prop) max_facts mess, unknown) end
362.302 +fun find_mash_suggestions ctxt max_facts suggs facts chained raw_unknown =
362.303 + let
362.304 + val inter_fact = inter (eq_snd Thm.eq_thm_prop)
362.305 + val raw_mash = find_suggested_facts ctxt facts suggs
362.306 + val proximate = take max_proximity_facts facts
362.307 + val unknown_chained = inter_fact raw_unknown chained
362.308 + val unknown_proximate = inter_fact raw_unknown proximate
362.309 + val mess =
362.310 + [(0.9 (* FUDGE *), (map (rpair 1.0) unknown_chained, [])),
362.311 + (0.4 (* FUDGE *), (weight_facts_smoothly unknown_proximate, [])),
362.312 + (0.1 (* FUDGE *), (weight_facts_steeply raw_mash, raw_unknown))]
362.313 + val unknown =
362.314 + raw_unknown
362.315 + |> fold (subtract (eq_snd Thm.eq_thm_prop))
362.316 + [unknown_chained, unknown_proximate]
362.317 + in (mesh_facts (eq_snd Thm.eq_thm_prop) max_facts mess, unknown) end
362.318
362.319 fun add_const_counts t =
362.320 fold (fn s => Symtab.map_default (s, 0) (Integer.add 1))
362.321 (Term.add_const_names t [])
362.322
362.323 -fun mash_suggested_facts ctxt ({debug, overlord, ...} : params) prover max_facts
362.324 - hyp_ts concl_t facts =
362.325 +fun mash_suggested_facts ctxt ({debug, overlord, ...} : params) max_facts hyp_ts concl_t facts =
362.326 let
362.327 val thy = Proof_Context.theory_of ctxt
362.328 val thy_name = Context.theory_name thy
362.329 @@ -966,22 +934,23 @@
362.330 val chained = facts |> filter (fn ((_, (scope, _)), _) => scope = Chained)
362.331 val num_facts = length facts
362.332 val const_tab = fold (add_const_counts o prop_of o snd) facts Symtab.empty
362.333 +
362.334 fun fact_has_right_theory (_, th) =
362.335 thy_name = Context.theory_name (theory_of_thm th)
362.336 fun chained_or_extra_features_of factor (((_, stature), th), weight) =
362.337 [prop_of th]
362.338 - |> features_of ctxt prover (theory_of_thm th) num_facts const_tab stature
362.339 + |> features_of ctxt (theory_of_thm th) num_facts const_tab stature
362.340 |> map (apsnd (fn r => weight * factor * r))
362.341 +
362.342 val (access_G, suggs) =
362.343 peek_state ctxt overlord (fn {access_G, ...} =>
362.344 if Graph.is_empty access_G then
362.345 - (access_G, [])
362.346 + (trace_msg ctxt (K "Nothing has been learned yet"); (access_G, []))
362.347 else
362.348 let
362.349 val parents = maximal_wrt_access_graph access_G facts
362.350 val goal_feats =
362.351 - features_of ctxt prover thy num_facts const_tab (Local, General)
362.352 - (concl_t :: hyp_ts)
362.353 + features_of ctxt thy num_facts const_tab (Local, General) (concl_t :: hyp_ts)
362.354 val chained_feats =
362.355 chained
362.356 |> map (rpair 1.0)
362.357 @@ -1043,16 +1012,12 @@
362.358 val desc = ("Machine learner for Sledgehammer", "")
362.359 in Async_Manager.thread MaShN birth_time death_time desc task end
362.360
362.361 -fun mash_learn_proof ctxt ({overlord, timeout, ...} : params) prover t facts
362.362 - used_ths =
362.363 +fun mash_learn_proof ctxt ({overlord, timeout, ...} : params) t facts used_ths =
362.364 if is_mash_enabled () then
362.365 launch_thread (timeout |> the_default one_day) (fn () =>
362.366 let
362.367 val thy = Proof_Context.theory_of ctxt
362.368 - val name = freshish_name ()
362.369 - val feats =
362.370 - features_of ctxt prover thy 0 Symtab.empty (Local, General) [t]
362.371 - |> map fst
362.372 + val feats = features_of ctxt thy 0 Symtab.empty (Local, General) [t] |> map fst
362.373 in
362.374 peek_state ctxt overlord (fn {access_G, ...} =>
362.375 let
362.376 @@ -1061,7 +1026,7 @@
362.377 used_ths |> filter (is_fact_in_graph access_G)
362.378 |> map nickname_of_thm
362.379 in
362.380 - MaSh.learn ctxt overlord true [(name, parents, feats, deps)]
362.381 + MaSh.learn ctxt overlord true [("", parents, feats, deps)]
362.382 end);
362.383 (true, "")
362.384 end)
362.385 @@ -1151,9 +1116,7 @@
362.386 let
362.387 val name = nickname_of_thm th
362.388 val feats =
362.389 - features_of ctxt prover (theory_of_thm th) 0 Symtab.empty
362.390 - stature [prop_of th]
362.391 - |> map fst
362.392 + features_of ctxt (theory_of_thm th) 0 Symtab.empty stature [prop_of th] |> map fst
362.393 val deps = deps_of status th |> these
362.394 val n = n |> not (null deps) ? Integer.add 1
362.395 val learns = (name, parents, feats, deps) :: learns
362.396 @@ -1215,7 +1178,7 @@
362.397 Isar_Proof => 0
362.398 | Automatic_Proof => 2 * max_isar
362.399 | Isar_Proof_wegen_Prover_Flop => max_isar)
362.400 - - 500 * length (isar_dependencies_of name_tabs th)
362.401 + - 100 * length (isar_dependencies_of name_tabs th)
362.402 val old_facts =
362.403 facts |> filter is_in_access_G
362.404 |> map (`priority_of)
362.405 @@ -1228,7 +1191,7 @@
362.406 in
362.407 if verbose orelse auto_level < 2 then
362.408 "Learned " ^ string_of_int n ^ " nontrivial " ^
362.409 - (if run_prover then "automatic" else "Isar") ^ " proof" ^ plural_s n ^
362.410 + (if run_prover then "automatic and " else "") ^ "Isar proof" ^ plural_s n ^
362.411 (if verbose then " in " ^ string_of_time (Timer.checkRealTimer timer)
362.412 else "") ^ "."
362.413 else
362.414 @@ -1236,15 +1199,14 @@
362.415 end
362.416 end
362.417
362.418 -fun mash_learn ctxt (params as {provers, timeout, max_facts, ...}) fact_override
362.419 - chained run_prover =
362.420 +fun mash_learn ctxt (params as {provers, timeout, ...}) fact_override chained run_prover =
362.421 let
362.422 val css = Sledgehammer_Fact.clasimpset_rule_table_of ctxt
362.423 val ctxt = ctxt |> Config.put instantiate_inducts false
362.424 val facts =
362.425 nearly_all_facts ctxt false fact_override Symtab.empty css chained []
362.426 @{prop True}
362.427 - |> (case max_facts of NONE => I | SOME n => take n)
362.428 + |> sort (crude_thm_ord o pairself snd o swap)
362.429 val num_facts = length facts
362.430 val prover = hd provers
362.431 fun learn auto_level run_prover =
362.432 @@ -1345,42 +1307,36 @@
362.433 if mash_can_suggest_facts ctxt overlord then meshN else mepoN)
362.434 else
362.435 (false, mepoN)
362.436 +
362.437 + val unique_facts = drop_duplicate_facts facts
362.438 val add_ths = Attrib.eval_thms ctxt add
362.439 +
362.440 fun in_add (_, th) = member Thm.eq_thm_prop add_ths th
362.441 fun add_and_take accepts =
362.442 (case add_ths of
362.443 [] => accepts
362.444 - | _ => (facts |> filter in_add |> map fact_of_raw_fact) @
362.445 + | _ => (unique_facts |> filter in_add |> map fact_of_raw_fact) @
362.446 (accepts |> filter_out in_add))
362.447 |> take max_facts
362.448 fun mepo () =
362.449 - mepo_suggested_facts ctxt params prover max_facts NONE hyp_ts concl_t
362.450 - facts
362.451 - |> weight_facts_steeply
362.452 + (mepo_suggested_facts ctxt params max_facts NONE hyp_ts concl_t unique_facts
362.453 + |> weight_facts_steeply, [])
362.454 fun mash () =
362.455 - mash_suggested_facts ctxt params prover (generous_max_facts max_facts)
362.456 - hyp_ts concl_t facts
362.457 + mash_suggested_facts ctxt params (generous_max_facts max_facts) hyp_ts concl_t facts
362.458 |>> weight_facts_steeply
362.459 val mess =
362.460 (* the order is important for the "case" expression below *)
362.461 - [] |> (if effective_fact_filter <> mepoN then
362.462 - cons (mash_weight, (mash ()))
362.463 - else
362.464 - I)
362.465 - |> (if effective_fact_filter <> mashN then
362.466 - cons (mepo_weight, (mepo (), []))
362.467 - else
362.468 - I)
362.469 - val mesh =
362.470 - mesh_facts (eq_snd Thm.eq_thm_prop) max_facts mess
362.471 - |> add_and_take
362.472 + [] |> effective_fact_filter <> mepoN ? cons (mash_weight, mash)
362.473 + |> effective_fact_filter <> mashN ? cons (mepo_weight, mepo)
362.474 + |> Par_List.map (apsnd (fn f => f ()))
362.475 + val mesh = mesh_facts (eq_snd Thm.eq_thm_prop) max_facts mess |> add_and_take
362.476 in
362.477 if save then MaSh.save ctxt overlord else ();
362.478 case (fact_filter, mess) of
362.479 (NONE, [(_, (mepo, _)), (_, (mash, _))]) =>
362.480 [(meshN, mesh), (mepoN, mepo |> map fst |> add_and_take),
362.481 (mashN, mash |> map fst |> add_and_take)]
362.482 - | _ => [("", mesh)]
362.483 + | _ => [(effective_fact_filter, mesh)]
362.484 end
362.485
362.486 fun kill_learners ctxt ({overlord, ...} : params) =
363.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_mepo.ML Thu Dec 05 17:52:12 2013 +0100
363.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_mepo.ML Thu Dec 05 17:58:03 2013 +0100
363.3 @@ -11,13 +11,33 @@
363.4 type raw_fact = Sledgehammer_Fact.raw_fact
363.5 type fact = Sledgehammer_Fact.fact
363.6 type params = Sledgehammer_Provers.params
363.7 - type relevance_fudge = Sledgehammer_Provers.relevance_fudge
363.8 +
363.9 + type relevance_fudge =
363.10 + {local_const_multiplier : real,
363.11 + worse_irrel_freq : real,
363.12 + higher_order_irrel_weight : real,
363.13 + abs_rel_weight : real,
363.14 + abs_irrel_weight : real,
363.15 + theory_const_rel_weight : real,
363.16 + theory_const_irrel_weight : real,
363.17 + chained_const_irrel_weight : real,
363.18 + intro_bonus : real,
363.19 + elim_bonus : real,
363.20 + simp_bonus : real,
363.21 + local_bonus : real,
363.22 + assum_bonus : real,
363.23 + chained_bonus : real,
363.24 + max_imperfect : real,
363.25 + max_imperfect_exp : real,
363.26 + threshold_divisor : real,
363.27 + ridiculous_threshold : real}
363.28
363.29 val trace : bool Config.T
363.30 val pseudo_abs_name : string
363.31 + val default_relevance_fudge : relevance_fudge
363.32 val mepo_suggested_facts :
363.33 - Proof.context -> params -> string -> int -> relevance_fudge option
363.34 - -> term list -> term -> raw_fact list -> fact list
363.35 + Proof.context -> params -> int -> relevance_fudge option -> term list -> term ->
363.36 + raw_fact list -> fact list
363.37 end;
363.38
363.39 structure Sledgehammer_MePo : SLEDGEHAMMER_MEPO =
363.40 @@ -36,6 +56,47 @@
363.41 val pseudo_abs_name = sledgehammer_prefix ^ "abs"
363.42 val theory_const_suffix = Long_Name.separator ^ " 1"
363.43
363.44 +type relevance_fudge =
363.45 + {local_const_multiplier : real,
363.46 + worse_irrel_freq : real,
363.47 + higher_order_irrel_weight : real,
363.48 + abs_rel_weight : real,
363.49 + abs_irrel_weight : real,
363.50 + theory_const_rel_weight : real,
363.51 + theory_const_irrel_weight : real,
363.52 + chained_const_irrel_weight : real,
363.53 + intro_bonus : real,
363.54 + elim_bonus : real,
363.55 + simp_bonus : real,
363.56 + local_bonus : real,
363.57 + assum_bonus : real,
363.58 + chained_bonus : real,
363.59 + max_imperfect : real,
363.60 + max_imperfect_exp : real,
363.61 + threshold_divisor : real,
363.62 + ridiculous_threshold : real}
363.63 +
363.64 +(* FUDGE *)
363.65 +val default_relevance_fudge =
363.66 + {local_const_multiplier = 1.5,
363.67 + worse_irrel_freq = 100.0,
363.68 + higher_order_irrel_weight = 1.05,
363.69 + abs_rel_weight = 0.5,
363.70 + abs_irrel_weight = 2.0,
363.71 + theory_const_rel_weight = 0.5,
363.72 + theory_const_irrel_weight = 0.25,
363.73 + chained_const_irrel_weight = 0.25,
363.74 + intro_bonus = 0.15,
363.75 + elim_bonus = 0.15,
363.76 + simp_bonus = 0.15,
363.77 + local_bonus = 0.55,
363.78 + assum_bonus = 1.05,
363.79 + chained_bonus = 1.5,
363.80 + max_imperfect = 11.5,
363.81 + max_imperfect_exp = 1.0,
363.82 + threshold_divisor = 2.0,
363.83 + ridiculous_threshold = 0.1}
363.84 +
363.85 fun order_of_type (Type (@{type_name fun}, [T1, T2])) =
363.86 Int.max (order_of_type T1 + 1, order_of_type T2)
363.87 | order_of_type (Type (_, Ts)) = fold (Integer.max o order_of_type) Ts 0
363.88 @@ -43,24 +104,26 @@
363.89
363.90 (* An abstraction of Isabelle types and first-order terms *)
363.91 datatype pattern = PVar | PApp of string * pattern list
363.92 -datatype ptype = PType of int * pattern list
363.93 +datatype ptype = PType of int * typ list
363.94
363.95 -fun string_of_pattern PVar = "_"
363.96 - | string_of_pattern (PApp (s, ps)) =
363.97 - if null ps then s else s ^ string_of_patterns ps
363.98 -and string_of_patterns ps = "(" ^ commas (map string_of_pattern ps) ^ ")"
363.99 -fun string_of_ptype (PType (_, ps)) = string_of_patterns ps
363.100 +fun string_of_patternT (TVar _) = "_"
363.101 + | string_of_patternT (Type (s, ps)) =
363.102 + if null ps then s else s ^ string_of_patternsT ps
363.103 + | string_of_patternT (TFree (s, _)) = s
363.104 +and string_of_patternsT ps = "(" ^ commas (map string_of_patternT ps) ^ ")"
363.105 +fun string_of_ptype (PType (_, ps)) = string_of_patternsT ps
363.106
363.107 (*Is the second type an instance of the first one?*)
363.108 -fun match_pattern (PVar, _) = true
363.109 - | match_pattern (PApp _, PVar) = false
363.110 - | match_pattern (PApp (s, ps), PApp (t, qs)) =
363.111 - s = t andalso match_patterns (ps, qs)
363.112 -and match_patterns (_, []) = true
363.113 - | match_patterns ([], _) = false
363.114 - | match_patterns (p :: ps, q :: qs) =
363.115 - match_pattern (p, q) andalso match_patterns (ps, qs)
363.116 -fun match_ptype (PType (_, ps), PType (_, qs)) = match_patterns (ps, qs)
363.117 +fun match_patternT (TVar _, _) = true
363.118 + | match_patternT (Type (s, ps), Type (t, qs)) =
363.119 + s = t andalso match_patternsT (ps, qs)
363.120 + | match_patternT (TFree (s, _), TFree (t, _)) = s = t
363.121 + | match_patternT (_, _) = false
363.122 +and match_patternsT (_, []) = true
363.123 + | match_patternsT ([], _) = false
363.124 + | match_patternsT (p :: ps, q :: qs) =
363.125 + match_patternT (p, q) andalso match_patternsT (ps, qs)
363.126 +fun match_ptype (PType (_, ps), PType (_, qs)) = match_patternsT (ps, qs)
363.127
363.128 (* Is there a unifiable constant? *)
363.129 fun pconst_mem f consts (s, ps) =
363.130 @@ -69,14 +132,9 @@
363.131 fun pconst_hyper_mem f const_tab (s, ps) =
363.132 exists (curry (match_ptype o f) ps) (these (Symtab.lookup const_tab s))
363.133
363.134 -fun pattern_of_type (Type (s, Ts)) = PApp (s, map pattern_of_type Ts)
363.135 - | pattern_of_type (TFree (s, _)) = PApp (s, [])
363.136 - | pattern_of_type (TVar _) = PVar
363.137 -
363.138 (* Pairs a constant with the list of its type instantiations. *)
363.139 fun ptype thy const x =
363.140 - (if const then map pattern_of_type (these (try (Sign.const_typargs thy) x))
363.141 - else [])
363.142 + (if const then these (try (Sign.const_typargs thy) x) else [])
363.143 fun rich_ptype thy const (s, T) =
363.144 PType (order_of_type T, ptype thy const (s, T))
363.145 fun rich_pconst thy const (s, T) = (s, rich_ptype thy const (s, T))
363.146 @@ -84,9 +142,19 @@
363.147 fun string_of_hyper_pconst (s, ps) =
363.148 s ^ "{" ^ commas (map string_of_ptype ps) ^ "}"
363.149
363.150 -(* Add a pconstant to the table, but a [] entry means a standard
363.151 - connective, which we ignore.*)
363.152 -fun add_pconst_to_table (s, p) = Symtab.map_default (s, [p]) (insert (op =) p)
363.153 +fun patternT_eq (TVar _, TVar _) = true
363.154 + | patternT_eq (Type (s, Ts), Type (t, Us)) = s = t andalso patternsT_eq (Ts, Us)
363.155 + | patternT_eq (TFree (s, _), TFree (t, _)) = (s = t)
363.156 + | patternT_eq _ = false
363.157 +and patternsT_eq ([], []) = true
363.158 + | patternsT_eq ([], _) = false
363.159 + | patternsT_eq (_, []) = false
363.160 + | patternsT_eq (T :: Ts, U :: Us) = patternT_eq (T, U) andalso patternsT_eq (Ts, Us)
363.161 +fun ptype_eq (PType (m, Ts), PType (n, Us)) = m = n andalso patternsT_eq (Ts, Us)
363.162 +
363.163 + (* Add a pconstant to the table, but a [] entry means a standard connective,
363.164 + which we ignore. *)
363.165 +fun add_pconst_to_table (s, p) = Symtab.map_default (s, [p]) (insert ptype_eq p)
363.166
363.167 (* Set constants tend to pull in too many irrelevant facts. We limit the damage
363.168 by treating them more or less as if they were built-in but add their
363.169 @@ -94,21 +162,18 @@
363.170 val set_consts = [@{const_name Collect}, @{const_name Set.member}]
363.171 val set_thms = @{thms Collect_mem_eq mem_Collect_eq Collect_cong}
363.172
363.173 -fun add_pconsts_in_term thy is_built_in_const =
363.174 +fun add_pconsts_in_term thy =
363.175 let
363.176 - fun do_const const ext_arg (x as (s, _)) ts =
363.177 - let val (built_in, ts) = is_built_in_const x ts in
363.178 - if member (op =) set_consts s then
363.179 - fold (do_term ext_arg) ts
363.180 - else
363.181 - (not built_in
363.182 - ? add_pconst_to_table (rich_pconst thy const x))
363.183 - #> fold (do_term false) ts
363.184 - end
363.185 + fun do_const const (x as (s, _)) ts =
363.186 + if member (op =) set_consts s then
363.187 + fold (do_term false) ts
363.188 + else
363.189 + (not (is_irrelevant_const s) ? add_pconst_to_table (rich_pconst thy const x))
363.190 + #> fold (do_term false) ts
363.191 and do_term ext_arg t =
363.192 case strip_comb t of
363.193 - (Const x, ts) => do_const true ext_arg x ts
363.194 - | (Free x, ts) => do_const false ext_arg x ts
363.195 + (Const x, ts) => do_const true x ts
363.196 + | (Free x, ts) => do_const false x ts
363.197 | (Abs (_, T, t'), ts) =>
363.198 ((null ts andalso not ext_arg)
363.199 (* Since lambdas on the right-hand side of equalities are usually
363.200 @@ -122,7 +187,7 @@
363.201 if T = HOLogic.boolT then do_formula else do_term ext_arg
363.202 and do_formula t =
363.203 case t of
363.204 - Const (@{const_name all}, _) $ Abs (_, T, t') => do_formula t'
363.205 + Const (@{const_name all}, _) $ Abs (_, _, t') => do_formula t'
363.206 | @{const "==>"} $ t1 $ t2 => do_formula t1 #> do_formula t2
363.207 | Const (@{const_name "=="}, Type (_, [T, _])) $ t1 $ t2 =>
363.208 do_term_or_formula false T t1 #> do_term_or_formula true T t2
363.209 @@ -130,8 +195,8 @@
363.210 | @{const False} => I
363.211 | @{const True} => I
363.212 | @{const Not} $ t1 => do_formula t1
363.213 - | Const (@{const_name All}, _) $ Abs (_, T, t') => do_formula t'
363.214 - | Const (@{const_name Ex}, _) $ Abs (_, T, t') => do_formula t'
363.215 + | Const (@{const_name All}, _) $ Abs (_, _, t') => do_formula t'
363.216 + | Const (@{const_name Ex}, _) $ Abs (_, _, t') => do_formula t'
363.217 | @{const HOL.conj} $ t1 $ t2 => do_formula t1 #> do_formula t2
363.218 | @{const HOL.disj} $ t1 $ t2 => do_formula t1 #> do_formula t2
363.219 | @{const HOL.implies} $ t1 $ t2 => do_formula t1 #> do_formula t2
363.220 @@ -140,19 +205,19 @@
363.221 | Const (@{const_name If}, Type (_, [_, Type (_, [T, _])]))
363.222 $ t1 $ t2 $ t3 =>
363.223 do_formula t1 #> fold (do_term_or_formula false T) [t2, t3]
363.224 - | Const (@{const_name Ex1}, _) $ Abs (_, T, t') => do_formula t'
363.225 - | Const (@{const_name Ball}, _) $ t1 $ Abs (_, T, t') =>
363.226 + | Const (@{const_name Ex1}, _) $ Abs (_, _, t') => do_formula t'
363.227 + | Const (@{const_name Ball}, _) $ t1 $ Abs (_, _, t') =>
363.228 do_formula (t1 $ Bound ~1) #> do_formula t'
363.229 - | Const (@{const_name Bex}, _) $ t1 $ Abs (_, T, t') =>
363.230 + | Const (@{const_name Bex}, _) $ t1 $ Abs (_, _, t') =>
363.231 do_formula (t1 $ Bound ~1) #> do_formula t'
363.232 | (t0 as Const (_, @{typ bool})) $ t1 =>
363.233 do_term false t0 #> do_formula t1 (* theory constant *)
363.234 | _ => do_term false t
363.235 in do_formula end
363.236
363.237 -fun pconsts_in_fact thy is_built_in_const t =
363.238 +fun pconsts_in_fact thy t =
363.239 Symtab.fold (fn (s, pss) => fold (cons o pair s) pss)
363.240 - (Symtab.empty |> add_pconsts_in_term thy is_built_in_const t) []
363.241 + (Symtab.empty |> add_pconsts_in_term thy t) []
363.242
363.243 (* Inserts a dummy "constant" referring to the theory name, so that relevance
363.244 takes the given theory into account. *)
363.245 @@ -167,9 +232,9 @@
363.246 fun theory_const_prop_of fudge th =
363.247 theory_constify fudge (Context.theory_name (theory_of_thm th)) (prop_of th)
363.248
363.249 -fun pair_consts_fact thy is_built_in_const fudge fact =
363.250 +fun pair_consts_fact thy fudge fact =
363.251 case fact |> snd |> theory_const_prop_of fudge
363.252 - |> pconsts_in_fact thy is_built_in_const of
363.253 + |> pconsts_in_fact thy of
363.254 [] => NONE
363.255 | consts => SOME ((fact, consts), NONE)
363.256
363.257 @@ -177,15 +242,22 @@
363.258 first by constant name and second by its list of type instantiations. For the
363.259 latter, we need a linear ordering on "pattern list". *)
363.260
363.261 -fun pattern_ord p =
363.262 +fun patternT_ord p =
363.263 case p of
363.264 - (PVar, PVar) => EQUAL
363.265 - | (PVar, PApp _) => LESS
363.266 - | (PApp _, PVar) => GREATER
363.267 - | (PApp q1, PApp q2) =>
363.268 - prod_ord fast_string_ord (dict_ord pattern_ord) (q1, q2)
363.269 -fun ptype_ord (PType p, PType q) =
363.270 - prod_ord (dict_ord pattern_ord) int_ord (swap p, swap q)
363.271 + (Type (s, ps), Type (t, qs)) =>
363.272 + (case fast_string_ord (s, t) of
363.273 + EQUAL => dict_ord patternT_ord (ps, qs)
363.274 + | ord => ord)
363.275 + | (TVar _, TVar _) => EQUAL
363.276 + | (TVar _, _) => LESS
363.277 + | (Type _, TVar _) => GREATER
363.278 + | (Type _, TFree _) => LESS
363.279 + | (TFree (s, _), TFree (t, _)) => fast_string_ord (s, t)
363.280 + | (TFree _, _) => GREATER
363.281 +fun ptype_ord (PType (m, ps), PType (n, qs)) =
363.282 + (case dict_ord patternT_ord (ps, qs) of
363.283 + EQUAL => int_ord (m, n)
363.284 + | ord => ord)
363.285
363.286 structure PType_Tab = Table(type key = ptype val ord = ptype_ord)
363.287
363.288 @@ -326,23 +398,23 @@
363.289 (accepts, more_rejects @ rejects)
363.290 end
363.291
363.292 -fun if_empty_replace_with_scope thy is_built_in_const facts sc tab =
363.293 +fun if_empty_replace_with_scope thy facts sc tab =
363.294 if Symtab.is_empty tab then
363.295 Symtab.empty
363.296 - |> fold (add_pconsts_in_term thy is_built_in_const)
363.297 + |> fold (add_pconsts_in_term thy)
363.298 (map_filter (fn ((_, (sc', _)), th) =>
363.299 if sc' = sc then SOME (prop_of th) else NONE) facts)
363.300 else
363.301 tab
363.302
363.303 -fun consider_arities is_built_in_const th =
363.304 +fun consider_arities th =
363.305 let
363.306 fun aux _ _ NONE = NONE
363.307 | aux t args (SOME tab) =
363.308 case t of
363.309 t1 $ t2 => SOME tab |> aux t1 (t2 :: args) |> aux t2 []
363.310 - | Const (x as (s, _)) =>
363.311 - (if is_built_in_const x args |> fst then
363.312 + | Const (s, _) =>
363.313 + (if is_widely_irrelevant_const s then
363.314 SOME tab
363.315 else case Symtab.lookup tab s of
363.316 NONE => SOME (Symtab.update (s, length args) tab)
363.317 @@ -351,24 +423,24 @@
363.318 in aux (prop_of th) [] end
363.319
363.320 (* FIXME: This is currently only useful for polymorphic type encodings. *)
363.321 -fun could_benefit_from_ext is_built_in_const facts =
363.322 - fold (consider_arities is_built_in_const o snd) facts (SOME Symtab.empty)
363.323 - |> is_none
363.324 +fun could_benefit_from_ext facts =
363.325 + fold (consider_arities o snd) facts (SOME Symtab.empty) |> is_none
363.326
363.327 (* High enough so that it isn't wrongly considered as very relevant (e.g., for E
363.328 weights), but low enough so that it is unlikely to be truncated away if few
363.329 facts are included. *)
363.330 val special_fact_index = 45 (* FUDGE *)
363.331
363.332 +fun eq_prod eqx eqy ((x1, y1), (x2, y2)) = eqx (x1, x2) andalso eqy (y1, y2)
363.333 +
363.334 val really_hopeless_get_kicked_out_iter = 5 (* FUDGE *)
363.335
363.336 -fun relevance_filter ctxt thres0 decay max_facts is_built_in_const
363.337 - (fudge as {threshold_divisor, ridiculous_threshold, ...}) facts hyp_ts
363.338 - concl_t =
363.339 +fun relevance_filter ctxt thres0 decay max_facts
363.340 + (fudge as {threshold_divisor, ridiculous_threshold, ...}) facts hyp_ts concl_t =
363.341 let
363.342 val thy = Proof_Context.theory_of ctxt
363.343 val const_tab = fold (count_fact_consts thy fudge) facts Symtab.empty
363.344 - val add_pconsts = add_pconsts_in_term thy is_built_in_const
363.345 + val add_pconsts = add_pconsts_in_term thy
363.346 val chained_ts =
363.347 facts |> map_filter (fn ((_, (Chained, _)), th) => SOME (prop_of th)
363.348 | _ => NONE)
363.349 @@ -378,8 +450,7 @@
363.350 |> fold add_pconsts hyp_ts
363.351 |> add_pconsts concl_t
363.352 |> (fn tab => if Symtab.is_empty tab then chained_const_tab else tab)
363.353 - |> fold (if_empty_replace_with_scope thy is_built_in_const facts)
363.354 - [Chained, Assum, Local]
363.355 + |> fold (if_empty_replace_with_scope thy facts) [Chained, Assum, Local]
363.356 fun iter j remaining_max thres rel_const_tab hopeless hopeful =
363.357 let
363.358 val hopeless =
363.359 @@ -421,7 +492,8 @@
363.360 trace_msg ctxt (fn () => "New or updated constants: " ^
363.361 commas (rel_const_tab'
363.362 |> Symtab.dest
363.363 - |> subtract (op =) (rel_const_tab |> Symtab.dest)
363.364 + |> subtract (eq_prod (op =) (eq_list ptype_eq))
363.365 + (rel_const_tab |> Symtab.dest)
363.366 |> map string_of_hyper_pconst));
363.367 map (fst o fst) accepts @
363.368 (if remaining_max = 0 then
363.369 @@ -475,41 +547,33 @@
363.370 in bef @ add @ after end
363.371 fun insert_special_facts accepts =
363.372 (* FIXME: get rid of "ext" here once it is treated as a helper *)
363.373 - [] |> could_benefit_from_ext is_built_in_const accepts ? cons @{thm ext}
363.374 + [] |> could_benefit_from_ext accepts ? cons @{thm ext}
363.375 |> add_set_const_thms accepts
363.376 |> insert_into_facts accepts
363.377 in
363.378 - facts |> map_filter (pair_consts_fact thy is_built_in_const fudge)
363.379 + facts |> map_filter (pair_consts_fact thy fudge)
363.380 |> iter 0 max_facts thres0 goal_const_tab []
363.381 |> insert_special_facts
363.382 |> tap (fn accepts => trace_msg ctxt (fn () =>
363.383 "Total relevant: " ^ string_of_int (length accepts)))
363.384 end
363.385
363.386 -fun mepo_suggested_facts ctxt
363.387 - ({fact_thresholds = (thres0, thres1), ...} : params) prover
363.388 - max_facts fudge hyp_ts concl_t facts =
363.389 +fun mepo_suggested_facts ctxt ({fact_thresholds = (thres0, thres1), ...} : params) max_facts fudge
363.390 + hyp_ts concl_t facts =
363.391 let
363.392 val thy = Proof_Context.theory_of ctxt
363.393 - val is_built_in_const =
363.394 - Sledgehammer_Provers.is_built_in_const_of_prover ctxt prover
363.395 - val fudge =
363.396 - case fudge of
363.397 - SOME fudge => fudge
363.398 - | NONE => Sledgehammer_Provers.relevance_fudge_of_prover ctxt prover
363.399 + val fudge = fudge |> the_default default_relevance_fudge
363.400 val decay = Math.pow ((1.0 - thres1) / (1.0 - thres0),
363.401 1.0 / Real.fromInt (max_facts + 1))
363.402 in
363.403 - trace_msg ctxt (fn () => "Considering " ^ string_of_int (length facts) ^
363.404 - " facts");
363.405 + trace_msg ctxt (fn () => "Considering " ^ string_of_int (length facts) ^ " facts");
363.406 (if thres1 < 0.0 then
363.407 facts
363.408 - else if thres0 > 1.0 orelse thres0 > thres1 then
363.409 + else if thres0 > 1.0 orelse thres0 > thres1 orelse max_facts <= 0 then
363.410 []
363.411 else
363.412 - relevance_filter ctxt thres0 decay max_facts is_built_in_const fudge
363.413 - facts hyp_ts
363.414 - (concl_t |> theory_constify fudge (Context.theory_name thy)))
363.415 + relevance_filter ctxt thres0 decay max_facts fudge facts hyp_ts
363.416 + (concl_t |> theory_constify fudge (Context.theory_name thy)))
363.417 |> map fact_of_raw_fact
363.418 end
363.419
364.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_minimize.ML Thu Dec 05 17:52:12 2013 +0100
364.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_minimize.ML Thu Dec 05 17:58:03 2013 +0100
364.3 @@ -17,16 +17,14 @@
364.4 val auto_minimize_min_facts : int Config.T
364.5 val auto_minimize_max_time : real Config.T
364.6 val minimize_facts :
364.7 - (string -> thm list -> unit) -> string -> params -> bool -> int -> int
364.8 - -> Proof.state -> play Lazy.lazy option
364.9 + (thm list -> unit) -> string -> params -> bool -> int -> int
364.10 + -> Proof.state -> thm -> play Lazy.lazy option
364.11 -> ((string * stature) * thm list) list
364.12 -> ((string * stature) * thm list) list option
364.13 * (play Lazy.lazy * (play -> string) * string)
364.14 - val get_minimizing_prover :
364.15 - Proof.context -> mode -> (string -> thm list -> unit) -> string -> prover
364.16 - val run_minimize :
364.17 - params -> (string -> thm list -> unit) -> int
364.18 - -> (Facts.ref * Attrib.src list) list -> Proof.state -> unit
364.19 + val get_minimizing_prover : Proof.context -> mode -> (thm list -> unit) -> string -> prover
364.20 + val run_minimize : params -> (thm list -> unit) -> int -> (Facts.ref * Attrib.src list) list ->
364.21 + Proof.state -> unit
364.22 end;
364.23
364.24 structure Sledgehammer_Minimize : SLEDGEHAMMER_MINIMIZE =
364.25 @@ -59,7 +57,7 @@
364.26 max_new_mono_instances, type_enc, strict, lam_trans,
364.27 uncurried_aliases, isar_proofs, isar_compress, isar_try0,
364.28 preplay_timeout, ...} : params)
364.29 - silent (prover : prover) timeout i n state facts =
364.30 + silent (prover : prover) timeout i n state goal facts =
364.31 let
364.32 val _ =
364.33 print silent (fn () =>
364.34 @@ -70,7 +68,6 @@
364.35 | _ => ""
364.36 else
364.37 "") ^ "...")
364.38 - val {goal, ...} = Proof.goal state
364.39 val facts = facts |> maps (fn (n, ths) => map (pair n) ths)
364.40 val params =
364.41 {debug = debug, verbose = verbose, overlord = overlord, spy = spy, blocking = true,
364.42 @@ -82,7 +79,8 @@
364.43 slice = false, minimize = SOME false, timeout = timeout, preplay_timeout = preplay_timeout,
364.44 expect = ""}
364.45 val problem =
364.46 - {state = state, goal = goal, subgoal = i, subgoal_count = n, factss = [("", facts)]}
364.47 + {comment = "", state = state, goal = goal, subgoal = i, subgoal_count = n,
364.48 + factss = [("", facts)]}
364.49 val result as {outcome, used_facts, run_time, ...} =
364.50 prover params (K (K (K ""))) problem
364.51 in
364.52 @@ -191,12 +189,12 @@
364.53 end
364.54
364.55 fun minimize_facts do_learn prover_name (params as {learn, timeout, ...}) silent
364.56 - i n state preplay0 facts =
364.57 + i n state goal preplay0 facts =
364.58 let
364.59 val ctxt = Proof.context_of state
364.60 val prover =
364.61 get_prover ctxt (if silent then Auto_Minimize else Minimize) prover_name
364.62 - fun test timeout = test_facts params silent prover timeout i n state
364.63 + fun test timeout = test_facts params silent prover timeout i n state goal
364.64 val (chained, non_chained) = List.partition is_fact_chained facts
364.65 (* Push chained facts to the back, so that they are less likely to be
364.66 kicked out by the linear minimization algorithm. *)
364.67 @@ -221,7 +219,7 @@
364.68 (case min_facts |> filter is_fact_chained |> length of
364.69 0 => ""
364.70 | n => "\n(including " ^ string_of_int n ^ " chained)") ^ ".");
364.71 - (if learn then do_learn prover_name (maps snd min_facts) else ());
364.72 + (if learn then do_learn (maps snd min_facts) else ());
364.73 (SOME min_facts,
364.74 (if is_some preplay0 andalso length min_facts = length facts then
364.75 the preplay0
364.76 @@ -272,7 +270,7 @@
364.77
364.78 fun maybe_minimize ctxt mode do_learn name
364.79 (params as {verbose, isar_proofs, minimize, ...})
364.80 - ({state, subgoal, subgoal_count, ...} : prover_problem)
364.81 + ({state, goal, subgoal, subgoal_count, ...} : prover_problem)
364.82 (result as {outcome, used_facts, used_from, run_time, preplay, message,
364.83 message_tail} : prover_result) =
364.84 if is_some outcome orelse null used_facts then
364.85 @@ -319,8 +317,8 @@
364.86 val (used_facts, (preplay, message, _)) =
364.87 if minimize then
364.88 minimize_facts do_learn minimize_name params
364.89 - (mode <> Normal orelse not verbose) subgoal subgoal_count state
364.90 - (SOME preplay)
364.91 + (not verbose orelse (mode <> Normal andalso mode <> MaSh)) subgoal
364.92 + subgoal_count state goal (SOME preplay)
364.93 (filter_used_facts true used_facts (map (apsnd single) used_from))
364.94 |>> Option.map (map fst)
364.95 else
364.96 @@ -342,12 +340,10 @@
364.97 fun run_minimize (params as {provers, ...}) do_learn i refs state =
364.98 let
364.99 val ctxt = Proof.context_of state
364.100 + val {goal, facts = chained_ths, ...} = Proof.goal state
364.101 val reserved = reserved_isar_keyword_table ()
364.102 - val chained_ths = #facts (Proof.goal state)
364.103 val css = clasimpset_rule_table_of ctxt
364.104 - val facts =
364.105 - refs |> maps (map (apsnd single)
364.106 - o fact_of_ref ctxt reserved chained_ths css)
364.107 + val facts = refs |> maps (map (apsnd single) o fact_of_ref ctxt reserved chained_ths css)
364.108 in
364.109 case subgoal_count state of
364.110 0 => Output.urgent_message "No subgoal!"
364.111 @@ -355,7 +351,7 @@
364.112 [] => error "No prover is set."
364.113 | prover :: _ =>
364.114 (kill_provers ();
364.115 - minimize_facts do_learn prover params false i n state NONE facts
364.116 + minimize_facts do_learn prover params false i n state goal NONE facts
364.117 |> (fn (_, (preplay, message, message_tail)) =>
364.118 message (Lazy.force preplay) ^ message_tail
364.119 |> Output.urgent_message))
365.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_minimize_isar.ML Thu Dec 05 17:52:12 2013 +0100
365.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_minimize_isar.ML Thu Dec 05 17:58:03 2013 +0100
365.3 @@ -11,7 +11,7 @@
365.4 type isar_proof = Sledgehammer_Proof.isar_proof
365.5 val minimize_dependencies_and_remove_unrefed_steps :
365.6 bool -> preplay_interface -> isar_proof -> isar_proof
365.7 -end
365.8 +end;
365.9
365.10 structure Sledgehammer_Minimize_Isar : SLEDGEHAMMER_MINIMIZE_ISAR =
365.11 struct
365.12 @@ -105,4 +105,4 @@
365.13 snd (do_proof proof)
365.14 end
365.15
365.16 -end
365.17 +end;
366.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_preplay.ML Thu Dec 05 17:52:12 2013 +0100
366.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_preplay.ML Thu Dec 05 17:58:03 2013 +0100
366.3 @@ -35,7 +35,7 @@
366.4 val proof_preplay_interface :
366.5 bool -> Proof.context -> string -> string -> bool -> Time.time
366.6 -> isar_proof -> preplay_interface
366.7 -end
366.8 +end;
366.9
366.10 structure Sledgehammer_Preplay : SLEDGEHAMMER_PREPLAY =
366.11 struct
366.12 @@ -312,4 +312,4 @@
366.13 overall_preplay_stats = overall_preplay_stats}
366.14 end
366.15
366.16 -end
366.17 +end;
367.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_print.ML Thu Dec 05 17:52:12 2013 +0100
367.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_print.ML Thu Dec 05 17:58:03 2013 +0100
367.3 @@ -293,4 +293,4 @@
367.4 of_indent 0 ^ (if n <> 1 then "next" else "qed")
367.5 end
367.6
367.7 -end
367.8 +end;
368.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_proof.ML Thu Dec 05 17:52:12 2013 +0100
368.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_proof.ML Thu Dec 05 17:58:03 2013 +0100
368.3 @@ -33,9 +33,6 @@
368.4 ArithM |
368.5 BlastM
368.6
368.7 - (* legacy *)
368.8 - val By_Metis : facts -> byline
368.9 -
368.10 val no_label : label
368.11 val no_facts : facts
368.12
368.13 @@ -64,19 +61,19 @@
368.14
368.15 val add_proof_steps : isar_step list -> int -> int
368.16
368.17 - (** canonical proof labels: 1, 2, 3, ... in post traversal order **)
368.18 + (** canonical proof labels: 1, 2, 3, ... in postorder **)
368.19 val canonical_label_ord : (label * label) -> order
368.20 val relabel_proof_canonically : isar_proof -> isar_proof
368.21
368.22 structure Canonical_Lbl_Tab : TABLE
368.23
368.24 -end
368.25 +end;
368.26
368.27 structure Sledgehammer_Proof : SLEDGEHAMMER_PROOF =
368.28 struct
368.29
368.30 type label = string * int
368.31 -type facts = label list * string list (* local & global facts *)
368.32 +type facts = label list * string list (* local and global facts *)
368.33
368.34 datatype isar_qualifier = Show | Then
368.35
368.36 @@ -100,9 +97,6 @@
368.37 ArithM |
368.38 BlastM
368.39
368.40 -(* legacy *)
368.41 -fun By_Metis facts = By (facts, MetisM)
368.42 -
368.43 val no_label = ("", ~1)
368.44 val no_facts = ([],[])
368.45
368.46 @@ -166,10 +160,8 @@
368.47
368.48 fun relabel_proof_canonically proof =
368.49 let
368.50 - val lbl = pair ""
368.51 -
368.52 fun next_label l (next, subst) =
368.53 - (lbl next, (next + 1, (l, lbl next) :: subst))
368.54 + let val l' = ("", next) in (l', (next + 1, (l, l') :: subst)) end
368.55
368.56 fun do_byline by (_, subst) =
368.57 by |> map_facts_of_byline (apfst (map (AList.lookup (op =) subst #> the)))
368.58 @@ -191,15 +183,15 @@
368.59
368.60 and do_step (step as Let _) state = (step, state)
368.61 | do_step (Prove (qs, fix, l, t, subproofs, by)) state=
368.62 - let
368.63 - val by = do_byline by state
368.64 - val (subproofs, state) = fold_map do_proof subproofs state
368.65 - val (l, state) = next_label l state
368.66 - in
368.67 - (Prove (qs, fix, l, t, subproofs, by), state)
368.68 - end
368.69 + let
368.70 + val by = do_byline by state
368.71 + val (subproofs, state) = fold_map do_proof subproofs state
368.72 + val (l, state) = next_label l state
368.73 + in
368.74 + (Prove (qs, fix, l, t, subproofs, by), state)
368.75 + end
368.76 in
368.77 fst (do_proof proof (0, []))
368.78 end
368.79
368.80 -end
368.81 +end;
369.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_provers.ML Thu Dec 05 17:52:12 2013 +0100
369.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_provers.ML Thu Dec 05 17:58:03 2013 +0100
369.3 @@ -44,28 +44,9 @@
369.4 preplay_timeout : Time.time option,
369.5 expect : string}
369.6
369.7 - type relevance_fudge =
369.8 - {local_const_multiplier : real,
369.9 - worse_irrel_freq : real,
369.10 - higher_order_irrel_weight : real,
369.11 - abs_rel_weight : real,
369.12 - abs_irrel_weight : real,
369.13 - theory_const_rel_weight : real,
369.14 - theory_const_irrel_weight : real,
369.15 - chained_const_irrel_weight : real,
369.16 - intro_bonus : real,
369.17 - elim_bonus : real,
369.18 - simp_bonus : real,
369.19 - local_bonus : real,
369.20 - assum_bonus : real,
369.21 - chained_bonus : real,
369.22 - max_imperfect : real,
369.23 - max_imperfect_exp : real,
369.24 - threshold_divisor : real,
369.25 - ridiculous_threshold : real}
369.26 -
369.27 type prover_problem =
369.28 - {state : Proof.state,
369.29 + {comment : string,
369.30 + state : Proof.state,
369.31 goal : thm,
369.32 subgoal : int,
369.33 subgoal_count : int,
369.34 @@ -88,8 +69,7 @@
369.35 val problem_prefix : string Config.T
369.36 val completish : bool Config.T
369.37 val atp_full_names : bool Config.T
369.38 - val smt_builtin_facts : bool Config.T
369.39 - val smt_builtin_trans : bool Config.T
369.40 + val smt_builtins : bool Config.T
369.41 val smt_triggers : bool Config.T
369.42 val smt_weights : bool Config.T
369.43 val smt_weight_min_facts : int Config.T
369.44 @@ -117,14 +97,9 @@
369.45 Proof.context -> string -> string option
369.46 val remotify_prover_if_not_installed :
369.47 Proof.context -> string -> string option
369.48 - val default_max_facts_of_prover : Proof.context -> bool -> string -> int
369.49 + val default_max_facts_of_prover : Proof.context -> string -> int
369.50 val is_unit_equality : term -> bool
369.51 val is_appropriate_prop_of_prover : Proof.context -> string -> term -> bool
369.52 - val is_built_in_const_of_prover :
369.53 - Proof.context -> string -> string * typ -> term list -> bool * term list
369.54 - val atp_relevance_fudge : relevance_fudge
369.55 - val smt_relevance_fudge : relevance_fudge
369.56 - val relevance_fudge_of_prover : Proof.context -> string -> relevance_fudge
369.57 val weight_smt_fact :
369.58 Proof.context -> int -> ((string * stature) * thm) * int
369.59 -> (string * stature) * (int option * thm)
369.60 @@ -160,27 +135,18 @@
369.61 (** The Sledgehammer **)
369.62
369.63 (* Empty string means create files in Isabelle's temporary files directory. *)
369.64 -val dest_dir =
369.65 - Attrib.setup_config_string @{binding sledgehammer_dest_dir} (K "")
369.66 -val problem_prefix =
369.67 - Attrib.setup_config_string @{binding sledgehammer_problem_prefix} (K "prob")
369.68 -val completish =
369.69 - Attrib.setup_config_bool @{binding sledgehammer_completish} (K false)
369.70 +val dest_dir = Attrib.setup_config_string @{binding sledgehammer_dest_dir} (K "")
369.71 +val problem_prefix = Attrib.setup_config_string @{binding sledgehammer_problem_prefix} (K "prob")
369.72 +val completish = Attrib.setup_config_bool @{binding sledgehammer_completish} (K false)
369.73
369.74 (* In addition to being easier to read, readable names are often much shorter,
369.75 especially if types are mangled in names. This makes a difference for some
369.76 provers (e.g., E). For these reason, short names are enabled by default. *)
369.77 -val atp_full_names =
369.78 - Attrib.setup_config_bool @{binding sledgehammer_atp_full_names} (K false)
369.79 +val atp_full_names = Attrib.setup_config_bool @{binding sledgehammer_atp_full_names} (K false)
369.80
369.81 -val smt_builtin_facts =
369.82 - Attrib.setup_config_bool @{binding sledgehammer_smt_builtin_facts} (K true)
369.83 -val smt_builtin_trans =
369.84 - Attrib.setup_config_bool @{binding sledgehammer_smt_builtin_trans} (K true)
369.85 -val smt_triggers =
369.86 - Attrib.setup_config_bool @{binding sledgehammer_smt_triggers} (K true)
369.87 -val smt_weights =
369.88 - Attrib.setup_config_bool @{binding sledgehammer_smt_weights} (K true)
369.89 +val smt_builtins = Attrib.setup_config_bool @{binding sledgehammer_smt_builtins} (K true)
369.90 +val smt_triggers = Attrib.setup_config_bool @{binding sledgehammer_smt_triggers} (K true)
369.91 +val smt_weights = Attrib.setup_config_bool @{binding sledgehammer_smt_weights} (K true)
369.92 val smt_weight_min_facts =
369.93 Attrib.setup_config_int @{binding sledgehammer_smt_weight_min_facts} (K 20)
369.94
369.95 @@ -240,15 +206,14 @@
369.96
369.97 val reconstructor_default_max_facts = 20
369.98
369.99 -fun slice_max_facts (_, (_, ( ((max_facts, _), _, _, _, _), _))) = max_facts
369.100 +fun slice_max_facts (_, ( ((max_facts, _), _, _, _, _), _)) = max_facts
369.101
369.102 -fun default_max_facts_of_prover ctxt slice name =
369.103 +fun default_max_facts_of_prover ctxt name =
369.104 let val thy = Proof_Context.theory_of ctxt in
369.105 if is_reconstructor name then
369.106 reconstructor_default_max_facts
369.107 else if is_atp thy name then
369.108 - fold (Integer.max o slice_max_facts)
369.109 - (get_slices slice (#best_slices (get_atp thy name ()) ctxt)) 0
369.110 + fold (Integer.max o slice_max_facts) (#best_slices (get_atp thy name ()) ctxt) 0
369.111 else (* is_smt_prover ctxt name *)
369.112 SMT_Solver.default_max_relevant ctxt name
369.113 end
369.114 @@ -275,68 +240,6 @@
369.115 fun is_appropriate_prop_of_prover ctxt name =
369.116 if is_unit_equational_atp ctxt name then is_unit_equality else K true
369.117
369.118 -val atp_irrelevant_const_tab =
369.119 - Symtab.make (map (rpair ()) atp_irrelevant_consts)
369.120 -
369.121 -fun is_built_in_const_of_prover ctxt name =
369.122 - if is_smt_prover ctxt name andalso Config.get ctxt smt_builtin_facts then
369.123 - let val ctxt = ctxt |> select_smt_solver name in
369.124 - fn x => fn ts =>
369.125 - if SMT_Builtin.is_builtin_num_ext ctxt (list_comb (Const x, ts)) then
369.126 - (true, [])
369.127 - else if SMT_Builtin.is_builtin_fun_ext ctxt x ts then
369.128 - (true, ts)
369.129 - else
369.130 - (false, ts)
369.131 - end
369.132 - else
369.133 - fn (s, _) => fn ts => (Symtab.defined atp_irrelevant_const_tab s, ts)
369.134 -
369.135 -(* FUDGE *)
369.136 -val atp_relevance_fudge =
369.137 - {local_const_multiplier = 1.5,
369.138 - worse_irrel_freq = 100.0,
369.139 - higher_order_irrel_weight = 1.05,
369.140 - abs_rel_weight = 0.5,
369.141 - abs_irrel_weight = 2.0,
369.142 - theory_const_rel_weight = 0.5,
369.143 - theory_const_irrel_weight = 0.25,
369.144 - chained_const_irrel_weight = 0.25,
369.145 - intro_bonus = 0.15,
369.146 - elim_bonus = 0.15,
369.147 - simp_bonus = 0.15,
369.148 - local_bonus = 0.55,
369.149 - assum_bonus = 1.05,
369.150 - chained_bonus = 1.5,
369.151 - max_imperfect = 11.5,
369.152 - max_imperfect_exp = 1.0,
369.153 - threshold_divisor = 2.0,
369.154 - ridiculous_threshold = 0.01}
369.155 -
369.156 -(* FUDGE (FIXME) *)
369.157 -val smt_relevance_fudge =
369.158 - {local_const_multiplier = #local_const_multiplier atp_relevance_fudge,
369.159 - worse_irrel_freq = #worse_irrel_freq atp_relevance_fudge,
369.160 - higher_order_irrel_weight = #higher_order_irrel_weight atp_relevance_fudge,
369.161 - abs_rel_weight = #abs_rel_weight atp_relevance_fudge,
369.162 - abs_irrel_weight = #abs_irrel_weight atp_relevance_fudge,
369.163 - theory_const_rel_weight = #theory_const_rel_weight atp_relevance_fudge,
369.164 - theory_const_irrel_weight = #theory_const_irrel_weight atp_relevance_fudge,
369.165 - chained_const_irrel_weight = #chained_const_irrel_weight atp_relevance_fudge,
369.166 - intro_bonus = #intro_bonus atp_relevance_fudge,
369.167 - elim_bonus = #elim_bonus atp_relevance_fudge,
369.168 - simp_bonus = #simp_bonus atp_relevance_fudge,
369.169 - local_bonus = #local_bonus atp_relevance_fudge,
369.170 - assum_bonus = #assum_bonus atp_relevance_fudge,
369.171 - chained_bonus = #chained_bonus atp_relevance_fudge,
369.172 - max_imperfect = #max_imperfect atp_relevance_fudge,
369.173 - max_imperfect_exp = #max_imperfect_exp atp_relevance_fudge,
369.174 - threshold_divisor = #threshold_divisor atp_relevance_fudge,
369.175 - ridiculous_threshold = #ridiculous_threshold atp_relevance_fudge}
369.176 -
369.177 -fun relevance_fudge_of_prover ctxt name =
369.178 - if is_smt_prover ctxt name then smt_relevance_fudge else atp_relevance_fudge
369.179 -
369.180 fun supported_provers ctxt =
369.181 let
369.182 val thy = Proof_Context.theory_of ctxt
369.183 @@ -383,28 +286,9 @@
369.184 preplay_timeout : Time.time option,
369.185 expect : string}
369.186
369.187 -type relevance_fudge =
369.188 - {local_const_multiplier : real,
369.189 - worse_irrel_freq : real,
369.190 - higher_order_irrel_weight : real,
369.191 - abs_rel_weight : real,
369.192 - abs_irrel_weight : real,
369.193 - theory_const_rel_weight : real,
369.194 - theory_const_irrel_weight : real,
369.195 - chained_const_irrel_weight : real,
369.196 - intro_bonus : real,
369.197 - elim_bonus : real,
369.198 - simp_bonus : real,
369.199 - local_bonus : real,
369.200 - assum_bonus : real,
369.201 - chained_bonus : real,
369.202 - max_imperfect : real,
369.203 - max_imperfect_exp : real,
369.204 - threshold_divisor : real,
369.205 - ridiculous_threshold : real}
369.206 -
369.207 type prover_problem =
369.208 - {state : Proof.state,
369.209 + {comment : string,
369.210 + state : Proof.state,
369.211 goal : thm,
369.212 subgoal : int,
369.213 subgoal_count : int,
369.214 @@ -483,7 +367,7 @@
369.215 []
369.216 else
369.217 [("type_enc", [hd (unalias_type_enc type_enc')])]) @
369.218 - (if is_none lam_trans andalso lam_trans' = metis_default_lam_trans then
369.219 + (if is_none lam_trans andalso lam_trans' = default_metis_lam_trans then
369.220 []
369.221 else
369.222 [("lam_trans", [lam_trans'])])
369.223 @@ -621,9 +505,9 @@
369.224 them each time. *)
369.225 val atp_important_message_keep_quotient = 25
369.226
369.227 -fun choose_type_enc soundness best_type_enc format =
369.228 +fun choose_type_enc strictness best_type_enc format =
369.229 the_default best_type_enc
369.230 - #> type_enc_of_string soundness
369.231 + #> type_enc_of_string strictness
369.232 #> adjust_type_enc format
369.233
369.234 fun isar_proof_reconstructor ctxt name =
369.235 @@ -681,7 +565,7 @@
369.236 max_new_mono_instances, isar_proofs, isar_compress,
369.237 isar_try0, slice, timeout, preplay_timeout, ...})
369.238 minimize_command
369.239 - ({state, goal, subgoal, subgoal_count, factss, ...} : prover_problem) =
369.240 + ({comment, state, goal, subgoal, subgoal_count, factss, ...} : prover_problem) =
369.241 let
369.242 val thy = Proof.theory_of state
369.243 val ctxt = Proof.context_of state
369.244 @@ -734,15 +618,15 @@
369.245 let
369.246 (* If slicing is disabled, we expand the last slice to fill the entire
369.247 time available. *)
369.248 - val actual_slices = get_slices slice (best_slices ctxt)
369.249 + val all_slices = best_slices ctxt
369.250 + val actual_slices = get_slices slice all_slices
369.251 + fun max_facts_of_slices f slices = fold (Integer.max o slice_max_facts o f) slices 0
369.252 val num_actual_slices = length actual_slices
369.253 val max_fact_factor =
369.254 - case max_facts of
369.255 - NONE => 1.0
369.256 - | SOME max =>
369.257 - Real.fromInt max
369.258 - / Real.fromInt (fold (Integer.max o slice_max_facts)
369.259 - actual_slices 0)
369.260 + Real.fromInt (case max_facts of
369.261 + NONE => max_facts_of_slices I all_slices
369.262 + | SOME max => max)
369.263 + / Real.fromInt (max_facts_of_slices snd actual_slices)
369.264 fun monomorphize_facts facts =
369.265 let
369.266 val ctxt =
369.267 @@ -779,9 +663,9 @@
369.268 Real.ceil (max_fact_factor * Real.fromInt best_max_facts) +
369.269 max_fact_factor_fudge
369.270 |> Integer.min (length facts)
369.271 - val soundness = if strict then Strict else Non_Strict
369.272 + val strictness = if strict then Strict else Non_Strict
369.273 val type_enc =
369.274 - type_enc |> choose_type_enc soundness best_type_enc format
369.275 + type_enc |> choose_type_enc strictness best_type_enc format
369.276 val sound = is_type_enc_sound type_enc
369.277 val real_ms = Real.fromInt o Time.toMilliseconds
369.278 val slice_timeout =
369.279 @@ -845,7 +729,8 @@
369.280 val _ =
369.281 atp_problem
369.282 |> lines_of_atp_problem format ord ord_info
369.283 - |> cons ("% " ^ command ^ "\n")
369.284 + |> cons ("% " ^ command ^ "\n" ^
369.285 + (if comment = "" then "" else "% " ^ comment ^ "\n"))
369.286 |> File.write_list prob_path
369.287 val ((output, run_time), (atp_proof, outcome)) =
369.288 time_limit generous_slice_timeout Isabelle_System.bash_output
369.289 @@ -935,7 +820,7 @@
369.290 bunch_of_reconstructors needs_full_types
369.291 (lam_trans_of_atp_proof atp_proof
369.292 o (fn desperate => if desperate then hide_lamsN
369.293 - else metis_default_lam_trans))
369.294 + else default_metis_lam_trans))
369.295 in
369.296 (used_facts,
369.297 Lazy.lazy (fn () =>
369.298 @@ -953,18 +838,27 @@
369.299 Output.urgent_message "Generating proof text..."
369.300 else
369.301 ()
369.302 - val isar_params =
369.303 - (debug, verbose, preplay_timeout, isar_compress, isar_try0,
369.304 - pool, fact_names, lifted, sym_tab, atp_proof, goal)
369.305 + fun isar_params () =
369.306 + let
369.307 + val metis_type_enc =
369.308 + if is_typed_helper_used_in_atp_proof atp_proof then full_typesN
369.309 + else partial_typesN
369.310 + val metis_lam_trans = lam_trans_of_atp_proof atp_proof default_metis_lam_trans
369.311 + val atp_proof =
369.312 + atp_proof
369.313 + |> termify_atp_proof ctxt pool lifted sym_tab
369.314 + |> factify_atp_proof fact_names hyp_ts concl_t
369.315 + in
369.316 + (debug, verbose, metis_type_enc, metis_lam_trans, preplay_timeout,
369.317 + isar_compress, isar_try0, atp_proof, goal)
369.318 + end
369.319 val one_line_params =
369.320 (preplay, proof_banner mode name, used_facts,
369.321 - choose_minimize_command ctxt params minimize_command name
369.322 - preplay,
369.323 + choose_minimize_command ctxt params minimize_command name preplay,
369.324 subgoal, subgoal_count)
369.325 val num_chained = length (#facts (Proof.goal state))
369.326 in
369.327 - proof_text ctxt isar_proofs isar_params
369.328 - num_chained one_line_params
369.329 + proof_text ctxt isar_proofs isar_params num_chained one_line_params
369.330 end,
369.331 (if verbose then
369.332 "\nATP real CPU time: " ^ string_of_time run_time ^ "."
369.333 @@ -1028,10 +922,8 @@
369.334 val is_boring_builtin_typ =
369.335 not o exists_subtype (member (op =) [@{typ nat}, @{typ int}, HOLogic.realT])
369.336
369.337 -fun smt_filter_loop name
369.338 - ({debug, verbose, overlord, max_mono_iters,
369.339 - max_new_mono_instances, timeout, slice, ...} : params)
369.340 - state goal i =
369.341 +fun smt_filter_loop name ({debug, overlord, max_mono_iters, max_new_mono_instances, timeout, slice,
369.342 + ...} : params) state goal i =
369.343 let
369.344 fun repair_context ctxt =
369.345 ctxt |> select_smt_solver name
369.346 @@ -1044,7 +936,7 @@
369.347 I)
369.348 |> Config.put SMT_Config.infer_triggers
369.349 (Config.get ctxt smt_triggers)
369.350 - |> not (Config.get ctxt smt_builtin_trans)
369.351 + |> not (Config.get ctxt smt_builtins)
369.352 ? (SMT_Builtin.filter_builtins is_boring_builtin_typ
369.353 #> Config.put SMT_Config.datatypes false)
369.354 |> repair_monomorph_context max_mono_iters default_max_mono_iters
369.355 @@ -1164,7 +1056,7 @@
369.356 play_one_line_proof mode debug verbose preplay_timeout used_pairs
369.357 state subgoal SMT
369.358 (bunch_of_reconstructors false (fn desperate =>
369.359 - if desperate then liftingN else metis_default_lam_trans))),
369.360 + if desperate then liftingN else default_metis_lam_trans))),
369.361 fn preplay =>
369.362 let
369.363 val one_line_params =
369.364 @@ -1198,7 +1090,7 @@
369.365 val reconstr =
369.366 if name = metisN then
369.367 Metis (type_enc |> the_default (hd partial_type_encs),
369.368 - lam_trans |> the_default metis_default_lam_trans)
369.369 + lam_trans |> the_default default_metis_lam_trans)
369.370 else if name = smtN then
369.371 SMT
369.372 else
370.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_reconstruct.ML Thu Dec 05 17:52:12 2013 +0100
370.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_reconstruct.ML Thu Dec 05 17:58:03 2013 +0100
370.3 @@ -7,28 +7,19 @@
370.4
370.5 signature SLEDGEHAMMER_RECONSTRUCT =
370.6 sig
370.7 + type ('a, 'b) atp_step = ('a, 'b) ATP_Proof.atp_step
370.8 type 'a atp_proof = 'a ATP_Proof.atp_proof
370.9 type stature = ATP_Problem_Generate.stature
370.10 - type one_line_params = Sledgehammer_Print.one_line_params
370.11 + type one_line_params = Sledgehammer_Reconstructor.one_line_params
370.12
370.13 type isar_params =
370.14 - bool * bool * Time.time option * real * bool * string Symtab.table
370.15 - * (string * stature) list vector * (string * term) list * int Symtab.table
370.16 - * string atp_proof * thm
370.17 + bool * bool * string * string * Time.time option * real * bool * (term, string) atp_step list *
370.18 + thm
370.19
370.20 - val lam_trans_of_atp_proof : string atp_proof -> string -> string
370.21 - val is_typed_helper_used_in_atp_proof : string atp_proof -> bool
370.22 - val used_facts_in_atp_proof :
370.23 - Proof.context -> (string * stature) list vector -> string atp_proof ->
370.24 - (string * stature) list
370.25 - val used_facts_in_unsound_atp_proof :
370.26 - Proof.context -> (string * stature) list vector -> 'a atp_proof ->
370.27 - string list option
370.28 val isar_proof_text :
370.29 Proof.context -> bool option -> isar_params -> one_line_params -> string
370.30 val proof_text :
370.31 - Proof.context -> bool option -> isar_params -> int -> one_line_params
370.32 - -> string
370.33 + Proof.context -> bool option -> (unit -> isar_params) -> int -> one_line_params -> string
370.34 end;
370.35
370.36 structure Sledgehammer_Reconstruct : SLEDGEHAMMER_RECONSTRUCT =
370.37 @@ -56,190 +47,13 @@
370.38
370.39 open String_Redirect
370.40
370.41 -(** fact extraction from ATP proofs **)
370.42 +fun raw_label_of_num num = (num, 0)
370.43
370.44 -fun find_first_in_list_vector vec key =
370.45 - Vector.foldl (fn (ps, NONE) => AList.lookup (op =) ps key
370.46 - | (_, value) => value) NONE vec
370.47 +fun label_of_clause [(num, _)] = raw_label_of_num num
370.48 + | label_of_clause c = (space_implode "___" (map (fst o raw_label_of_num o fst) c), 0)
370.49
370.50 -val unprefix_fact_number = space_implode "_" o tl o space_explode "_"
370.51 -
370.52 -fun resolve_one_named_fact fact_names s =
370.53 - case try (unprefix fact_prefix) s of
370.54 - SOME s' =>
370.55 - let val s' = s' |> unprefix_fact_number |> unascii_of in
370.56 - s' |> find_first_in_list_vector fact_names |> Option.map (pair s')
370.57 - end
370.58 - | NONE => NONE
370.59 -fun resolve_fact fact_names = map_filter (resolve_one_named_fact fact_names)
370.60 -fun is_fact fact_names = not o null o resolve_fact fact_names
370.61 -
370.62 -fun resolve_one_named_conjecture s =
370.63 - case try (unprefix conjecture_prefix) s of
370.64 - SOME s' => Int.fromString s'
370.65 - | NONE => NONE
370.66 -
370.67 -val resolve_conjecture = map_filter resolve_one_named_conjecture
370.68 -val is_conjecture = not o null o resolve_conjecture
370.69 -
370.70 -val ascii_of_lam_fact_prefix = ascii_of lam_fact_prefix
370.71 -
370.72 -(* overapproximation (good enough) *)
370.73 -fun is_lam_lifted s =
370.74 - String.isPrefix fact_prefix s andalso
370.75 - String.isSubstring ascii_of_lam_fact_prefix s
370.76 -
370.77 -val is_combinator_def = String.isPrefix (helper_prefix ^ combinator_prefix)
370.78 -
370.79 -fun is_axiom_used_in_proof pred =
370.80 - exists (fn ((_, ss), _, _, _, []) => exists pred ss | _ => false)
370.81 -
370.82 -fun lam_trans_of_atp_proof atp_proof default =
370.83 - case (is_axiom_used_in_proof is_combinator_def atp_proof,
370.84 - is_axiom_used_in_proof is_lam_lifted atp_proof) of
370.85 - (false, false) => default
370.86 - | (false, true) => liftingN
370.87 -(* | (true, true) => combs_and_liftingN -- not supported by "metis" *)
370.88 - | (true, _) => combsN
370.89 -
370.90 -val is_typed_helper_name =
370.91 - String.isPrefix helper_prefix andf String.isSuffix typed_helper_suffix
370.92 -
370.93 -fun is_typed_helper_used_in_atp_proof atp_proof =
370.94 - is_axiom_used_in_proof is_typed_helper_name atp_proof
370.95 -
370.96 -fun add_non_rec_defs fact_names accum =
370.97 - Vector.foldl (fn (facts, facts') =>
370.98 - union (op =) (filter (fn (_, (_, status)) => status = Non_Rec_Def) facts)
370.99 - facts')
370.100 - accum fact_names
370.101 -
370.102 -val isa_ext = Thm.get_name_hint @{thm ext}
370.103 -val isa_short_ext = Long_Name.base_name isa_ext
370.104 -
370.105 -fun ext_name ctxt =
370.106 - if Thm.eq_thm_prop (@{thm ext},
370.107 - singleton (Attrib.eval_thms ctxt) (Facts.named isa_short_ext, [])) then
370.108 - isa_short_ext
370.109 - else
370.110 - isa_ext
370.111 -
370.112 -val leo2_extcnf_equal_neg_rule = "extcnf_equal_neg"
370.113 -val leo2_unfold_def_rule = "unfold_def"
370.114 -
370.115 -fun add_fact ctxt fact_names ((_, ss), _, _, rule, deps) =
370.116 - (if rule = leo2_extcnf_equal_neg_rule then
370.117 - insert (op =) (ext_name ctxt, (Global, General))
370.118 - else if rule = leo2_unfold_def_rule then
370.119 - (* LEO 1.3.3 does not record definitions properly, leading to missing
370.120 - dependencies in the TSTP proof. Remove the next line once this is
370.121 - fixed. *)
370.122 - add_non_rec_defs fact_names
370.123 - else if rule = agsyhol_coreN orelse rule = satallax_coreN then
370.124 - (fn [] =>
370.125 - (* agsyHOL and Satallax don't include definitions in their
370.126 - unsatisfiable cores, so we assume the worst and include them all
370.127 - here. *)
370.128 - [(ext_name ctxt, (Global, General))] |> add_non_rec_defs fact_names
370.129 - | facts => facts)
370.130 - else
370.131 - I)
370.132 - #> (if null deps then union (op =) (resolve_fact fact_names ss) else I)
370.133 -
370.134 -fun used_facts_in_atp_proof ctxt fact_names atp_proof =
370.135 - if null atp_proof then Vector.foldl (uncurry (union (op =))) [] fact_names
370.136 - else fold (add_fact ctxt fact_names) atp_proof []
370.137 -
370.138 -fun used_facts_in_unsound_atp_proof _ _ [] = NONE
370.139 - | used_facts_in_unsound_atp_proof ctxt fact_names atp_proof =
370.140 - let val used_facts = used_facts_in_atp_proof ctxt fact_names atp_proof in
370.141 - if forall (fn (_, (sc, _)) => sc = Global) used_facts andalso
370.142 - not (is_axiom_used_in_proof (is_conjecture o single) atp_proof) then
370.143 - SOME (map fst used_facts)
370.144 - else
370.145 - NONE
370.146 - end
370.147 -
370.148 -
370.149 -(** Isar proof construction and manipulation **)
370.150 -
370.151 -val assume_prefix = "a"
370.152 -val have_prefix = "f"
370.153 -val raw_prefix = "x"
370.154 -
370.155 -fun raw_label_of_name (num, ss) =
370.156 - case resolve_conjecture ss of
370.157 - [j] => (conjecture_prefix, j)
370.158 - | _ => (raw_prefix ^ ascii_of num, 0)
370.159 -
370.160 -fun label_of_clause [name] = raw_label_of_name name
370.161 - | label_of_clause c =
370.162 - (space_implode "___" (map (fst o raw_label_of_name) c), 0)
370.163 -
370.164 -fun add_fact_of_dependencies fact_names (names as [(_, ss)]) =
370.165 - if is_fact fact_names ss then
370.166 - apsnd (union (op =) (map fst (resolve_fact fact_names ss)))
370.167 - else
370.168 - apfst (insert (op =) (label_of_clause names))
370.169 - | add_fact_of_dependencies _ names =
370.170 - apfst (insert (op =) (label_of_clause names))
370.171 -
370.172 -fun repair_name "$true" = "c_True"
370.173 - | repair_name "$false" = "c_False"
370.174 - | repair_name "$$e" = tptp_equal (* seen in Vampire proofs *)
370.175 - | repair_name s =
370.176 - if is_tptp_equal s orelse
370.177 - (* seen in Vampire proofs *)
370.178 - (String.isPrefix "sQ" s andalso String.isSuffix "_eqProxy" s) then
370.179 - tptp_equal
370.180 - else
370.181 - s
370.182 -
370.183 -fun infer_formula_types ctxt =
370.184 - Type.constraint HOLogic.boolT
370.185 - #> Syntax.check_term
370.186 - (Proof_Context.set_mode Proof_Context.mode_schematic ctxt)
370.187 -
370.188 -val combinator_table =
370.189 - [(@{const_name Meson.COMBI}, @{thm Meson.COMBI_def [abs_def]}),
370.190 - (@{const_name Meson.COMBK}, @{thm Meson.COMBK_def [abs_def]}),
370.191 - (@{const_name Meson.COMBB}, @{thm Meson.COMBB_def [abs_def]}),
370.192 - (@{const_name Meson.COMBC}, @{thm Meson.COMBC_def [abs_def]}),
370.193 - (@{const_name Meson.COMBS}, @{thm Meson.COMBS_def [abs_def]})]
370.194 -
370.195 -fun uncombine_term thy =
370.196 - let
370.197 - fun aux (t1 $ t2) = betapply (pairself aux (t1, t2))
370.198 - | aux (Abs (s, T, t')) = Abs (s, T, aux t')
370.199 - | aux (t as Const (x as (s, _))) =
370.200 - (case AList.lookup (op =) combinator_table s of
370.201 - SOME thm => thm |> prop_of |> specialize_type thy x
370.202 - |> Logic.dest_equals |> snd
370.203 - | NONE => t)
370.204 - | aux t = t
370.205 - in aux end
370.206 -
370.207 -fun unlift_term lifted =
370.208 - map_aterms (fn t as Const (s, _) =>
370.209 - if String.isPrefix lam_lifted_prefix s then
370.210 - case AList.lookup (op =) lifted s of
370.211 - SOME t =>
370.212 - (* FIXME: do something about the types *)
370.213 - unlift_term lifted t
370.214 - | NONE => t
370.215 - else
370.216 - t
370.217 - | t => t)
370.218 -
370.219 -fun decode_line ctxt lifted sym_tab (name, role, u, rule, deps) =
370.220 - let
370.221 - val thy = Proof_Context.theory_of ctxt
370.222 - val t =
370.223 - u |> prop_of_atp ctxt true sym_tab
370.224 - |> uncombine_term thy
370.225 - |> unlift_term lifted
370.226 - |> infer_formula_types ctxt
370.227 - in (name, role, t, rule, deps) end
370.228 +fun add_fact_of_dependencies [(_, ss as _ :: _)] = apsnd (union (op =) ss)
370.229 + | add_fact_of_dependencies names = apfst (insert (op =) (label_of_clause names))
370.230
370.231 fun replace_one_dependency (old, new) dep =
370.232 if is_same_atp_step dep old then new else [dep]
370.233 @@ -257,20 +71,17 @@
370.234
370.235 (* Discard facts; consolidate adjacent lines that prove the same formula, since
370.236 they differ only in type information.*)
370.237 -fun add_line fact_names (name as (_, ss), role, t, rule, []) lines =
370.238 +fun add_line (name as (_, ss), role, t, rule, []) lines =
370.239 (* No dependencies: fact, conjecture, or (for Vampire) internal facts or
370.240 definitions. *)
370.241 - if is_conjecture ss then
370.242 + if role = Conjecture orelse role = Negated_Conjecture orelse role = Hypothesis then
370.243 (name, role, t, rule, []) :: lines
370.244 - else if is_fact fact_names ss then
370.245 + else if role = Axiom then
370.246 (* Facts are not proof lines. *)
370.247 - if is_only_type_information t then
370.248 - map (replace_dependencies_in_line (name, [])) lines
370.249 - else
370.250 - lines
370.251 + lines |> is_only_type_information t ? map (replace_dependencies_in_line (name, []))
370.252 else
370.253 map (replace_dependencies_in_line (name, [])) lines
370.254 - | add_line _ (line as (name, role, t, _, _)) lines =
370.255 + | add_line (line as (name, role, t, _, _)) lines =
370.256 (* Type information will be deleted later; skip repetition test. *)
370.257 if is_only_type_information t then
370.258 line :: lines
370.259 @@ -280,22 +91,9 @@
370.260 | (pre, (name', _, _, _, _) :: post) =>
370.261 line :: pre @ map (replace_dependencies_in_line (name', [name])) post
370.262
370.263 -val waldmeister_conjecture_num = "1.0.0.0"
370.264 -
370.265 -fun repair_waldmeister_endgame arg =
370.266 - let
370.267 - fun do_tail (name, _, t, rule, deps) =
370.268 - (name, Negated_Conjecture, s_not t, rule, deps)
370.269 - fun do_body [] = []
370.270 - | do_body ((line as ((num, _), _, _, _, _)) :: lines) =
370.271 - if num = waldmeister_conjecture_num then map do_tail (line :: lines)
370.272 - else line :: do_body lines
370.273 - in do_body arg end
370.274 -
370.275 (* Recursively delete empty lines (type information) from the proof. *)
370.276 fun add_nontrivial_line (line as (name, _, t, _, [])) lines =
370.277 - if is_only_type_information t then delete_dependency name lines
370.278 - else line :: lines
370.279 + if is_only_type_information t then delete_dependency name lines else line :: lines
370.280 | add_nontrivial_line line lines = line :: lines
370.281 and delete_dependency name lines =
370.282 fold_rev add_nontrivial_line
370.283 @@ -307,12 +105,9 @@
370.284 val is_skolemize_rule =
370.285 member (op =) [e_skolemize_rule, vampire_skolemisation_rule]
370.286
370.287 -fun add_desired_line fact_names (name as (_, ss), role, t, rule, deps)
370.288 - (j, lines) =
370.289 +fun add_desired_line (name as (_, ss), role, t, rule, deps) (j, lines) =
370.290 (j + 1,
370.291 - if is_fact fact_names ss orelse
370.292 - is_conjecture ss orelse
370.293 - is_skolemize_rule rule orelse
370.294 + if role <> Plain orelse is_skolemize_rule rule orelse
370.295 (* the last line must be kept *)
370.296 j = 0 orelse
370.297 (not (is_only_type_information t) andalso
370.298 @@ -335,14 +130,17 @@
370.299 fun do_label l = if member (op =) used_ls l then l else no_label
370.300 fun do_assms (Assume assms) = Assume (map (apfst do_label) assms)
370.301 fun do_step (Prove (qs, xs, l, t, subproofs, by)) =
370.302 - Prove (qs, xs, do_label l, t, map do_proof subproofs, by)
370.303 + Prove (qs, xs, do_label l, t, map do_proof subproofs, by)
370.304 | do_step step = step
370.305 and do_proof (Proof (fix, assms, steps)) =
370.306 - Proof (fix, do_assms assms, map do_step steps)
370.307 + Proof (fix, do_assms assms, map do_step steps)
370.308 in do_proof proof end
370.309
370.310 fun prefix_of_depth n = replicate_string (n + 1)
370.311
370.312 +val assume_prefix = "a"
370.313 +val have_prefix = "f"
370.314 +
370.315 val relabel_proof =
370.316 let
370.317 fun fresh_label depth prefix (old as (l, subst, next)) =
370.318 @@ -352,24 +150,17 @@
370.319 let val l' = (prefix_of_depth depth prefix, next) in
370.320 (l', (l, l') :: subst, next + 1)
370.321 end
370.322 - fun do_facts subst =
370.323 - apfst (maps (the_list o AList.lookup (op =) subst))
370.324 + fun do_facts subst = apfst (maps (the_list o AList.lookup (op =) subst))
370.325 fun do_assm depth (l, t) (subst, next) =
370.326 - let
370.327 - val (l, subst, next) =
370.328 - (l, subst, next) |> fresh_label depth assume_prefix
370.329 - in
370.330 + let val (l, subst, next) = (l, subst, next) |> fresh_label depth assume_prefix in
370.331 ((l, t), (subst, next))
370.332 end
370.333 fun do_assms subst depth (Assume assms) =
370.334 - fold_map (do_assm depth) assms (subst, 1)
370.335 - |> apfst Assume
370.336 - |> apsnd fst
370.337 + fold_map (do_assm depth) assms (subst, 1) |>> Assume ||> fst
370.338 fun do_steps _ _ _ [] = []
370.339 | do_steps subst depth next (Prove (qs, xs, l, t, sub, by) :: steps) =
370.340 let
370.341 - val (l, subst, next) =
370.342 - (l, subst, next) |> fresh_label depth have_prefix
370.343 + val (l, subst, next) = (l, subst, next) |> fresh_label depth have_prefix
370.344 val sub = do_proofs subst depth sub
370.345 val by = by |> do_byline subst
370.346 in Prove (qs, xs, l, t, sub, by) :: do_steps subst depth next steps end
370.347 @@ -407,59 +198,40 @@
370.348 and chain_proofs proofs = map (chain_proof) proofs
370.349 in chain_proof end
370.350
370.351 +fun maybe_mk_Trueprop t = t |> fastype_of t = HOLogic.boolT ? HOLogic.mk_Trueprop
370.352 +
370.353 type isar_params =
370.354 - bool * bool * Time.time option * real * bool * string Symtab.table
370.355 - * (string * stature) list vector * (string * term) list * int Symtab.table
370.356 - * string atp_proof * thm
370.357 + bool * bool * string * string * Time.time option * real * bool * (term, string) atp_step list *
370.358 + thm
370.359
370.360 fun isar_proof_text ctxt isar_proofs
370.361 - (debug, verbose, preplay_timeout, isar_compress, isar_try0, pool,
370.362 - fact_names, lifted, sym_tab, atp_proof, goal)
370.363 + (debug, verbose, metis_type_enc, metis_lam_trans, preplay_timeout, isar_compress,
370.364 + isar_try0, atp_proof, goal)
370.365 (one_line_params as (_, _, _, _, subgoal, subgoal_count)) =
370.366 let
370.367 val (params, hyp_ts, concl_t) = strip_subgoal goal subgoal ctxt
370.368 val (_, ctxt) =
370.369 params
370.370 |> map (fn (s, T) => (Binding.name s, SOME T, NoSyn))
370.371 - |> (fn fixes =>
370.372 - ctxt |> Variable.set_body false
370.373 - |> Proof_Context.add_fixes fixes)
370.374 + |> (fn fixes => ctxt |> Variable.set_body false |> Proof_Context.add_fixes fixes)
370.375 val one_line_proof = one_line_proof_text 0 one_line_params
370.376 - val type_enc =
370.377 - if is_typed_helper_used_in_atp_proof atp_proof then full_typesN
370.378 - else partial_typesN
370.379 - val lam_trans = lam_trans_of_atp_proof atp_proof metis_default_lam_trans
370.380 val do_preplay = preplay_timeout <> SOME Time.zeroTime
370.381
370.382 fun isar_proof_of () =
370.383 let
370.384 val atp_proof =
370.385 atp_proof
370.386 - |> clean_up_atp_proof_dependencies
370.387 - |> nasty_atp_proof pool
370.388 - |> map_term_names_in_atp_proof repair_name
370.389 - |> map (decode_line ctxt lifted sym_tab)
370.390 - |> repair_waldmeister_endgame
370.391 - |> rpair [] |-> fold_rev (add_line fact_names)
370.392 + |> rpair [] |-> fold_rev add_line
370.393 |> rpair [] |-> fold_rev add_nontrivial_line
370.394 |> rpair (0, [])
370.395 - |-> fold_rev (add_desired_line fact_names)
370.396 + |-> fold_rev add_desired_line
370.397 |> snd
370.398 - val conj_name = conjecture_prefix ^ string_of_int (length hyp_ts)
370.399 val conjs =
370.400 - atp_proof |> map_filter
370.401 - (fn (name as (_, ss), _, _, _, []) =>
370.402 - if member (op =) ss conj_name then SOME name else NONE
370.403 - | _ => NONE)
370.404 + atp_proof |> map_filter (fn (name, role, _, _, _) =>
370.405 + if role = Conjecture orelse role = Negated_Conjecture then SOME name else NONE)
370.406 val assms =
370.407 - atp_proof |> map_filter
370.408 - (fn (name as (_, ss), _, _, _, []) =>
370.409 - (case resolve_conjecture ss of
370.410 - [j] =>
370.411 - if j = length hyp_ts then NONE
370.412 - else SOME (raw_label_of_name name, nth hyp_ts j)
370.413 - | _ => NONE)
370.414 - | _ => NONE)
370.415 + atp_proof
370.416 + |> map_filter (try (fn ((num, _), Hypothesis, t, _, _) => (raw_label_of_num num, t)))
370.417 val bot = atp_proof |> List.last |> #1
370.418 val refute_graph =
370.419 atp_proof
370.420 @@ -480,41 +252,32 @@
370.421 I))))
370.422 atp_proof
370.423 fun is_clause_skolemize_rule [(s, _)] =
370.424 - Option.map (is_skolemize_rule o fst) (Symtab.lookup steps s) =
370.425 - SOME true
370.426 + Option.map (is_skolemize_rule o fst) (Symtab.lookup steps s) = SOME true
370.427 | is_clause_skolemize_rule _ = false
370.428 - (* The assumptions and conjecture are "prop"s; the other formulas are
370.429 - "bool"s. *)
370.430 - fun prop_of_clause [(s, ss)] =
370.431 - (case resolve_conjecture ss of
370.432 - [j] => if j = length hyp_ts then concl_t else nth hyp_ts j
370.433 - | _ => the_default ("", @{term False}) (Symtab.lookup steps s)
370.434 - |> snd |> HOLogic.mk_Trueprop |> close_form)
370.435 + (* The assumptions and conjecture are "prop"s; the other formulas are "bool"s. *)
370.436 + fun prop_of_clause [(num, _)] =
370.437 + Symtab.lookup steps num |> the |> snd |> maybe_mk_Trueprop |> close_form
370.438 | prop_of_clause names =
370.439 let
370.440 val lits = map snd (map_filter (Symtab.lookup steps o fst) names)
370.441 in
370.442 case List.partition (can HOLogic.dest_not) lits of
370.443 (negs as _ :: _, pos as _ :: _) =>
370.444 - s_imp (Library.foldr1 s_conj (map HOLogic.dest_not negs),
370.445 - Library.foldr1 s_disj pos)
370.446 + s_imp (Library.foldr1 s_conj (map HOLogic.dest_not negs), Library.foldr1 s_disj pos)
370.447 | _ => fold (curry s_disj) lits @{term False}
370.448 end
370.449 |> HOLogic.mk_Trueprop |> close_form
370.450 fun isar_proof_of_direct_proof infs =
370.451 let
370.452 fun maybe_show outer c =
370.453 - (outer andalso length c = 1 andalso subset (op =) (c, conjs))
370.454 - ? cons Show
370.455 + (outer andalso length c = 1 andalso subset (op =) (c, conjs)) ? cons Show
370.456 val is_fixed = Variable.is_declared ctxt orf can Name.dest_skolem
370.457 - fun skolems_of t =
370.458 - Term.add_frees t [] |> filter_out (is_fixed o fst) |> rev
370.459 + fun skolems_of t = Term.add_frees t [] |> filter_out (is_fixed o fst) |> rev
370.460 fun do_steps outer predecessor accum [] =
370.461 accum
370.462 |> (if tainted = [] then
370.463 - cons (Prove (if outer then [Show] else [],
370.464 - Fix [], no_label, concl_t, [],
370.465 - By_Metis ([the predecessor], [])))
370.466 + cons (Prove (if outer then [Show] else [], Fix [], no_label, concl_t, [],
370.467 + By (([the predecessor], []), MetisM)))
370.468 else
370.469 I)
370.470 |> rev
370.471 @@ -522,26 +285,19 @@
370.472 let
370.473 val l = label_of_clause c
370.474 val t = prop_of_clause c
370.475 - val by =
370.476 - By_Metis
370.477 - (fold (add_fact_of_dependencies fact_names) gamma no_facts)
370.478 - fun prove sub by =
370.479 - Prove (maybe_show outer c [], Fix [], l, t, sub, by)
370.480 - fun do_rest l step =
370.481 - do_steps outer (SOME l) (step :: accum) infs
370.482 + val by = By (fold add_fact_of_dependencies gamma no_facts, MetisM)
370.483 + fun prove sub by = Prove (maybe_show outer c [], Fix [], l, t, sub, by)
370.484 + fun do_rest l step = do_steps outer (SOME l) (step :: accum) infs
370.485 in
370.486 if is_clause_tainted c then
370.487 case gamma of
370.488 [g] =>
370.489 - if is_clause_skolemize_rule g andalso
370.490 - is_clause_tainted g then
370.491 + if is_clause_skolemize_rule g andalso is_clause_tainted g then
370.492 let
370.493 val subproof =
370.494 - Proof (Fix (skolems_of (prop_of_clause g)),
370.495 - Assume [], rev accum)
370.496 + Proof (Fix (skolems_of (prop_of_clause g)), Assume [], rev accum)
370.497 in
370.498 - do_steps outer (SOME l)
370.499 - [prove [subproof] (By_Metis no_facts)] []
370.500 + do_steps outer (SOME l) [prove [subproof] (By (no_facts, MetisM))] []
370.501 end
370.502 else
370.503 do_rest l (prove [] by)
370.504 @@ -555,14 +311,13 @@
370.505 | do_steps outer predecessor accum (Cases cases :: infs) =
370.506 let
370.507 fun do_case (c, infs) =
370.508 - do_proof false [] [(label_of_clause c, prop_of_clause c)]
370.509 - infs
370.510 + do_proof false [] [(label_of_clause c, prop_of_clause c)] infs
370.511 val c = succedent_of_cases cases
370.512 val l = label_of_clause c
370.513 val t = prop_of_clause c
370.514 val step =
370.515 - Prove (maybe_show outer c [], Fix [], l, t,
370.516 - map do_case cases, By_Metis (the_list predecessor, []))
370.517 + Prove (maybe_show outer c [], Fix [], l, t, map do_case cases,
370.518 + By ((the_list predecessor, []), MetisM))
370.519 in
370.520 do_steps outer (SOME l) (step :: accum) infs
370.521 end
370.522 @@ -584,20 +339,18 @@
370.523 |> redirect_graph axioms tainted bot
370.524 |> isar_proof_of_direct_proof
370.525 |> relabel_proof_canonically
370.526 - |> `(proof_preplay_interface debug ctxt type_enc lam_trans do_preplay
370.527 + |> `(proof_preplay_interface debug ctxt metis_type_enc metis_lam_trans do_preplay
370.528 preplay_timeout)
370.529 val ((preplay_time, preplay_fail), isar_proof) =
370.530 isar_proof
370.531 - |> compress_proof
370.532 - (if isar_proofs = SOME true then isar_compress else 1000.0)
370.533 + |> compress_proof (if isar_proofs = SOME true then isar_compress else 1000.0)
370.534 preplay_interface
370.535 |> isar_try0 ? try0 preplay_timeout preplay_interface
370.536 - |> minimize_dependencies_and_remove_unrefed_steps isar_try0
370.537 - preplay_interface
370.538 + |> minimize_dependencies_and_remove_unrefed_steps isar_try0 preplay_interface
370.539 |> `overall_preplay_stats
370.540 ||> clean_up_labels_in_proof
370.541 - val isar_text = string_of_proof ctxt type_enc lam_trans subgoal
370.542 - subgoal_count isar_proof
370.543 + val isar_text =
370.544 + string_of_proof ctxt metis_type_enc metis_lam_trans subgoal subgoal_count isar_proof
370.545 in
370.546 case isar_text of
370.547 "" =>
370.548 @@ -620,10 +373,8 @@
370.549 else
370.550 [])
370.551 in
370.552 - "\n\nStructured proof"
370.553 - ^ (commas msg |> not (null msg) ? enclose " (" ")")
370.554 - ^ ":\n" ^
370.555 - Active.sendback_markup [Markup.padding_command] isar_text
370.556 + "\n\nStructured proof" ^ (commas msg |> not (null msg) ? enclose " (" ")") ^ ":\n" ^
370.557 + Active.sendback_markup [Markup.padding_command] isar_text
370.558 end
370.559 end
370.560 val isar_proof =
370.561 @@ -640,14 +391,14 @@
370.562 fun isar_proof_would_be_a_good_idea preplay =
370.563 case preplay of
370.564 Played (reconstr, _) => reconstr = SMT
370.565 - | Trust_Playable _ => true
370.566 + | Trust_Playable _ => false
370.567 | Failed_to_Play _ => true
370.568
370.569 fun proof_text ctxt isar_proofs isar_params num_chained
370.570 (one_line_params as (preplay, _, _, _, _, _)) =
370.571 (if isar_proofs = SOME true orelse
370.572 (isar_proofs = NONE andalso isar_proof_would_be_a_good_idea preplay) then
370.573 - isar_proof_text ctxt isar_proofs isar_params
370.574 + isar_proof_text ctxt isar_proofs (isar_params ())
370.575 else
370.576 one_line_proof_text num_chained) one_line_params
370.577
371.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_reconstructor.ML Thu Dec 05 17:52:12 2013 +0100
371.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_reconstructor.ML Thu Dec 05 17:58:03 2013 +0100
371.3 @@ -7,7 +7,6 @@
371.4
371.5 signature SLEDGEHAMMER_RECONSTRUCTOR =
371.6 sig
371.7 -
371.8 type stature = ATP_Problem_Generate.stature
371.9
371.10 datatype reconstructor =
371.11 @@ -25,8 +24,7 @@
371.12 play * string * (string * stature) list * minimize_command * int * int
371.13
371.14 val smtN : string
371.15 -
371.16 -end
371.17 +end;
371.18
371.19 structure Sledgehammer_Reconstructor : SLEDGEHAMMER_RECONSTRUCTOR =
371.20 struct
371.21 @@ -49,4 +47,4 @@
371.22
371.23 val smtN = "smt"
371.24
371.25 -end
371.26 +end;
372.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_run.ML Thu Dec 05 17:52:12 2013 +0100
372.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_run.ML Thu Dec 05 17:58:03 2013 +0100
372.3 @@ -68,21 +68,21 @@
372.4 fun launch_prover (params as {debug, verbose, spy, blocking, max_facts, slice,
372.5 timeout, expect, ...})
372.6 mode output_result minimize_command only learn
372.7 - {state, goal, subgoal, subgoal_count, factss as (_, facts) :: _} name =
372.8 + {comment, state, goal, subgoal, subgoal_count, factss as (_, facts) :: _} name =
372.9 let
372.10 val ctxt = Proof.context_of state
372.11
372.12 val hard_timeout = time_mult 3.0 (timeout |> the_default one_day)
372.13 - val _ = spying spy (fn () => (state, subgoal, name, "launched"));
372.14 + val _ = spying spy (fn () => (state, subgoal, name, "Launched"));
372.15 val birth_time = Time.now ()
372.16 val death_time = Time.+ (birth_time, hard_timeout)
372.17 - val max_facts = max_facts |> the_default (default_max_facts_of_prover ctxt slice name)
372.18 + val max_facts = max_facts |> the_default (default_max_facts_of_prover ctxt name)
372.19 val num_facts = length facts |> not only ? Integer.min max_facts
372.20
372.21 fun desc () = prover_description ctxt params name num_facts subgoal subgoal_count goal
372.22
372.23 val problem =
372.24 - {state = state, goal = goal, subgoal = subgoal,
372.25 + {comment = comment, state = state, goal = goal, subgoal = subgoal,
372.26 subgoal_count = subgoal_count,
372.27 factss = factss
372.28 |> map (apsnd ((not (is_ho_atp ctxt name)
372.29 @@ -100,13 +100,33 @@
372.30 " proof (of " ^ string_of_int (length facts) ^ "): ") "."
372.31 |> Output.urgent_message
372.32
372.33 - fun spying_str_of_res ({outcome = NONE, used_facts, ...} : prover_result) =
372.34 - let val num_used_facts = length used_facts in
372.35 - "success: Found proof with " ^ string_of_int num_used_facts ^ " fact" ^
372.36 - plural_s num_used_facts
372.37 + fun spying_str_of_res ({outcome = NONE, used_facts, used_from, ...} : prover_result) =
372.38 + let
372.39 + val num_used_facts = length used_facts
372.40 +
372.41 + fun find_indices facts =
372.42 + tag_list 1 facts
372.43 + |> map (fn (j, fact) => fact |> apsnd (K j))
372.44 + |> filter_used_facts false used_facts
372.45 + |> map (prefix "@" o string_of_int o snd)
372.46 +
372.47 + fun filter_info (fact_filter, facts) =
372.48 + let
372.49 + val indices = find_indices facts
372.50 + val unknowns = replicate (num_used_facts - length indices) "?"
372.51 + in (commas (indices @ unknowns), fact_filter) end
372.52 +
372.53 + val filter_infos =
372.54 + map filter_info (("actual", used_from) :: factss)
372.55 + |> AList.group (op =)
372.56 + |> map (fn (indices, fact_filters) => commas fact_filters ^ ": " ^ indices)
372.57 + in
372.58 + "Success: Found proof with " ^ string_of_int num_used_facts ^
372.59 + " of " ^ string_of_int num_facts ^ " fact" ^ plural_s num_facts ^
372.60 + (if num_used_facts = 0 then "" else ": " ^ commas filter_infos)
372.61 end
372.62 | spying_str_of_res {outcome = SOME failure, ...} =
372.63 - "failure: " ^ string_of_atp_failure failure
372.64 + "Failure: " ^ string_of_atp_failure failure
372.65
372.66 fun really_go () =
372.67 problem
372.68 @@ -209,8 +229,7 @@
372.69 val _ = Proof.assert_backward state
372.70 val print =
372.71 if mode = Normal andalso is_none output_result then Output.urgent_message else K ()
372.72 - val state =
372.73 - state |> Proof.map_context (Config.put SMT_Config.verbose debug)
372.74 + val state = state |> Proof.map_context (Config.put SMT_Config.verbose debug)
372.75 val ctxt = Proof.context_of state
372.76 val {facts = chained, goal, ...} = Proof.goal state
372.77 val (_, hyp_ts, concl_t) = strip_subgoal goal i ctxt
372.78 @@ -225,11 +244,9 @@
372.79 SOME name => error ("No such prover: " ^ name ^ ".")
372.80 | NONE => ()
372.81 val _ = print "Sledgehammering..."
372.82 - val _ =
372.83 - spying spy (fn () => (state, i, "***", "starting " ^ @{make_string} mode ^ " mode"))
372.84 - val (smts, (ueq_atps, full_atps)) =
372.85 - provers |> List.partition (is_smt_prover ctxt)
372.86 - ||> List.partition (is_unit_equational_atp ctxt)
372.87 + val _ = spying spy (fn () => (state, i, "***", "Starting " ^ @{make_string} mode ^ " mode"))
372.88 +
372.89 + val (ueq_atps, full_provers) = List.partition (is_unit_equational_atp ctxt) provers
372.90
372.91 val spying_str_of_factss =
372.92 commas o map (fn (filter, facts) => filter ^ ": " ^ string_of_int (length facts))
372.93 @@ -240,18 +257,16 @@
372.94 case max_facts of
372.95 SOME n => n
372.96 | NONE =>
372.97 - 0 |> fold (Integer.max o default_max_facts_of_prover ctxt slice)
372.98 - provers
372.99 + 0 |> fold (Integer.max o default_max_facts_of_prover ctxt) provers
372.100 |> mode = Auto_Try ? (fn n => n div auto_try_max_facts_divisor)
372.101 val _ = spying spy (fn () => (state, i, label ^ "s",
372.102 - "filtering " ^ string_of_int (length all_facts) ^ " facts"));
372.103 + "Filtering " ^ string_of_int (length all_facts) ^ " facts"));
372.104 in
372.105 all_facts
372.106 |> (case is_appropriate_prop of
372.107 SOME is_app => filter (is_app o prop_of o snd)
372.108 | NONE => I)
372.109 - |> relevant_facts ctxt params (hd provers) max_max_facts fact_override
372.110 - hyp_ts concl_t
372.111 + |> relevant_facts ctxt params (hd provers) max_max_facts fact_override hyp_ts concl_t
372.112 |> tap (fn factss =>
372.113 if verbose then
372.114 label ^ plural_s (length provers) ^ ": " ^
372.115 @@ -259,21 +274,18 @@
372.116 |> print
372.117 else
372.118 ())
372.119 - |> spy ? tap (fn factss =>
372.120 - spying spy (fn () =>
372.121 - (state, i, label ^ "s", "selected facts: " ^ spying_str_of_factss factss)))
372.122 + |> spy ? tap (fn factss => spying spy (fn () =>
372.123 + (state, i, label ^ "s", "Selected facts: " ^ spying_str_of_factss factss)))
372.124 end
372.125
372.126 fun launch_provers state label is_appropriate_prop provers =
372.127 let
372.128 val factss = get_factss label is_appropriate_prop provers
372.129 val problem =
372.130 - {state = state, goal = goal, subgoal = i, subgoal_count = n,
372.131 + {comment = "", state = state, goal = goal, subgoal = i, subgoal_count = n,
372.132 factss = factss}
372.133 - fun learn prover =
372.134 - mash_learn_proof ctxt params prover (prop_of goal) all_facts
372.135 - val launch =
372.136 - launch_prover params mode output_result minimize_command only learn
372.137 + val learn = mash_learn_proof ctxt params (prop_of goal) all_facts
372.138 + val launch = launch_prover params mode output_result minimize_command only learn
372.139 in
372.140 if mode = Auto_Try then
372.141 (unknownN, state)
372.142 @@ -287,30 +299,26 @@
372.143 |> max_outcome_code |> rpair state
372.144 end
372.145
372.146 - fun launch_atps label is_appropriate_prop atps accum =
372.147 - if null atps then
372.148 + fun maybe_launch_provers label is_appropriate_prop provers_to_launch accum =
372.149 + if null provers_to_launch then
372.150 accum
372.151 else if is_some is_appropriate_prop andalso
372.152 not (the is_appropriate_prop concl_t) then
372.153 - (if verbose orelse length atps = length provers then
372.154 + (if verbose orelse length provers_to_launch = length provers then
372.155 "Goal outside the scope of " ^
372.156 - space_implode " " (serial_commas "and" (map quote atps)) ^ "."
372.157 + space_implode " " (serial_commas "and" (map quote provers_to_launch)) ^ "."
372.158 |> Output.urgent_message
372.159 else
372.160 ();
372.161 accum)
372.162 else
372.163 - launch_provers state label is_appropriate_prop atps
372.164 + launch_provers state label is_appropriate_prop provers_to_launch
372.165
372.166 - fun launch_smts accum =
372.167 - if null smts then accum else launch_provers state "SMT solver" NONE smts
372.168 -
372.169 - val launch_full_atps = launch_atps "ATP" NONE full_atps
372.170 -
372.171 - val launch_ueq_atps = launch_atps "Unit-equational provers" (SOME is_unit_equality) ueq_atps
372.172 + val launch_full_provers = maybe_launch_provers "ATP/SMT" NONE full_provers
372.173 + val launch_ueq_atps = maybe_launch_provers "Unit-equational provers" (SOME is_unit_equality) ueq_atps
372.174
372.175 fun launch_atps_and_smt_solvers p =
372.176 - [launch_full_atps, launch_smts, launch_ueq_atps]
372.177 + [launch_full_provers, launch_ueq_atps]
372.178 |> Par_List.map (fn f => fst (f p))
372.179 handle ERROR msg => (print ("Error: " ^ msg); error msg)
372.180
372.181 @@ -318,14 +326,9 @@
372.182 accum |> (mode = Normal orelse outcome_code <> someN) ? f
372.183 in
372.184 (unknownN, state)
372.185 - |> (if mode = Auto_Try then
372.186 - launch_full_atps
372.187 - else if blocking then
372.188 - launch_atps_and_smt_solvers #> max_outcome_code #> rpair state
372.189 - else
372.190 - (fn p => (Future.fork (tap (fn () => launch_atps_and_smt_solvers p)); p)))
372.191 - handle TimeLimit.TimeOut =>
372.192 - (print "Sledgehammer ran out of time."; (unknownN, state))
372.193 + |> (if blocking then launch_full_provers
372.194 + else (fn p => (Future.fork (tap (fn () => launch_full_provers p)); p)))
372.195 + handle TimeLimit.TimeOut => (print "Sledgehammer ran out of time."; (unknownN, state))
372.196 end
372.197 |> `(fn (outcome_code, _) => outcome_code = someN)
372.198
373.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_try0.ML Thu Dec 05 17:52:12 2013 +0100
373.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_try0.ML Thu Dec 05 17:58:03 2013 +0100
373.3 @@ -12,7 +12,7 @@
373.4 type preplay_interface = Sledgehammer_Preplay.preplay_interface
373.5
373.6 val try0 : Time.time -> preplay_interface -> isar_proof -> isar_proof
373.7 -end
373.8 +end;
373.9
373.10 structure Sledgehammer_Try0 : SLEDGEHAMMER_TRY0 =
373.11 struct
373.12 @@ -59,4 +59,4 @@
373.13 fun try0 preplay_timeout preplay_interface proof =
373.14 map_isar_steps (try0_step preplay_timeout preplay_interface) proof
373.15
373.16 -end
373.17 +end;
374.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_util.ML Thu Dec 05 17:52:12 2013 +0100
374.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_util.ML Thu Dec 05 17:58:03 2013 +0100
374.3 @@ -97,44 +97,29 @@
374.4 (* FIXME: Similar yet different code in "mirabelle.ML". The code here has a few
374.5 fixes that seem to be missing over there; or maybe the two code portions are
374.6 not doing the same? *)
374.7 -fun fold_body_thms outer_name (map_plain_name, map_inclass_name) =
374.8 +fun fold_body_thm outer_name (map_plain_name, map_inclass_name) =
374.9 let
374.10 - fun app map_name n (PBody {thms, ...}) =
374.11 - thms |> fold (fn (_, (name, _, body)) => fn accum =>
374.12 - let
374.13 - val collect = union (op =) o the_list o map_name
374.14 - (* The "name = outer_name" case caters for the uncommon case where
374.15 - the proved theorem occurs in its own proof (e.g.,
374.16 - "Transitive_Closure.trancl_into_trancl"). *)
374.17 - val (anonymous, enter_class) =
374.18 - if name = "" orelse (n = 1 andalso name = outer_name) then
374.19 - (true, false)
374.20 - else if n = 1 andalso map_inclass_name name = SOME outer_name then
374.21 - (true, true)
374.22 - else
374.23 - (false, false)
374.24 - val accum =
374.25 - accum |> (if n = 1 andalso not anonymous then collect name else I)
374.26 - val n = n + (if anonymous then 0 else 1)
374.27 - in
374.28 - accum
374.29 - |> (if n <= 1 then
374.30 - app (if enter_class then map_inclass_name else map_name) n
374.31 - (Future.join body)
374.32 - else
374.33 - I)
374.34 - end)
374.35 - in fold (app map_plain_name 0) end
374.36 + fun app_thm map_name (_, (name, _, body)) accum =
374.37 + let
374.38 + val (anonymous, enter_class) =
374.39 + (* The "name = outer_name" case caters for the uncommon case where the proved theorem
374.40 + occurs in its own proof (e.g., "Transitive_Closure.trancl_into_trancl"). *)
374.41 + if name = "" orelse name = outer_name then (true, false)
374.42 + else if map_inclass_name name = SOME outer_name then (true, true)
374.43 + else (false, false)
374.44 + in
374.45 + if anonymous then
374.46 + accum |> app_body (if enter_class then map_inclass_name else map_name) (Future.join body)
374.47 + else
374.48 + accum |> union (op =) (the_list (map_name name))
374.49 + end
374.50 + and app_body map_name (PBody {thms, ...}) = fold (app_thm map_name) thms
374.51 + in app_body map_plain_name end
374.52
374.53 fun thms_in_proof name_tabs th =
374.54 - let
374.55 - val map_names =
374.56 - case name_tabs of
374.57 - SOME p => pairself Symtab.lookup p
374.58 - | NONE => `I SOME
374.59 - val names =
374.60 - fold_body_thms (Thm.get_name_hint th) map_names [Thm.proof_body_of th] []
374.61 - in names end
374.62 + let val map_names = (case name_tabs of SOME p => pairself Symtab.lookup p | NONE => `I SOME) in
374.63 + fold_body_thm (Thm.get_name_hint th) map_names (Proofterm.strip_thm (Thm.proof_body_of th)) []
374.64 + end
374.65
374.66 fun thms_of_name ctxt name =
374.67 let
374.68 @@ -162,7 +147,7 @@
374.69 fun hackish_string_of_term ctxt =
374.70 with_vanilla_print_mode (Syntax.string_of_term ctxt) #> simplify_spaces
374.71
374.72 -val spying_version = "b"
374.73 +val spying_version = "c"
374.74
374.75 fun spying false _ = ()
374.76 | spying true f =
375.1 --- a/src/HOL/Tools/case_translation.ML Thu Dec 05 17:52:12 2013 +0100
375.2 +++ b/src/HOL/Tools/case_translation.ML Thu Dec 05 17:58:03 2013 +0100
375.3 @@ -8,6 +8,9 @@
375.4
375.5 signature CASE_TRANSLATION =
375.6 sig
375.7 + val indexify_names: string list -> string list
375.8 + val make_tnames: typ list -> string list
375.9 +
375.10 datatype config = Error | Warning | Quiet
375.11 val case_tr: bool -> Proof.context -> term list -> term
375.12 val lookup_by_constr: Proof.context -> string * typ -> (term * term list) option
375.13 @@ -25,6 +28,30 @@
375.14 structure Case_Translation: CASE_TRANSLATION =
375.15 struct
375.16
375.17 +(** general utilities **)
375.18 +
375.19 +fun indexify_names names =
375.20 + let
375.21 + fun index (x :: xs) tab =
375.22 + (case AList.lookup (op =) tab x of
375.23 + NONE =>
375.24 + if member (op =) xs x
375.25 + then (x ^ "1") :: index xs ((x, 2) :: tab)
375.26 + else x :: index xs tab
375.27 + | SOME i => (x ^ string_of_int i) :: index xs ((x, i + 1) :: tab))
375.28 + | index [] _ = [];
375.29 + in index names [] end;
375.30 +
375.31 +fun make_tnames Ts =
375.32 + let
375.33 + fun type_name (TFree (name, _)) = unprefix "'" name
375.34 + | type_name (Type (name, _)) =
375.35 + let val name' = Long_Name.base_name name
375.36 + in if Symbol_Pos.is_identifier name' then name' else "x" end;
375.37 + in indexify_names (map type_name Ts) end;
375.38 +
375.39 +
375.40 +
375.41 (** data management **)
375.42
375.43 datatype data = Data of
375.44 @@ -228,8 +255,7 @@
375.45 val (_, T) = dest_Const c;
375.46 val Ts = binder_types T;
375.47 val (names, _) =
375.48 - fold_map Name.variant
375.49 - (Datatype_Prop.make_tnames (map Logic.unvarifyT_global Ts)) used;
375.50 + fold_map Name.variant (make_tnames (map Logic.unvarifyT_global Ts)) used;
375.51 val ty = body_type T;
375.52 val ty_theta = Type.raw_match (ty, colty) Vartab.empty
375.53 handle Type.TYPE_MATCH => raise CASE_ERROR ("type mismatch", ~1);
376.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
376.2 +++ b/src/HOL/Tools/coinduction.ML Thu Dec 05 17:58:03 2013 +0100
376.3 @@ -0,0 +1,159 @@
376.4 +(* Title: HOL/Tools/coinduction.ML
376.5 + Author: Johannes Hölzl, TU Muenchen
376.6 + Author: Dmitriy Traytel, TU Muenchen
376.7 + Copyright 2013
376.8 +
376.9 +Coinduction method that avoids some boilerplate compared to coinduct.
376.10 +*)
376.11 +
376.12 +signature COINDUCTION =
376.13 +sig
376.14 + val coinduction_tac: Proof.context -> term list -> thm option -> thm list -> cases_tactic
376.15 + val setup: theory -> theory
376.16 +end;
376.17 +
376.18 +structure Coinduction : COINDUCTION =
376.19 +struct
376.20 +
376.21 +open Ctr_Sugar_Util
376.22 +open Ctr_Sugar_General_Tactics
376.23 +
376.24 +fun filter_in_out _ [] = ([], [])
376.25 + | filter_in_out P (x :: xs) = (let
376.26 + val (ins, outs) = filter_in_out P xs;
376.27 + in
376.28 + if P x then (x :: ins, outs) else (ins, x :: outs)
376.29 + end);
376.30 +
376.31 +fun ALLGOALS_SKIP skip tac st =
376.32 + let fun doall n = if n = skip then all_tac else tac n THEN doall (n - 1)
376.33 + in doall (nprems_of st) st end;
376.34 +
376.35 +fun THEN_ALL_NEW_SKIP skip tac1 tac2 i st =
376.36 + st |> (tac1 i THEN (fn st' =>
376.37 + Seq.INTERVAL tac2 (i + skip) (i + nprems_of st' - nprems_of st) st'));
376.38 +
376.39 +fun DELETE_PREMS_AFTER skip tac i st =
376.40 + let
376.41 + val n = nth (prems_of st) (i - 1) |> Logic.strip_assums_hyp |> length;
376.42 + in
376.43 + (THEN_ALL_NEW_SKIP skip tac (REPEAT_DETERM_N n o etac thin_rl)) i st
376.44 + end;
376.45 +
376.46 +fun coinduction_tac ctxt raw_vars opt_raw_thm prems st =
376.47 + let
376.48 + val lhs_of_eq = HOLogic.dest_Trueprop #> HOLogic.dest_eq #> fst;
376.49 + fun find_coinduct t =
376.50 + Induct.find_coinductP ctxt t @
376.51 + (try (Induct.find_coinductT ctxt o fastype_of o lhs_of_eq) t |> the_default [])
376.52 + val raw_thm = case opt_raw_thm
376.53 + of SOME raw_thm => raw_thm
376.54 + | NONE => st |> prems_of |> hd |> Logic.strip_assums_concl |> find_coinduct |> hd;
376.55 + val skip = Integer.max 1 (Rule_Cases.get_consumes raw_thm) - 1
376.56 + val cases = Rule_Cases.get raw_thm |> fst
376.57 + in
376.58 + NO_CASES (HEADGOAL (
376.59 + Object_Logic.rulify_tac THEN'
376.60 + Method.insert_tac prems THEN'
376.61 + Object_Logic.atomize_prems_tac THEN'
376.62 + DELETE_PREMS_AFTER skip (Subgoal.FOCUS (fn {concl, context = ctxt, params, prems, ...} =>
376.63 + let
376.64 + val vars = raw_vars @ map (term_of o snd) params;
376.65 + val names_ctxt = ctxt
376.66 + |> fold Variable.declare_names vars
376.67 + |> fold Variable.declare_thm (raw_thm :: prems);
376.68 + val thm_concl = Thm.cprop_of raw_thm |> strip_imp_concl;
376.69 + val (rhoTs, rhots) = Thm.match (thm_concl, concl)
376.70 + |>> map (pairself typ_of)
376.71 + ||> map (pairself term_of);
376.72 + val xs = hd (Thm.prems_of raw_thm) |> HOLogic.dest_Trueprop |> strip_comb |> snd
376.73 + |> map (subst_atomic_types rhoTs);
376.74 + val raw_eqs = map (fn x => (x, AList.lookup op aconv rhots x |> the)) xs;
376.75 + val ((names, ctxt), Ts) = map_split (apfst fst o dest_Var o fst) raw_eqs
376.76 + |>> (fn names => Variable.variant_fixes names names_ctxt) ;
376.77 + val eqs =
376.78 + map3 (fn name => fn T => fn (_, rhs) =>
376.79 + HOLogic.mk_eq (Free (name, T), rhs))
376.80 + names Ts raw_eqs;
376.81 + val phi = eqs @ map (HOLogic.dest_Trueprop o prop_of) prems
376.82 + |> try (Library.foldr1 HOLogic.mk_conj)
376.83 + |> the_default @{term True}
376.84 + |> list_exists_free vars
376.85 + |> Term.map_abs_vars (Variable.revert_fixed ctxt)
376.86 + |> fold_rev Term.absfree (names ~~ Ts)
376.87 + |> certify ctxt;
376.88 + val thm = cterm_instantiate_pos [SOME phi] raw_thm;
376.89 + val e = length eqs;
376.90 + val p = length prems;
376.91 + in
376.92 + HEADGOAL (EVERY' [rtac thm,
376.93 + EVERY' (map (fn var =>
376.94 + rtac (cterm_instantiate_pos [NONE, SOME (certify ctxt var)] exI)) vars),
376.95 + if p = 0 then CONJ_WRAP' (K (rtac refl)) eqs
376.96 + else REPEAT_DETERM_N e o (rtac conjI THEN' rtac refl) THEN' CONJ_WRAP' rtac prems,
376.97 + K (ALLGOALS_SKIP skip
376.98 + (REPEAT_DETERM_N (length vars) o (etac exE THEN' rotate_tac ~1) THEN'
376.99 + DELETE_PREMS_AFTER 0 (Subgoal.FOCUS (fn {prems, params, context = ctxt, ...} =>
376.100 + (case prems of
376.101 + [] => all_tac
376.102 + | inv::case_prems =>
376.103 + let
376.104 + val (init, last) = funpow_yield (p + e - 1) HOLogic.conj_elim inv;
376.105 + val inv_thms = init @ [last];
376.106 + val eqs = take e inv_thms;
376.107 + fun is_local_var t =
376.108 + member (fn (t, (_, t')) => t aconv (term_of t')) params t;
376.109 + val (eqs, assms') = filter_in_out (is_local_var o lhs_of_eq o prop_of) eqs;
376.110 + val assms = assms' @ drop e inv_thms
376.111 + in
376.112 + HEADGOAL (Method.insert_tac (assms @ case_prems)) THEN
376.113 + unfold_thms_tac ctxt eqs
376.114 + end)) ctxt)))])
376.115 + end) ctxt) THEN'
376.116 + K (prune_params_tac))) st
376.117 + |> Seq.maps (fn (_, st) =>
376.118 + CASES (Rule_Cases.make_common (Proof_Context.theory_of ctxt, prop_of st) cases) all_tac st)
376.119 + end;
376.120 +
376.121 +local
376.122 +
376.123 +val ruleN = "rule"
376.124 +val arbitraryN = "arbitrary"
376.125 +fun single_rule [rule] = rule
376.126 + | single_rule _ = error "Single rule expected";
376.127 +
376.128 +fun named_rule k arg get =
376.129 + Scan.lift (Args.$$$ k -- Args.colon) |-- Scan.repeat arg :|--
376.130 + (fn names => Scan.peek (fn context => Scan.succeed (names |> map (fn name =>
376.131 + (case get (Context.proof_of context) name of SOME x => x
376.132 + | NONE => error ("No rule for " ^ k ^ " " ^ quote name))))));
376.133 +
376.134 +fun rule get_type get_pred =
376.135 + named_rule Induct.typeN (Args.type_name false) get_type ||
376.136 + named_rule Induct.predN (Args.const false) get_pred ||
376.137 + named_rule Induct.setN (Args.const false) get_pred ||
376.138 + Scan.lift (Args.$$$ ruleN -- Args.colon) |-- Attrib.thms;
376.139 +
376.140 +val coinduct_rule = rule Induct.lookup_coinductT Induct.lookup_coinductP >> single_rule;
376.141 +
376.142 +fun unless_more_args scan = Scan.unless (Scan.lift
376.143 + ((Args.$$$ arbitraryN || Args.$$$ Induct.typeN ||
376.144 + Args.$$$ Induct.predN || Args.$$$ Induct.setN || Args.$$$ ruleN) -- Args.colon)) scan;
376.145 +
376.146 +val arbitrary = Scan.optional (Scan.lift (Args.$$$ arbitraryN -- Args.colon) |--
376.147 + Scan.repeat1 (unless_more_args Args.term)) [];
376.148 +
376.149 +in
376.150 +
376.151 +val setup =
376.152 + Method.setup @{binding coinduction}
376.153 + (arbitrary -- Scan.option coinduct_rule >>
376.154 + (fn (arbitrary, opt_rule) => fn ctxt =>
376.155 + RAW_METHOD_CASES (fn facts =>
376.156 + Seq.DETERM (coinduction_tac ctxt arbitrary opt_rule facts))))
376.157 + "coinduction on types or predicates/sets";
376.158 +
376.159 +end;
376.160 +
376.161 +end;
376.162 +
377.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
377.2 +++ b/src/HOL/Tools/ctr_sugar.ML Thu Dec 05 17:58:03 2013 +0100
377.3 @@ -0,0 +1,978 @@
377.4 +(* Title: HOL/Tools/ctr_sugar.ML
377.5 + Author: Jasmin Blanchette, TU Muenchen
377.6 + Copyright 2012, 2013
377.7 +
377.8 +Wrapping existing freely generated type's constructors.
377.9 +*)
377.10 +
377.11 +signature CTR_SUGAR =
377.12 +sig
377.13 + type ctr_sugar =
377.14 + {ctrs: term list,
377.15 + casex: term,
377.16 + discs: term list,
377.17 + selss: term list list,
377.18 + exhaust: thm,
377.19 + nchotomy: thm,
377.20 + injects: thm list,
377.21 + distincts: thm list,
377.22 + case_thms: thm list,
377.23 + case_cong: thm,
377.24 + weak_case_cong: thm,
377.25 + split: thm,
377.26 + split_asm: thm,
377.27 + disc_thmss: thm list list,
377.28 + discIs: thm list,
377.29 + sel_thmss: thm list list,
377.30 + disc_exhausts: thm list,
377.31 + sel_exhausts: thm list,
377.32 + collapses: thm list,
377.33 + expands: thm list,
377.34 + sel_splits: thm list,
377.35 + sel_split_asms: thm list,
377.36 + case_eq_ifs: thm list};
377.37 +
377.38 + val morph_ctr_sugar: morphism -> ctr_sugar -> ctr_sugar
377.39 + val transfer_ctr_sugar: Proof.context -> ctr_sugar -> ctr_sugar
377.40 + val ctr_sugar_of: Proof.context -> string -> ctr_sugar option
377.41 + val ctr_sugars_of: Proof.context -> ctr_sugar list
377.42 + val ctr_sugar_of_case: Proof.context -> string -> ctr_sugar option
377.43 + val register_ctr_sugar: string -> ctr_sugar -> local_theory -> local_theory
377.44 + val register_ctr_sugar_global: string -> ctr_sugar -> theory -> theory
377.45 +
377.46 + val rep_compat_prefix: string
377.47 +
377.48 + val mk_half_pairss: 'a list * 'a list -> ('a * 'a) list list
377.49 + val join_halves: int -> 'a list list -> 'a list list -> 'a list * 'a list list list
377.50 +
377.51 + val mk_ctr: typ list -> term -> term
377.52 + val mk_case: typ list -> typ -> term -> term
377.53 + val mk_disc_or_sel: typ list -> term -> term
377.54 + val name_of_ctr: term -> string
377.55 + val name_of_disc: term -> string
377.56 + val dest_ctr: Proof.context -> string -> term -> term * term list
377.57 + val dest_case: Proof.context -> string -> typ list -> term -> (term list * term list) option
377.58 +
377.59 + val wrap_free_constructors: ({prems: thm list, context: Proof.context} -> tactic) list list ->
377.60 + (((bool * (bool * bool)) * term list) * binding) *
377.61 + (binding list * (binding list list * (binding * term) list list)) -> local_theory ->
377.62 + ctr_sugar * local_theory
377.63 + val parse_wrap_free_constructors_options: (bool * (bool * bool)) parser
377.64 + val parse_bound_term: (binding * string) parser
377.65 +end;
377.66 +
377.67 +structure Ctr_Sugar : CTR_SUGAR =
377.68 +struct
377.69 +
377.70 +open Ctr_Sugar_Util
377.71 +open Ctr_Sugar_Tactics
377.72 +open Ctr_Sugar_Code
377.73 +
377.74 +type ctr_sugar =
377.75 + {ctrs: term list,
377.76 + casex: term,
377.77 + discs: term list,
377.78 + selss: term list list,
377.79 + exhaust: thm,
377.80 + nchotomy: thm,
377.81 + injects: thm list,
377.82 + distincts: thm list,
377.83 + case_thms: thm list,
377.84 + case_cong: thm,
377.85 + weak_case_cong: thm,
377.86 + split: thm,
377.87 + split_asm: thm,
377.88 + disc_thmss: thm list list,
377.89 + discIs: thm list,
377.90 + sel_thmss: thm list list,
377.91 + disc_exhausts: thm list,
377.92 + sel_exhausts: thm list,
377.93 + collapses: thm list,
377.94 + expands: thm list,
377.95 + sel_splits: thm list,
377.96 + sel_split_asms: thm list,
377.97 + case_eq_ifs: thm list};
377.98 +
377.99 +fun eq_ctr_sugar ({ctrs = ctrs1, casex = case1, discs = discs1, selss = selss1, ...} : ctr_sugar,
377.100 + {ctrs = ctrs2, casex = case2, discs = discs2, selss = selss2, ...} : ctr_sugar) =
377.101 + ctrs1 = ctrs2 andalso case1 = case2 andalso discs1 = discs2 andalso selss1 = selss2;
377.102 +
377.103 +fun morph_ctr_sugar phi {ctrs, casex, discs, selss, exhaust, nchotomy, injects, distincts,
377.104 + case_thms, case_cong, weak_case_cong, split, split_asm, disc_thmss, discIs, sel_thmss,
377.105 + disc_exhausts, sel_exhausts, collapses, expands, sel_splits, sel_split_asms, case_eq_ifs} =
377.106 + {ctrs = map (Morphism.term phi) ctrs,
377.107 + casex = Morphism.term phi casex,
377.108 + discs = map (Morphism.term phi) discs,
377.109 + selss = map (map (Morphism.term phi)) selss,
377.110 + exhaust = Morphism.thm phi exhaust,
377.111 + nchotomy = Morphism.thm phi nchotomy,
377.112 + injects = map (Morphism.thm phi) injects,
377.113 + distincts = map (Morphism.thm phi) distincts,
377.114 + case_thms = map (Morphism.thm phi) case_thms,
377.115 + case_cong = Morphism.thm phi case_cong,
377.116 + weak_case_cong = Morphism.thm phi weak_case_cong,
377.117 + split = Morphism.thm phi split,
377.118 + split_asm = Morphism.thm phi split_asm,
377.119 + disc_thmss = map (map (Morphism.thm phi)) disc_thmss,
377.120 + discIs = map (Morphism.thm phi) discIs,
377.121 + sel_thmss = map (map (Morphism.thm phi)) sel_thmss,
377.122 + disc_exhausts = map (Morphism.thm phi) disc_exhausts,
377.123 + sel_exhausts = map (Morphism.thm phi) sel_exhausts,
377.124 + collapses = map (Morphism.thm phi) collapses,
377.125 + expands = map (Morphism.thm phi) expands,
377.126 + sel_splits = map (Morphism.thm phi) sel_splits,
377.127 + sel_split_asms = map (Morphism.thm phi) sel_split_asms,
377.128 + case_eq_ifs = map (Morphism.thm phi) case_eq_ifs};
377.129 +
377.130 +val transfer_ctr_sugar =
377.131 + morph_ctr_sugar o Morphism.thm_morphism o Thm.transfer o Proof_Context.theory_of;
377.132 +
377.133 +structure Data = Generic_Data
377.134 +(
377.135 + type T = ctr_sugar Symtab.table;
377.136 + val empty = Symtab.empty;
377.137 + val extend = I;
377.138 + val merge = Symtab.merge eq_ctr_sugar;
377.139 +);
377.140 +
377.141 +fun ctr_sugar_of ctxt =
377.142 + Symtab.lookup (Data.get (Context.Proof ctxt))
377.143 + #> Option.map (transfer_ctr_sugar ctxt);
377.144 +
377.145 +fun ctr_sugars_of ctxt =
377.146 + Symtab.fold (cons o transfer_ctr_sugar ctxt o snd) (Data.get (Context.Proof ctxt)) [];
377.147 +
377.148 +fun ctr_sugar_of_case ctxt s =
377.149 + find_first (fn {casex = Const (s', _), ...} => s' = s | _ => false) (ctr_sugars_of ctxt);
377.150 +
377.151 +fun register_ctr_sugar key ctr_sugar =
377.152 + Local_Theory.declaration {syntax = false, pervasive = true}
377.153 + (fn phi => Data.map (Symtab.default (key, morph_ctr_sugar phi ctr_sugar)));
377.154 +
377.155 +fun register_ctr_sugar_global key ctr_sugar =
377.156 + Context.theory_map (Data.map (Symtab.default (key, ctr_sugar)));
377.157 +
377.158 +val rep_compat_prefix = "new";
377.159 +
377.160 +val isN = "is_";
377.161 +val unN = "un_";
377.162 +fun mk_unN 1 1 suf = unN ^ suf
377.163 + | mk_unN _ l suf = unN ^ suf ^ string_of_int l;
377.164 +
377.165 +val caseN = "case";
377.166 +val case_congN = "case_cong";
377.167 +val case_eq_ifN = "case_eq_if";
377.168 +val collapseN = "collapse";
377.169 +val disc_excludeN = "disc_exclude";
377.170 +val disc_exhaustN = "disc_exhaust";
377.171 +val discN = "disc";
377.172 +val discIN = "discI";
377.173 +val distinctN = "distinct";
377.174 +val exhaustN = "exhaust";
377.175 +val expandN = "expand";
377.176 +val injectN = "inject";
377.177 +val nchotomyN = "nchotomy";
377.178 +val selN = "sel";
377.179 +val sel_exhaustN = "sel_exhaust";
377.180 +val sel_splitN = "sel_split";
377.181 +val sel_split_asmN = "sel_split_asm";
377.182 +val splitN = "split";
377.183 +val splitsN = "splits";
377.184 +val split_asmN = "split_asm";
377.185 +val weak_case_cong_thmsN = "weak_case_cong";
377.186 +
377.187 +val cong_attrs = @{attributes [cong]};
377.188 +val dest_attrs = @{attributes [dest]};
377.189 +val safe_elim_attrs = @{attributes [elim!]};
377.190 +val iff_attrs = @{attributes [iff]};
377.191 +val inductsimp_attrs = @{attributes [induct_simp]};
377.192 +val nitpicksimp_attrs = @{attributes [nitpick_simp]};
377.193 +val simp_attrs = @{attributes [simp]};
377.194 +val code_nitpicksimp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs;
377.195 +val code_nitpicksimp_simp_attrs = code_nitpicksimp_attrs @ simp_attrs;
377.196 +
377.197 +fun unflat_lookup eq xs ys = map (fn xs' => permute_like eq xs xs' ys);
377.198 +
377.199 +fun mk_half_pairss' _ ([], []) = []
377.200 + | mk_half_pairss' indent (x :: xs, _ :: ys) =
377.201 + indent @ fold_rev (cons o single o pair x) ys (mk_half_pairss' ([] :: indent) (xs, ys));
377.202 +
377.203 +fun mk_half_pairss p = mk_half_pairss' [[]] p;
377.204 +
377.205 +fun join_halves n half_xss other_half_xss =
377.206 + let
377.207 + val xsss =
377.208 + map2 (map2 append) (Library.chop_groups n half_xss)
377.209 + (transpose (Library.chop_groups n other_half_xss))
377.210 + val xs = splice (flat half_xss) (flat other_half_xss);
377.211 + in (xs, xsss) end;
377.212 +
377.213 +fun mk_undefined T = Const (@{const_name undefined}, T);
377.214 +
377.215 +fun mk_ctr Ts t =
377.216 + let val Type (_, Ts0) = body_type (fastype_of t) in
377.217 + subst_nonatomic_types (Ts0 ~~ Ts) t
377.218 + end;
377.219 +
377.220 +fun mk_case Ts T t =
377.221 + let val (Type (_, Ts0), body) = strip_type (fastype_of t) |>> List.last in
377.222 + subst_nonatomic_types ((body, T) :: (Ts0 ~~ Ts)) t
377.223 + end;
377.224 +
377.225 +fun mk_disc_or_sel Ts t =
377.226 + subst_nonatomic_types (snd (Term.dest_Type (domain_type (fastype_of t))) ~~ Ts) t;
377.227 +
377.228 +fun name_of_const what t =
377.229 + (case head_of t of
377.230 + Const (s, _) => s
377.231 + | Free (s, _) => s
377.232 + | _ => error ("Cannot extract name of " ^ what));
377.233 +
377.234 +val name_of_ctr = name_of_const "constructor";
377.235 +
377.236 +val notN = "not_";
377.237 +val eqN = "eq_";
377.238 +val neqN = "neq_";
377.239 +
377.240 +fun name_of_disc t =
377.241 + (case head_of t of
377.242 + Abs (_, _, @{const Not} $ (t' $ Bound 0)) =>
377.243 + Long_Name.map_base_name (prefix notN) (name_of_disc t')
377.244 + | Abs (_, _, Const (@{const_name HOL.eq}, _) $ Bound 0 $ t') =>
377.245 + Long_Name.map_base_name (prefix eqN) (name_of_disc t')
377.246 + | Abs (_, _, @{const Not} $ (Const (@{const_name HOL.eq}, _) $ Bound 0 $ t')) =>
377.247 + Long_Name.map_base_name (prefix neqN) (name_of_disc t')
377.248 + | t' => name_of_const "destructor" t');
377.249 +
377.250 +val base_name_of_ctr = Long_Name.base_name o name_of_ctr;
377.251 +
377.252 +fun dest_ctr ctxt s t =
377.253 + let
377.254 + val (f, args) = Term.strip_comb t;
377.255 + in
377.256 + (case ctr_sugar_of ctxt s of
377.257 + SOME {ctrs, ...} =>
377.258 + (case find_first (can (fo_match ctxt f)) ctrs of
377.259 + SOME f' => (f', args)
377.260 + | NONE => raise Fail "dest_ctr")
377.261 + | NONE => raise Fail "dest_ctr")
377.262 + end;
377.263 +
377.264 +fun dest_case ctxt s Ts t =
377.265 + (case Term.strip_comb t of
377.266 + (Const (c, _), args as _ :: _) =>
377.267 + (case ctr_sugar_of ctxt s of
377.268 + SOME {casex = Const (case_name, _), discs = discs0, selss = selss0, ...} =>
377.269 + if case_name = c then
377.270 + let val n = length discs0 in
377.271 + if n < length args then
377.272 + let
377.273 + val (branches, obj :: leftovers) = chop n args;
377.274 + val discs = map (mk_disc_or_sel Ts) discs0;
377.275 + val selss = map (map (mk_disc_or_sel Ts)) selss0;
377.276 + val conds = map (rapp obj) discs;
377.277 + val branch_argss = map (fn sels => map (rapp obj) sels @ leftovers) selss;
377.278 + val branches' = map2 (curry Term.betapplys) branches branch_argss;
377.279 + in
377.280 + SOME (conds, branches')
377.281 + end
377.282 + else
377.283 + NONE
377.284 + end
377.285 + else
377.286 + NONE
377.287 + | _ => NONE)
377.288 + | _ => NONE);
377.289 +
377.290 +fun eta_expand_arg xs f_xs = fold_rev Term.lambda xs f_xs;
377.291 +
377.292 +fun prepare_wrap_free_constructors prep_term ((((no_discs_sels, (no_code, rep_compat)), raw_ctrs),
377.293 + raw_case_binding), (raw_disc_bindings, (raw_sel_bindingss, raw_sel_defaultss))) no_defs_lthy =
377.294 + let
377.295 + (* TODO: sanity checks on arguments *)
377.296 +
377.297 + val n = length raw_ctrs;
377.298 + val ks = 1 upto n;
377.299 +
377.300 + val _ = if n > 0 then () else error "No constructors specified";
377.301 +
377.302 + val ctrs0 = map (prep_term no_defs_lthy) raw_ctrs;
377.303 + val sel_defaultss =
377.304 + pad_list [] n (map (map (apsnd (prep_term no_defs_lthy))) raw_sel_defaultss);
377.305 +
377.306 + val Type (fcT_name, As0) = body_type (fastype_of (hd ctrs0));
377.307 + val fc_b_name = Long_Name.base_name fcT_name;
377.308 + val fc_b = Binding.name fc_b_name;
377.309 +
377.310 + fun qualify mandatory =
377.311 + Binding.qualify mandatory fc_b_name o (rep_compat ? Binding.qualify false rep_compat_prefix);
377.312 +
377.313 + fun dest_TFree_or_TVar (TFree sS) = sS
377.314 + | dest_TFree_or_TVar (TVar ((s, _), S)) = (s, S)
377.315 + | dest_TFree_or_TVar _ = error "Invalid type argument";
377.316 +
377.317 + val (unsorted_As, B) =
377.318 + no_defs_lthy
377.319 + |> variant_tfrees (map (fst o dest_TFree_or_TVar) As0)
377.320 + ||> the_single o fst o mk_TFrees 1;
377.321 +
377.322 + val As = map2 (resort_tfree o snd o dest_TFree_or_TVar) As0 unsorted_As;
377.323 +
377.324 + val fcT = Type (fcT_name, As);
377.325 + val ctrs = map (mk_ctr As) ctrs0;
377.326 + val ctr_Tss = map (binder_types o fastype_of) ctrs;
377.327 +
377.328 + val ms = map length ctr_Tss;
377.329 +
377.330 + val raw_disc_bindings' = pad_list Binding.empty n raw_disc_bindings;
377.331 +
377.332 + fun can_definitely_rely_on_disc k = not (Binding.is_empty (nth raw_disc_bindings' (k - 1)));
377.333 + fun can_rely_on_disc k =
377.334 + can_definitely_rely_on_disc k orelse (k = 1 andalso not (can_definitely_rely_on_disc 2));
377.335 + fun should_omit_disc_binding k = n = 1 orelse (n = 2 andalso can_rely_on_disc (3 - k));
377.336 +
377.337 + fun is_disc_binding_valid b =
377.338 + not (Binding.is_empty b orelse Binding.eq_name (b, equal_binding));
377.339 +
377.340 + val standard_disc_binding = Binding.name o prefix isN o base_name_of_ctr;
377.341 +
377.342 + val disc_bindings =
377.343 + raw_disc_bindings'
377.344 + |> map4 (fn k => fn m => fn ctr => fn disc =>
377.345 + qualify false
377.346 + (if Binding.is_empty disc then
377.347 + if should_omit_disc_binding k then disc else standard_disc_binding ctr
377.348 + else if Binding.eq_name (disc, equal_binding) then
377.349 + if m = 0 then disc
377.350 + else error "Cannot use \"=\" syntax for discriminating nonnullary constructor"
377.351 + else if Binding.eq_name (disc, standard_binding) then
377.352 + standard_disc_binding ctr
377.353 + else
377.354 + disc)) ks ms ctrs0;
377.355 +
377.356 + fun standard_sel_binding m l = Binding.name o mk_unN m l o base_name_of_ctr;
377.357 +
377.358 + val sel_bindingss =
377.359 + pad_list [] n raw_sel_bindingss
377.360 + |> map3 (fn ctr => fn m => map2 (fn l => fn sel =>
377.361 + qualify false
377.362 + (if Binding.is_empty sel orelse Binding.eq_name (sel, standard_binding) then
377.363 + standard_sel_binding m l ctr
377.364 + else
377.365 + sel)) (1 upto m) o pad_list Binding.empty m) ctrs0 ms;
377.366 +
377.367 + val case_Ts = map (fn Ts => Ts ---> B) ctr_Tss;
377.368 +
377.369 + val ((((((((xss, xss'), yss), fs), gs), [u', v']), [w]), (p, p')), names_lthy) = no_defs_lthy |>
377.370 + mk_Freess' "x" ctr_Tss
377.371 + ||>> mk_Freess "y" ctr_Tss
377.372 + ||>> mk_Frees "f" case_Ts
377.373 + ||>> mk_Frees "g" case_Ts
377.374 + ||>> (apfst (map (rpair fcT)) oo Variable.variant_fixes) [fc_b_name, fc_b_name ^ "'"]
377.375 + ||>> mk_Frees "z" [B]
377.376 + ||>> yield_singleton (apfst (op ~~) oo mk_Frees' "P") HOLogic.boolT;
377.377 +
377.378 + val u = Free u';
377.379 + val v = Free v';
377.380 + val q = Free (fst p', mk_pred1T B);
377.381 +
377.382 + val xctrs = map2 (curry Term.list_comb) ctrs xss;
377.383 + val yctrs = map2 (curry Term.list_comb) ctrs yss;
377.384 +
377.385 + val xfs = map2 (curry Term.list_comb) fs xss;
377.386 + val xgs = map2 (curry Term.list_comb) gs xss;
377.387 +
377.388 + (* TODO: Eta-expension is for compatibility with the old datatype package (but it also provides
377.389 + nicer names). Consider removing. *)
377.390 + val eta_fs = map2 eta_expand_arg xss xfs;
377.391 + val eta_gs = map2 eta_expand_arg xss xgs;
377.392 +
377.393 + val case_binding =
377.394 + qualify false
377.395 + (if Binding.is_empty raw_case_binding orelse
377.396 + Binding.eq_name (raw_case_binding, standard_binding) then
377.397 + Binding.prefix_name (caseN ^ "_") fc_b
377.398 + else
377.399 + raw_case_binding);
377.400 +
377.401 + fun mk_case_disj xctr xf xs =
377.402 + list_exists_free xs (HOLogic.mk_conj (HOLogic.mk_eq (u, xctr), HOLogic.mk_eq (w, xf)));
377.403 +
377.404 + val case_rhs = fold_rev (fold_rev Term.lambda) [fs, [u]]
377.405 + (Const (@{const_name The}, (B --> HOLogic.boolT) --> B) $
377.406 + Term.lambda w (Library.foldr1 HOLogic.mk_disj (map3 mk_case_disj xctrs xfs xss)));
377.407 +
377.408 + val ((raw_case, (_, raw_case_def)), (lthy', lthy)) = no_defs_lthy
377.409 + |> Local_Theory.define ((case_binding, NoSyn),
377.410 + ((Binding.conceal (Thm.def_binding case_binding), []), case_rhs))
377.411 + ||> `Local_Theory.restore;
377.412 +
377.413 + val phi = Proof_Context.export_morphism lthy lthy';
377.414 +
377.415 + val case_def = Morphism.thm phi raw_case_def;
377.416 +
377.417 + val case0 = Morphism.term phi raw_case;
377.418 + val casex = mk_case As B case0;
377.419 +
377.420 + val fcase = Term.list_comb (casex, fs);
377.421 +
377.422 + val ufcase = fcase $ u;
377.423 + val vfcase = fcase $ v;
377.424 +
377.425 + val eta_fcase = Term.list_comb (casex, eta_fs);
377.426 + val eta_gcase = Term.list_comb (casex, eta_gs);
377.427 +
377.428 + val eta_ufcase = eta_fcase $ u;
377.429 + val eta_vgcase = eta_gcase $ v;
377.430 +
377.431 + fun mk_uu_eq () = HOLogic.mk_eq (u, u);
377.432 +
377.433 + val uv_eq = mk_Trueprop_eq (u, v);
377.434 +
377.435 + val exist_xs_u_eq_ctrs =
377.436 + map2 (fn xctr => fn xs => list_exists_free xs (HOLogic.mk_eq (u, xctr))) xctrs xss;
377.437 +
377.438 + val unique_disc_no_def = TrueI; (*arbitrary marker*)
377.439 + val alternate_disc_no_def = FalseE; (*arbitrary marker*)
377.440 +
377.441 + fun alternate_disc_lhs get_udisc k =
377.442 + HOLogic.mk_not
377.443 + (let val b = nth disc_bindings (k - 1) in
377.444 + if is_disc_binding_valid b then get_udisc b (k - 1) else nth exist_xs_u_eq_ctrs (k - 1)
377.445 + end);
377.446 +
377.447 + val (all_sels_distinct, discs, selss, disc_defs, sel_defs, sel_defss, lthy') =
377.448 + if no_discs_sels then
377.449 + (true, [], [], [], [], [], lthy)
377.450 + else
377.451 + let
377.452 + fun disc_free b = Free (Binding.name_of b, mk_pred1T fcT);
377.453 +
377.454 + fun disc_spec b exist_xs_u_eq_ctr = mk_Trueprop_eq (disc_free b $ u, exist_xs_u_eq_ctr);
377.455 +
377.456 + fun alternate_disc k =
377.457 + Term.lambda u (alternate_disc_lhs (K o rapp u o disc_free) (3 - k));
377.458 +
377.459 + fun mk_sel_case_args b proto_sels T =
377.460 + map2 (fn Ts => fn k =>
377.461 + (case AList.lookup (op =) proto_sels k of
377.462 + NONE =>
377.463 + (case AList.lookup Binding.eq_name (rev (nth sel_defaultss (k - 1))) b of
377.464 + NONE => fold_rev (Term.lambda o curry Free Name.uu) Ts (mk_undefined T)
377.465 + | SOME t => t |> Type.constraint (Ts ---> T) |> Syntax.check_term lthy)
377.466 + | SOME (xs, x) => fold_rev Term.lambda xs x)) ctr_Tss ks;
377.467 +
377.468 + fun sel_spec b proto_sels =
377.469 + let
377.470 + val _ =
377.471 + (case duplicates (op =) (map fst proto_sels) of
377.472 + k :: _ => error ("Duplicate selector name " ^ quote (Binding.name_of b) ^
377.473 + " for constructor " ^
377.474 + quote (Syntax.string_of_term lthy (nth ctrs (k - 1))))
377.475 + | [] => ())
377.476 + val T =
377.477 + (case distinct (op =) (map (fastype_of o snd o snd) proto_sels) of
377.478 + [T] => T
377.479 + | T :: T' :: _ => error ("Inconsistent range type for selector " ^
377.480 + quote (Binding.name_of b) ^ ": " ^ quote (Syntax.string_of_typ lthy T) ^ " vs. "
377.481 + ^ quote (Syntax.string_of_typ lthy T')));
377.482 + in
377.483 + mk_Trueprop_eq (Free (Binding.name_of b, fcT --> T) $ u,
377.484 + Term.list_comb (mk_case As T case0, mk_sel_case_args b proto_sels T) $ u)
377.485 + end;
377.486 +
377.487 + val sel_bindings = flat sel_bindingss;
377.488 + val uniq_sel_bindings = distinct Binding.eq_name sel_bindings;
377.489 + val all_sels_distinct = (length uniq_sel_bindings = length sel_bindings);
377.490 +
377.491 + val sel_binding_index =
377.492 + if all_sels_distinct then 1 upto length sel_bindings
377.493 + else map (fn b => find_index (curry Binding.eq_name b) uniq_sel_bindings) sel_bindings;
377.494 +
377.495 + val proto_sels = flat (map3 (fn k => fn xs => map (fn x => (k, (xs, x)))) ks xss xss);
377.496 + val sel_infos =
377.497 + AList.group (op =) (sel_binding_index ~~ proto_sels)
377.498 + |> sort (int_ord o pairself fst)
377.499 + |> map snd |> curry (op ~~) uniq_sel_bindings;
377.500 + val sel_bindings = map fst sel_infos;
377.501 +
377.502 + fun unflat_selss xs = unflat_lookup Binding.eq_name sel_bindings xs sel_bindingss;
377.503 +
377.504 + val (((raw_discs, raw_disc_defs), (raw_sels, raw_sel_defs)), (lthy', lthy)) =
377.505 + lthy
377.506 + |> apfst split_list o fold_map3 (fn k => fn exist_xs_u_eq_ctr => fn b =>
377.507 + if Binding.is_empty b then
377.508 + if n = 1 then pair (Term.lambda u (mk_uu_eq ()), unique_disc_no_def)
377.509 + else pair (alternate_disc k, alternate_disc_no_def)
377.510 + else if Binding.eq_name (b, equal_binding) then
377.511 + pair (Term.lambda u exist_xs_u_eq_ctr, refl)
377.512 + else
377.513 + Specification.definition (SOME (b, NONE, NoSyn),
377.514 + ((Thm.def_binding b, []), disc_spec b exist_xs_u_eq_ctr)) #>> apsnd snd)
377.515 + ks exist_xs_u_eq_ctrs disc_bindings
377.516 + ||>> apfst split_list o fold_map (fn (b, proto_sels) =>
377.517 + Specification.definition (SOME (b, NONE, NoSyn),
377.518 + ((Thm.def_binding b, []), sel_spec b proto_sels)) #>> apsnd snd) sel_infos
377.519 + ||> `Local_Theory.restore;
377.520 +
377.521 + val phi = Proof_Context.export_morphism lthy lthy';
377.522 +
377.523 + val disc_defs = map (Morphism.thm phi) raw_disc_defs;
377.524 + val sel_defs = map (Morphism.thm phi) raw_sel_defs;
377.525 + val sel_defss = unflat_selss sel_defs;
377.526 +
377.527 + val discs0 = map (Morphism.term phi) raw_discs;
377.528 + val selss0 = unflat_selss (map (Morphism.term phi) raw_sels);
377.529 +
377.530 + val discs = map (mk_disc_or_sel As) discs0;
377.531 + val selss = map (map (mk_disc_or_sel As)) selss0;
377.532 + in
377.533 + (all_sels_distinct, discs, selss, disc_defs, sel_defs, sel_defss, lthy')
377.534 + end;
377.535 +
377.536 + fun mk_imp_p Qs = Logic.list_implies (Qs, HOLogic.mk_Trueprop p);
377.537 +
377.538 + val exhaust_goal =
377.539 + let fun mk_prem xctr xs = fold_rev Logic.all xs (mk_imp_p [mk_Trueprop_eq (u, xctr)]) in
377.540 + fold_rev Logic.all [p, u] (mk_imp_p (map2 mk_prem xctrs xss))
377.541 + end;
377.542 +
377.543 + val inject_goalss =
377.544 + let
377.545 + fun mk_goal _ _ [] [] = []
377.546 + | mk_goal xctr yctr xs ys =
377.547 + [fold_rev Logic.all (xs @ ys) (mk_Trueprop_eq (HOLogic.mk_eq (xctr, yctr),
377.548 + Library.foldr1 HOLogic.mk_conj (map2 (curry HOLogic.mk_eq) xs ys)))];
377.549 + in
377.550 + map4 mk_goal xctrs yctrs xss yss
377.551 + end;
377.552 +
377.553 + val half_distinct_goalss =
377.554 + let
377.555 + fun mk_goal ((xs, xc), (xs', xc')) =
377.556 + fold_rev Logic.all (xs @ xs')
377.557 + (HOLogic.mk_Trueprop (HOLogic.mk_not (HOLogic.mk_eq (xc, xc'))));
377.558 + in
377.559 + map (map mk_goal) (mk_half_pairss (`I (xss ~~ xctrs)))
377.560 + end;
377.561 +
377.562 + val goalss = [exhaust_goal] :: inject_goalss @ half_distinct_goalss;
377.563 +
377.564 + fun after_qed thmss lthy =
377.565 + let
377.566 + val ([exhaust_thm], (inject_thmss, half_distinct_thmss)) = (hd thmss, chop n (tl thmss));
377.567 +
377.568 + val inject_thms = flat inject_thmss;
377.569 +
377.570 + val rho_As = map (pairself (certifyT lthy)) (map Logic.varifyT_global As ~~ As);
377.571 +
377.572 + fun inst_thm t thm =
377.573 + Drule.instantiate' [] [SOME (certify lthy t)]
377.574 + (Thm.instantiate (rho_As, []) (Drule.zero_var_indexes thm));
377.575 +
377.576 + val uexhaust_thm = inst_thm u exhaust_thm;
377.577 +
377.578 + val exhaust_cases = map base_name_of_ctr ctrs;
377.579 +
377.580 + val other_half_distinct_thmss = map (map (fn thm => thm RS not_sym)) half_distinct_thmss;
377.581 +
377.582 + val (distinct_thms, (distinct_thmsss', distinct_thmsss)) =
377.583 + join_halves n half_distinct_thmss other_half_distinct_thmss ||> `transpose;
377.584 +
377.585 + val nchotomy_thm =
377.586 + let
377.587 + val goal =
377.588 + HOLogic.mk_Trueprop (HOLogic.mk_all (fst u', snd u',
377.589 + Library.foldr1 HOLogic.mk_disj exist_xs_u_eq_ctrs));
377.590 + in
377.591 + Goal.prove_sorry lthy [] [] goal (fn _ => mk_nchotomy_tac n exhaust_thm)
377.592 + |> Thm.close_derivation
377.593 + end;
377.594 +
377.595 + val case_thms =
377.596 + let
377.597 + val goals =
377.598 + map3 (fn xctr => fn xf => fn xs =>
377.599 + fold_rev Logic.all (fs @ xs) (mk_Trueprop_eq (fcase $ xctr, xf))) xctrs xfs xss;
377.600 + in
377.601 + map4 (fn k => fn goal => fn injects => fn distinctss =>
377.602 + Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
377.603 + mk_case_tac ctxt n k case_def injects distinctss)
377.604 + |> Thm.close_derivation)
377.605 + ks goals inject_thmss distinct_thmsss
377.606 + end;
377.607 +
377.608 + val (case_cong_thm, weak_case_cong_thm) =
377.609 + let
377.610 + fun mk_prem xctr xs xf xg =
377.611 + fold_rev Logic.all xs (Logic.mk_implies (mk_Trueprop_eq (v, xctr),
377.612 + mk_Trueprop_eq (xf, xg)));
377.613 +
377.614 + val goal =
377.615 + Logic.list_implies (uv_eq :: map4 mk_prem xctrs xss xfs xgs,
377.616 + mk_Trueprop_eq (eta_ufcase, eta_vgcase));
377.617 + val weak_goal = Logic.mk_implies (uv_eq, mk_Trueprop_eq (ufcase, vfcase));
377.618 + in
377.619 + (Goal.prove_sorry lthy [] [] goal (fn _ => mk_case_cong_tac lthy uexhaust_thm case_thms),
377.620 + Goal.prove_sorry lthy [] [] weak_goal (K (etac arg_cong 1)))
377.621 + |> pairself (Thm.close_derivation #> singleton (Proof_Context.export names_lthy lthy))
377.622 + end;
377.623 +
377.624 + val split_lhs = q $ ufcase;
377.625 +
377.626 + fun mk_split_conjunct xctr xs f_xs =
377.627 + list_all_free xs (HOLogic.mk_imp (HOLogic.mk_eq (u, xctr), q $ f_xs));
377.628 + fun mk_split_disjunct xctr xs f_xs =
377.629 + list_exists_free xs (HOLogic.mk_conj (HOLogic.mk_eq (u, xctr),
377.630 + HOLogic.mk_not (q $ f_xs)));
377.631 +
377.632 + fun mk_split_goal xctrs xss xfs =
377.633 + mk_Trueprop_eq (split_lhs, Library.foldr1 HOLogic.mk_conj
377.634 + (map3 mk_split_conjunct xctrs xss xfs));
377.635 + fun mk_split_asm_goal xctrs xss xfs =
377.636 + mk_Trueprop_eq (split_lhs, HOLogic.mk_not (Library.foldr1 HOLogic.mk_disj
377.637 + (map3 mk_split_disjunct xctrs xss xfs)));
377.638 +
377.639 + fun prove_split selss goal =
377.640 + Goal.prove_sorry lthy [] [] goal (fn _ =>
377.641 + mk_split_tac lthy uexhaust_thm case_thms selss inject_thmss distinct_thmsss)
377.642 + |> Thm.close_derivation
377.643 + |> singleton (Proof_Context.export names_lthy lthy);
377.644 +
377.645 + fun prove_split_asm asm_goal split_thm =
377.646 + Goal.prove_sorry lthy [] [] asm_goal (fn {context = ctxt, ...} =>
377.647 + mk_split_asm_tac ctxt split_thm)
377.648 + |> Thm.close_derivation
377.649 + |> singleton (Proof_Context.export names_lthy lthy);
377.650 +
377.651 + val (split_thm, split_asm_thm) =
377.652 + let
377.653 + val goal = mk_split_goal xctrs xss xfs;
377.654 + val asm_goal = mk_split_asm_goal xctrs xss xfs;
377.655 +
377.656 + val thm = prove_split (replicate n []) goal;
377.657 + val asm_thm = prove_split_asm asm_goal thm;
377.658 + in
377.659 + (thm, asm_thm)
377.660 + end;
377.661 +
377.662 + val (all_sel_thms, sel_thmss, disc_thmss, nontriv_disc_thms, discI_thms, nontriv_discI_thms,
377.663 + disc_exclude_thms, disc_exhaust_thms, sel_exhaust_thms, all_collapse_thms,
377.664 + safe_collapse_thms, expand_thms, sel_split_thms, sel_split_asm_thms, case_eq_if_thms) =
377.665 + if no_discs_sels then
377.666 + ([], [], [], [], [], [], [], [], [], [], [], [], [], [], [])
377.667 + else
377.668 + let
377.669 + val udiscs = map (rapp u) discs;
377.670 + val uselss = map (map (rapp u)) selss;
377.671 + val usel_ctrs = map2 (curry Term.list_comb) ctrs uselss;
377.672 + val usel_fs = map2 (curry Term.list_comb) fs uselss;
377.673 +
377.674 + val vdiscs = map (rapp v) discs;
377.675 + val vselss = map (map (rapp v)) selss;
377.676 +
377.677 + fun make_sel_thm xs' case_thm sel_def =
377.678 + zero_var_indexes (Drule.gen_all (Drule.rename_bvars' (map (SOME o fst) xs')
377.679 + (Drule.forall_intr_vars (case_thm RS (sel_def RS trans)))));
377.680 +
377.681 + val sel_thmss = map3 (map oo make_sel_thm) xss' case_thms sel_defss;
377.682 +
377.683 + fun has_undefined_rhs thm =
377.684 + (case snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (prop_of thm))) of
377.685 + Const (@{const_name undefined}, _) => true
377.686 + | _ => false);
377.687 +
377.688 + val all_sel_thms =
377.689 + (if all_sels_distinct andalso forall null sel_defaultss then
377.690 + flat sel_thmss
377.691 + else
377.692 + map_product (fn s => fn (xs', c) => make_sel_thm xs' c s) sel_defs
377.693 + (xss' ~~ case_thms))
377.694 + |> filter_out has_undefined_rhs;
377.695 +
377.696 + fun mk_unique_disc_def () =
377.697 + let
377.698 + val m = the_single ms;
377.699 + val goal = mk_Trueprop_eq (mk_uu_eq (), the_single exist_xs_u_eq_ctrs);
377.700 + in
377.701 + Goal.prove_sorry lthy [] [] goal (fn _ => mk_unique_disc_def_tac m uexhaust_thm)
377.702 + |> Thm.close_derivation
377.703 + |> singleton (Proof_Context.export names_lthy lthy)
377.704 + end;
377.705 +
377.706 + fun mk_alternate_disc_def k =
377.707 + let
377.708 + val goal =
377.709 + mk_Trueprop_eq (alternate_disc_lhs (K (nth udiscs)) (3 - k),
377.710 + nth exist_xs_u_eq_ctrs (k - 1));
377.711 + in
377.712 + Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
377.713 + mk_alternate_disc_def_tac ctxt k (nth disc_defs (2 - k))
377.714 + (nth distinct_thms (2 - k)) uexhaust_thm)
377.715 + |> Thm.close_derivation
377.716 + |> singleton (Proof_Context.export names_lthy lthy)
377.717 + end;
377.718 +
377.719 + val has_alternate_disc_def =
377.720 + exists (fn def => Thm.eq_thm_prop (def, alternate_disc_no_def)) disc_defs;
377.721 +
377.722 + val disc_defs' =
377.723 + map2 (fn k => fn def =>
377.724 + if Thm.eq_thm_prop (def, unique_disc_no_def) then mk_unique_disc_def ()
377.725 + else if Thm.eq_thm_prop (def, alternate_disc_no_def) then mk_alternate_disc_def k
377.726 + else def) ks disc_defs;
377.727 +
377.728 + val discD_thms = map (fn def => def RS iffD1) disc_defs';
377.729 + val discI_thms =
377.730 + map2 (fn m => fn def => funpow m (fn thm => exI RS thm) (def RS iffD2)) ms
377.731 + disc_defs';
377.732 + val not_discI_thms =
377.733 + map2 (fn m => fn def => funpow m (fn thm => allI RS thm)
377.734 + (unfold_thms lthy @{thms not_ex} (def RS @{thm ssubst[of _ _ Not]})))
377.735 + ms disc_defs';
377.736 +
377.737 + val (disc_thmss', disc_thmss) =
377.738 + let
377.739 + fun mk_thm discI _ [] = refl RS discI
377.740 + | mk_thm _ not_discI [distinct] = distinct RS not_discI;
377.741 + fun mk_thms discI not_discI distinctss = map (mk_thm discI not_discI) distinctss;
377.742 + in
377.743 + map3 mk_thms discI_thms not_discI_thms distinct_thmsss' |> `transpose
377.744 + end;
377.745 +
377.746 + val nontriv_disc_thms =
377.747 + flat (map2 (fn b => if is_disc_binding_valid b then I else K [])
377.748 + disc_bindings disc_thmss);
377.749 +
377.750 + fun is_discI_boring b =
377.751 + (n = 1 andalso Binding.is_empty b) orelse Binding.eq_name (b, equal_binding);
377.752 +
377.753 + val nontriv_discI_thms =
377.754 + flat (map2 (fn b => if is_discI_boring b then K [] else single) disc_bindings
377.755 + discI_thms);
377.756 +
377.757 + val (disc_exclude_thms, (disc_exclude_thmsss', disc_exclude_thmsss)) =
377.758 + let
377.759 + fun mk_goal [] = []
377.760 + | mk_goal [((_, udisc), (_, udisc'))] =
377.761 + [Logic.all u (Logic.mk_implies (HOLogic.mk_Trueprop udisc,
377.762 + HOLogic.mk_Trueprop (HOLogic.mk_not udisc')))];
377.763 +
377.764 + fun prove tac goal =
377.765 + Goal.prove_sorry lthy [] [] goal (K tac)
377.766 + |> Thm.close_derivation;
377.767 +
377.768 + val half_pairss = mk_half_pairss (`I (ms ~~ discD_thms ~~ udiscs));
377.769 +
377.770 + val half_goalss = map mk_goal half_pairss;
377.771 + val half_thmss =
377.772 + map3 (fn [] => K (K []) | [goal] => fn [(((m, discD), _), _)] =>
377.773 + fn disc_thm => [prove (mk_half_disc_exclude_tac lthy m discD disc_thm) goal])
377.774 + half_goalss half_pairss (flat disc_thmss');
377.775 +
377.776 + val other_half_goalss = map (mk_goal o map swap) half_pairss;
377.777 + val other_half_thmss =
377.778 + map2 (map2 (prove o mk_other_half_disc_exclude_tac)) half_thmss
377.779 + other_half_goalss;
377.780 + in
377.781 + join_halves n half_thmss other_half_thmss ||> `transpose
377.782 + |>> has_alternate_disc_def ? K []
377.783 + end;
377.784 +
377.785 + val disc_exhaust_thm =
377.786 + let
377.787 + fun mk_prem udisc = mk_imp_p [HOLogic.mk_Trueprop udisc];
377.788 + val goal = fold_rev Logic.all [p, u] (mk_imp_p (map mk_prem udiscs));
377.789 + in
377.790 + Goal.prove_sorry lthy [] [] goal (fn _ =>
377.791 + mk_disc_exhaust_tac n exhaust_thm discI_thms)
377.792 + |> Thm.close_derivation
377.793 + end;
377.794 +
377.795 + val (safe_collapse_thms, all_collapse_thms) =
377.796 + let
377.797 + fun mk_goal m udisc usel_ctr =
377.798 + let
377.799 + val prem = HOLogic.mk_Trueprop udisc;
377.800 + val concl = mk_Trueprop_eq ((usel_ctr, u) |> m = 0 ? swap);
377.801 + in
377.802 + (prem aconv concl, Logic.all u (Logic.mk_implies (prem, concl)))
377.803 + end;
377.804 + val (trivs, goals) = map3 mk_goal ms udiscs usel_ctrs |> split_list;
377.805 + val thms =
377.806 + map5 (fn m => fn discD => fn sel_thms => fn triv => fn goal =>
377.807 + Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
377.808 + mk_collapse_tac ctxt m discD sel_thms ORELSE HEADGOAL atac)
377.809 + |> Thm.close_derivation
377.810 + |> not triv ? perhaps (try (fn thm => refl RS thm)))
377.811 + ms discD_thms sel_thmss trivs goals;
377.812 + in
377.813 + (map_filter (fn (true, _) => NONE | (false, thm) => SOME thm) (trivs ~~ thms),
377.814 + thms)
377.815 + end;
377.816 +
377.817 + val swapped_all_collapse_thms =
377.818 + map2 (fn m => fn thm => if m = 0 then thm else thm RS sym) ms all_collapse_thms;
377.819 +
377.820 + val sel_exhaust_thm =
377.821 + let
377.822 + fun mk_prem usel_ctr = mk_imp_p [mk_Trueprop_eq (u, usel_ctr)];
377.823 + val goal = fold_rev Logic.all [p, u] (mk_imp_p (map mk_prem usel_ctrs));
377.824 + in
377.825 + Goal.prove_sorry lthy [] [] goal (fn _ =>
377.826 + mk_sel_exhaust_tac n disc_exhaust_thm swapped_all_collapse_thms)
377.827 + |> Thm.close_derivation
377.828 + end;
377.829 +
377.830 + val expand_thm =
377.831 + let
377.832 + fun mk_prems k udisc usels vdisc vsels =
377.833 + (if k = n then [] else [mk_Trueprop_eq (udisc, vdisc)]) @
377.834 + (if null usels then
377.835 + []
377.836 + else
377.837 + [Logic.list_implies
377.838 + (if n = 1 then [] else map HOLogic.mk_Trueprop [udisc, vdisc],
377.839 + HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
377.840 + (map2 (curry HOLogic.mk_eq) usels vsels)))]);
377.841 +
377.842 + val goal =
377.843 + Library.foldr Logic.list_implies
377.844 + (map5 mk_prems ks udiscs uselss vdiscs vselss, uv_eq);
377.845 + val uncollapse_thms =
377.846 + map2 (fn thm => fn [] => thm | _ => thm RS sym) all_collapse_thms uselss;
377.847 + in
377.848 + Goal.prove_sorry lthy [] [] goal (fn _ =>
377.849 + mk_expand_tac lthy n ms (inst_thm u disc_exhaust_thm)
377.850 + (inst_thm v disc_exhaust_thm) uncollapse_thms disc_exclude_thmsss
377.851 + disc_exclude_thmsss')
377.852 + |> Thm.close_derivation
377.853 + |> singleton (Proof_Context.export names_lthy lthy)
377.854 + end;
377.855 +
377.856 + val (sel_split_thm, sel_split_asm_thm) =
377.857 + let
377.858 + val zss = map (K []) xss;
377.859 + val goal = mk_split_goal usel_ctrs zss usel_fs;
377.860 + val asm_goal = mk_split_asm_goal usel_ctrs zss usel_fs;
377.861 +
377.862 + val thm = prove_split sel_thmss goal;
377.863 + val asm_thm = prove_split_asm asm_goal thm;
377.864 + in
377.865 + (thm, asm_thm)
377.866 + end;
377.867 +
377.868 + val case_eq_if_thm =
377.869 + let
377.870 + val goal = mk_Trueprop_eq (ufcase, mk_IfN B udiscs usel_fs);
377.871 + in
377.872 + Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, ...} =>
377.873 + mk_case_eq_if_tac ctxt n uexhaust_thm case_thms disc_thmss' sel_thmss)
377.874 + |> Thm.close_derivation
377.875 + |> singleton (Proof_Context.export names_lthy lthy)
377.876 + end;
377.877 + in
377.878 + (all_sel_thms, sel_thmss, disc_thmss, nontriv_disc_thms, discI_thms,
377.879 + nontriv_discI_thms, disc_exclude_thms, [disc_exhaust_thm], [sel_exhaust_thm],
377.880 + all_collapse_thms, safe_collapse_thms, [expand_thm], [sel_split_thm],
377.881 + [sel_split_asm_thm], [case_eq_if_thm])
377.882 + end;
377.883 +
377.884 + val exhaust_case_names_attr = Attrib.internal (K (Rule_Cases.case_names exhaust_cases));
377.885 + val cases_type_attr = Attrib.internal (K (Induct.cases_type fcT_name));
377.886 +
377.887 + val anonymous_notes =
377.888 + [(map (fn th => th RS notE) distinct_thms, safe_elim_attrs),
377.889 + (map (fn th => th RS @{thm eq_False[THEN iffD2]}
377.890 + handle THM _ => th RS @{thm eq_True[THEN iffD2]}) nontriv_disc_thms,
377.891 + code_nitpicksimp_attrs)]
377.892 + |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
377.893 +
377.894 + val notes =
377.895 + [(caseN, case_thms, code_nitpicksimp_simp_attrs),
377.896 + (case_congN, [case_cong_thm], []),
377.897 + (case_eq_ifN, case_eq_if_thms, []),
377.898 + (collapseN, safe_collapse_thms, simp_attrs),
377.899 + (discN, nontriv_disc_thms, simp_attrs),
377.900 + (discIN, nontriv_discI_thms, []),
377.901 + (disc_excludeN, disc_exclude_thms, dest_attrs),
377.902 + (disc_exhaustN, disc_exhaust_thms, [exhaust_case_names_attr]),
377.903 + (distinctN, distinct_thms, simp_attrs @ inductsimp_attrs),
377.904 + (exhaustN, [exhaust_thm], [exhaust_case_names_attr, cases_type_attr]),
377.905 + (expandN, expand_thms, []),
377.906 + (injectN, inject_thms, iff_attrs @ inductsimp_attrs),
377.907 + (nchotomyN, [nchotomy_thm], []),
377.908 + (selN, all_sel_thms, code_nitpicksimp_simp_attrs),
377.909 + (sel_exhaustN, sel_exhaust_thms, [exhaust_case_names_attr]),
377.910 + (sel_splitN, sel_split_thms, []),
377.911 + (sel_split_asmN, sel_split_asm_thms, []),
377.912 + (splitN, [split_thm], []),
377.913 + (split_asmN, [split_asm_thm], []),
377.914 + (splitsN, [split_thm, split_asm_thm], []),
377.915 + (weak_case_cong_thmsN, [weak_case_cong_thm], cong_attrs)]
377.916 + |> filter_out (null o #2)
377.917 + |> map (fn (thmN, thms, attrs) =>
377.918 + ((qualify true (Binding.name thmN), attrs), [(thms, [])]));
377.919 +
377.920 + val ctr_sugar =
377.921 + {ctrs = ctrs, casex = casex, discs = discs, selss = selss, exhaust = exhaust_thm,
377.922 + nchotomy = nchotomy_thm, injects = inject_thms, distincts = distinct_thms,
377.923 + case_thms = case_thms, case_cong = case_cong_thm, weak_case_cong = weak_case_cong_thm,
377.924 + split = split_thm, split_asm = split_asm_thm, disc_thmss = disc_thmss,
377.925 + discIs = discI_thms, sel_thmss = sel_thmss, disc_exhausts = disc_exhaust_thms,
377.926 + sel_exhausts = sel_exhaust_thms, collapses = all_collapse_thms, expands = expand_thms,
377.927 + sel_splits = sel_split_thms, sel_split_asms = sel_split_asm_thms,
377.928 + case_eq_ifs = case_eq_if_thms};
377.929 + in
377.930 + (ctr_sugar,
377.931 + lthy
377.932 + |> not rep_compat ?
377.933 + Local_Theory.declaration {syntax = false, pervasive = true}
377.934 + (fn phi => Case_Translation.register
377.935 + (Morphism.term phi casex) (map (Morphism.term phi) ctrs))
377.936 + |> (not no_code andalso null (Thm.hyps_of (hd case_thms)))
377.937 + ? Local_Theory.background_theory
377.938 + (fold (fold Code.del_eqn) [disc_defs, sel_defs]
377.939 + #> add_ctr_code fcT_name As (map dest_Const ctrs) inject_thms distinct_thms
377.940 + case_thms)
377.941 + |> Local_Theory.notes (anonymous_notes @ notes) |> snd
377.942 + |> register_ctr_sugar fcT_name ctr_sugar)
377.943 + end;
377.944 + in
377.945 + (goalss, after_qed, lthy')
377.946 + end;
377.947 +
377.948 +fun wrap_free_constructors tacss = (fn (goalss, after_qed, lthy) =>
377.949 + map2 (map2 (Thm.close_derivation oo Goal.prove_sorry lthy [] [])) goalss tacss
377.950 + |> (fn thms => after_qed thms lthy)) oo prepare_wrap_free_constructors (K I);
377.951 +
377.952 +val wrap_free_constructors_cmd = (fn (goalss, after_qed, lthy) =>
377.953 + Proof.theorem NONE (snd oo after_qed) (map (map (rpair [])) goalss) lthy) oo
377.954 + prepare_wrap_free_constructors Syntax.read_term;
377.955 +
377.956 +fun parse_bracket_list parser = @{keyword "["} |-- Parse.list parser --| @{keyword "]"};
377.957 +
377.958 +val parse_bindings = parse_bracket_list parse_binding;
377.959 +val parse_bindingss = parse_bracket_list parse_bindings;
377.960 +
377.961 +val parse_bound_term = (parse_binding --| @{keyword ":"}) -- Parse.term;
377.962 +val parse_bound_terms = parse_bracket_list parse_bound_term;
377.963 +val parse_bound_termss = parse_bracket_list parse_bound_terms;
377.964 +
377.965 +val parse_wrap_free_constructors_options =
377.966 + Scan.optional (@{keyword "("} |-- Parse.list1
377.967 + (Parse.reserved "no_discs_sels" >> K 0 || Parse.reserved "no_code" >> K 1 ||
377.968 + Parse.reserved "rep_compat" >> K 2) --| @{keyword ")"}
377.969 + >> (fn js => (member (op =) js 0, (member (op =) js 1, member (op =) js 2))))
377.970 + (false, (false, false));
377.971 +
377.972 +val _ =
377.973 + Outer_Syntax.local_theory_to_proof @{command_spec "wrap_free_constructors"}
377.974 + "wrap an existing freely generated type's constructors"
377.975 + ((parse_wrap_free_constructors_options -- (@{keyword "["} |-- Parse.list Parse.term --|
377.976 + @{keyword "]"}) --
377.977 + parse_binding -- Scan.optional (parse_bindings -- Scan.optional (parse_bindingss --
377.978 + Scan.optional parse_bound_termss []) ([], [])) ([], ([], [])))
377.979 + >> wrap_free_constructors_cmd);
377.980 +
377.981 +end;
378.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
378.2 +++ b/src/HOL/Tools/ctr_sugar_code.ML Thu Dec 05 17:58:03 2013 +0100
378.3 @@ -0,0 +1,129 @@
378.4 +(* Title: HOL/Tools/ctr_sugar_code.ML
378.5 + Author: Jasmin Blanchette, TU Muenchen
378.6 + Author: Dmitriy Traytel, TU Muenchen
378.7 + Author: Stefan Berghofer, TU Muenchen
378.8 + Author: Florian Haftmann, TU Muenchen
378.9 + Copyright 2001-2013
378.10 +
378.11 +Code generation for freely generated types.
378.12 +*)
378.13 +
378.14 +signature CTR_SUGAR_CODE =
378.15 +sig
378.16 + val add_ctr_code: string -> typ list -> (string * typ) list -> thm list -> thm list -> thm list ->
378.17 + theory -> theory
378.18 +end;
378.19 +
378.20 +structure Ctr_Sugar_Code : CTR_SUGAR_CODE =
378.21 +struct
378.22 +
378.23 +open Ctr_Sugar_Util
378.24 +
378.25 +val eqN = "eq"
378.26 +val reflN = "refl"
378.27 +val simpsN = "simps"
378.28 +
378.29 +fun mk_case_certificate thy raw_thms =
378.30 + let
378.31 + val thms as thm1 :: _ = raw_thms
378.32 + |> Conjunction.intr_balanced
378.33 + |> Thm.unvarify_global
378.34 + |> Conjunction.elim_balanced (length raw_thms)
378.35 + |> map Simpdata.mk_meta_eq
378.36 + |> map Drule.zero_var_indexes;
378.37 + val params = Term.add_free_names (Thm.prop_of thm1) [];
378.38 + val rhs = thm1
378.39 + |> Thm.prop_of |> Logic.dest_equals |> fst |> Term.strip_comb
378.40 + ||> fst o split_last |> list_comb;
378.41 + val lhs = Free (singleton (Name.variant_list params) "case", Term.fastype_of rhs);
378.42 + val assum = Thm.cterm_of thy (Logic.mk_equals (lhs, rhs));
378.43 + in
378.44 + thms
378.45 + |> Conjunction.intr_balanced
378.46 + |> rewrite_rule [Thm.symmetric (Thm.assume assum)]
378.47 + |> Thm.implies_intr assum
378.48 + |> Thm.generalize ([], params) 0
378.49 + |> Axclass.unoverload thy
378.50 + |> Thm.varifyT_global
378.51 + end;
378.52 +
378.53 +fun mk_free_ctr_equations fcT ctrs inject_thms distinct_thms thy =
378.54 + let
378.55 + fun mk_fcT_eq (t, u) = Const (@{const_name HOL.equal}, fcT --> fcT --> HOLogic.boolT) $ t $ u;
378.56 + fun true_eq tu = HOLogic.mk_eq (mk_fcT_eq tu, @{term True});
378.57 + fun false_eq tu = HOLogic.mk_eq (mk_fcT_eq tu, @{term False});
378.58 +
378.59 + val monomorphic_prop_of = prop_of o Thm.unvarify_global o Drule.zero_var_indexes;
378.60 +
378.61 + fun massage_inject (tp $ (eqv $ (_ $ t $ u) $ rhs)) = tp $ (eqv $ mk_fcT_eq (t, u) $ rhs);
378.62 + fun massage_distinct (tp $ (_ $ (_ $ t $ u))) = [tp $ false_eq (t, u), tp $ false_eq (u, t)];
378.63 +
378.64 + val triv_inject_goals =
378.65 + map_filter (fn c as (_, T) =>
378.66 + if T = fcT then SOME (HOLogic.mk_Trueprop (true_eq (Const c, Const c))) else NONE)
378.67 + ctrs;
378.68 + val inject_goals = map (massage_inject o monomorphic_prop_of) inject_thms;
378.69 + val distinct_goals = maps (massage_distinct o monomorphic_prop_of) distinct_thms;
378.70 + val refl_goal = HOLogic.mk_Trueprop (true_eq (Free ("x", fcT), Free ("x", fcT)));
378.71 +
378.72 + val simp_ctxt =
378.73 + Simplifier.global_context thy HOL_basic_ss
378.74 + addsimps (map Simpdata.mk_eq (@{thms equal eq_True} @ inject_thms @ distinct_thms));
378.75 +
378.76 + fun prove goal =
378.77 + Goal.prove_sorry_global thy [] [] goal (K (ALLGOALS (simp_tac simp_ctxt)))
378.78 + |> Simpdata.mk_eq;
378.79 + in
378.80 + (map prove (triv_inject_goals @ inject_goals @ distinct_goals), prove refl_goal)
378.81 + end;
378.82 +
378.83 +fun add_equality fcT fcT_name As ctrs inject_thms distinct_thms =
378.84 + let
378.85 + fun add_def lthy =
378.86 + let
378.87 + fun mk_side const_name =
378.88 + Const (const_name, fcT --> fcT --> HOLogic.boolT) $ Free ("x", fcT) $ Free ("y", fcT);
378.89 + val spec =
378.90 + mk_Trueprop_eq (mk_side @{const_name HOL.equal}, mk_side @{const_name HOL.eq})
378.91 + |> Syntax.check_term lthy;
378.92 + val ((_, (_, raw_def)), lthy') =
378.93 + Specification.definition (NONE, (Attrib.empty_binding, spec)) lthy;
378.94 + val ctxt_thy = Proof_Context.init_global (Proof_Context.theory_of lthy); (* FIXME? *)
378.95 + val def = singleton (Proof_Context.export lthy' ctxt_thy) raw_def;
378.96 + in
378.97 + (def, lthy')
378.98 + end;
378.99 +
378.100 + fun tac thms = Class.intro_classes_tac [] THEN ALLGOALS (Proof_Context.fact_tac thms);
378.101 +
378.102 + val qualify =
378.103 + Binding.qualify true (Long_Name.base_name fcT_name) o Binding.qualify true eqN o Binding.name;
378.104 + in
378.105 + Class.instantiation ([fcT_name], map dest_TFree As, [HOLogic.class_equal])
378.106 + #> add_def
378.107 + #-> Class.prove_instantiation_exit_result (map o Morphism.thm) (K tac) o single
378.108 + #-> fold Code.del_eqn
378.109 + #> `(mk_free_ctr_equations fcT ctrs inject_thms distinct_thms)
378.110 + #-> (fn (thms, thm) => Global_Theory.note_thmss Thm.lemmaK
378.111 + [((qualify reflN, [Code.add_nbe_default_eqn_attribute]), [([thm], [])]),
378.112 + ((qualify simpsN, [Code.add_default_eqn_attribute]), [(rev thms, [])])])
378.113 + #> snd
378.114 + end;
378.115 +
378.116 +fun add_ctr_code fcT_name As ctrs inject_thms distinct_thms case_thms thy =
378.117 + let
378.118 + val fcT = Type (fcT_name, As);
378.119 + val unover_ctrs = map (fn ctr as (_, fcT) => (Axclass.unoverload_const thy ctr, fcT)) ctrs;
378.120 + in
378.121 + if can (Code.constrset_of_consts thy) unover_ctrs then
378.122 + thy
378.123 + |> Code.add_datatype ctrs
378.124 + |> fold_rev Code.add_default_eqn case_thms
378.125 + |> Code.add_case (mk_case_certificate thy case_thms)
378.126 + |> not (Sorts.has_instance (Sign.classes_of thy) fcT_name [HOLogic.class_equal])
378.127 + ? add_equality fcT fcT_name As ctrs inject_thms distinct_thms
378.128 + else
378.129 + thy
378.130 + end;
378.131 +
378.132 +end;
379.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
379.2 +++ b/src/HOL/Tools/ctr_sugar_tactics.ML Thu Dec 05 17:58:03 2013 +0100
379.3 @@ -0,0 +1,172 @@
379.4 +(* Title: HOL/Tools/ctr_sugar_tactics.ML
379.5 + Author: Jasmin Blanchette, TU Muenchen
379.6 + Copyright 2012, 2013
379.7 +
379.8 +Tactics for wrapping existing freely generated type's constructors.
379.9 +*)
379.10 +
379.11 +signature CTR_SUGAR_GENERAL_TACTICS =
379.12 +sig
379.13 + val select_prem_tac: int -> (int -> tactic) -> int -> int -> tactic
379.14 + val unfold_thms_tac: Proof.context -> thm list -> tactic
379.15 +end;
379.16 +
379.17 +signature CTR_SUGAR_TACTICS =
379.18 +sig
379.19 + include CTR_SUGAR_GENERAL_TACTICS
379.20 +
379.21 + val mk_alternate_disc_def_tac: Proof.context -> int -> thm -> thm -> thm -> tactic
379.22 + val mk_case_tac: Proof.context -> int -> int -> thm -> thm list -> thm list list -> tactic
379.23 + val mk_case_cong_tac: Proof.context -> thm -> thm list -> tactic
379.24 + val mk_case_eq_if_tac: Proof.context -> int -> thm -> thm list -> thm list list ->
379.25 + thm list list -> tactic
379.26 + val mk_collapse_tac: Proof.context -> int -> thm -> thm list -> tactic
379.27 + val mk_disc_exhaust_tac: int -> thm -> thm list -> tactic
379.28 + val mk_expand_tac: Proof.context -> int -> int list -> thm -> thm -> thm list ->
379.29 + thm list list list -> thm list list list -> tactic
379.30 + val mk_half_disc_exclude_tac: Proof.context -> int -> thm -> thm -> tactic
379.31 + val mk_nchotomy_tac: int -> thm -> tactic
379.32 + val mk_other_half_disc_exclude_tac: thm -> tactic
379.33 + val mk_sel_exhaust_tac: int -> thm -> thm list -> tactic
379.34 + val mk_split_tac: Proof.context -> thm -> thm list -> thm list list -> thm list list ->
379.35 + thm list list list -> tactic
379.36 + val mk_split_asm_tac: Proof.context -> thm -> tactic
379.37 + val mk_unique_disc_def_tac: int -> thm -> tactic
379.38 +end;
379.39 +
379.40 +structure Ctr_Sugar_Tactics : CTR_SUGAR_TACTICS =
379.41 +struct
379.42 +
379.43 +open Ctr_Sugar_Util
379.44 +
379.45 +val meta_mp = @{thm meta_mp};
379.46 +
379.47 +fun select_prem_tac n tac k = DETERM o (EVERY' [REPEAT_DETERM_N (k - 1) o etac thin_rl,
379.48 + tac, REPEAT_DETERM_N (n - k) o etac thin_rl]);
379.49 +
379.50 +fun unfold_thms_tac _ [] = all_tac
379.51 + | unfold_thms_tac ctxt thms = Local_Defs.unfold_tac ctxt (distinct Thm.eq_thm_prop thms);
379.52 +
379.53 +fun if_P_or_not_P_OF pos thm = thm RS (if pos then @{thm if_P} else @{thm if_not_P});
379.54 +
379.55 +fun mk_nchotomy_tac n exhaust =
379.56 + HEADGOAL (rtac allI THEN' rtac exhaust THEN'
379.57 + EVERY' (maps (fn k => [rtac (mk_disjIN n k), REPEAT_DETERM o rtac exI, atac]) (1 upto n)));
379.58 +
379.59 +fun mk_unique_disc_def_tac m uexhaust =
379.60 + HEADGOAL (EVERY' [rtac iffI, rtac uexhaust, REPEAT_DETERM_N m o rtac exI, atac, rtac refl]);
379.61 +
379.62 +fun mk_alternate_disc_def_tac ctxt k other_disc_def distinct uexhaust =
379.63 + HEADGOAL (EVERY' ([rtac (other_disc_def RS @{thm arg_cong[of _ _ Not]} RS trans),
379.64 + rtac @{thm iffI_np}, REPEAT_DETERM o etac exE,
379.65 + hyp_subst_tac ctxt, SELECT_GOAL (unfold_thms_tac ctxt [not_ex]), REPEAT_DETERM o rtac allI,
379.66 + rtac distinct, rtac uexhaust] @
379.67 + (([etac notE, REPEAT_DETERM o rtac exI, atac], [REPEAT_DETERM o rtac exI, atac])
379.68 + |> k = 1 ? swap |> op @)));
379.69 +
379.70 +fun mk_half_disc_exclude_tac ctxt m discD disc' =
379.71 + HEADGOAL (dtac discD THEN' REPEAT_DETERM_N m o etac exE THEN' hyp_subst_tac ctxt THEN'
379.72 + rtac disc');
379.73 +
379.74 +fun mk_other_half_disc_exclude_tac half = HEADGOAL (etac @{thm contrapos_pn} THEN' etac half);
379.75 +
379.76 +fun mk_disc_or_sel_exhaust_tac n exhaust destIs =
379.77 + HEADGOAL (rtac exhaust THEN'
379.78 + EVERY' (map2 (fn k => fn destI => dtac destI THEN'
379.79 + select_prem_tac n (etac meta_mp) k THEN' atac) (1 upto n) destIs));
379.80 +
379.81 +val mk_disc_exhaust_tac = mk_disc_or_sel_exhaust_tac;
379.82 +
379.83 +fun mk_sel_exhaust_tac n disc_exhaust collapses =
379.84 + mk_disc_or_sel_exhaust_tac n disc_exhaust collapses ORELSE
379.85 + HEADGOAL (etac meta_mp THEN' resolve_tac collapses);
379.86 +
379.87 +fun mk_collapse_tac ctxt m discD sels =
379.88 + HEADGOAL (dtac discD THEN'
379.89 + (if m = 0 then
379.90 + atac
379.91 + else
379.92 + REPEAT_DETERM_N m o etac exE THEN' hyp_subst_tac ctxt THEN'
379.93 + SELECT_GOAL (unfold_thms_tac ctxt sels) THEN' rtac refl));
379.94 +
379.95 +fun mk_expand_tac ctxt n ms udisc_exhaust vdisc_exhaust uncollapses disc_excludesss
379.96 + disc_excludesss' =
379.97 + if ms = [0] then
379.98 + HEADGOAL (rtac (@{thm trans_sym} OF (replicate 2 (the_single uncollapses))) THEN'
379.99 + TRY o EVERY' [rtac udisc_exhaust, atac, rtac vdisc_exhaust, atac])
379.100 + else
379.101 + let val ks = 1 upto n in
379.102 + HEADGOAL (rtac udisc_exhaust THEN'
379.103 + EVERY' (map5 (fn k => fn m => fn disc_excludess => fn disc_excludess' =>
379.104 + fn uuncollapse =>
379.105 + EVERY' [rtac (uuncollapse RS trans) THEN' TRY o atac,
379.106 + rtac sym, rtac vdisc_exhaust,
379.107 + EVERY' (map4 (fn k' => fn disc_excludes => fn disc_excludes' => fn vuncollapse =>
379.108 + EVERY'
379.109 + (if k' = k then
379.110 + [rtac (vuncollapse RS trans), TRY o atac] @
379.111 + (if m = 0 then
379.112 + [rtac refl]
379.113 + else
379.114 + [if n = 1 then K all_tac else EVERY' [dtac meta_mp, atac, dtac meta_mp, atac],
379.115 + REPEAT_DETERM_N (Int.max (0, m - 1)) o etac conjE,
379.116 + asm_simp_tac (ss_only [] ctxt)])
379.117 + else
379.118 + [dtac (the_single (if k = n then disc_excludes else disc_excludes')),
379.119 + etac (if k = n then @{thm iff_contradict(1)} else @{thm iff_contradict(2)}),
379.120 + atac, atac]))
379.121 + ks disc_excludess disc_excludess' uncollapses)])
379.122 + ks ms disc_excludesss disc_excludesss' uncollapses))
379.123 + end;
379.124 +
379.125 +fun mk_case_same_ctr_tac ctxt injects =
379.126 + REPEAT_DETERM o etac exE THEN' etac conjE THEN'
379.127 + (case injects of
379.128 + [] => atac
379.129 + | [inject] => dtac (inject RS iffD1) THEN' REPEAT_DETERM o etac conjE THEN'
379.130 + hyp_subst_tac ctxt THEN' rtac refl);
379.131 +
379.132 +fun mk_case_distinct_ctrs_tac ctxt distincts =
379.133 + REPEAT_DETERM o etac exE THEN' etac conjE THEN' full_simp_tac (ss_only distincts ctxt);
379.134 +
379.135 +fun mk_case_tac ctxt n k case_def injects distinctss =
379.136 + let
379.137 + val case_def' = mk_unabs_def (n + 1) (case_def RS meta_eq_to_obj_eq);
379.138 + val ks = 1 upto n;
379.139 + in
379.140 + HEADGOAL (rtac (case_def' RS trans) THEN' rtac @{thm the_equality} THEN'
379.141 + rtac (mk_disjIN n k) THEN' REPEAT_DETERM o rtac exI THEN' rtac conjI THEN' rtac refl THEN'
379.142 + rtac refl THEN'
379.143 + EVERY' (map2 (fn k' => fn distincts =>
379.144 + (if k' < n then etac disjE else K all_tac) THEN'
379.145 + (if k' = k then mk_case_same_ctr_tac ctxt injects
379.146 + else mk_case_distinct_ctrs_tac ctxt distincts)) ks distinctss))
379.147 + end;
379.148 +
379.149 +fun mk_case_cong_tac ctxt uexhaust cases =
379.150 + HEADGOAL (rtac uexhaust THEN'
379.151 + EVERY' (maps (fn casex => [dtac sym, asm_simp_tac (ss_only [casex] ctxt)]) cases));
379.152 +
379.153 +fun mk_case_eq_if_tac ctxt n uexhaust cases discss' selss =
379.154 + HEADGOAL (rtac uexhaust THEN'
379.155 + EVERY' (map3 (fn casex => fn if_discs => fn sels =>
379.156 + EVERY' [hyp_subst_tac ctxt, SELECT_GOAL (unfold_thms_tac ctxt (if_discs @ sels)),
379.157 + rtac casex])
379.158 + cases (map2 (seq_conds if_P_or_not_P_OF n) (1 upto n) discss') selss));
379.159 +
379.160 +fun mk_split_tac ctxt uexhaust cases selss injectss distinctsss =
379.161 + HEADGOAL (rtac uexhaust) THEN
379.162 + ALLGOALS (fn k => (hyp_subst_tac ctxt THEN'
379.163 + simp_tac (ss_only (@{thms simp_thms} @ cases @ nth selss (k - 1) @ nth injectss (k - 1) @
379.164 + flat (nth distinctsss (k - 1))) ctxt)) k) THEN
379.165 + ALLGOALS (blast_tac (put_claset (claset_of @{theory_context HOL}) ctxt));
379.166 +
379.167 +val split_asm_thms = @{thms imp_conv_disj de_Morgan_conj de_Morgan_disj not_not not_ex};
379.168 +
379.169 +fun mk_split_asm_tac ctxt split =
379.170 + HEADGOAL (rtac (split RS trans)) THEN unfold_thms_tac ctxt split_asm_thms THEN
379.171 + HEADGOAL (rtac refl);
379.172 +
379.173 +end;
379.174 +
379.175 +structure Ctr_Sugar_General_Tactics : CTR_SUGAR_GENERAL_TACTICS = Ctr_Sugar_Tactics;
380.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
380.2 +++ b/src/HOL/Tools/ctr_sugar_util.ML Thu Dec 05 17:58:03 2013 +0100
380.3 @@ -0,0 +1,244 @@
380.4 +(* Title: HOL/Tools/ctr_sugar_util.ML
380.5 + Author: Dmitriy Traytel, TU Muenchen
380.6 + Author: Jasmin Blanchette, TU Muenchen
380.7 + Copyright 2012, 2013
380.8 +
380.9 +Library for wrapping existing freely generated type's constructors.
380.10 +*)
380.11 +
380.12 +signature CTR_SUGAR_UTIL =
380.13 +sig
380.14 + val map3: ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
380.15 + val map4: ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list
380.16 + val map5: ('a -> 'b -> 'c -> 'd -> 'e -> 'f) ->
380.17 + 'a list -> 'b list -> 'c list -> 'd list -> 'e list -> 'f list
380.18 + val fold_map2: ('a -> 'b -> 'c -> 'd * 'c) -> 'a list -> 'b list -> 'c -> 'd list * 'c
380.19 + val fold_map3: ('a -> 'b -> 'c -> 'd -> 'e * 'd) ->
380.20 + 'a list -> 'b list -> 'c list -> 'd -> 'e list * 'd
380.21 + val seq_conds: (bool -> 'a -> 'b) -> int -> int -> 'a list -> 'b list
380.22 + val transpose: 'a list list -> 'a list list
380.23 + val pad_list: 'a -> int -> 'a list -> 'a list
380.24 + val splice: 'a list -> 'a list -> 'a list
380.25 + val permute_like: ('a * 'b -> bool) -> 'a list -> 'b list -> 'c list -> 'c list
380.26 +
380.27 + val mk_names: int -> string -> string list
380.28 + val mk_fresh_names: Proof.context -> int -> string -> string list * Proof.context
380.29 + val mk_TFrees': sort list -> Proof.context -> typ list * Proof.context
380.30 + val mk_TFrees: int -> Proof.context -> typ list * Proof.context
380.31 + val mk_Frees': string -> typ list -> Proof.context ->
380.32 + (term list * (string * typ) list) * Proof.context
380.33 + val mk_Freess': string -> typ list list -> Proof.context ->
380.34 + (term list list * (string * typ) list list) * Proof.context
380.35 + val mk_Frees: string -> typ list -> Proof.context -> term list * Proof.context
380.36 + val mk_Freess: string -> typ list list -> Proof.context -> term list list * Proof.context
380.37 + val resort_tfree: sort -> typ -> typ
380.38 + val variant_types: string list -> sort list -> Proof.context ->
380.39 + (string * sort) list * Proof.context
380.40 + val variant_tfrees: string list -> Proof.context -> typ list * Proof.context
380.41 +
380.42 + val typ_subst_nonatomic: (typ * typ) list -> typ -> typ
380.43 + val subst_nonatomic_types: (typ * typ) list -> term -> term
380.44 +
380.45 + val mk_predT: typ list -> typ
380.46 + val mk_pred1T: typ -> typ
380.47 +
380.48 + val mk_disjIN: int -> int -> thm
380.49 +
380.50 + val mk_unabs_def: int -> thm -> thm
380.51 +
380.52 + val mk_IfN: typ -> term list -> term list -> term
380.53 + val mk_Trueprop_eq: term * term -> term
380.54 +
380.55 + val rapp: term -> term -> term
380.56 +
380.57 + val list_all_free: term list -> term -> term
380.58 + val list_exists_free: term list -> term -> term
380.59 +
380.60 + val fo_match: Proof.context -> term -> term -> Type.tyenv * Envir.tenv
380.61 +
380.62 + val cterm_instantiate_pos: cterm option list -> thm -> thm
380.63 + val unfold_thms: Proof.context -> thm list -> thm -> thm
380.64 +
380.65 + val certifyT: Proof.context -> typ -> ctyp
380.66 + val certify: Proof.context -> term -> cterm
380.67 +
380.68 + val standard_binding: binding
380.69 + val equal_binding: binding
380.70 + val parse_binding: binding parser
380.71 +
380.72 + val ss_only: thm list -> Proof.context -> Proof.context
380.73 +
380.74 + val WRAP: ('a -> tactic) -> ('a -> tactic) -> 'a list -> tactic -> tactic
380.75 + val WRAP': ('a -> int -> tactic) -> ('a -> int -> tactic) -> 'a list -> (int -> tactic) -> int ->
380.76 + tactic
380.77 + val CONJ_WRAP_GEN: tactic -> ('a -> tactic) -> 'a list -> tactic
380.78 + val CONJ_WRAP_GEN': (int -> tactic) -> ('a -> int -> tactic) -> 'a list -> int -> tactic
380.79 + val CONJ_WRAP: ('a -> tactic) -> 'a list -> tactic
380.80 + val CONJ_WRAP': ('a -> int -> tactic) -> 'a list -> int -> tactic
380.81 +end;
380.82 +
380.83 +structure Ctr_Sugar_Util : CTR_SUGAR_UTIL =
380.84 +struct
380.85 +
380.86 +fun map3 _ [] [] [] = []
380.87 + | map3 f (x1::x1s) (x2::x2s) (x3::x3s) = f x1 x2 x3 :: map3 f x1s x2s x3s
380.88 + | map3 _ _ _ _ = raise ListPair.UnequalLengths;
380.89 +
380.90 +fun map4 _ [] [] [] [] = []
380.91 + | map4 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) = f x1 x2 x3 x4 :: map4 f x1s x2s x3s x4s
380.92 + | map4 _ _ _ _ _ = raise ListPair.UnequalLengths;
380.93 +
380.94 +fun map5 _ [] [] [] [] [] = []
380.95 + | map5 f (x1::x1s) (x2::x2s) (x3::x3s) (x4::x4s) (x5::x5s) =
380.96 + f x1 x2 x3 x4 x5 :: map5 f x1s x2s x3s x4s x5s
380.97 + | map5 _ _ _ _ _ _ = raise ListPair.UnequalLengths;
380.98 +
380.99 +fun fold_map2 _ [] [] acc = ([], acc)
380.100 + | fold_map2 f (x1::x1s) (x2::x2s) acc =
380.101 + let
380.102 + val (x, acc') = f x1 x2 acc;
380.103 + val (xs, acc'') = fold_map2 f x1s x2s acc';
380.104 + in (x :: xs, acc'') end
380.105 + | fold_map2 _ _ _ _ = raise ListPair.UnequalLengths;
380.106 +
380.107 +fun fold_map3 _ [] [] [] acc = ([], acc)
380.108 + | fold_map3 f (x1::x1s) (x2::x2s) (x3::x3s) acc =
380.109 + let
380.110 + val (x, acc') = f x1 x2 x3 acc;
380.111 + val (xs, acc'') = fold_map3 f x1s x2s x3s acc';
380.112 + in (x :: xs, acc'') end
380.113 + | fold_map3 _ _ _ _ _ = raise ListPair.UnequalLengths;
380.114 +
380.115 +fun seq_conds f n k xs =
380.116 + if k = n then
380.117 + map (f false) (take (k - 1) xs)
380.118 + else
380.119 + let val (negs, pos) = split_last (take k xs) in
380.120 + map (f false) negs @ [f true pos]
380.121 + end;
380.122 +
380.123 +fun transpose [] = []
380.124 + | transpose ([] :: xss) = transpose xss
380.125 + | transpose xss = map hd xss :: transpose (map tl xss);
380.126 +
380.127 +fun pad_list x n xs = xs @ replicate (n - length xs) x;
380.128 +
380.129 +fun splice xs ys = flat (map2 (fn x => fn y => [x, y]) xs ys);
380.130 +
380.131 +fun permute_like eq xs xs' ys = map (nth ys o (fn y => find_index (fn x => eq (x, y)) xs)) xs';
380.132 +
380.133 +fun mk_names n x = if n = 1 then [x] else map (fn i => x ^ string_of_int i) (1 upto n);
380.134 +fun mk_fresh_names ctxt = (fn xs => Variable.variant_fixes xs ctxt) oo mk_names;
380.135 +
380.136 +val mk_TFrees' = apfst (map TFree) oo Variable.invent_types;
380.137 +
380.138 +fun mk_TFrees n = mk_TFrees' (replicate n HOLogic.typeS);
380.139 +
380.140 +fun mk_Frees' x Ts ctxt = mk_fresh_names ctxt (length Ts) x |>> (fn xs => `(map Free) (xs ~~ Ts));
380.141 +fun mk_Freess' x Tss = fold_map2 mk_Frees' (mk_names (length Tss) x) Tss #>> split_list;
380.142 +
380.143 +fun mk_Frees x Ts ctxt = mk_fresh_names ctxt (length Ts) x |>> (fn xs => map2 (curry Free) xs Ts);
380.144 +fun mk_Freess x Tss = fold_map2 mk_Frees (mk_names (length Tss) x) Tss;
380.145 +
380.146 +fun resort_tfree S (TFree (s, _)) = TFree (s, S);
380.147 +
380.148 +fun ensure_prefix pre s = s |> not (String.isPrefix pre s) ? prefix pre;
380.149 +
380.150 +fun variant_types ss Ss ctxt =
380.151 + let
380.152 + val (tfrees, _) =
380.153 + fold_map2 (fn s => fn S => Name.variant s #> apfst (rpair S)) ss Ss (Variable.names_of ctxt);
380.154 + val ctxt' = fold (Variable.declare_constraints o Logic.mk_type o TFree) tfrees ctxt;
380.155 + in (tfrees, ctxt') end;
380.156 +
380.157 +fun variant_tfrees ss =
380.158 + apfst (map TFree) o
380.159 + variant_types (map (ensure_prefix "'") ss) (replicate (length ss) HOLogic.typeS);
380.160 +
380.161 +(*Replace each Ti by Ui (starting from the leaves); inst = [(T1, U1), ..., (Tn, Un)].*)
380.162 +fun typ_subst_nonatomic [] = I
380.163 + | typ_subst_nonatomic inst =
380.164 + let
380.165 + fun subst (Type (s, Ts)) = perhaps (AList.lookup (op =) inst) (Type (s, map subst Ts))
380.166 + | subst T = perhaps (AList.lookup (op =) inst) T;
380.167 + in subst end;
380.168 +
380.169 +fun subst_nonatomic_types [] = I
380.170 + | subst_nonatomic_types inst = map_types (typ_subst_nonatomic inst);
380.171 +
380.172 +fun mk_predT Ts = Ts ---> HOLogic.boolT;
380.173 +fun mk_pred1T T = mk_predT [T];
380.174 +
380.175 +fun mk_disjIN 1 1 = @{thm TrueE[OF TrueI]}
380.176 + | mk_disjIN _ 1 = disjI1
380.177 + | mk_disjIN 2 2 = disjI2
380.178 + | mk_disjIN n m = (mk_disjIN (n - 1) (m - 1)) RS disjI2;
380.179 +
380.180 +fun mk_unabs_def n = funpow n (fn thm => thm RS fun_cong);
380.181 +
380.182 +fun mk_IfN _ _ [t] = t
380.183 + | mk_IfN T (c :: cs) (t :: ts) =
380.184 + Const (@{const_name If}, HOLogic.boolT --> T --> T --> T) $ c $ t $ mk_IfN T cs ts;
380.185 +
380.186 +val mk_Trueprop_eq = HOLogic.mk_Trueprop o HOLogic.mk_eq;
380.187 +
380.188 +fun rapp u t = betapply (t, u);
380.189 +
380.190 +fun list_quant_free quant_const =
380.191 + fold_rev (fn Free (xT as (_, T)) => fn P => quant_const T $ Term.absfree xT P);
380.192 +
380.193 +val list_all_free = list_quant_free HOLogic.all_const;
380.194 +val list_exists_free = list_quant_free HOLogic.exists_const;
380.195 +
380.196 +fun fo_match ctxt t pat =
380.197 + let val thy = Proof_Context.theory_of ctxt in
380.198 + Pattern.first_order_match thy (pat, t) (Vartab.empty, Vartab.empty)
380.199 + end;
380.200 +
380.201 +fun cterm_instantiate_pos cts thm =
380.202 + let
380.203 + val cert = Thm.cterm_of (Thm.theory_of_thm thm);
380.204 + val vars = Term.add_vars (prop_of thm) [];
380.205 + val vars' = rev (drop (length vars - length cts) vars);
380.206 + val ps = map_filter (fn (_, NONE) => NONE
380.207 + | (var, SOME ct) => SOME (cert (Var var), ct)) (vars' ~~ cts);
380.208 + in
380.209 + Drule.cterm_instantiate ps thm
380.210 + end;
380.211 +
380.212 +fun unfold_thms ctxt thms = Local_Defs.unfold ctxt (distinct Thm.eq_thm_prop thms);
380.213 +
380.214 +(*stolen from ~~/src/HOL/Tools/SMT/smt_utils.ML*)
380.215 +fun certifyT ctxt = Thm.ctyp_of (Proof_Context.theory_of ctxt);
380.216 +fun certify ctxt = Thm.cterm_of (Proof_Context.theory_of ctxt);
380.217 +
380.218 +(* The standard binding stands for a name generated following the canonical convention (e.g.,
380.219 + "is_Nil" from "Nil"). In contrast, the empty binding is either the standard binding or no
380.220 + binding at all, depending on the context. *)
380.221 +val standard_binding = @{binding _};
380.222 +val equal_binding = @{binding "="};
380.223 +
380.224 +val parse_binding = Parse.binding || @{keyword "="} >> K equal_binding;
380.225 +
380.226 +fun ss_only thms ctxt = clear_simpset (put_simpset HOL_basic_ss ctxt) addsimps thms;
380.227 +
380.228 +(*Tactical WRAP surrounds a static given tactic (core) with two deterministic chains of tactics*)
380.229 +fun WRAP gen_before gen_after xs core_tac =
380.230 + fold_rev (fn x => fn tac => gen_before x THEN tac THEN gen_after x) xs core_tac;
380.231 +
380.232 +fun WRAP' gen_before gen_after xs core_tac =
380.233 + fold_rev (fn x => fn tac => gen_before x THEN' tac THEN' gen_after x) xs core_tac;
380.234 +
380.235 +fun CONJ_WRAP_GEN conj_tac gen_tac xs =
380.236 + let val (butlast, last) = split_last xs;
380.237 + in WRAP (fn thm => conj_tac THEN gen_tac thm) (K all_tac) butlast (gen_tac last) end;
380.238 +
380.239 +fun CONJ_WRAP_GEN' conj_tac gen_tac xs =
380.240 + let val (butlast, last) = split_last xs;
380.241 + in WRAP' (fn thm => conj_tac THEN' gen_tac thm) (K (K all_tac)) butlast (gen_tac last) end;
380.242 +
380.243 +(*not eta-converted because of monotype restriction*)
380.244 +fun CONJ_WRAP gen_tac = CONJ_WRAP_GEN (rtac conjI 1) gen_tac;
380.245 +fun CONJ_WRAP' gen_tac = CONJ_WRAP_GEN' (rtac conjI) gen_tac;
380.246 +
380.247 +end;
381.1 --- a/src/HOL/Tools/groebner.ML Thu Dec 05 17:52:12 2013 +0100
381.2 +++ b/src/HOL/Tools/groebner.ML Thu Dec 05 17:58:03 2013 +0100
381.3 @@ -21,11 +21,6 @@
381.4 structure Groebner : GROEBNER =
381.5 struct
381.6
381.7 -fun is_comb ct =
381.8 - (case Thm.term_of ct of
381.9 - _ $ _ => true
381.10 - | _ => false);
381.11 -
381.12 val concl = Thm.cprop_of #> Thm.dest_arg;
381.13
381.14 fun is_binop ct ct' =
381.15 @@ -37,8 +32,6 @@
381.16 if is_binop ct ct' then Thm.dest_binop ct'
381.17 else raise CTERM ("dest_binary: bad binop", [ct, ct'])
381.18
381.19 -fun inst_thm inst = Thm.instantiate ([], inst);
381.20 -
381.21 val rat_0 = Rat.zero;
381.22 val rat_1 = Rat.one;
381.23 val minus_rat = Rat.neg;
381.24 @@ -77,10 +70,6 @@
381.25 n1 < n2 orelse n1 = n2 andalso lexorder m1 m2
381.26 end;
381.27
381.28 -fun morder_le m1 m2 = morder_lt m1 m2 orelse (m1 = m2);
381.29 -
381.30 -fun morder_gt m1 m2 = morder_lt m2 m1;
381.31 -
381.32 (* Arithmetic on canonical polynomials. *)
381.33
381.34 fun grob_neg l = map (fn (c,m) => (minus_rat c,m)) l;
381.35 @@ -125,33 +114,9 @@
381.36
381.37 fun grob_pow vars l n =
381.38 if n < 0 then error "grob_pow: negative power"
381.39 - else if n = 0 then [(rat_1,map (fn v => 0) vars)]
381.40 + else if n = 0 then [(rat_1,map (K 0) vars)]
381.41 else grob_mul l (grob_pow vars l (n - 1));
381.42
381.43 -fun degree vn p =
381.44 - case p of
381.45 - [] => error "Zero polynomial"
381.46 -| [(c,ns)] => nth ns vn
381.47 -| (c,ns)::p' => Int.max (nth ns vn, degree vn p');
381.48 -
381.49 -fun head_deg vn p = let val d = degree vn p in
381.50 - (d,fold (fn (c,r) => fn q => grob_add q [(c, map_index (fn (i,n) => if i = vn then 0 else n) r)]) (filter (fn (c,ns) => c <>/ rat_0 andalso nth ns vn = d) p) []) end;
381.51 -
381.52 -val is_zerop = forall (fn (c,ns) => c =/ rat_0 andalso forall (curry (op =) 0) ns);
381.53 -val grob_pdiv =
381.54 - let fun pdiv_aux vn (n,a) p k s =
381.55 - if is_zerop s then (k,s) else
381.56 - let val (m,b) = head_deg vn s
381.57 - in if m < n then (k,s) else
381.58 - let val p' = grob_mul p [(rat_1, map_index (fn (i,v) => if i = vn then m - n else 0)
381.59 - (snd (hd s)))]
381.60 - in if a = b then pdiv_aux vn (n,a) p k (grob_sub s p')
381.61 - else pdiv_aux vn (n,a) p (k + 1) (grob_sub (grob_mul a s) (grob_mul b p'))
381.62 - end
381.63 - end
381.64 - in fn vn => fn s => fn p => pdiv_aux vn (head_deg vn p) p 0 s
381.65 - end;
381.66 -
381.67 (* Monomial division operation. *)
381.68
381.69 fun mdiv (c1,m1) (c2,m2) =
381.70 @@ -160,7 +125,7 @@
381.71
381.72 (* Lowest common multiple of two monomials. *)
381.73
381.74 -fun mlcm (c1,m1) (c2,m2) = (rat_1, ListPair.map Int.max (m1, m2));
381.75 +fun mlcm (_,m1) (_,m2) = (rat_1, ListPair.map Int.max (m1, m2));
381.76
381.77 (* Reduce monomial cm by polynomial pol, returning replacement for cm. *)
381.78
381.79 @@ -200,8 +165,8 @@
381.80
381.81 fun spoly cm ph1 ph2 =
381.82 case (ph1,ph2) of
381.83 - (([],h),p) => ([],h)
381.84 - | (p,([],h)) => ([],h)
381.85 + (([],h),_) => ([],h)
381.86 + | (_,([],h)) => ([],h)
381.87 | ((cm1::ptl1,his1),(cm2::ptl2,his2)) =>
381.88 (grob_sub (grob_cmul (mdiv cm cm1) ptl1)
381.89 (grob_cmul (mdiv cm cm2) ptl2),
381.90 @@ -218,12 +183,12 @@
381.91
381.92 (* The most popular heuristic is to order critical pairs by LCM monomial. *)
381.93
381.94 -fun forder ((c1,m1),_) ((c2,m2),_) = morder_lt m1 m2;
381.95 +fun forder ((_,m1),_) ((_,m2),_) = morder_lt m1 m2;
381.96
381.97 fun poly_lt p q =
381.98 case (p,q) of
381.99 - (p,[]) => false
381.100 - | ([],q) => true
381.101 + (_,[]) => false
381.102 + | ([],_) => true
381.103 | ((c1,m1)::o1,(c2,m2)::o2) =>
381.104 c1 </ c2 orelse
381.105 c1 =/ c2 andalso ((morder_lt m1 m2) orelse m1 = m2 andalso poly_lt o1 o2);
381.106 @@ -234,7 +199,7 @@
381.107 fun poly_eq p1 p2 =
381.108 eq_list (fn ((c1, m1), (c2, m2)) => c1 =/ c2 andalso (m1: int list) = m2) (p1, p2);
381.109
381.110 -fun memx ((p1,h1),(p2,h2)) ppairs =
381.111 +fun memx ((p1,_),(p2,_)) ppairs =
381.112 not (exists (fn ((q1,_),(q2,_)) => poly_eq p1 q1 andalso poly_eq p2 q2) ppairs);
381.113
381.114 (* Buchberger's second criterion. *)
381.115 @@ -277,7 +242,7 @@
381.116 case pairs of
381.117 [] => basis
381.118 | (l,(p1,p2))::opairs =>
381.119 - let val (sph as (sp,hist)) = monic (reduce basis (spoly l p1 p2))
381.120 + let val (sph as (sp,_)) = monic (reduce basis (spoly l p1 p2))
381.121 in
381.122 if null sp orelse criterion2 basis (l,(p1,p2)) opairs
381.123 then grobner_basis basis opairs
381.124 @@ -324,7 +289,7 @@
381.125
381.126 fun grobner_refute pols =
381.127 let val gb = grobner pols in
381.128 - snd(find (fn (p,h) => length p = 1 andalso forall (fn x=> x=0) (snd(hd p))) gb)
381.129 + snd(find (fn (p,_) => length p = 1 andalso forall (fn x=> x=0) (snd(hd p))) gb)
381.130 end;
381.131
381.132 (* Turn proof into a certificate as sum of multipliers. *)
381.133 @@ -366,8 +331,8 @@
381.134
381.135 fun grobner_strong vars pols pol =
381.136 let val vars' = @{cterm "True"}::vars
381.137 - val grob_z = [(rat_1,1::(map (fn x => 0) vars))]
381.138 - val grob_1 = [(rat_1,(map (fn x => 0) vars'))]
381.139 + val grob_z = [(rat_1,1::(map (K 0) vars))]
381.140 + val grob_1 = [(rat_1,(map (K 0) vars'))]
381.141 fun augment p= map (fn (c,m) => (c,0::m)) p
381.142 val pols' = map augment pols
381.143 val pol' = augment pol
381.144 @@ -387,7 +352,7 @@
381.145
381.146 fun refute_disj rfn tm =
381.147 case term_of tm of
381.148 - Const(@{const_name HOL.disj},_)$l$r =>
381.149 + Const(@{const_name HOL.disj},_)$_$_ =>
381.150 Drule.compose
381.151 (refute_disj rfn (Thm.dest_arg tm), 2,
381.152 Drule.compose (refute_disj rfn (Thm.dest_arg1 tm), 2, disjE))
381.153 @@ -398,7 +363,7 @@
381.154
381.155 fun is_neg t =
381.156 case term_of t of
381.157 - (Const(@{const_name Not},_)$p) => true
381.158 + (Const(@{const_name Not},_)$_) => true
381.159 | _ => false;
381.160 fun is_eq t =
381.161 case term_of t of
381.162 @@ -423,7 +388,7 @@
381.163 val strip_exists =
381.164 let fun h (acc, t) =
381.165 case term_of t of
381.166 - Const (@{const_name Ex}, _) $ Abs (x, T, p) =>
381.167 + Const (@{const_name Ex}, _) $ Abs _ =>
381.168 h (Thm.dest_abs NONE (Thm.dest_arg t) |>> (fn v => v::acc))
381.169 | _ => (acc,t)
381.170 in fn t => h ([],t)
381.171 @@ -435,10 +400,7 @@
381.172 | _ => false;
381.173
381.174 val mk_object_eq = fn th => th COMP meta_eq_to_obj_eq;
381.175 -val bool_simps = @{thms bool_simps};
381.176 val nnf_simps = @{thms nnf_simps};
381.177 -fun nnf_conv ctxt =
381.178 - Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps bool_simps addsimps nnf_simps)
381.179
381.180 fun weak_dnf_conv ctxt =
381.181 Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps @{thms weak_dnf_simps});
381.182 @@ -484,12 +446,10 @@
381.183
381.184 fun fold1 f = foldr1 (uncurry f);
381.185
381.186 -val list_conj = fold1 (fn c => fn c' => Thm.apply (Thm.apply @{cterm HOL.conj} c) c') ;
381.187 -
381.188 fun mk_conj_tab th =
381.189 let fun h acc th =
381.190 case prop_of th of
381.191 - @{term "Trueprop"}$(@{term HOL.conj}$p$q) =>
381.192 + @{term "Trueprop"}$(@{term HOL.conj}$_$_) =>
381.193 h (h acc (th RS conjunct2)) (th RS conjunct1)
381.194 | @{term "Trueprop"}$p => (p,th)::acc
381.195 in fold (Termtab.insert Thm.eq_thm) (h [] th) Termtab.empty end;
381.196 @@ -567,8 +527,7 @@
381.197 | Var ((s,_),_) => s
381.198 | _ => "x"
381.199 fun mk_eq s t = Thm.apply (Thm.apply @{cterm "op == :: bool => _"} s) t
381.200 - fun mkeq s t = Thm.apply @{cterm Trueprop} (Thm.apply (Thm.apply @{cterm "op = :: bool => _"} s) t)
381.201 - fun mk_exists v th = Drule.arg_cong_rule (ext (ctyp_of_term v))
381.202 + fun mk_exists v th = Drule.arg_cong_rule (ext (ctyp_of_term v))
381.203 (Thm.abstract_rule (getname v) v th)
381.204 fun simp_ex_conv ctxt =
381.205 Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps @{thms simp_thms(39)})
381.206 @@ -585,8 +544,8 @@
381.207 (** main **)
381.208
381.209 fun ring_and_ideal_conv
381.210 - {vars, semiring = (sr_ops, sr_rules), ring = (r_ops, r_rules),
381.211 - field = (f_ops, f_rules), idom, ideal}
381.212 + {vars = _, semiring = (sr_ops, _), ring = (r_ops, _),
381.213 + field = (f_ops, _), idom, ideal}
381.214 dest_const mk_const ring_eq_conv ring_normalize_conv =
381.215 let
381.216 val [add_pat, mul_pat, pow_pat, zero_tm, one_tm] = sr_ops;
381.217 @@ -612,7 +571,6 @@
381.218 else raise CTERM ("ring_dest_neg", [t])
381.219 end
381.220
381.221 - val ring_mk_neg = fn tm => Thm.apply (ring_neg_tm) (tm);
381.222 fun field_dest_inv t =
381.223 let val (l,r) = Thm.dest_comb t in
381.224 if Term.could_unify(term_of l, term_of field_inv_tm) then r
381.225 @@ -621,11 +579,9 @@
381.226 val ring_dest_add = dest_binary ring_add_tm;
381.227 val ring_mk_add = mk_binop ring_add_tm;
381.228 val ring_dest_sub = dest_binary ring_sub_tm;
381.229 - val ring_mk_sub = mk_binop ring_sub_tm;
381.230 val ring_dest_mul = dest_binary ring_mul_tm;
381.231 val ring_mk_mul = mk_binop ring_mul_tm;
381.232 val field_dest_div = dest_binary field_div_tm;
381.233 - val field_mk_div = mk_binop field_div_tm;
381.234 val ring_dest_pow = dest_binary ring_pow_tm;
381.235 val ring_mk_pow = mk_binop ring_pow_tm ;
381.236 fun grobvars tm acc =
381.237 @@ -652,7 +608,7 @@
381.238 [(rat_1,map (fn i => if i aconvc tm then 1 else 0) vars)])
381.239 handle CTERM _ =>
381.240 ((let val x = dest_const tm
381.241 - in if x =/ rat_0 then [] else [(x,map (fn v => 0) vars)]
381.242 + in if x =/ rat_0 then [] else [(x,map (K 0) vars)]
381.243 end)
381.244 handle ERROR _ =>
381.245 ((grob_neg(grobify_term vars (ring_dest_neg tm)))
381.246 @@ -732,7 +688,7 @@
381.247 Conv.fconv_rule
381.248 ((Conv.arg_conv #> Conv.arg_conv) (Conv.binop_conv ring_normalize_conv)) th1
381.249 val conc = th2 |> concl |> Thm.dest_arg
381.250 - val (l,r) = conc |> dest_eq
381.251 + val (l,_) = conc |> dest_eq
381.252 in Thm.implies_intr (Thm.apply cTrp tm)
381.253 (Thm.equal_elim (Drule.arg_cong_rule cTrp (eqF_intr th2))
381.254 (Thm.reflexive l |> mk_object_eq))
381.255 @@ -756,9 +712,9 @@
381.256 val th2 = funpow deg (idom_rule ctxt o HOLogic.conj_intr th1) neq_01
381.257 in (vars,l,cert,th2)
381.258 end)
381.259 - val cert_pos = map (fn (i,p) => (i,filter (fn (c,m) => c >/ rat_0) p)) cert
381.260 + val cert_pos = map (fn (i,p) => (i,filter (fn (c,_) => c >/ rat_0) p)) cert
381.261 val cert_neg = map (fn (i,p) => (i,map (fn (c,m) => (minus_rat c,m))
381.262 - (filter (fn (c,m) => c </ rat_0) p))) cert
381.263 + (filter (fn (c,_) => c </ rat_0) p))) cert
381.264 val herts_pos = map (fn (i,p) => (i,holify_polynomial vars p)) cert_pos
381.265 val herts_neg = map (fn (i,p) => (i,holify_polynomial vars p)) cert_neg
381.266 fun thm_fn pols =
381.267 @@ -772,7 +728,7 @@
381.268 val th4 =
381.269 Conv.fconv_rule ((Conv.arg_conv o Conv.arg_conv o Conv.binop_conv) ring_normalize_conv)
381.270 (neq_rule l th3)
381.271 - val (l,r) = dest_eq(Thm.dest_arg(concl th4))
381.272 + val (l, _) = dest_eq(Thm.dest_arg(concl th4))
381.273 in Thm.implies_intr (Thm.apply cTrp tm)
381.274 (Thm.equal_elim (Drule.arg_cong_rule cTrp (eqF_intr th4))
381.275 (Thm.reflexive l |> mk_object_eq))
381.276 @@ -873,7 +829,6 @@
381.277 (Drule.binop_cong_rule @{cterm HOL.conj} th1
381.278 (Thm.reflexive (Thm.dest_arg (Thm.rhs_of th2))))
381.279 val v = Thm.dest_arg1(Thm.dest_arg1(Thm.rhs_of th3))
381.280 - val vars' = (remove op aconvc v vars) @ [v]
381.281 val th4 = Conv.fconv_rule (Conv.arg_conv (simp_ex_conv ctxt)) (mk_exists v th3)
381.282 val th5 = ex_eq_conv (mk_eq tm (fold mk_ex (remove op aconvc v vars) (Thm.lhs_of th4)))
381.283 in Thm.transitive th5 (fold mk_exists (remove op aconvc v vars) th4)
381.284 @@ -961,23 +916,12 @@
381.285 | SOME tm =>
381.286 (case Semiring_Normalizer.match ctxt tm of
381.287 NONE => NONE
381.288 - | SOME (res as (theory, {is_const, dest_const,
381.289 + | SOME (res as (theory, {is_const = _, dest_const,
381.290 mk_const, conv = ring_eq_conv})) =>
381.291 SOME (ring_and_ideal_conv theory
381.292 dest_const (mk_const (ctyp_of_term tm)) (ring_eq_conv ctxt)
381.293 (Semiring_Normalizer.semiring_normalize_wrapper ctxt res)))
381.294
381.295 -fun ring_solve ctxt form =
381.296 - (case try (find_term 0 (* FIXME !? *)) form of
381.297 - NONE => Thm.reflexive form
381.298 - | SOME tm =>
381.299 - (case Semiring_Normalizer.match ctxt tm of
381.300 - NONE => Thm.reflexive form
381.301 - | SOME (res as (theory, {is_const, dest_const, mk_const, conv = ring_eq_conv})) =>
381.302 - #ring_conv (ring_and_ideal_conv theory
381.303 - dest_const (mk_const (ctyp_of_term tm)) (ring_eq_conv ctxt)
381.304 - (Semiring_Normalizer.semiring_normalize_wrapper ctxt res)) ctxt form));
381.305 -
381.306 fun presimplify ctxt add_thms del_thms =
381.307 asm_full_simp_tac (put_simpset HOL_basic_ss ctxt
381.308 addsimps (Algebra_Simplification.get ctxt)
381.309 @@ -1014,7 +958,7 @@
381.310 | SOME thy =>
381.311 let
381.312 fun poly_exists_tac {asms = asms, concl = concl, prems = prems,
381.313 - params = params, context = ctxt, schematics = scs} =
381.314 + params = _, context = ctxt, schematics = _} =
381.315 let
381.316 val (evs,bod) = strip_exists (Thm.dest_arg concl)
381.317 val ps = map_filter (try (lhs o Thm.dest_arg)) asms
382.1 --- a/src/HOL/Tools/group_cancel.ML Thu Dec 05 17:52:12 2013 +0100
382.2 +++ b/src/HOL/Tools/group_cancel.ML Thu Dec 05 17:58:03 2013 +0100
382.3 @@ -25,7 +25,7 @@
382.4 val sub1 = @{lemma "(A::'a::ab_group_add) == k + a ==> A - b == k + (a - b)"
382.5 by (simp only: add_diff_eq)}
382.6 val sub2 = @{lemma "(B::'a::ab_group_add) == k + b ==> a - B == - k + (a - b)"
382.7 - by (simp only: diff_minus minus_add add_ac)}
382.8 + by (simp only: minus_add diff_conv_add_uminus add_ac)}
382.9 val neg1 = @{lemma "(A::'a::ab_group_add) == k + a ==> - A == - k + - a"
382.10 by (simp only: minus_add_distrib)}
382.11 val rule0 = @{lemma "(a::'a::comm_monoid_add) == a + 0"
383.1 --- a/src/HOL/Tools/hologic.ML Thu Dec 05 17:52:12 2013 +0100
383.2 +++ b/src/HOL/Tools/hologic.ML Thu Dec 05 17:58:03 2013 +0100
383.3 @@ -104,7 +104,6 @@
383.4 val mk_numeral: int -> term
383.5 val dest_num: term -> int
383.6 val numeral_const: typ -> term
383.7 - val neg_numeral_const: typ -> term
383.8 val add_numerals: term -> (term * typ) list -> (term * typ) list
383.9 val mk_number: typ -> int -> term
383.10 val dest_number: term -> typ * int
383.11 @@ -548,7 +547,6 @@
383.12 | dest_num t = raise TERM ("dest_num", [t]);
383.13
383.14 fun numeral_const T = Const ("Num.numeral_class.numeral", numT --> T);
383.15 -fun neg_numeral_const T = Const ("Num.neg_numeral_class.neg_numeral", numT --> T);
383.16
383.17 fun add_numerals (Const ("Num.numeral_class.numeral", Type (_, [_, T])) $ t) = cons (t, T)
383.18 | add_numerals (t $ u) = add_numerals t #> add_numerals u
383.19 @@ -559,14 +557,14 @@
383.20 | mk_number T 1 = Const ("Groups.one_class.one", T)
383.21 | mk_number T i =
383.22 if i > 0 then numeral_const T $ mk_numeral i
383.23 - else neg_numeral_const T $ mk_numeral (~ i);
383.24 + else Const ("Groups.uminus_class.uminus", T --> T) $ mk_number T (~ i);
383.25
383.26 fun dest_number (Const ("Groups.zero_class.zero", T)) = (T, 0)
383.27 | dest_number (Const ("Groups.one_class.one", T)) = (T, 1)
383.28 | dest_number (Const ("Num.numeral_class.numeral", Type ("fun", [_, T])) $ t) =
383.29 (T, dest_num t)
383.30 - | dest_number (Const ("Num.neg_numeral_class.neg_numeral", Type ("fun", [_, T])) $ t) =
383.31 - (T, ~ (dest_num t))
383.32 + | dest_number (Const ("Groups.uminus_class.uminus", Type ("fun", [_, T])) $ t) =
383.33 + apsnd (op ~) (dest_number t)
383.34 | dest_number t = raise TERM ("dest_number", [t]);
383.35
383.36
384.1 --- a/src/HOL/Tools/int_arith.ML Thu Dec 05 17:52:12 2013 +0100
384.2 +++ b/src/HOL/Tools/int_arith.ML Thu Dec 05 17:58:03 2013 +0100
384.3 @@ -87,9 +87,9 @@
384.4 val setup =
384.5 Lin_Arith.add_inj_thms [@{thm zle_int} RS iffD2, @{thm int_int_eq} RS iffD2]
384.6 #> Lin_Arith.add_lessD @{thm zless_imp_add1_zle}
384.7 - #> Lin_Arith.add_simps (@{thms simp_thms} @ @{thms arith_simps} @ @{thms rel_simps}
384.8 - @ @{thms pred_numeral_simps}
384.9 - @ @{thms arith_special} @ @{thms int_arith_rules})
384.10 + #> Lin_Arith.add_simps @{thms of_nat_simps of_int_simps}
384.11 + #> Lin_Arith.add_simps
384.12 + [@{thm of_int_numeral}, @{thm nat_0}, @{thm nat_1}, @{thm diff_nat_numeral}, @{thm nat_numeral}]
384.13 #> Lin_Arith.add_simprocs [zero_one_idom_simproc]
384.14 #> Lin_Arith.set_number_of number_of
384.15 #> Lin_Arith.add_inj_const (@{const_name of_nat}, HOLogic.natT --> HOLogic.intT)
385.1 --- a/src/HOL/Tools/lin_arith.ML Thu Dec 05 17:52:12 2013 +0100
385.2 +++ b/src/HOL/Tools/lin_arith.ML Thu Dec 05 17:58:03 2013 +0100
385.3 @@ -183,9 +183,6 @@
385.4 | demult (t as Const ("Num.numeral_class.numeral", _) $ n, m) =
385.5 ((NONE, Rat.mult m (Rat.rat_of_int (HOLogic.dest_num n)))
385.6 handle TERM _ => (SOME t, m))
385.7 - | demult (t as Const ("Num.neg_numeral_class.neg_numeral", _) $ n, m) =
385.8 - ((NONE, Rat.mult m (Rat.rat_of_int (~ (HOLogic.dest_num n))))
385.9 - handle TERM _ => (SOME t, m))
385.10 | demult (t as Const (@{const_name Suc}, _) $ _, m) =
385.11 ((NONE, Rat.mult m (Rat.rat_of_int (HOLogic.dest_nat t)))
385.12 handle TERM _ => (SOME t, m))
385.13 @@ -212,6 +209,10 @@
385.14 pi
385.15 | poly (Const (@{const_name Groups.one}, _), m, (p, i)) =
385.16 (p, Rat.add i m)
385.17 + | poly (all as Const ("Num.numeral_class.numeral", Type(_,[_,_])) $ t, m, pi as (p, i)) =
385.18 + (let val k = HOLogic.dest_num t
385.19 + in (p, Rat.add i (Rat.mult m (Rat.rat_of_int k))) end
385.20 + handle TERM _ => add_atom all m pi)
385.21 | poly (Const (@{const_name Suc}, _) $ t, m, (p, i)) =
385.22 poly (t, m, (p, Rat.add i m))
385.23 | poly (all as Const (@{const_name Groups.times}, _) $ _ $ _, m, pi as (p, i)) =
385.24 @@ -222,14 +223,6 @@
385.25 (case demult inj_consts (all, m) of
385.26 (NONE, m') => (p, Rat.add i m')
385.27 | (SOME u, m') => add_atom u m' pi)
385.28 - | poly (all as Const ("Num.numeral_class.numeral", Type(_,[_,_])) $ t, m, pi as (p, i)) =
385.29 - (let val k = HOLogic.dest_num t
385.30 - in (p, Rat.add i (Rat.mult m (Rat.rat_of_int k))) end
385.31 - handle TERM _ => add_atom all m pi)
385.32 - | poly (all as Const ("Num.neg_numeral_class.neg_numeral", Type(_,[_,_])) $ t, m, pi as (p, i)) =
385.33 - (let val k = HOLogic.dest_num t
385.34 - in (p, Rat.add i (Rat.mult m (Rat.rat_of_int (~ k)))) end
385.35 - handle TERM _ => add_atom all m pi)
385.36 | poly (all as Const f $ x, m, pi) =
385.37 if member (op =) inj_consts f then poly (x, m, pi) else add_atom all m pi
385.38 | poly (all, m, pi) =
385.39 @@ -791,37 +784,16 @@
385.40 Most of the work is done by the cancel tactics. *)
385.41
385.42 val init_arith_data =
385.43 - Fast_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, number_of, ...} =>
385.44 - {add_mono_thms = @{thms add_mono_thms_linordered_semiring} @
385.45 - @{thms add_mono_thms_linordered_field} @ add_mono_thms,
385.46 - mult_mono_thms = @{thm mult_strict_left_mono} :: @{thm mult_left_mono} ::
385.47 - @{lemma "a = b ==> c*a = c*b" by (rule arg_cong)} :: mult_mono_thms,
385.48 + Fast_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, number_of, ...} =>
385.49 + {add_mono_thms = @{thms add_mono_thms_linordered_semiring}
385.50 + @ @{thms add_mono_thms_linordered_field} @ add_mono_thms,
385.51 + mult_mono_thms = @{thm mult_strict_left_mono} :: @{thm mult_left_mono}
385.52 + :: @{lemma "a = b ==> c * a = c * b" by (rule arg_cong)} :: mult_mono_thms,
385.53 inj_thms = inj_thms,
385.54 - lessD = lessD @ [@{thm "Suc_leI"}],
385.55 - neqE = [@{thm linorder_neqE_nat}, @{thm linorder_neqE_linordered_idom}],
385.56 - simpset =
385.57 - put_simpset HOL_basic_ss @{context}
385.58 - addsimps @{thms ring_distribs}
385.59 - addsimps [@{thm if_True}, @{thm if_False}]
385.60 - addsimps
385.61 - [@{thm add_0_left}, @{thm add_0_right},
385.62 - @{thm add_Suc}, @{thm add_Suc_right},
385.63 - @{thm nat.inject}, @{thm Suc_le_mono}, @{thm Suc_less_eq},
385.64 - @{thm "Zero_not_Suc"}, @{thm "Suc_not_Zero"}, @{thm "le_0_eq"}, @{thm "One_nat_def"},
385.65 - @{thm "order_less_irrefl"}, @{thm "zero_neq_one"}, @{thm "zero_less_one"},
385.66 - @{thm "zero_le_one"}, @{thm "zero_neq_one"} RS not_sym, @{thm "not_one_le_zero"},
385.67 - @{thm "not_one_less_zero"}]
385.68 - addsimprocs [@{simproc group_cancel_add}, @{simproc group_cancel_diff},
385.69 - @{simproc group_cancel_eq}, @{simproc group_cancel_le},
385.70 - @{simproc group_cancel_less}]
385.71 - (*abel_cancel helps it work in abstract algebraic domains*)
385.72 - addsimprocs [@{simproc nateq_cancel_sums},
385.73 - @{simproc natless_cancel_sums},
385.74 - @{simproc natle_cancel_sums}]
385.75 - |> Simplifier.add_cong @{thm if_weak_cong}
385.76 - |> simpset_of,
385.77 - number_of = number_of}) #>
385.78 - add_discrete_type @{type_name nat};
385.79 + lessD = lessD,
385.80 + neqE = @{thm linorder_neqE_nat} :: @{thm linorder_neqE_linordered_idom} :: neqE,
385.81 + simpset = put_simpset HOL_basic_ss @{context} |> Simplifier.add_cong @{thm if_weak_cong} |> simpset_of,
385.82 + number_of = number_of});
385.83
385.84 (* FIXME !?? *)
385.85 fun add_arith_facts ctxt =
385.86 @@ -909,9 +881,6 @@
385.87
385.88 (* context setup *)
385.89
385.90 -val setup =
385.91 - init_arith_data;
385.92 -
385.93 val global_setup =
385.94 map_theory_simpset (fn ctxt => ctxt
385.95 addSolver (mk_solver "lin_arith" (add_arith_facts #> Fast_Arith.prems_lin_arith_tac))) #>
385.96 @@ -924,4 +893,22 @@
385.97 THEN' tac ctxt)))) "linear arithmetic" #>
385.98 Arith_Data.add_tactic "linear arithmetic" gen_tac;
385.99
385.100 +val setup =
385.101 + init_arith_data
385.102 + #> add_discrete_type @{type_name nat}
385.103 + #> add_lessD @{thm Suc_leI}
385.104 + #> add_simps (@{thms simp_thms} @ @{thms ring_distribs} @ [@{thm if_True}, @{thm if_False},
385.105 + @{thm add_0_left}, @{thm add_0_right}, @{thm order_less_irrefl},
385.106 + @{thm zero_neq_one}, @{thm zero_less_one}, @{thm zero_le_one},
385.107 + @{thm zero_neq_one} RS not_sym, @{thm not_one_le_zero}, @{thm not_one_less_zero}])
385.108 + #> add_simps [@{thm add_Suc}, @{thm add_Suc_right}, @{thm nat.inject},
385.109 + @{thm Suc_le_mono}, @{thm Suc_less_eq}, @{thm Zero_not_Suc},
385.110 + @{thm Suc_not_Zero}, @{thm le_0_eq}, @{thm One_nat_def}]
385.111 + #> add_simprocs [@{simproc group_cancel_add}, @{simproc group_cancel_diff},
385.112 + @{simproc group_cancel_eq}, @{simproc group_cancel_le},
385.113 + @{simproc group_cancel_less}]
385.114 + (*abel_cancel helps it work in abstract algebraic domains*)
385.115 + #> add_simprocs [@{simproc nateq_cancel_sums},@{simproc natless_cancel_sums},
385.116 + @{simproc natle_cancel_sums}];
385.117 +
385.118 end;
386.1 --- a/src/HOL/Tools/numeral.ML Thu Dec 05 17:52:12 2013 +0100
386.2 +++ b/src/HOL/Tools/numeral.ML Thu Dec 05 17:58:03 2013 +0100
386.3 @@ -45,8 +45,8 @@
386.4 val numeral = @{cpat "numeral"};
386.5 val numeralT = Thm.ctyp_of @{theory} (Term.range_type (Thm.typ_of (Thm.ctyp_of_term numeral)));
386.6
386.7 -val neg_numeral = @{cpat "neg_numeral"};
386.8 -val neg_numeralT = Thm.ctyp_of @{theory} (Term.range_type (Thm.typ_of (Thm.ctyp_of_term neg_numeral)));
386.9 +val uminus = @{cpat "uminus"};
386.10 +val uminusT = Thm.ctyp_of @{theory} (Term.range_type (Thm.typ_of (Thm.ctyp_of_term uminus)));
386.11
386.12 fun instT T V = Thm.instantiate_cterm ([(V, T)], []);
386.13
386.14 @@ -56,7 +56,7 @@
386.15 | mk_cnumber T 1 = instT T oneT one
386.16 | mk_cnumber T i =
386.17 if i > 0 then Thm.apply (instT T numeralT numeral) (mk_cnumeral i)
386.18 - else Thm.apply (instT T neg_numeralT neg_numeral) (mk_cnumeral (~i));
386.19 + else Thm.apply (instT T uminusT uminus) (Thm.apply (instT T numeralT numeral) (mk_cnumeral (~i)));
386.20
386.21 end;
386.22
387.1 --- a/src/HOL/Tools/numeral_simprocs.ML Thu Dec 05 17:52:12 2013 +0100
387.2 +++ b/src/HOL/Tools/numeral_simprocs.ML Thu Dec 05 17:58:03 2013 +0100
387.3 @@ -56,9 +56,6 @@
387.4 val long_mk_sum = Arith_Data.long_mk_sum;
387.5 val dest_sum = Arith_Data.dest_sum;
387.6
387.7 -val mk_diff = HOLogic.mk_binop @{const_name Groups.minus};
387.8 -val dest_diff = HOLogic.dest_bin @{const_name Groups.minus} dummyT;
387.9 -
387.10 val mk_times = HOLogic.mk_binop @{const_name Groups.times};
387.11
387.12 fun one_of T = Const(@{const_name Groups.one}, T);
387.13 @@ -181,7 +178,7 @@
387.14
387.15 (*Simplify 0+n, n+0, Numeral1*n, n*Numeral1, 1*x, x*1, x/1 *)
387.16 val add_0s = @{thms add_0s};
387.17 -val mult_1s = @{thms mult_1s mult_1_left mult_1_right divide_1};
387.18 +val mult_1s = @{thms mult_1s divide_numeral_1 mult_1_left mult_1_right mult_minus1 mult_minus1_right divide_1};
387.19
387.20 (* For post-simplification of the rhs of simproc-generated rules *)
387.21 val post_simps =
387.22 @@ -194,9 +191,8 @@
387.23 val field_post_simps =
387.24 post_simps @ [@{thm divide_zero_left}, @{thm divide_1}]
387.25
387.26 -(*Simplify inverse Numeral1, a/Numeral1*)
387.27 +(*Simplify inverse Numeral1*)
387.28 val inverse_1s = [@{thm inverse_numeral_1}];
387.29 -val divide_1s = [@{thm divide_numeral_1}];
387.30
387.31 (*To perform binary arithmetic. The "left" rewriting handles patterns
387.32 created by the Numeral_Simprocs, such as 3 * (5 * x). *)
387.33 @@ -217,24 +213,21 @@
387.34 @{thms add_neg_numeral_simps}) simps;
387.35
387.36 (*To evaluate binary negations of coefficients*)
387.37 -val minus_simps = [@{thm minus_zero}, @{thm minus_one}, @{thm minus_numeral}, @{thm minus_neg_numeral}];
387.38 +val minus_simps = [@{thm minus_zero}, @{thm minus_minus}];
387.39
387.40 (*To let us treat subtraction as addition*)
387.41 -val diff_simps = [@{thm diff_minus}, @{thm minus_add_distrib}, @{thm minus_minus}];
387.42 +val diff_simps = [@{thm diff_conv_add_uminus}, @{thm minus_add_distrib}, @{thm minus_minus}];
387.43
387.44 (*To let us treat division as multiplication*)
387.45 val divide_simps = [@{thm divide_inverse}, @{thm inverse_mult_distrib}, @{thm inverse_inverse_eq}];
387.46
387.47 -(*push the unary minus down*)
387.48 -val minus_mult_eq_1_to_2 = @{lemma "- (a::'a::ring) * b = a * - b" by simp};
387.49 -
387.50 (*to extract again any uncancelled minuses*)
387.51 val minus_from_mult_simps =
387.52 [@{thm minus_minus}, @{thm mult_minus_left}, @{thm mult_minus_right}];
387.53
387.54 (*combine unary minus with numeric literals, however nested within a product*)
387.55 val mult_minus_simps =
387.56 - [@{thm mult_assoc}, @{thm minus_mult_left}, minus_mult_eq_1_to_2];
387.57 + [@{thm mult_assoc}, @{thm minus_mult_right}, @{thm minus_mult_commute}];
387.58
387.59 val norm_ss1 =
387.60 simpset_of (put_simpset num_ss @{context}
387.61 @@ -247,7 +240,7 @@
387.62
387.63 val norm_ss3 =
387.64 simpset_of (put_simpset num_ss @{context}
387.65 - addsimps minus_from_mult_simps @ @{thms add_ac} @ @{thms mult_ac})
387.66 + addsimps minus_from_mult_simps @ @{thms add_ac} @ @{thms mult_ac minus_mult_commute})
387.67
387.68 structure CancelNumeralsCommon =
387.69 struct
387.70 @@ -330,7 +323,7 @@
387.71 structure FieldCombineNumeralsData =
387.72 struct
387.73 type coeff = int * int
387.74 - val iszero = (fn (p, q) => p = 0)
387.75 + val iszero = (fn (p, _) => p = 0)
387.76 val add = add_frac
387.77 val mk_sum = long_mk_sum
387.78 val dest_sum = dest_sum
387.79 @@ -368,7 +361,7 @@
387.80
387.81 structure Semiring_Times_Assoc_Data : ASSOC_FOLD_DATA =
387.82 struct
387.83 - val assoc_ss = simpset_of (put_simpset HOL_basic_ss @{context} addsimps @{thms mult_ac})
387.84 + val assoc_ss = simpset_of (put_simpset HOL_basic_ss @{context} addsimps @{thms mult_ac minus_mult_commute})
387.85 val eq_reflection = eq_reflection
387.86 val is_numeral = can HOLogic.dest_number
387.87 end;
387.88 @@ -388,7 +381,7 @@
387.89 val norm_ss2 =
387.90 simpset_of (put_simpset HOL_basic_ss @{context} addsimps simps @ mult_minus_simps)
387.91 val norm_ss3 =
387.92 - simpset_of (put_simpset HOL_basic_ss @{context} addsimps @{thms mult_ac})
387.93 + simpset_of (put_simpset HOL_basic_ss @{context} addsimps @{thms mult_ac minus_mult_commute})
387.94 fun norm_tac ctxt =
387.95 ALLGOALS (simp_tac (put_simpset norm_ss1 ctxt))
387.96 THEN ALLGOALS (simp_tac (put_simpset norm_ss2 ctxt))
387.97 @@ -463,9 +456,9 @@
387.98 ["((l::'a::field_inverse_zero) * m) / n",
387.99 "(l::'a::field_inverse_zero) / (m * n)",
387.100 "((numeral v)::'a::field_inverse_zero) / (numeral w)",
387.101 - "((numeral v)::'a::field_inverse_zero) / (neg_numeral w)",
387.102 - "((neg_numeral v)::'a::field_inverse_zero) / (numeral w)",
387.103 - "((neg_numeral v)::'a::field_inverse_zero) / (neg_numeral w)"],
387.104 + "((numeral v)::'a::field_inverse_zero) / (- numeral w)",
387.105 + "((- numeral v)::'a::field_inverse_zero) / (numeral w)",
387.106 + "((- numeral v)::'a::field_inverse_zero) / (- numeral w)"],
387.107 DivideCancelNumeralFactor.proc)]
387.108
387.109
387.110 @@ -516,7 +509,7 @@
387.111 val find_first = find_first_t []
387.112 val trans_tac = trans_tac
387.113 val norm_ss =
387.114 - simpset_of (put_simpset HOL_basic_ss @{context} addsimps mult_1s @ @{thms mult_ac})
387.115 + simpset_of (put_simpset HOL_basic_ss @{context} addsimps mult_1s @ @{thms mult_ac minus_mult_commute})
387.116 fun norm_tac ctxt =
387.117 ALLGOALS (simp_tac (put_simpset norm_ss ctxt))
387.118 val simplify_meta_eq = cancel_simplify_meta_eq
387.119 @@ -719,7 +712,7 @@
387.120 @{thm "times_divide_eq_left"}, @{thm "times_divide_eq_right"},
387.121 @{thm "times_divide_times_eq"},
387.122 @{thm "divide_divide_eq_right"},
387.123 - @{thm "diff_minus"}, @{thm "minus_divide_left"},
387.124 + @{thm diff_conv_add_uminus}, @{thm "minus_divide_left"},
387.125 @{thm "add_divide_distrib"} RS sym,
387.126 @{thm field_divide_inverse} RS sym, @{thm inverse_divide},
387.127 Conv.fconv_rule (Conv.arg_conv (Conv.arg1_conv (Conv.rewr_conv (mk_meta_eq @{thm mult_commute}))))
388.1 --- a/src/HOL/Tools/semiring_normalizer.ML Thu Dec 05 17:52:12 2013 +0100
388.2 +++ b/src/HOL/Tools/semiring_normalizer.ML Thu Dec 05 17:58:03 2013 +0100
388.3 @@ -848,7 +848,7 @@
388.4 val nat_exp_ss =
388.5 simpset_of
388.6 (put_simpset HOL_basic_ss @{context}
388.7 - addsimps (@{thms eval_nat_numeral} @ @{thms nat_arith} @ @{thms arith_simps} @ @{thms rel_simps})
388.8 + addsimps (@{thms eval_nat_numeral} @ @{thms diff_nat_numeral} @ @{thms arith_simps} @ @{thms rel_simps})
388.9 addsimps [@{thm Let_def}, @{thm if_False}, @{thm if_True}, @{thm Nat.add_0}, @{thm add_Suc}]);
388.10
388.11 fun simple_cterm_ord t u = Term_Ord.term_ord (term_of t, term_of u) = LESS;
389.1 --- a/src/HOL/Tools/try0.ML Thu Dec 05 17:52:12 2013 +0100
389.2 +++ b/src/HOL/Tools/try0.ML Thu Dec 05 17:58:03 2013 +0100
389.3 @@ -41,10 +41,10 @@
389.4 end
389.5 handle TimeLimit.TimeOut => false
389.6
389.7 -fun do_generic timeout_opt command pre post apply st =
389.8 +fun do_generic timeout_opt name command pre post apply st =
389.9 let val timer = Timer.startRealTimer () in
389.10 if can_apply timeout_opt pre post apply st then
389.11 - SOME (command, Time.toMilliseconds (Timer.checkRealTimer timer))
389.12 + SOME (name, command, Time.toMilliseconds (Timer.checkRealTimer timer))
389.13 else
389.14 NONE
389.15 end
389.16 @@ -75,16 +75,11 @@
389.17 timeout_opt quad st =
389.18 if mode <> Auto_Try orelse run_if_auto_try then
389.19 let val attrs = attrs_text attrs quad in
389.20 - do_generic timeout_opt
389.21 - (name ^ attrs ^
389.22 - (if all_goals andalso
389.23 - nprems_of (#goal (Proof.goal st)) > 1 then
389.24 - " [1]"
389.25 - else
389.26 - ""))
389.27 - I (#goal o Proof.goal)
389.28 - (apply_named_method_on_first_goal (name ^ attrs)
389.29 - (Proof.theory_of st)) st
389.30 + do_generic timeout_opt name
389.31 + ((name ^ attrs |> attrs <> "" ? enclose "(" ")") ^
389.32 + (if all_goals andalso nprems_of (#goal (Proof.goal st)) > 1 then "[1]" else ""))
389.33 + I (#goal o Proof.goal)
389.34 + (apply_named_method_on_first_goal (name ^ attrs) (Proof.theory_of st)) st
389.35 end
389.36 else
389.37 NONE
389.38 @@ -108,12 +103,17 @@
389.39 ("presburger", ((false, true), no_attrs))]
389.40 val do_methods = map do_named_method named_methods
389.41
389.42 -fun time_string (s, ms) = s ^ ": " ^ string_of_int ms ^ " ms"
389.43 +fun time_string ms = string_of_int ms ^ " ms"
389.44 +fun tool_time_string (s, ms) = s ^ ": " ^ time_string ms
389.45
389.46 fun do_try0 mode timeout_opt quad st =
389.47 let
389.48 val st = st |> Proof.map_context (Config.put Metis_Tactic.verbose false #>
389.49 Config.put Lin_Arith.verbose false)
389.50 + fun trd (_, _, t) = t
389.51 + fun par_map f =
389.52 + if mode = Normal then Par_List.map f #> map_filter I #> sort (int_ord o pairself trd)
389.53 + else Par_List.get_some f #> the_list
389.54 in
389.55 if mode = Normal then
389.56 "Trying " ^ space_implode " " (Try.serial_commas "and"
389.57 @@ -121,17 +121,15 @@
389.58 |> Output.urgent_message
389.59 else
389.60 ();
389.61 - case do_methods |> Par_List.map (fn f => f mode timeout_opt quad st)
389.62 - |> map_filter I |> sort (int_ord o pairself snd) of
389.63 + (case par_map (fn f => f mode timeout_opt quad st) do_methods of
389.64 [] =>
389.65 (if mode = Normal then Output.urgent_message "No proof found." else ();
389.66 (false, (noneN, st)))
389.67 - | xs as (s, _) :: _ =>
389.68 + | xs as (name, command, _) :: _ =>
389.69 let
389.70 - val xs = xs |> map (fn (s, n) => (n, hd (space_explode " " s)))
389.71 + val xs = xs |> map (fn (name, _, n) => (n, name))
389.72 |> AList.coalesce (op =)
389.73 |> map (swap o apsnd commas)
389.74 - val need_parens = exists_string (curry (op =) " ") s
389.75 val message =
389.76 (case mode of
389.77 Auto_Try => "Auto Try0 found a proof"
389.78 @@ -139,16 +137,18 @@
389.79 | Normal => "Try this") ^ ": " ^
389.80 Active.sendback_markup [Markup.padding_command]
389.81 ((if nprems_of (#goal (Proof.goal st)) = 1 then "by"
389.82 - else "apply") ^ " " ^ (s |> need_parens ? enclose "(" ")")) ^
389.83 - "\n(" ^ space_implode "; " (map time_string xs) ^ ")."
389.84 + else "apply") ^ " " ^ command) ^
389.85 + (case xs of
389.86 + [(_, ms)] => " (" ^ time_string ms ^ ")."
389.87 + | xs => "\n(" ^ space_implode "; " (map tool_time_string xs) ^ ").")
389.88 in
389.89 - (true, (s, st |> (if mode = Auto_Try then
389.90 - Proof.goal_message
389.91 - (fn () => Pretty.markup Markup.information
389.92 - [Pretty.str message])
389.93 - else
389.94 - tap (fn _ => Output.urgent_message message))))
389.95 - end
389.96 + (true, (name,
389.97 + st |> (if mode = Auto_Try then
389.98 + Proof.goal_message
389.99 + (fn () => Pretty.markup Markup.information [Pretty.str message])
389.100 + else
389.101 + tap (fn _ => Output.urgent_message message))))
389.102 + end)
389.103 end
389.104
389.105 fun try0 timeout_opt = fst oo do_try0 Normal timeout_opt
390.1 --- a/src/HOL/Topological_Spaces.thy Thu Dec 05 17:52:12 2013 +0100
390.2 +++ b/src/HOL/Topological_Spaces.thy Thu Dec 05 17:58:03 2013 +0100
390.3 @@ -2112,7 +2112,7 @@
390.4 with dense[of b "Inf A"] obtain c where "c < Inf A" "c \<in> A"
390.5 by (auto simp: subset_eq)
390.6 then show False
390.7 - using cInf_lower[OF `c \<in> A`, of x] bnd by (metis less_imp_le not_le)
390.8 + using cInf_lower[OF `c \<in> A`] bnd by (metis not_le less_imp_le bdd_belowI)
390.9 qed
390.10
390.11 lemma Sup_notin_open:
390.12 @@ -2125,7 +2125,7 @@
390.13 with dense[of "Sup A" b] obtain c where "Sup A < c" "c \<in> A"
390.14 by (auto simp: subset_eq)
390.15 then show False
390.16 - using cSup_upper[OF `c \<in> A`, of x] bnd by (metis less_imp_le not_le)
390.17 + using cSup_upper[OF `c \<in> A`] bnd by (metis less_imp_le not_le bdd_aboveI)
390.18 qed
390.19
390.20 end
390.21 @@ -2151,7 +2151,7 @@
390.22 let ?z = "Inf (B \<inter> {x <..})"
390.23
390.24 have "x \<le> ?z" "?z \<le> y"
390.25 - using `y \<in> B` `x < y` by (auto intro: cInf_lower[where z=x] cInf_greatest)
390.26 + using `y \<in> B` `x < y` by (auto intro: cInf_lower cInf_greatest)
390.27 with `x \<in> U` `y \<in> U` have "?z \<in> U"
390.28 by (rule *)
390.29 moreover have "?z \<notin> B \<inter> {x <..}"
390.30 @@ -2163,11 +2163,11 @@
390.31 obtain a where "?z < a" "{?z ..< a} \<subseteq> A"
390.32 using open_right[OF `open A` `?z \<in> A` `?z < y`] by auto
390.33 moreover obtain b where "b \<in> B" "x < b" "b < min a y"
390.34 - using cInf_less_iff[of "B \<inter> {x <..}" x "min a y"] `?z < a` `?z < y` `x < y` `y \<in> B`
390.35 + using cInf_less_iff[of "B \<inter> {x <..}" "min a y"] `?z < a` `?z < y` `x < y` `y \<in> B`
390.36 by (auto intro: less_imp_le)
390.37 moreover have "?z \<le> b"
390.38 using `b \<in> B` `x < b`
390.39 - by (intro cInf_lower[where z=x]) auto
390.40 + by (intro cInf_lower) auto
390.41 moreover have "b \<in> U"
390.42 using `x \<le> ?z` `?z \<le> b` `b < min a y`
390.43 by (intro *[OF `x \<in> U` `y \<in> U`]) (auto simp: less_imp_le)
391.1 --- a/src/HOL/Transcendental.thy Thu Dec 05 17:52:12 2013 +0100
391.2 +++ b/src/HOL/Transcendental.thy Thu Dec 05 17:58:03 2013 +0100
391.3 @@ -33,24 +33,31 @@
391.4 shows
391.5 "x ^ (Suc n) - y ^ (Suc n) =
391.6 (x - y) * (\<Sum>p=0..<Suc n. (x ^ p) * y ^ (n - p))"
391.7 - apply (induct n)
391.8 - apply simp
391.9 - apply (simp del: setsum_op_ivl_Suc)
391.10 - apply (subst setsum_op_ivl_Suc)
391.11 - apply (subst lemma_realpow_diff_sumr)
391.12 - apply (simp add: distrib_left del: setsum_op_ivl_Suc)
391.13 - apply (subst mult_left_commute [of "x - y"])
391.14 - apply (erule subst)
391.15 - apply (simp add: algebra_simps)
391.16 - done
391.17 +proof (induct n)
391.18 + case 0 show ?case
391.19 + by simp
391.20 +next
391.21 + case (Suc n)
391.22 + have "x ^ Suc (Suc n) - y ^ Suc (Suc n) = x * (x * x ^ n) - y * (y * y ^ n)"
391.23 + by simp
391.24 + also have "... = y * (x ^ (Suc n) - y ^ (Suc n)) + (x - y) * (x * x ^ n)"
391.25 + by (simp add: algebra_simps)
391.26 + also have "... = y * ((x - y) * (\<Sum>p=0..<Suc n. (x ^ p) * y ^ (n - p))) + (x - y) * (x * x ^ n)"
391.27 + by (simp only: Suc)
391.28 + also have "... = (x - y) * (y * (\<Sum>p=0..<Suc n. (x ^ p) * y ^ (n - p))) + (x - y) * (x * x ^ n)"
391.29 + by (simp only: mult_left_commute)
391.30 + also have "... = (x - y) * (\<Sum>p = 0..<Suc (Suc n). x ^ p * y ^ (Suc n - p))"
391.31 + by (simp add: setsum_op_ivl_Suc [where n = "Suc n"] distrib_left lemma_realpow_diff_sumr
391.32 + del: setsum_op_ivl_Suc)
391.33 + finally show ?case .
391.34 +qed
391.35
391.36 lemma lemma_realpow_rev_sumr:
391.37 - "(\<Sum>p=0..<Suc n. (x ^ p) * (y ^ (n - p))) =
391.38 + "(\<Sum>p=0..<Suc n. (x ^ p) * (y ^ (n - p))) =
391.39 (\<Sum>p=0..<Suc n. (x ^ (n - p)) * (y ^ p))"
391.40 apply (rule setsum_reindex_cong [where f="\<lambda>i. n - i"])
391.41 - apply (rule inj_onI, simp)
391.42 - apply auto
391.43 - apply (rule_tac x="n - x" in image_eqI, simp, simp)
391.44 + apply (rule inj_onI, auto)
391.45 + apply (metis atLeastLessThan_iff diff_diff_cancel diff_less_Suc imageI le0 less_Suc_eq_le)
391.46 done
391.47
391.48 text{*Power series has a `circle` of convergence, i.e. if it sums for @{term
391.49 @@ -388,12 +395,8 @@
391.50 by auto
391.51 ultimately show ?thesis by auto
391.52 qed
391.53 - from this[THEN conjunct1]
391.54 - this[THEN conjunct2, THEN conjunct1]
391.55 - this[THEN conjunct2, THEN conjunct2, THEN conjunct1]
391.56 - this[THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct1]
391.57 - this[THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2]
391.58 - show ?summable and ?pos and ?neg and ?f and ?g .
391.59 + then show ?summable and ?pos and ?neg and ?f and ?g
391.60 + by safe
391.61 qed
391.62
391.63 subsection {* Term-by-Term Differentiability of Power Series *}
391.64 @@ -420,9 +423,7 @@
391.65 (\<lambda>n. of_nat n * c(n) * (x ^ (n - Suc 0))) sums
391.66 (\<Sum>n. (diffs c)(n) * (x ^ n))"
391.67 unfolding diffs_def
391.68 - apply (drule summable_sums)
391.69 - apply (rule sums_Suc_imp, simp_all)
391.70 - done
391.71 + by (simp add: summable_sums sums_Suc_imp)
391.72
391.73 lemma lemma_termdiff1:
391.74 fixes z :: "'a :: {monoid_mult,comm_ring}" shows
391.75 @@ -453,7 +454,7 @@
391.76 apply simp
391.77 apply (simp only: lemma_termdiff1 setsum_right_distrib)
391.78 apply (rule setsum_cong [OF refl])
391.79 - apply (simp add: diff_minus [symmetric] less_iff_Suc_add)
391.80 + apply (simp add: less_iff_Suc_add)
391.81 apply (clarify)
391.82 apply (simp add: setsum_right_distrib lemma_realpow_diff_sumr2 mult_ac
391.83 del: setsum_op_ivl_Suc power_Suc)
391.84 @@ -482,10 +483,7 @@
391.85 have "norm (((z + h) ^ n - z ^ n) / h - of_nat n * z ^ (n - Suc 0)) =
391.86 norm (\<Sum>p = 0..<n - Suc 0. \<Sum>q = 0..<n - Suc 0 - p.
391.87 (z + h) ^ q * z ^ (n - 2 - q)) * norm h"
391.88 - apply (subst lemma_termdiff2 [OF 1])
391.89 - apply (subst norm_mult)
391.90 - apply (rule mult_commute)
391.91 - done
391.92 + by (metis (lifting, no_types) lemma_termdiff2 [OF 1] mult_commute norm_mult)
391.93 also have "\<dots> \<le> of_nat n * (of_nat (n - Suc 0) * K ^ (n - 2)) * norm h"
391.94 proof (rule mult_right_mono [OF _ norm_ge_zero])
391.95 from norm_ge_zero 2 have K: "0 \<le> K"
391.96 @@ -642,11 +640,8 @@
391.97 \<le> norm (c n) * of_nat n * of_nat (n - Suc 0) * r ^ (n - 2) * norm h"
391.98 apply (simp only: norm_mult mult_assoc)
391.99 apply (rule mult_left_mono [OF _ norm_ge_zero])
391.100 - apply (simp (no_asm) add: mult_assoc [symmetric])
391.101 - apply (rule lemma_termdiff3)
391.102 - apply (rule h)
391.103 - apply (rule r1 [THEN order_less_imp_le])
391.104 - apply (rule xh [THEN order_less_imp_le])
391.105 + apply (simp add: mult_assoc [symmetric])
391.106 + apply (metis h lemma_termdiff3 less_eq_real_def r1 xh)
391.107 done
391.108 qed
391.109 qed
391.110 @@ -654,9 +649,9 @@
391.111 lemma termdiffs:
391.112 fixes K x :: "'a::{real_normed_field,banach}"
391.113 assumes 1: "summable (\<lambda>n. c n * K ^ n)"
391.114 - and 2: "summable (\<lambda>n. (diffs c) n * K ^ n)"
391.115 - and 3: "summable (\<lambda>n. (diffs (diffs c)) n * K ^ n)"
391.116 - and 4: "norm x < norm K"
391.117 + and 2: "summable (\<lambda>n. (diffs c) n * K ^ n)"
391.118 + and 3: "summable (\<lambda>n. (diffs (diffs c)) n * K ^ n)"
391.119 + and 4: "norm x < norm K"
391.120 shows "DERIV (\<lambda>x. \<Sum>n. c n * x ^ n) x :> (\<Sum>n. (diffs c) n * x ^ n)"
391.121 unfolding deriv_def
391.122 proof (rule LIM_zero_cancel)
391.123 @@ -677,20 +672,23 @@
391.124 by (rule powser_inside [OF 1 5])
391.125 have C: "summable (\<lambda>n. diffs c n * x ^ n)"
391.126 by (rule powser_inside [OF 2 4])
391.127 - show "((\<Sum>n. c n * (x + h) ^ n) - (\<Sum>n. c n * x ^ n)) / h
391.128 - - (\<Sum>n. diffs c n * x ^ n) =
391.129 - (\<Sum>n. c n * (((x + h) ^ n - x ^ n) / h - of_nat n * x ^ (n - Suc 0)))"
391.130 - apply (subst sums_unique [OF diffs_equiv [OF C]])
391.131 - apply (subst suminf_diff [OF B A])
391.132 - apply (subst suminf_divide [symmetric])
391.133 - apply (rule summable_diff [OF B A])
391.134 + let ?dp = "(\<Sum>n. of_nat n * c n * x ^ (n - Suc 0))"
391.135 + have "((\<Sum>n. c n * (x + h) ^ n) - (\<Sum>n. c n * x ^ n)) / h - (\<Sum>n. diffs c n * x ^ n) =
391.136 + ((\<Sum>n. c n * (x + h) ^ n) - (\<Sum>n. c n * x ^ n)) / h - ?dp"
391.137 + by (metis sums_unique [OF diffs_equiv [OF C]])
391.138 + also have "... = (\<Sum>n. c n * (x + h) ^ n - c n * x ^ n) / h - ?dp"
391.139 + by (metis suminf_diff [OF B A])
391.140 + also have "... = (\<Sum>n. (c n * (x + h) ^ n - c n * x ^ n) / h) - ?dp"
391.141 + by (metis suminf_divide [OF summable_diff [OF B A]] )
391.142 + also have "... = (\<Sum>n. (c n * (x + h) ^ n - c n * x ^ n) / h - of_nat n * c n * x ^ (n - Suc 0))"
391.143 apply (subst suminf_diff)
391.144 - apply (rule summable_divide)
391.145 - apply (rule summable_diff [OF B A])
391.146 - apply (rule sums_summable [OF diffs_equiv [OF C]])
391.147 - apply (rule arg_cong [where f="suminf"], rule ext)
391.148 - apply (simp add: algebra_simps)
391.149 + apply (auto intro: summable_divide summable_diff [OF B A] sums_summable [OF diffs_equiv [OF C]])
391.150 done
391.151 + also have "... = (\<Sum>n. c n * (((x + h) ^ n - x ^ n) / h - of_nat n * x ^ (n - Suc 0)))"
391.152 + by (simp add: algebra_simps)
391.153 + finally show "((\<Sum>n. c n * (x + h) ^ n) - (\<Sum>n. c n * x ^ n)) / h
391.154 + - (\<Sum>n. diffs c n * x ^ n) =
391.155 + (\<Sum>n. c n * (((x + h) ^ n - x ^ n) / h - of_nat n * x ^ (n - Suc 0)))" .
391.156 next
391.157 show "(\<lambda>h. \<Sum>n. c n * (((x + h) ^ n - x ^ n) / h - of_nat n * x ^ (n - Suc 0))) -- 0 --> 0"
391.158 by (rule termdiffs_aux [OF 3 4])
391.159 @@ -1129,8 +1127,7 @@
391.160 by (rule inverse_unique [symmetric], simp add: mult_exp_exp)
391.161
391.162 lemma exp_diff: "exp (x - y) = exp x / exp y"
391.163 - unfolding diff_minus divide_inverse
391.164 - by (simp add: exp_add exp_minus)
391.165 + using exp_add [of x "- y"] by (simp add: exp_minus divide_inverse)
391.166
391.167
391.168 subsubsection {* Properties of the Exponential Function on Reals *}
391.169 @@ -1161,13 +1158,25 @@
391.170
391.171 text {* Strict monotonicity of exponential. *}
391.172
391.173 -lemma exp_ge_add_one_self_aux: "0 \<le> (x::real) \<Longrightarrow> (1 + x) \<le> exp(x)"
391.174 - apply (drule order_le_imp_less_or_eq, auto)
391.175 - apply (simp add: exp_def)
391.176 - apply (rule order_trans)
391.177 - apply (rule_tac [2] n = 2 and f = "(\<lambda>n. inverse (real (fact n)) * x ^ n)" in series_pos_le)
391.178 - apply (auto intro: summable_exp simp add: numeral_2_eq_2 zero_le_mult_iff)
391.179 - done
391.180 +lemma exp_ge_add_one_self_aux:
391.181 + assumes "0 \<le> (x::real)" shows "1+x \<le> exp(x)"
391.182 +using order_le_imp_less_or_eq [OF assms]
391.183 +proof
391.184 + assume "0 < x"
391.185 + have "1+x \<le> (\<Sum>n = 0..<2. inverse (real (fact n)) * x ^ n)"
391.186 + by (auto simp add: numeral_2_eq_2)
391.187 + also have "... \<le> (\<Sum>n. inverse (real (fact n)) * x ^ n)"
391.188 + apply (rule series_pos_le [OF summable_exp])
391.189 + using `0 < x`
391.190 + apply (auto simp add: zero_le_mult_iff)
391.191 + done
391.192 + finally show "1+x \<le> exp x"
391.193 + by (simp add: exp_def)
391.194 +next
391.195 + assume "0 = x"
391.196 + then show "1 + x \<le> exp x"
391.197 + by auto
391.198 +qed
391.199
391.200 lemma exp_gt_one: "0 < (x::real) \<Longrightarrow> 1 < exp x"
391.201 proof -
391.202 @@ -1190,9 +1199,8 @@
391.203 qed
391.204
391.205 lemma exp_less_cancel: "exp (x::real) < exp y \<Longrightarrow> x < y"
391.206 - apply (simp add: linorder_not_le [symmetric])
391.207 - apply (auto simp add: order_le_less exp_less_mono)
391.208 - done
391.209 + unfolding linorder_not_le [symmetric]
391.210 + by (auto simp add: order_le_less exp_less_mono)
391.211
391.212 lemma exp_less_cancel_iff [iff]: "exp (x::real) < exp y \<longleftrightarrow> x < y"
391.213 by (auto intro: exp_less_mono exp_less_cancel)
391.214 @@ -1344,8 +1352,7 @@
391.215
391.216 lemma DERIV_ln: "0 < x \<Longrightarrow> DERIV ln x :> inverse x"
391.217 apply (rule DERIV_inverse_function [where f=exp and a=0 and b="x+1"])
391.218 - apply (erule DERIV_cong [OF DERIV_exp exp_ln])
391.219 - apply (simp_all add: abs_if isCont_ln)
391.220 + apply (auto intro: DERIV_cong [OF DERIV_exp exp_ln] isCont_ln)
391.221 done
391.222
391.223 lemma DERIV_ln_divide: "0 < x \<Longrightarrow> DERIV ln x :> 1 / x"
391.224 @@ -1466,24 +1473,13 @@
391.225 ultimately have "1 - x <= 1 / (1 + x + x\<^sup>2)"
391.226 by (elim mult_imp_le_div_pos)
391.227 also have "... <= 1 / exp x"
391.228 - apply (rule divide_left_mono)
391.229 - apply (rule exp_bound, rule a)
391.230 - apply (rule b [THEN less_imp_le])
391.231 - apply simp
391.232 - apply (rule mult_pos_pos)
391.233 - apply (rule c)
391.234 - apply simp
391.235 - done
391.236 + by (metis a abs_one b exp_bound exp_gt_zero frac_le less_eq_real_def real_sqrt_abs
391.237 + real_sqrt_pow2_iff real_sqrt_power)
391.238 also have "... = exp (-x)"
391.239 by (auto simp add: exp_minus divide_inverse)
391.240 finally have "1 - x <= exp (- x)" .
391.241 also have "1 - x = exp (ln (1 - x))"
391.242 - proof -
391.243 - have "0 < 1 - x"
391.244 - by (insert b, auto)
391.245 - thus ?thesis
391.246 - by (auto simp only: exp_ln_iff [THEN sym])
391.247 - qed
391.248 + by (metis b diff_0 exp_ln_iff less_iff_diff_less_0 minus_diff_eq)
391.249 finally have "exp (ln (1 - x)) <= exp (- x)" .
391.250 thus ?thesis by (auto simp only: exp_le_cancel_iff)
391.251 qed
391.252 @@ -1511,17 +1507,9 @@
391.253 have "exp (x - x\<^sup>2) = exp x / exp (x\<^sup>2)"
391.254 by (rule exp_diff)
391.255 also have "... <= (1 + x + x\<^sup>2) / exp (x \<^sup>2)"
391.256 - apply (rule divide_right_mono)
391.257 - apply (rule exp_bound)
391.258 - apply (rule a, rule b)
391.259 - apply simp
391.260 - done
391.261 + by (metis a b divide_right_mono exp_bound exp_ge_zero)
391.262 also have "... <= (1 + x + x\<^sup>2) / (1 + x\<^sup>2)"
391.263 - apply (rule divide_left_mono)
391.264 - apply (simp add: exp_ge_add_one_self_aux)
391.265 - apply (simp add: a)
391.266 - apply (simp add: mult_pos_pos add_pos_nonneg)
391.267 - done
391.268 + by (simp add: a divide_left_mono mult_pos_pos add_pos_nonneg)
391.269 also from a have "... <= 1 + x"
391.270 by (simp add: field_simps add_strict_increasing zero_le_mult_iff)
391.271 finally have "exp (x - x\<^sup>2) <= 1 + x" .
391.272 @@ -1532,26 +1520,8 @@
391.273 by (auto simp only: exp_ln_iff [THEN sym])
391.274 qed
391.275 finally have "exp (x - x\<^sup>2) <= exp (ln (1 + x))" .
391.276 - thus ?thesis by (auto simp only: exp_le_cancel_iff)
391.277 -qed
391.278 -
391.279 -lemma aux5: "x < 1 \<Longrightarrow> ln(1 - x) = - ln(1 + x / (1 - x))"
391.280 -proof -
391.281 - assume a: "x < 1"
391.282 - have "ln(1 - x) = - ln(1 / (1 - x))"
391.283 - proof -
391.284 - have "ln(1 - x) = - (- ln (1 - x))"
391.285 - by auto
391.286 - also have "- ln(1 - x) = ln 1 - ln(1 - x)"
391.287 - by simp
391.288 - also have "... = ln(1 / (1 - x))"
391.289 - apply (rule ln_div [THEN sym])
391.290 - using a apply auto
391.291 - done
391.292 - finally show ?thesis .
391.293 - qed
391.294 - also have " 1 / (1 - x) = 1 + x / (1 - x)" using a by(simp add:field_simps)
391.295 - finally show ?thesis .
391.296 + thus ?thesis
391.297 + by (metis exp_le_cancel_iff)
391.298 qed
391.299
391.300 lemma ln_one_minus_pos_lower_bound:
391.301 @@ -1560,7 +1530,11 @@
391.302 assume a: "0 <= x" and b: "x <= (1 / 2)"
391.303 from b have c: "x < 1" by auto
391.304 then have "ln (1 - x) = - ln (1 + x / (1 - x))"
391.305 - by (rule aux5)
391.306 + apply (subst ln_inverse [symmetric])
391.307 + apply (simp add: field_simps)
391.308 + apply (rule arg_cong [where f=ln])
391.309 + apply (simp add: field_simps)
391.310 + done
391.311 also have "- (x / (1 - x)) <= ..."
391.312 proof -
391.313 have "ln (1 + x / (1 - x)) <= x / (1 - x)"
391.314 @@ -2001,8 +1975,8 @@
391.315 apply (subst powr_add, simp, simp)
391.316 done
391.317
391.318 -lemma powr_realpow_numeral: "0 < x \<Longrightarrow> x powr (numeral n :: real) = x^(numeral n)"
391.319 - unfolding real_of_nat_numeral[symmetric] by (rule powr_realpow)
391.320 +lemma powr_realpow_numeral: "0 < x \<Longrightarrow> x powr (numeral n :: real) = x ^ (numeral n)"
391.321 + unfolding real_of_nat_numeral [symmetric] by (rule powr_realpow)
391.322
391.323 lemma powr_realpow2: "0 <= x ==> 0 < n ==> x^n = (if (x = 0) then 0 else x powr (real n))"
391.324 apply (case_tac "x = 0", simp, simp)
391.325 @@ -2021,11 +1995,17 @@
391.326 then show ?thesis by (simp add: assms powr_realpow[symmetric])
391.327 qed
391.328
391.329 -lemma powr_numeral: "0 < x \<Longrightarrow> x powr numeral n = x^numeral n"
391.330 - using powr_realpow[of x "numeral n"] by simp
391.331 -
391.332 -lemma powr_neg_numeral: "0 < x \<Longrightarrow> x powr neg_numeral n = 1 / x^numeral n"
391.333 - using powr_int[of x "neg_numeral n"] by simp
391.334 +lemma powr_one: "0 < x \<Longrightarrow> x powr 1 = x"
391.335 + using powr_realpow [of x 1] by simp
391.336 +
391.337 +lemma powr_numeral: "0 < x \<Longrightarrow> x powr numeral n = x ^ numeral n"
391.338 + by (fact powr_realpow_numeral)
391.339 +
391.340 +lemma powr_neg_one: "0 < x \<Longrightarrow> x powr - 1 = 1 / x"
391.341 + using powr_int [of x "- 1"] by simp
391.342 +
391.343 +lemma powr_neg_numeral: "0 < x \<Longrightarrow> x powr - numeral n = 1 / x ^ numeral n"
391.344 + using powr_int [of x "- numeral n"] by simp
391.345
391.346 lemma root_powr_inverse: "0 < n \<Longrightarrow> 0 < x \<Longrightarrow> root n x = x powr (1/n)"
391.347 by (rule real_root_pos_unique) (auto simp: powr_realpow[symmetric] powr_powr)
391.348 @@ -2086,55 +2066,32 @@
391.349 lemma powr_mono2: "0 <= a ==> 0 < x ==> x <= y ==> x powr a <= y powr a"
391.350 apply (case_tac "a = 0", simp)
391.351 apply (case_tac "x = y", simp)
391.352 - apply (rule order_less_imp_le)
391.353 - apply (rule powr_less_mono2, auto)
391.354 + apply (metis less_eq_real_def powr_less_mono2)
391.355 done
391.356
391.357 lemma powr_inj: "0 < a \<Longrightarrow> a \<noteq> 1 \<Longrightarrow> a powr x = a powr y \<longleftrightarrow> x = y"
391.358 unfolding powr_def exp_inj_iff by simp
391.359
391.360 lemma ln_powr_bound: "1 <= x ==> 0 < a ==> ln x <= (x powr a) / a"
391.361 - apply (rule mult_imp_le_div_pos)
391.362 - apply (assumption)
391.363 - apply (subst mult_commute)
391.364 - apply (subst ln_powr [THEN sym])
391.365 - apply auto
391.366 - apply (rule ln_bound)
391.367 - apply (erule ge_one_powr_ge_zero)
391.368 - apply (erule order_less_imp_le)
391.369 - done
391.370 + by (metis less_eq_real_def ln_less_self mult_imp_le_div_pos ln_powr mult_commute
391.371 + order.strict_trans2 powr_gt_zero zero_less_one)
391.372
391.373 lemma ln_powr_bound2:
391.374 assumes "1 < x" and "0 < a"
391.375 shows "(ln x) powr a <= (a powr a) * x"
391.376 proof -
391.377 from assms have "ln x <= (x powr (1 / a)) / (1 / a)"
391.378 - apply (intro ln_powr_bound)
391.379 - apply (erule order_less_imp_le)
391.380 - apply (rule divide_pos_pos)
391.381 - apply simp_all
391.382 - done
391.383 + by (metis less_eq_real_def ln_powr_bound zero_less_divide_1_iff)
391.384 also have "... = a * (x powr (1 / a))"
391.385 by simp
391.386 finally have "(ln x) powr a <= (a * (x powr (1 / a))) powr a"
391.387 - apply (intro powr_mono2)
391.388 - apply (rule order_less_imp_le, rule assms)
391.389 - apply (rule ln_gt_zero)
391.390 - apply (rule assms)
391.391 - apply assumption
391.392 - done
391.393 + by (metis assms less_imp_le ln_gt_zero powr_mono2)
391.394 also have "... = (a powr a) * ((x powr (1 / a)) powr a)"
391.395 - apply (rule powr_mult)
391.396 - apply (rule assms)
391.397 - apply (rule powr_gt_zero)
391.398 - done
391.399 + by (metis assms(2) powr_mult powr_gt_zero)
391.400 also have "(x powr (1 / a)) powr a = x powr ((1 / a) * a)"
391.401 by (rule powr_powr)
391.402 - also have "... = x"
391.403 - apply simp
391.404 - apply (subgoal_tac "a ~= 0")
391.405 - using assms apply auto
391.406 - done
391.407 + also have "... = x" using assms
391.408 + by auto
391.409 finally show ?thesis .
391.410 qed
391.411
391.412 @@ -2410,13 +2367,13 @@
391.413 using sin_cos_minus_lemma [where x=x] by simp
391.414
391.415 lemma sin_diff: "sin (x - y) = sin x * cos y - cos x * sin y"
391.416 - by (simp add: diff_minus sin_add)
391.417 + using sin_add [of x "- y"] by simp
391.418
391.419 lemma sin_diff2: "sin (x - y) = cos y * sin x - sin y * cos x"
391.420 by (simp add: sin_diff mult_commute)
391.421
391.422 lemma cos_diff: "cos (x - y) = cos x * cos y + sin x * sin y"
391.423 - by (simp add: diff_minus cos_add)
391.424 + using cos_add [of x "- y"] by simp
391.425
391.426 lemma cos_diff2: "cos (x - y) = cos y * cos x + sin y * sin x"
391.427 by (simp add: cos_diff mult_commute)
391.428 @@ -2484,12 +2441,7 @@
391.429 lemma real_mult_inverse_cancel:
391.430 "[|(0::real) < x; 0 < x1; x1 * y < x * u |]
391.431 ==> inverse x * y < inverse x1 * u"
391.432 - apply (rule_tac c=x in mult_less_imp_less_left)
391.433 - apply (auto simp add: mult_assoc [symmetric])
391.434 - apply (simp (no_asm) add: mult_ac)
391.435 - apply (rule_tac c=x1 in mult_less_imp_less_right)
391.436 - apply (auto simp add: mult_ac)
391.437 - done
391.438 + by (metis field_divide_inverse mult_commute mult_assoc pos_divide_less_eq pos_less_divide_eq)
391.439
391.440 lemma real_mult_inverse_cancel2:
391.441 "[|(0::real) < x;0 < x1; x1 * y < x * u |] ==> y * inverse x < u * inverse x1"
391.442 @@ -2526,8 +2478,9 @@
391.443 by (simp add: inverse_eq_divide less_divide_eq)
391.444 }
391.445 note *** = this
391.446 + have [simp]: "\<And>x y::real. 0 < x - y \<longleftrightarrow> y < x" by arith
391.447 from ** show ?thesis by (rule sumr_pos_lt_pair)
391.448 - (simp add: divide_inverse real_0_less_add_iff mult_assoc [symmetric] ***)
391.449 + (simp add: divide_inverse mult_assoc [symmetric] ***)
391.450 qed
391.451 ultimately have "0 < (\<Sum>n. - (-1 ^ n * 2 ^ (2 * n) / real (fact (2 * n))))"
391.452 by (rule order_less_trans)
391.453 @@ -2569,7 +2522,7 @@
391.454 lemma pi_half_gt_zero [simp]: "0 < pi / 2"
391.455 apply (rule order_le_neq_trans)
391.456 apply (simp add: pi_half cos_is_zero [THEN theI'])
391.457 - apply (rule notI, drule arg_cong [where f=cos], simp)
391.458 + apply (metis cos_pi_half cos_zero zero_neq_one)
391.459 done
391.460
391.461 lemmas pi_half_neq_zero [simp] = pi_half_gt_zero [THEN less_imp_neq, symmetric]
391.462 @@ -2578,7 +2531,7 @@
391.463 lemma pi_half_less_two [simp]: "pi / 2 < 2"
391.464 apply (rule order_le_neq_trans)
391.465 apply (simp add: pi_half cos_is_zero [THEN theI'])
391.466 - apply (rule notI, drule arg_cong [where f=cos], simp)
391.467 + apply (metis cos_pi_half cos_two_neq_zero)
391.468 done
391.469
391.470 lemmas pi_half_neq_two [simp] = pi_half_less_two [THEN less_imp_neq]
391.471 @@ -2641,11 +2594,7 @@
391.472 by (induct n) (auto simp add: real_of_nat_Suc distrib_right)
391.473
391.474 lemma cos_npi2 [simp]: "cos (pi * real n) = -1 ^ n"
391.475 -proof -
391.476 - have "cos (pi * real n) = cos (real n * pi)" by (simp only: mult_commute)
391.477 - also have "... = -1 ^ n" by (rule cos_npi)
391.478 - finally show ?thesis .
391.479 -qed
391.480 + by (metis cos_npi mult_commute)
391.481
391.482 lemma sin_npi [simp]: "sin (real (n::nat) * pi) = 0"
391.483 by (induct n) (auto simp add: real_of_nat_Suc distrib_right)
391.484 @@ -2660,10 +2609,7 @@
391.485 by simp
391.486
391.487 lemma sin_gt_zero2: "[| 0 < x; x < pi/2 |] ==> 0 < sin x"
391.488 - apply (rule sin_gt_zero, assumption)
391.489 - apply (rule order_less_trans, assumption)
391.490 - apply (rule pi_half_less_two)
391.491 - done
391.492 + by (metis sin_gt_zero order_less_trans pi_half_less_two)
391.493
391.494 lemma sin_less_zero:
391.495 assumes "- pi/2 < x" and "x < 0"
391.496 @@ -2687,8 +2633,7 @@
391.497
391.498 lemma cos_gt_zero_pi: "[| -(pi/2) < x; x < pi/2 |] ==> 0 < cos x"
391.499 apply (rule_tac x = x and y = 0 in linorder_cases)
391.500 - apply (rule cos_minus [THEN subst])
391.501 - apply (rule cos_gt_zero)
391.502 + apply (metis cos_gt_zero cos_minus minus_less_iff neg_0_less_iff_less)
391.503 apply (auto intro: cos_gt_zero)
391.504 done
391.505
391.506 @@ -2810,7 +2755,7 @@
391.507 apply (cut_tac x="-x" in cos_zero_lemma, simp, simp)
391.508 apply (force simp add: minus_equation_iff [of x])
391.509 apply (auto simp only: odd_Suc_mult_two_ex real_of_nat_Suc distrib_right)
391.510 -apply (auto simp add: cos_add)
391.511 +apply (auto simp add: cos_diff cos_add)
391.512 done
391.513
391.514 (* ditto: but to a lesser extent *)
391.515 @@ -3699,8 +3644,8 @@
391.516 assumes "\<bar>x\<bar> < 1"
391.517 shows "x\<^sup>2 < 1"
391.518 proof -
391.519 - from mult_left_mono[OF less_imp_le[OF `\<bar>x\<bar> < 1`] abs_ge_zero[of x]]
391.520 - have "\<bar>x\<^sup>2\<bar> < 1" using `\<bar>x\<bar> < 1` unfolding numeral_2_eq_2 power_Suc2 by auto
391.521 + have "\<bar>x\<^sup>2\<bar> < 1"
391.522 + by (metis abs_power2 assms pos2 power2_abs power_0 power_strict_decreasing zero_eq_power2 zero_less_abs_iff)
391.523 thus ?thesis using zero_le_power2 by auto
391.524 qed
391.525
391.526 @@ -3833,7 +3778,7 @@
391.527 by (rule DERIV_arctan_suminf[OF `0 < r` `r < 1` `\<bar>x\<bar> < r`])
391.528 from DERIV_add_minus[OF this DERIV_arctan]
391.529 show "DERIV (\<lambda> x. suminf (?c x) - arctan x) x :> 0"
391.530 - unfolding diff_minus by auto
391.531 + by auto
391.532 qed
391.533 hence DERIV_in_rball: "\<forall> y. a \<le> y \<and> y \<le> b \<longrightarrow> DERIV (\<lambda> x. suminf (?c x) - arctan x) y :> 0"
391.534 using `-r < a` `b < r` by auto
391.535 @@ -3861,7 +3806,7 @@
391.536 moreover
391.537 have "suminf (?c x) - arctan x = suminf (?c (-\<bar>x\<bar>)) - arctan (-\<bar>x\<bar>)"
391.538 by (rule suminf_eq_arctan_bounded[where x="x" and a="-\<bar>x\<bar>" and b="\<bar>x\<bar>"])
391.539 - (simp_all only: `\<bar>x\<bar> < r` `-\<bar>x\<bar> < \<bar>x\<bar>` neg_less_iff_less)
391.540 + (simp_all only: `\<bar>x\<bar> < r` `-\<bar>x\<bar> < \<bar>x\<bar>` neg_less_iff_less)
391.541 ultimately
391.542 show ?thesis using suminf_arctan_zero by auto
391.543 qed
391.544 @@ -3922,9 +3867,10 @@
391.545 }
391.546 hence "\<forall> x \<in> { 0 <..< 1 }. 0 \<le> ?a x n - ?diff x n" by auto
391.547 moreover have "\<And>x. isCont (\<lambda> x. ?a x n - ?diff x n) x"
391.548 - unfolding diff_minus divide_inverse
391.549 + unfolding diff_conv_add_uminus divide_inverse
391.550 by (auto intro!: isCont_add isCont_rabs isCont_ident isCont_minus isCont_arctan
391.551 - isCont_inverse isCont_mult isCont_power isCont_const isCont_setsum)
391.552 + isCont_inverse isCont_mult isCont_power isCont_const isCont_setsum
391.553 + simp del: add_uminus_conv_diff)
391.554 ultimately have "0 \<le> ?a 1 n - ?diff 1 n"
391.555 by (rule LIM_less_bound)
391.556 hence "?diff 1 n \<le> ?a 1 n" by auto
391.557 @@ -4046,7 +3992,7 @@
391.558 show "sgn x * pi / 2 - arctan x < pi / 2"
391.559 using arctan_bounded [of "- x"] assms
391.560 unfolding sgn_real_def arctan_minus
391.561 - by auto
391.562 + by (auto simp add: algebra_simps)
391.563 show "tan (sgn x * pi / 2 - arctan x) = 1 / x"
391.564 unfolding tan_inverse [of "arctan x", unfolded tan_arctan]
391.565 unfolding sgn_real_def
391.566 @@ -4078,28 +4024,28 @@
391.567
391.568 lemmas sin_arccos_lemma1 = sin_arccos_abs [OF cos_x_y_le_one]
391.569
391.570 -lemma polar_ex1: "0 < y \<Longrightarrow> \<exists>r a. x = r * cos a & y = r * sin a"
391.571 - apply (rule_tac x = "sqrt (x\<^sup>2 + y\<^sup>2)" in exI)
391.572 - apply (rule_tac x = "arccos (x / sqrt (x\<^sup>2 + y\<^sup>2))" in exI)
391.573 - apply (simp add: cos_arccos_lemma1)
391.574 - apply (simp add: sin_arccos_lemma1)
391.575 - apply (simp add: power_divide)
391.576 - apply (simp add: real_sqrt_mult [symmetric])
391.577 - apply (simp add: right_diff_distrib)
391.578 - done
391.579 -
391.580 -lemma polar_ex2: "y < 0 ==> \<exists>r a. x = r * cos a & y = r * sin a"
391.581 - using polar_ex1 [where x=x and y="-y"]
391.582 - apply simp
391.583 - apply clarify
391.584 - apply (metis cos_minus minus_minus minus_mult_right sin_minus)
391.585 - done
391.586 -
391.587 lemma polar_Ex: "\<exists>r a. x = r * cos a & y = r * sin a"
391.588 - apply (rule_tac x=0 and y=y in linorder_cases)
391.589 - apply (erule polar_ex1)
391.590 - apply (rule_tac x=x in exI, rule_tac x=0 in exI, simp)
391.591 - apply (erule polar_ex2)
391.592 - done
391.593 +proof -
391.594 + have polar_ex1: "\<And>y. 0 < y \<Longrightarrow> \<exists>r a. x = r * cos a & y = r * sin a"
391.595 + apply (rule_tac x = "sqrt (x\<^sup>2 + y\<^sup>2)" in exI)
391.596 + apply (rule_tac x = "arccos (x / sqrt (x\<^sup>2 + y\<^sup>2))" in exI)
391.597 + apply (simp add: cos_arccos_lemma1 sin_arccos_lemma1 power_divide
391.598 + real_sqrt_mult [symmetric] right_diff_distrib)
391.599 + done
391.600 + show ?thesis
391.601 + proof (cases "0::real" y rule: linorder_cases)
391.602 + case less
391.603 + then show ?thesis by (rule polar_ex1)
391.604 + next
391.605 + case equal
391.606 + then show ?thesis
391.607 + by (force simp add: intro!: cos_zero sin_zero)
391.608 + next
391.609 + case greater
391.610 + then show ?thesis
391.611 + using polar_ex1 [where y="-y"]
391.612 + by auto (metis cos_minus minus_minus minus_mult_right sin_minus)
391.613 + qed
391.614 +qed
391.615
391.616 end
392.1 --- a/src/HOL/Transitive_Closure.thy Thu Dec 05 17:52:12 2013 +0100
392.2 +++ b/src/HOL/Transitive_Closure.thy Thu Dec 05 17:58:03 2013 +0100
392.3 @@ -1181,6 +1181,17 @@
392.4 lemma acyclicI: "ALL x. (x, x) ~: r^+ ==> acyclic r"
392.5 by (simp add: acyclic_def)
392.6
392.7 +lemma (in order) acyclicI_order:
392.8 + assumes *: "\<And>a b. (a, b) \<in> r \<Longrightarrow> f b < f a"
392.9 + shows "acyclic r"
392.10 +proof -
392.11 + { fix a b assume "(a, b) \<in> r\<^sup>+"
392.12 + then have "f b < f a"
392.13 + by induct (auto intro: * less_trans) }
392.14 + then show ?thesis
392.15 + by (auto intro!: acyclicI)
392.16 +qed
392.17 +
392.18 lemma acyclic_insert [iff]:
392.19 "acyclic(insert (y,x) r) = (acyclic r & (x,y) ~: r^*)"
392.20 apply (simp add: acyclic_def trancl_insert)
393.1 --- a/src/HOL/Wellfounded.thy Thu Dec 05 17:52:12 2013 +0100
393.2 +++ b/src/HOL/Wellfounded.thy Thu Dec 05 17:58:03 2013 +0100
393.3 @@ -482,6 +482,11 @@
393.4
393.5 lemmas accpI = accp.accI
393.6
393.7 +lemma accp_eq_acc [code]:
393.8 + "accp r = (\<lambda>x. x \<in> Wellfounded.acc {(x, y). r x y})"
393.9 + by (simp add: acc_def)
393.10 +
393.11 +
393.12 text {* Induction rules *}
393.13
393.14 theorem accp_induct:
393.15 @@ -855,4 +860,7 @@
393.16
393.17 declare "prod.size" [no_atp]
393.18
393.19 +
393.20 +hide_const (open) acc accp
393.21 +
393.22 end
394.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
394.2 +++ b/src/HOL/Word/Bit_Bit.thy Thu Dec 05 17:58:03 2013 +0100
394.3 @@ -0,0 +1,73 @@
394.4 +(* Title: HOL/Word/Bit_Bit.thy
394.5 + Author: Author: Brian Huffman, PSU and Gerwin Klein, NICTA
394.6 +*)
394.7 +
394.8 +header {* Bit operations in $\cal Z_2$ *}
394.9 +
394.10 +theory Bit_Bit
394.11 +imports Bit_Operations "~~/src/HOL/Library/Bit"
394.12 +begin
394.13 +
394.14 +instantiation bit :: bit
394.15 +begin
394.16 +
394.17 +primrec bitNOT_bit where
394.18 + "NOT 0 = (1::bit)"
394.19 + | "NOT 1 = (0::bit)"
394.20 +
394.21 +primrec bitAND_bit where
394.22 + "0 AND y = (0::bit)"
394.23 + | "1 AND y = (y::bit)"
394.24 +
394.25 +primrec bitOR_bit where
394.26 + "0 OR y = (y::bit)"
394.27 + | "1 OR y = (1::bit)"
394.28 +
394.29 +primrec bitXOR_bit where
394.30 + "0 XOR y = (y::bit)"
394.31 + | "1 XOR y = (NOT y :: bit)"
394.32 +
394.33 +instance ..
394.34 +
394.35 +end
394.36 +
394.37 +lemmas bit_simps =
394.38 + bitNOT_bit.simps bitAND_bit.simps bitOR_bit.simps bitXOR_bit.simps
394.39 +
394.40 +lemma bit_extra_simps [simp]:
394.41 + "x AND 0 = (0::bit)"
394.42 + "x AND 1 = (x::bit)"
394.43 + "x OR 1 = (1::bit)"
394.44 + "x OR 0 = (x::bit)"
394.45 + "x XOR 1 = NOT (x::bit)"
394.46 + "x XOR 0 = (x::bit)"
394.47 + by (cases x, auto)+
394.48 +
394.49 +lemma bit_ops_comm:
394.50 + "(x::bit) AND y = y AND x"
394.51 + "(x::bit) OR y = y OR x"
394.52 + "(x::bit) XOR y = y XOR x"
394.53 + by (cases y, auto)+
394.54 +
394.55 +lemma bit_ops_same [simp]:
394.56 + "(x::bit) AND x = x"
394.57 + "(x::bit) OR x = x"
394.58 + "(x::bit) XOR x = 0"
394.59 + by (cases x, auto)+
394.60 +
394.61 +lemma bit_not_not [simp]: "NOT (NOT (x::bit)) = x"
394.62 + by (cases x) auto
394.63 +
394.64 +lemma bit_or_def: "(b::bit) OR c = NOT (NOT b AND NOT c)"
394.65 + by (induct b, simp_all)
394.66 +
394.67 +lemma bit_xor_def: "(b::bit) XOR c = (b AND NOT c) OR (NOT b AND c)"
394.68 + by (induct b, simp_all)
394.69 +
394.70 +lemma bit_NOT_eq_1_iff [simp]: "NOT (b::bit) = 1 \<longleftrightarrow> b = 0"
394.71 + by (induct b, simp_all)
394.72 +
394.73 +lemma bit_AND_eq_1_iff [simp]: "(a::bit) AND b = 1 \<longleftrightarrow> a = 1 \<and> b = 1"
394.74 + by (induct a, simp_all)
394.75 +
394.76 +end
395.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
395.2 +++ b/src/HOL/Word/Bit_Comparison.thy Thu Dec 05 17:58:03 2013 +0100
395.3 @@ -0,0 +1,193 @@
395.4 +(* Title: HOL/SPARK/SPARK.thy
395.5 + Author: Stefan Berghofer
395.6 + Copyright: secunet Security Networks AG
395.7 +
395.8 +Comparison on bit operations on integers.
395.9 +*)
395.10 +
395.11 +theory Bit_Comparison
395.12 +imports Type_Length Bit_Operations Bit_Int
395.13 +begin
395.14 +
395.15 +lemma AND_lower [simp]:
395.16 + fixes x :: int and y :: int
395.17 + assumes "0 \<le> x"
395.18 + shows "0 \<le> x AND y"
395.19 + using assms
395.20 +proof (induct x arbitrary: y rule: bin_induct)
395.21 + case (3 bin bit)
395.22 + show ?case
395.23 + proof (cases y rule: bin_exhaust)
395.24 + case (1 bin' bit')
395.25 + from 3 have "0 \<le> bin"
395.26 + by (simp add: Bit_def bitval_def split add: bit.split_asm)
395.27 + then have "0 \<le> bin AND bin'" by (rule 3)
395.28 + with 1 show ?thesis
395.29 + by simp (simp add: Bit_def bitval_def split add: bit.split)
395.30 + qed
395.31 +next
395.32 + case 2
395.33 + then show ?case by (simp only: Min_def)
395.34 +qed simp
395.35 +
395.36 +lemma OR_lower [simp]:
395.37 + fixes x :: int and y :: int
395.38 + assumes "0 \<le> x" "0 \<le> y"
395.39 + shows "0 \<le> x OR y"
395.40 + using assms
395.41 +proof (induct x arbitrary: y rule: bin_induct)
395.42 + case (3 bin bit)
395.43 + show ?case
395.44 + proof (cases y rule: bin_exhaust)
395.45 + case (1 bin' bit')
395.46 + from 3 have "0 \<le> bin"
395.47 + by (simp add: Bit_def bitval_def split add: bit.split_asm)
395.48 + moreover from 1 3 have "0 \<le> bin'"
395.49 + by (simp add: Bit_def bitval_def split add: bit.split_asm)
395.50 + ultimately have "0 \<le> bin OR bin'" by (rule 3)
395.51 + with 1 show ?thesis
395.52 + by simp (simp add: Bit_def bitval_def split add: bit.split)
395.53 + qed
395.54 +qed simp_all
395.55 +
395.56 +lemma XOR_lower [simp]:
395.57 + fixes x :: int and y :: int
395.58 + assumes "0 \<le> x" "0 \<le> y"
395.59 + shows "0 \<le> x XOR y"
395.60 + using assms
395.61 +proof (induct x arbitrary: y rule: bin_induct)
395.62 + case (3 bin bit)
395.63 + show ?case
395.64 + proof (cases y rule: bin_exhaust)
395.65 + case (1 bin' bit')
395.66 + from 3 have "0 \<le> bin"
395.67 + by (simp add: Bit_def bitval_def split add: bit.split_asm)
395.68 + moreover from 1 3 have "0 \<le> bin'"
395.69 + by (simp add: Bit_def bitval_def split add: bit.split_asm)
395.70 + ultimately have "0 \<le> bin XOR bin'" by (rule 3)
395.71 + with 1 show ?thesis
395.72 + by simp (simp add: Bit_def bitval_def split add: bit.split)
395.73 + qed
395.74 +next
395.75 + case 2
395.76 + then show ?case by (simp only: Min_def)
395.77 +qed simp
395.78 +
395.79 +lemma AND_upper1 [simp]:
395.80 + fixes x :: int and y :: int
395.81 + assumes "0 \<le> x"
395.82 + shows "x AND y \<le> x"
395.83 + using assms
395.84 +proof (induct x arbitrary: y rule: bin_induct)
395.85 + case (3 bin bit)
395.86 + show ?case
395.87 + proof (cases y rule: bin_exhaust)
395.88 + case (1 bin' bit')
395.89 + from 3 have "0 \<le> bin"
395.90 + by (simp add: Bit_def bitval_def split add: bit.split_asm)
395.91 + then have "bin AND bin' \<le> bin" by (rule 3)
395.92 + with 1 show ?thesis
395.93 + by simp (simp add: Bit_def bitval_def split add: bit.split)
395.94 + qed
395.95 +next
395.96 + case 2
395.97 + then show ?case by (simp only: Min_def)
395.98 +qed simp
395.99 +
395.100 +lemmas AND_upper1' [simp] = order_trans [OF AND_upper1]
395.101 +lemmas AND_upper1'' [simp] = order_le_less_trans [OF AND_upper1]
395.102 +
395.103 +lemma AND_upper2 [simp]:
395.104 + fixes x :: int and y :: int
395.105 + assumes "0 \<le> y"
395.106 + shows "x AND y \<le> y"
395.107 + using assms
395.108 +proof (induct y arbitrary: x rule: bin_induct)
395.109 + case (3 bin bit)
395.110 + show ?case
395.111 + proof (cases x rule: bin_exhaust)
395.112 + case (1 bin' bit')
395.113 + from 3 have "0 \<le> bin"
395.114 + by (simp add: Bit_def bitval_def split add: bit.split_asm)
395.115 + then have "bin' AND bin \<le> bin" by (rule 3)
395.116 + with 1 show ?thesis
395.117 + by simp (simp add: Bit_def bitval_def split add: bit.split)
395.118 + qed
395.119 +next
395.120 + case 2
395.121 + then show ?case by (simp only: Min_def)
395.122 +qed simp
395.123 +
395.124 +lemmas AND_upper2' [simp] = order_trans [OF AND_upper2]
395.125 +lemmas AND_upper2'' [simp] = order_le_less_trans [OF AND_upper2]
395.126 +
395.127 +lemma OR_upper:
395.128 + fixes x :: int and y :: int
395.129 + assumes "0 \<le> x" "x < 2 ^ n" "y < 2 ^ n"
395.130 + shows "x OR y < 2 ^ n"
395.131 + using assms
395.132 +proof (induct x arbitrary: y n rule: bin_induct)
395.133 + case (3 bin bit)
395.134 + show ?case
395.135 + proof (cases y rule: bin_exhaust)
395.136 + case (1 bin' bit')
395.137 + show ?thesis
395.138 + proof (cases n)
395.139 + case 0
395.140 + with 3 have "bin BIT bit = 0" by simp
395.141 + then have "bin = 0" "bit = 0"
395.142 + by (auto simp add: Bit_def bitval_def split add: bit.split_asm) arith
395.143 + then show ?thesis using 0 1 `y < 2 ^ n`
395.144 + by simp
395.145 + next
395.146 + case (Suc m)
395.147 + from 3 have "0 \<le> bin"
395.148 + by (simp add: Bit_def bitval_def split add: bit.split_asm)
395.149 + moreover from 3 Suc have "bin < 2 ^ m"
395.150 + by (simp add: Bit_def bitval_def split add: bit.split_asm)
395.151 + moreover from 1 3 Suc have "bin' < 2 ^ m"
395.152 + by (simp add: Bit_def bitval_def split add: bit.split_asm)
395.153 + ultimately have "bin OR bin' < 2 ^ m" by (rule 3)
395.154 + with 1 Suc show ?thesis
395.155 + by simp (simp add: Bit_def bitval_def split add: bit.split)
395.156 + qed
395.157 + qed
395.158 +qed simp_all
395.159 +
395.160 +lemma XOR_upper:
395.161 + fixes x :: int and y :: int
395.162 + assumes "0 \<le> x" "x < 2 ^ n" "y < 2 ^ n"
395.163 + shows "x XOR y < 2 ^ n"
395.164 + using assms
395.165 +proof (induct x arbitrary: y n rule: bin_induct)
395.166 + case (3 bin bit)
395.167 + show ?case
395.168 + proof (cases y rule: bin_exhaust)
395.169 + case (1 bin' bit')
395.170 + show ?thesis
395.171 + proof (cases n)
395.172 + case 0
395.173 + with 3 have "bin BIT bit = 0" by simp
395.174 + then have "bin = 0" "bit = 0"
395.175 + by (auto simp add: Bit_def bitval_def split add: bit.split_asm) arith
395.176 + then show ?thesis using 0 1 `y < 2 ^ n`
395.177 + by simp
395.178 + next
395.179 + case (Suc m)
395.180 + from 3 have "0 \<le> bin"
395.181 + by (simp add: Bit_def bitval_def split add: bit.split_asm)
395.182 + moreover from 3 Suc have "bin < 2 ^ m"
395.183 + by (simp add: Bit_def bitval_def split add: bit.split_asm)
395.184 + moreover from 1 3 Suc have "bin' < 2 ^ m"
395.185 + by (simp add: Bit_def bitval_def split add: bit.split_asm)
395.186 + ultimately have "bin XOR bin' < 2 ^ m" by (rule 3)
395.187 + with 1 Suc show ?thesis
395.188 + by simp (simp add: Bit_def bitval_def split add: bit.split)
395.189 + qed
395.190 + qed
395.191 +next
395.192 + case 2
395.193 + then show ?case by (simp only: Min_def)
395.194 +qed simp
395.195 +
395.196 +end
396.1 --- a/src/HOL/Word/Bit_Int.thy Thu Dec 05 17:52:12 2013 +0100
396.2 +++ b/src/HOL/Word/Bit_Int.thy Thu Dec 05 17:58:03 2013 +0100
396.3 @@ -9,7 +9,7 @@
396.4 header {* Bitwise Operations on Binary Integers *}
396.5
396.6 theory Bit_Int
396.7 -imports Bit_Representation Bit_Operations
396.8 +imports Bit_Representation Bit_Bit
396.9 begin
396.10
396.11 subsection {* Logical operations *}
396.12 @@ -52,10 +52,10 @@
396.13 lemma int_not_simps [simp]:
396.14 "NOT (0::int) = -1"
396.15 "NOT (1::int) = -2"
396.16 - "NOT (-1::int) = 0"
396.17 - "NOT (numeral w::int) = neg_numeral (w + Num.One)"
396.18 - "NOT (neg_numeral (Num.Bit0 w)::int) = numeral (Num.BitM w)"
396.19 - "NOT (neg_numeral (Num.Bit1 w)::int) = numeral (Num.Bit0 w)"
396.20 + "NOT (- 1::int) = 0"
396.21 + "NOT (numeral w::int) = - numeral (w + Num.One)"
396.22 + "NOT (- numeral (Num.Bit0 w)::int) = numeral (Num.BitM w)"
396.23 + "NOT (- numeral (Num.Bit1 w)::int) = numeral (Num.Bit0 w)"
396.24 unfolding int_not_def by simp_all
396.25
396.26 lemma int_not_not [simp]: "NOT (NOT (x::int)) = x"
396.27 @@ -228,11 +228,11 @@
396.28 by (metis bin_rl_simp)
396.29
396.30 lemma bin_rest_neg_numeral_BitM [simp]:
396.31 - "bin_rest (neg_numeral (Num.BitM w)) = neg_numeral w"
396.32 + "bin_rest (- numeral (Num.BitM w)) = - numeral w"
396.33 by (simp only: BIT_bin_simps [symmetric] bin_rest_BIT)
396.34
396.35 lemma bin_last_neg_numeral_BitM [simp]:
396.36 - "bin_last (neg_numeral (Num.BitM w)) = 1"
396.37 + "bin_last (- numeral (Num.BitM w)) = 1"
396.38 by (simp only: BIT_bin_simps [symmetric] bin_last_BIT)
396.39
396.40 text {* FIXME: The rule sets below are very large (24 rules for each
396.41 @@ -243,26 +243,26 @@
396.42 "numeral (Num.Bit0 x) AND numeral (Num.Bit1 y) = (numeral x AND numeral y) BIT 0"
396.43 "numeral (Num.Bit1 x) AND numeral (Num.Bit0 y) = (numeral x AND numeral y) BIT 0"
396.44 "numeral (Num.Bit1 x) AND numeral (Num.Bit1 y) = (numeral x AND numeral y) BIT 1"
396.45 - "numeral (Num.Bit0 x) AND neg_numeral (Num.Bit0 y) = (numeral x AND neg_numeral y) BIT 0"
396.46 - "numeral (Num.Bit0 x) AND neg_numeral (Num.Bit1 y) = (numeral x AND neg_numeral (y + Num.One)) BIT 0"
396.47 - "numeral (Num.Bit1 x) AND neg_numeral (Num.Bit0 y) = (numeral x AND neg_numeral y) BIT 0"
396.48 - "numeral (Num.Bit1 x) AND neg_numeral (Num.Bit1 y) = (numeral x AND neg_numeral (y + Num.One)) BIT 1"
396.49 - "neg_numeral (Num.Bit0 x) AND numeral (Num.Bit0 y) = (neg_numeral x AND numeral y) BIT 0"
396.50 - "neg_numeral (Num.Bit0 x) AND numeral (Num.Bit1 y) = (neg_numeral x AND numeral y) BIT 0"
396.51 - "neg_numeral (Num.Bit1 x) AND numeral (Num.Bit0 y) = (neg_numeral (x + Num.One) AND numeral y) BIT 0"
396.52 - "neg_numeral (Num.Bit1 x) AND numeral (Num.Bit1 y) = (neg_numeral (x + Num.One) AND numeral y) BIT 1"
396.53 - "neg_numeral (Num.Bit0 x) AND neg_numeral (Num.Bit0 y) = (neg_numeral x AND neg_numeral y) BIT 0"
396.54 - "neg_numeral (Num.Bit0 x) AND neg_numeral (Num.Bit1 y) = (neg_numeral x AND neg_numeral (y + Num.One)) BIT 0"
396.55 - "neg_numeral (Num.Bit1 x) AND neg_numeral (Num.Bit0 y) = (neg_numeral (x + Num.One) AND neg_numeral y) BIT 0"
396.56 - "neg_numeral (Num.Bit1 x) AND neg_numeral (Num.Bit1 y) = (neg_numeral (x + Num.One) AND neg_numeral (y + Num.One)) BIT 1"
396.57 + "numeral (Num.Bit0 x) AND - numeral (Num.Bit0 y) = (numeral x AND - numeral y) BIT 0"
396.58 + "numeral (Num.Bit0 x) AND - numeral (Num.Bit1 y) = (numeral x AND - numeral (y + Num.One)) BIT 0"
396.59 + "numeral (Num.Bit1 x) AND - numeral (Num.Bit0 y) = (numeral x AND - numeral y) BIT 0"
396.60 + "numeral (Num.Bit1 x) AND - numeral (Num.Bit1 y) = (numeral x AND - numeral (y + Num.One)) BIT 1"
396.61 + "- numeral (Num.Bit0 x) AND numeral (Num.Bit0 y) = (- numeral x AND numeral y) BIT 0"
396.62 + "- numeral (Num.Bit0 x) AND numeral (Num.Bit1 y) = (- numeral x AND numeral y) BIT 0"
396.63 + "- numeral (Num.Bit1 x) AND numeral (Num.Bit0 y) = (- numeral (x + Num.One) AND numeral y) BIT 0"
396.64 + "- numeral (Num.Bit1 x) AND numeral (Num.Bit1 y) = (- numeral (x + Num.One) AND numeral y) BIT 1"
396.65 + "- numeral (Num.Bit0 x) AND - numeral (Num.Bit0 y) = (- numeral x AND - numeral y) BIT 0"
396.66 + "- numeral (Num.Bit0 x) AND - numeral (Num.Bit1 y) = (- numeral x AND - numeral (y + Num.One)) BIT 0"
396.67 + "- numeral (Num.Bit1 x) AND - numeral (Num.Bit0 y) = (- numeral (x + Num.One) AND - numeral y) BIT 0"
396.68 + "- numeral (Num.Bit1 x) AND - numeral (Num.Bit1 y) = (- numeral (x + Num.One) AND - numeral (y + Num.One)) BIT 1"
396.69 "(1::int) AND numeral (Num.Bit0 y) = 0"
396.70 "(1::int) AND numeral (Num.Bit1 y) = 1"
396.71 - "(1::int) AND neg_numeral (Num.Bit0 y) = 0"
396.72 - "(1::int) AND neg_numeral (Num.Bit1 y) = 1"
396.73 + "(1::int) AND - numeral (Num.Bit0 y) = 0"
396.74 + "(1::int) AND - numeral (Num.Bit1 y) = 1"
396.75 "numeral (Num.Bit0 x) AND (1::int) = 0"
396.76 "numeral (Num.Bit1 x) AND (1::int) = 1"
396.77 - "neg_numeral (Num.Bit0 x) AND (1::int) = 0"
396.78 - "neg_numeral (Num.Bit1 x) AND (1::int) = 1"
396.79 + "- numeral (Num.Bit0 x) AND (1::int) = 0"
396.80 + "- numeral (Num.Bit1 x) AND (1::int) = 1"
396.81 by (rule bin_rl_eqI, simp, simp)+
396.82
396.83 lemma int_or_numerals [simp]:
396.84 @@ -270,26 +270,26 @@
396.85 "numeral (Num.Bit0 x) OR numeral (Num.Bit1 y) = (numeral x OR numeral y) BIT 1"
396.86 "numeral (Num.Bit1 x) OR numeral (Num.Bit0 y) = (numeral x OR numeral y) BIT 1"
396.87 "numeral (Num.Bit1 x) OR numeral (Num.Bit1 y) = (numeral x OR numeral y) BIT 1"
396.88 - "numeral (Num.Bit0 x) OR neg_numeral (Num.Bit0 y) = (numeral x OR neg_numeral y) BIT 0"
396.89 - "numeral (Num.Bit0 x) OR neg_numeral (Num.Bit1 y) = (numeral x OR neg_numeral (y + Num.One)) BIT 1"
396.90 - "numeral (Num.Bit1 x) OR neg_numeral (Num.Bit0 y) = (numeral x OR neg_numeral y) BIT 1"
396.91 - "numeral (Num.Bit1 x) OR neg_numeral (Num.Bit1 y) = (numeral x OR neg_numeral (y + Num.One)) BIT 1"
396.92 - "neg_numeral (Num.Bit0 x) OR numeral (Num.Bit0 y) = (neg_numeral x OR numeral y) BIT 0"
396.93 - "neg_numeral (Num.Bit0 x) OR numeral (Num.Bit1 y) = (neg_numeral x OR numeral y) BIT 1"
396.94 - "neg_numeral (Num.Bit1 x) OR numeral (Num.Bit0 y) = (neg_numeral (x + Num.One) OR numeral y) BIT 1"
396.95 - "neg_numeral (Num.Bit1 x) OR numeral (Num.Bit1 y) = (neg_numeral (x + Num.One) OR numeral y) BIT 1"
396.96 - "neg_numeral (Num.Bit0 x) OR neg_numeral (Num.Bit0 y) = (neg_numeral x OR neg_numeral y) BIT 0"
396.97 - "neg_numeral (Num.Bit0 x) OR neg_numeral (Num.Bit1 y) = (neg_numeral x OR neg_numeral (y + Num.One)) BIT 1"
396.98 - "neg_numeral (Num.Bit1 x) OR neg_numeral (Num.Bit0 y) = (neg_numeral (x + Num.One) OR neg_numeral y) BIT 1"
396.99 - "neg_numeral (Num.Bit1 x) OR neg_numeral (Num.Bit1 y) = (neg_numeral (x + Num.One) OR neg_numeral (y + Num.One)) BIT 1"
396.100 + "numeral (Num.Bit0 x) OR - numeral (Num.Bit0 y) = (numeral x OR - numeral y) BIT 0"
396.101 + "numeral (Num.Bit0 x) OR - numeral (Num.Bit1 y) = (numeral x OR - numeral (y + Num.One)) BIT 1"
396.102 + "numeral (Num.Bit1 x) OR - numeral (Num.Bit0 y) = (numeral x OR - numeral y) BIT 1"
396.103 + "numeral (Num.Bit1 x) OR - numeral (Num.Bit1 y) = (numeral x OR - numeral (y + Num.One)) BIT 1"
396.104 + "- numeral (Num.Bit0 x) OR numeral (Num.Bit0 y) = (- numeral x OR numeral y) BIT 0"
396.105 + "- numeral (Num.Bit0 x) OR numeral (Num.Bit1 y) = (- numeral x OR numeral y) BIT 1"
396.106 + "- numeral (Num.Bit1 x) OR numeral (Num.Bit0 y) = (- numeral (x + Num.One) OR numeral y) BIT 1"
396.107 + "- numeral (Num.Bit1 x) OR numeral (Num.Bit1 y) = (- numeral (x + Num.One) OR numeral y) BIT 1"
396.108 + "- numeral (Num.Bit0 x) OR - numeral (Num.Bit0 y) = (- numeral x OR - numeral y) BIT 0"
396.109 + "- numeral (Num.Bit0 x) OR - numeral (Num.Bit1 y) = (- numeral x OR - numeral (y + Num.One)) BIT 1"
396.110 + "- numeral (Num.Bit1 x) OR - numeral (Num.Bit0 y) = (- numeral (x + Num.One) OR - numeral y) BIT 1"
396.111 + "- numeral (Num.Bit1 x) OR - numeral (Num.Bit1 y) = (- numeral (x + Num.One) OR - numeral (y + Num.One)) BIT 1"
396.112 "(1::int) OR numeral (Num.Bit0 y) = numeral (Num.Bit1 y)"
396.113 "(1::int) OR numeral (Num.Bit1 y) = numeral (Num.Bit1 y)"
396.114 - "(1::int) OR neg_numeral (Num.Bit0 y) = neg_numeral (Num.BitM y)"
396.115 - "(1::int) OR neg_numeral (Num.Bit1 y) = neg_numeral (Num.Bit1 y)"
396.116 + "(1::int) OR - numeral (Num.Bit0 y) = - numeral (Num.BitM y)"
396.117 + "(1::int) OR - numeral (Num.Bit1 y) = - numeral (Num.Bit1 y)"
396.118 "numeral (Num.Bit0 x) OR (1::int) = numeral (Num.Bit1 x)"
396.119 "numeral (Num.Bit1 x) OR (1::int) = numeral (Num.Bit1 x)"
396.120 - "neg_numeral (Num.Bit0 x) OR (1::int) = neg_numeral (Num.BitM x)"
396.121 - "neg_numeral (Num.Bit1 x) OR (1::int) = neg_numeral (Num.Bit1 x)"
396.122 + "- numeral (Num.Bit0 x) OR (1::int) = - numeral (Num.BitM x)"
396.123 + "- numeral (Num.Bit1 x) OR (1::int) = - numeral (Num.Bit1 x)"
396.124 by (rule bin_rl_eqI, simp, simp)+
396.125
396.126 lemma int_xor_numerals [simp]:
396.127 @@ -297,26 +297,26 @@
396.128 "numeral (Num.Bit0 x) XOR numeral (Num.Bit1 y) = (numeral x XOR numeral y) BIT 1"
396.129 "numeral (Num.Bit1 x) XOR numeral (Num.Bit0 y) = (numeral x XOR numeral y) BIT 1"
396.130 "numeral (Num.Bit1 x) XOR numeral (Num.Bit1 y) = (numeral x XOR numeral y) BIT 0"
396.131 - "numeral (Num.Bit0 x) XOR neg_numeral (Num.Bit0 y) = (numeral x XOR neg_numeral y) BIT 0"
396.132 - "numeral (Num.Bit0 x) XOR neg_numeral (Num.Bit1 y) = (numeral x XOR neg_numeral (y + Num.One)) BIT 1"
396.133 - "numeral (Num.Bit1 x) XOR neg_numeral (Num.Bit0 y) = (numeral x XOR neg_numeral y) BIT 1"
396.134 - "numeral (Num.Bit1 x) XOR neg_numeral (Num.Bit1 y) = (numeral x XOR neg_numeral (y + Num.One)) BIT 0"
396.135 - "neg_numeral (Num.Bit0 x) XOR numeral (Num.Bit0 y) = (neg_numeral x XOR numeral y) BIT 0"
396.136 - "neg_numeral (Num.Bit0 x) XOR numeral (Num.Bit1 y) = (neg_numeral x XOR numeral y) BIT 1"
396.137 - "neg_numeral (Num.Bit1 x) XOR numeral (Num.Bit0 y) = (neg_numeral (x + Num.One) XOR numeral y) BIT 1"
396.138 - "neg_numeral (Num.Bit1 x) XOR numeral (Num.Bit1 y) = (neg_numeral (x + Num.One) XOR numeral y) BIT 0"
396.139 - "neg_numeral (Num.Bit0 x) XOR neg_numeral (Num.Bit0 y) = (neg_numeral x XOR neg_numeral y) BIT 0"
396.140 - "neg_numeral (Num.Bit0 x) XOR neg_numeral (Num.Bit1 y) = (neg_numeral x XOR neg_numeral (y + Num.One)) BIT 1"
396.141 - "neg_numeral (Num.Bit1 x) XOR neg_numeral (Num.Bit0 y) = (neg_numeral (x + Num.One) XOR neg_numeral y) BIT 1"
396.142 - "neg_numeral (Num.Bit1 x) XOR neg_numeral (Num.Bit1 y) = (neg_numeral (x + Num.One) XOR neg_numeral (y + Num.One)) BIT 0"
396.143 + "numeral (Num.Bit0 x) XOR - numeral (Num.Bit0 y) = (numeral x XOR - numeral y) BIT 0"
396.144 + "numeral (Num.Bit0 x) XOR - numeral (Num.Bit1 y) = (numeral x XOR - numeral (y + Num.One)) BIT 1"
396.145 + "numeral (Num.Bit1 x) XOR - numeral (Num.Bit0 y) = (numeral x XOR - numeral y) BIT 1"
396.146 + "numeral (Num.Bit1 x) XOR - numeral (Num.Bit1 y) = (numeral x XOR - numeral (y + Num.One)) BIT 0"
396.147 + "- numeral (Num.Bit0 x) XOR numeral (Num.Bit0 y) = (- numeral x XOR numeral y) BIT 0"
396.148 + "- numeral (Num.Bit0 x) XOR numeral (Num.Bit1 y) = (- numeral x XOR numeral y) BIT 1"
396.149 + "- numeral (Num.Bit1 x) XOR numeral (Num.Bit0 y) = (- numeral (x + Num.One) XOR numeral y) BIT 1"
396.150 + "- numeral (Num.Bit1 x) XOR numeral (Num.Bit1 y) = (- numeral (x + Num.One) XOR numeral y) BIT 0"
396.151 + "- numeral (Num.Bit0 x) XOR - numeral (Num.Bit0 y) = (- numeral x XOR - numeral y) BIT 0"
396.152 + "- numeral (Num.Bit0 x) XOR - numeral (Num.Bit1 y) = (- numeral x XOR - numeral (y + Num.One)) BIT 1"
396.153 + "- numeral (Num.Bit1 x) XOR - numeral (Num.Bit0 y) = (- numeral (x + Num.One) XOR - numeral y) BIT 1"
396.154 + "- numeral (Num.Bit1 x) XOR - numeral (Num.Bit1 y) = (- numeral (x + Num.One) XOR - numeral (y + Num.One)) BIT 0"
396.155 "(1::int) XOR numeral (Num.Bit0 y) = numeral (Num.Bit1 y)"
396.156 "(1::int) XOR numeral (Num.Bit1 y) = numeral (Num.Bit0 y)"
396.157 - "(1::int) XOR neg_numeral (Num.Bit0 y) = neg_numeral (Num.BitM y)"
396.158 - "(1::int) XOR neg_numeral (Num.Bit1 y) = neg_numeral (Num.Bit0 (y + Num.One))"
396.159 + "(1::int) XOR - numeral (Num.Bit0 y) = - numeral (Num.BitM y)"
396.160 + "(1::int) XOR - numeral (Num.Bit1 y) = - numeral (Num.Bit0 (y + Num.One))"
396.161 "numeral (Num.Bit0 x) XOR (1::int) = numeral (Num.Bit1 x)"
396.162 "numeral (Num.Bit1 x) XOR (1::int) = numeral (Num.Bit0 x)"
396.163 - "neg_numeral (Num.Bit0 x) XOR (1::int) = neg_numeral (Num.BitM x)"
396.164 - "neg_numeral (Num.Bit1 x) XOR (1::int) = neg_numeral (Num.Bit0 (x + Num.One))"
396.165 + "- numeral (Num.Bit0 x) XOR (1::int) = - numeral (Num.BitM x)"
396.166 + "- numeral (Num.Bit1 x) XOR (1::int) = - numeral (Num.Bit0 (x + Num.One))"
396.167 by (rule bin_rl_eqI, simp, simp)+
396.168
396.169 subsubsection {* Interactions with arithmetic *}
396.170 @@ -632,5 +632,46 @@
396.171 "(EX m. n = Suc m & (m = k | P m)) = (n = Suc k | (EX m. n = Suc m & P m))"
396.172 by auto
396.173
396.174 +lemma power_BIT: "2 ^ (Suc n) - 1 = (2 ^ n - 1) BIT 1"
396.175 + unfolding Bit_B1
396.176 + by (induct n) simp_all
396.177 +
396.178 +lemma mod_BIT:
396.179 + "bin BIT bit mod 2 ^ Suc n = (bin mod 2 ^ n) BIT bit"
396.180 +proof -
396.181 + have "bin mod 2 ^ n < 2 ^ n" by simp
396.182 + then have "bin mod 2 ^ n \<le> 2 ^ n - 1" by simp
396.183 + then have "2 * (bin mod 2 ^ n) \<le> 2 * (2 ^ n - 1)"
396.184 + by (rule mult_left_mono) simp
396.185 + then have "2 * (bin mod 2 ^ n) + 1 < 2 * 2 ^ n" by simp
396.186 + then show ?thesis
396.187 + by (auto simp add: Bit_def bitval_def mod_mult_mult1 mod_add_left_eq [of "2 * bin"]
396.188 + mod_pos_pos_trivial split add: bit.split)
396.189 +qed
396.190 +
396.191 +lemma AND_mod:
396.192 + fixes x :: int
396.193 + shows "x AND 2 ^ n - 1 = x mod 2 ^ n"
396.194 +proof (induct x arbitrary: n rule: bin_induct)
396.195 + case 1
396.196 + then show ?case
396.197 + by simp
396.198 +next
396.199 + case 2
396.200 + then show ?case
396.201 + by (simp, simp add: m1mod2k)
396.202 +next
396.203 + case (3 bin bit)
396.204 + show ?case
396.205 + proof (cases n)
396.206 + case 0
396.207 + then show ?thesis by (simp add: int_and_extra_simps)
396.208 + next
396.209 + case (Suc m)
396.210 + with 3 show ?thesis
396.211 + by (simp only: power_BIT mod_BIT int_and_Bits) simp
396.212 + qed
396.213 +qed
396.214 +
396.215 end
396.216
397.1 --- a/src/HOL/Word/Bit_Operations.thy Thu Dec 05 17:52:12 2013 +0100
397.2 +++ b/src/HOL/Word/Bit_Operations.thy Thu Dec 05 17:58:03 2013 +0100
397.3 @@ -8,8 +8,6 @@
397.4 imports "~~/src/HOL/Library/Bit"
397.5 begin
397.6
397.7 -subsection {* Abstract syntactic bit operations *}
397.8 -
397.9 class bit =
397.10 fixes bitNOT :: "'a \<Rightarrow> 'a" ("NOT _" [70] 71)
397.11 and bitAND :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "AND" 64)
397.12 @@ -37,69 +35,5 @@
397.13 class bitss = bits +
397.14 fixes msb :: "'a \<Rightarrow> bool"
397.15
397.16 -
397.17 -subsection {* Bitwise operations on @{typ bit} *}
397.18 -
397.19 -instantiation bit :: bit
397.20 -begin
397.21 -
397.22 -primrec bitNOT_bit where
397.23 - "NOT 0 = (1::bit)"
397.24 - | "NOT 1 = (0::bit)"
397.25 -
397.26 -primrec bitAND_bit where
397.27 - "0 AND y = (0::bit)"
397.28 - | "1 AND y = (y::bit)"
397.29 -
397.30 -primrec bitOR_bit where
397.31 - "0 OR y = (y::bit)"
397.32 - | "1 OR y = (1::bit)"
397.33 -
397.34 -primrec bitXOR_bit where
397.35 - "0 XOR y = (y::bit)"
397.36 - | "1 XOR y = (NOT y :: bit)"
397.37 -
397.38 -instance ..
397.39 -
397.40 end
397.41
397.42 -lemmas bit_simps =
397.43 - bitNOT_bit.simps bitAND_bit.simps bitOR_bit.simps bitXOR_bit.simps
397.44 -
397.45 -lemma bit_extra_simps [simp]:
397.46 - "x AND 0 = (0::bit)"
397.47 - "x AND 1 = (x::bit)"
397.48 - "x OR 1 = (1::bit)"
397.49 - "x OR 0 = (x::bit)"
397.50 - "x XOR 1 = NOT (x::bit)"
397.51 - "x XOR 0 = (x::bit)"
397.52 - by (cases x, auto)+
397.53 -
397.54 -lemma bit_ops_comm:
397.55 - "(x::bit) AND y = y AND x"
397.56 - "(x::bit) OR y = y OR x"
397.57 - "(x::bit) XOR y = y XOR x"
397.58 - by (cases y, auto)+
397.59 -
397.60 -lemma bit_ops_same [simp]:
397.61 - "(x::bit) AND x = x"
397.62 - "(x::bit) OR x = x"
397.63 - "(x::bit) XOR x = 0"
397.64 - by (cases x, auto)+
397.65 -
397.66 -lemma bit_not_not [simp]: "NOT (NOT (x::bit)) = x"
397.67 - by (cases x) auto
397.68 -
397.69 -lemma bit_or_def: "(b::bit) OR c = NOT (NOT b AND NOT c)"
397.70 - by (induct b, simp_all)
397.71 -
397.72 -lemma bit_xor_def: "(b::bit) XOR c = (b AND NOT c) OR (NOT b AND c)"
397.73 - by (induct b, simp_all)
397.74 -
397.75 -lemma bit_NOT_eq_1_iff [simp]: "NOT (b::bit) = 1 \<longleftrightarrow> b = 0"
397.76 - by (induct b, simp_all)
397.77 -
397.78 -lemma bit_AND_eq_1_iff [simp]: "(a::bit) AND b = 1 \<longleftrightarrow> a = 1 \<and> b = 1"
397.79 - by (induct a, simp_all)
397.80 -
397.81 -end
398.1 --- a/src/HOL/Word/Bit_Representation.thy Thu Dec 05 17:52:12 2013 +0100
398.2 +++ b/src/HOL/Word/Bit_Representation.thy Thu Dec 05 17:58:03 2013 +0100
398.3 @@ -61,21 +61,23 @@
398.4 lemma BIT_bin_simps [simp]:
398.5 "numeral k BIT 0 = numeral (Num.Bit0 k)"
398.6 "numeral k BIT 1 = numeral (Num.Bit1 k)"
398.7 - "neg_numeral k BIT 0 = neg_numeral (Num.Bit0 k)"
398.8 - "neg_numeral k BIT 1 = neg_numeral (Num.BitM k)"
398.9 - unfolding neg_numeral_def numeral.simps numeral_BitM
398.10 + "(- numeral k) BIT 0 = - numeral (Num.Bit0 k)"
398.11 + "(- numeral k) BIT 1 = - numeral (Num.BitM k)"
398.12 + unfolding numeral.simps numeral_BitM
398.13 unfolding Bit_def bitval_simps
398.14 by (simp_all del: arith_simps add_numeral_special diff_numeral_special)
398.15
398.16 lemma BIT_special_simps [simp]:
398.17 - shows "0 BIT 0 = 0" and "0 BIT 1 = 1" and "1 BIT 0 = 2" and "1 BIT 1 = 3"
398.18 + shows "0 BIT 0 = 0" and "0 BIT 1 = 1"
398.19 + and "1 BIT 0 = 2" and "1 BIT 1 = 3"
398.20 + and "(- 1) BIT 0 = - 2" and "(- 1) BIT 1 = - 1"
398.21 unfolding Bit_def by simp_all
398.22
398.23 lemma Bit_eq_0_iff: "w BIT b = 0 \<longleftrightarrow> w = 0 \<and> b = 0"
398.24 by (subst BIT_eq_iff [symmetric], simp)
398.25
398.26 -lemma Bit_eq_m1_iff: "w BIT b = -1 \<longleftrightarrow> w = -1 \<and> b = 1"
398.27 - by (subst BIT_eq_iff [symmetric], simp)
398.28 +lemma Bit_eq_m1_iff: "w BIT b = - 1 \<longleftrightarrow> w = - 1 \<and> b = 1"
398.29 + by (cases b) (auto simp add: Bit_def, arith)
398.30
398.31 lemma BitM_inc: "Num.BitM (Num.inc w) = Num.Bit1 w"
398.32 by (induct w, simp_all)
398.33 @@ -83,8 +85,8 @@
398.34 lemma expand_BIT:
398.35 "numeral (Num.Bit0 w) = numeral w BIT 0"
398.36 "numeral (Num.Bit1 w) = numeral w BIT 1"
398.37 - "neg_numeral (Num.Bit0 w) = neg_numeral w BIT 0"
398.38 - "neg_numeral (Num.Bit1 w) = neg_numeral (w + Num.One) BIT 1"
398.39 + "- numeral (Num.Bit0 w) = - numeral w BIT 0"
398.40 + "- numeral (Num.Bit1 w) = (- numeral (w + Num.One)) BIT 1"
398.41 unfolding add_One by (simp_all add: BitM_inc)
398.42
398.43 lemma bin_last_numeral_simps [simp]:
398.44 @@ -94,9 +96,9 @@
398.45 "bin_last Numeral1 = 1"
398.46 "bin_last (numeral (Num.Bit0 w)) = 0"
398.47 "bin_last (numeral (Num.Bit1 w)) = 1"
398.48 - "bin_last (neg_numeral (Num.Bit0 w)) = 0"
398.49 - "bin_last (neg_numeral (Num.Bit1 w)) = 1"
398.50 - unfolding expand_BIT bin_last_BIT by (simp_all add: bin_last_def)
398.51 + "bin_last (- numeral (Num.Bit0 w)) = 0"
398.52 + "bin_last (- numeral (Num.Bit1 w)) = 1"
398.53 + unfolding expand_BIT bin_last_BIT by (simp_all add: bin_last_def zmod_zminus1_eq_if)
398.54
398.55 lemma bin_rest_numeral_simps [simp]:
398.56 "bin_rest 0 = 0"
398.57 @@ -105,9 +107,9 @@
398.58 "bin_rest Numeral1 = 0"
398.59 "bin_rest (numeral (Num.Bit0 w)) = numeral w"
398.60 "bin_rest (numeral (Num.Bit1 w)) = numeral w"
398.61 - "bin_rest (neg_numeral (Num.Bit0 w)) = neg_numeral w"
398.62 - "bin_rest (neg_numeral (Num.Bit1 w)) = neg_numeral (w + Num.One)"
398.63 - unfolding expand_BIT bin_rest_BIT by (simp_all add: bin_rest_def)
398.64 + "bin_rest (- numeral (Num.Bit0 w)) = - numeral w"
398.65 + "bin_rest (- numeral (Num.Bit1 w)) = - numeral (w + Num.One)"
398.66 + unfolding expand_BIT bin_rest_BIT by (simp_all add: bin_rest_def zdiv_zminus1_eq_if)
398.67
398.68 lemma less_Bits:
398.69 "(v BIT b < w BIT c) = (v < w | v <= w & b = (0::bit) & c = (1::bit))"
398.70 @@ -197,42 +199,45 @@
398.71 lemma Bit_div2 [simp]: "(w BIT b) div 2 = w"
398.72 unfolding bin_rest_def [symmetric] by (rule bin_rest_BIT)
398.73
398.74 -lemma bin_nth_lem [rule_format]:
398.75 - "ALL y. bin_nth x = bin_nth y --> x = y"
398.76 - apply (induct x rule: bin_induct)
398.77 - apply safe
398.78 - apply (erule rev_mp)
398.79 - apply (induct_tac y rule: bin_induct)
398.80 +lemma bin_nth_eq_iff:
398.81 + "bin_nth x = bin_nth y \<longleftrightarrow> x = y"
398.82 +proof -
398.83 + have bin_nth_lem [rule_format]: "ALL y. bin_nth x = bin_nth y --> x = y"
398.84 + apply (induct x rule: bin_induct)
398.85 apply safe
398.86 + apply (erule rev_mp)
398.87 + apply (induct_tac y rule: bin_induct)
398.88 + apply safe
398.89 + apply (drule_tac x=0 in fun_cong, force)
398.90 + apply (erule notE, rule ext,
398.91 + drule_tac x="Suc x" in fun_cong, force)
398.92 apply (drule_tac x=0 in fun_cong, force)
398.93 - apply (erule notE, rule ext,
398.94 - drule_tac x="Suc x" in fun_cong, force)
398.95 - apply (drule_tac x=0 in fun_cong, force)
398.96 - apply (erule rev_mp)
398.97 - apply (induct_tac y rule: bin_induct)
398.98 - apply safe
398.99 + apply (erule rev_mp)
398.100 + apply (induct_tac y rule: bin_induct)
398.101 + apply safe
398.102 + apply (drule_tac x=0 in fun_cong, force)
398.103 + apply (erule notE, rule ext,
398.104 + drule_tac x="Suc x" in fun_cong, force)
398.105 + apply (metis Bit_eq_m1_iff Z bin_last_BIT)
398.106 + apply (case_tac y rule: bin_exhaust)
398.107 + apply clarify
398.108 + apply (erule allE)
398.109 + apply (erule impE)
398.110 + prefer 2
398.111 + apply (erule conjI)
398.112 apply (drule_tac x=0 in fun_cong, force)
398.113 - apply (erule notE, rule ext,
398.114 - drule_tac x="Suc x" in fun_cong, force)
398.115 - apply (drule_tac x=0 in fun_cong, force)
398.116 - apply (case_tac y rule: bin_exhaust)
398.117 - apply clarify
398.118 - apply (erule allE)
398.119 - apply (erule impE)
398.120 - prefer 2
398.121 - apply (erule conjI)
398.122 - apply (drule_tac x=0 in fun_cong, force)
398.123 - apply (rule ext)
398.124 - apply (drule_tac x="Suc ?x" in fun_cong, force)
398.125 - done
398.126 -
398.127 -lemma bin_nth_eq_iff: "(bin_nth x = bin_nth y) = (x = y)"
398.128 + apply (rule ext)
398.129 + apply (drule_tac x="Suc ?x" in fun_cong, force)
398.130 + done
398.131 + show ?thesis
398.132 by (auto elim: bin_nth_lem)
398.133 +qed
398.134
398.135 lemmas bin_eqI = ext [THEN bin_nth_eq_iff [THEN iffD1]]
398.136
398.137 -lemma bin_eq_iff: "x = y \<longleftrightarrow> (\<forall>n. bin_nth x n = bin_nth y n)"
398.138 - by (auto intro!: bin_nth_lem del: equalityI)
398.139 +lemma bin_eq_iff:
398.140 + "x = y \<longleftrightarrow> (\<forall>n. bin_nth x n = bin_nth y n)"
398.141 + using bin_nth_eq_iff by auto
398.142
398.143 lemma bin_nth_zero [simp]: "\<not> bin_nth 0 n"
398.144 by (induct n) auto
398.145 @@ -276,8 +281,9 @@
398.146 lemma bin_sign_simps [simp]:
398.147 "bin_sign 0 = 0"
398.148 "bin_sign 1 = 0"
398.149 + "bin_sign (- 1) = - 1"
398.150 "bin_sign (numeral k) = 0"
398.151 - "bin_sign (neg_numeral k) = -1"
398.152 + "bin_sign (- numeral k) = -1"
398.153 "bin_sign (w BIT b) = bin_sign w"
398.154 unfolding bin_sign_def Bit_def bitval_def
398.155 by (simp_all split: bit.split)
398.156 @@ -331,18 +337,18 @@
398.157 "bintrunc (Suc n) -1 = bintrunc n -1 BIT 1"
398.158 "bintrunc (Suc n) (numeral (Num.Bit0 w)) = bintrunc n (numeral w) BIT 0"
398.159 "bintrunc (Suc n) (numeral (Num.Bit1 w)) = bintrunc n (numeral w) BIT 1"
398.160 - "bintrunc (Suc n) (neg_numeral (Num.Bit0 w)) =
398.161 - bintrunc n (neg_numeral w) BIT 0"
398.162 - "bintrunc (Suc n) (neg_numeral (Num.Bit1 w)) =
398.163 - bintrunc n (neg_numeral (w + Num.One)) BIT 1"
398.164 + "bintrunc (Suc n) (- numeral (Num.Bit0 w)) =
398.165 + bintrunc n (- numeral w) BIT 0"
398.166 + "bintrunc (Suc n) (- numeral (Num.Bit1 w)) =
398.167 + bintrunc n (- numeral (w + Num.One)) BIT 1"
398.168 by simp_all
398.169
398.170 lemma sbintrunc_0_numeral [simp]:
398.171 "sbintrunc 0 1 = -1"
398.172 "sbintrunc 0 (numeral (Num.Bit0 w)) = 0"
398.173 "sbintrunc 0 (numeral (Num.Bit1 w)) = -1"
398.174 - "sbintrunc 0 (neg_numeral (Num.Bit0 w)) = 0"
398.175 - "sbintrunc 0 (neg_numeral (Num.Bit1 w)) = -1"
398.176 + "sbintrunc 0 (- numeral (Num.Bit0 w)) = 0"
398.177 + "sbintrunc 0 (- numeral (Num.Bit1 w)) = -1"
398.178 by simp_all
398.179
398.180 lemma sbintrunc_Suc_numeral:
398.181 @@ -351,10 +357,10 @@
398.182 sbintrunc n (numeral w) BIT 0"
398.183 "sbintrunc (Suc n) (numeral (Num.Bit1 w)) =
398.184 sbintrunc n (numeral w) BIT 1"
398.185 - "sbintrunc (Suc n) (neg_numeral (Num.Bit0 w)) =
398.186 - sbintrunc n (neg_numeral w) BIT 0"
398.187 - "sbintrunc (Suc n) (neg_numeral (Num.Bit1 w)) =
398.188 - sbintrunc n (neg_numeral (w + Num.One)) BIT 1"
398.189 + "sbintrunc (Suc n) (- numeral (Num.Bit0 w)) =
398.190 + sbintrunc n (- numeral w) BIT 0"
398.191 + "sbintrunc (Suc n) (- numeral (Num.Bit1 w)) =
398.192 + sbintrunc n (- numeral (w + Num.One)) BIT 1"
398.193 by simp_all
398.194
398.195 lemma bit_bool:
398.196 @@ -580,10 +586,10 @@
398.197 bintrunc (pred_numeral k) (numeral w) BIT 0"
398.198 "bintrunc (numeral k) (numeral (Num.Bit1 w)) =
398.199 bintrunc (pred_numeral k) (numeral w) BIT 1"
398.200 - "bintrunc (numeral k) (neg_numeral (Num.Bit0 w)) =
398.201 - bintrunc (pred_numeral k) (neg_numeral w) BIT 0"
398.202 - "bintrunc (numeral k) (neg_numeral (Num.Bit1 w)) =
398.203 - bintrunc (pred_numeral k) (neg_numeral (w + Num.One)) BIT 1"
398.204 + "bintrunc (numeral k) (- numeral (Num.Bit0 w)) =
398.205 + bintrunc (pred_numeral k) (- numeral w) BIT 0"
398.206 + "bintrunc (numeral k) (- numeral (Num.Bit1 w)) =
398.207 + bintrunc (pred_numeral k) (- numeral (w + Num.One)) BIT 1"
398.208 "bintrunc (numeral k) 1 = 1"
398.209 by (simp_all add: bintrunc_numeral)
398.210
398.211 @@ -592,10 +598,10 @@
398.212 sbintrunc (pred_numeral k) (numeral w) BIT 0"
398.213 "sbintrunc (numeral k) (numeral (Num.Bit1 w)) =
398.214 sbintrunc (pred_numeral k) (numeral w) BIT 1"
398.215 - "sbintrunc (numeral k) (neg_numeral (Num.Bit0 w)) =
398.216 - sbintrunc (pred_numeral k) (neg_numeral w) BIT 0"
398.217 - "sbintrunc (numeral k) (neg_numeral (Num.Bit1 w)) =
398.218 - sbintrunc (pred_numeral k) (neg_numeral (w + Num.One)) BIT 1"
398.219 + "sbintrunc (numeral k) (- numeral (Num.Bit0 w)) =
398.220 + sbintrunc (pred_numeral k) (- numeral w) BIT 0"
398.221 + "sbintrunc (numeral k) (- numeral (Num.Bit1 w)) =
398.222 + sbintrunc (pred_numeral k) (- numeral (w + Num.One)) BIT 1"
398.223 "sbintrunc (numeral k) 1 = 1"
398.224 by (simp_all add: sbintrunc_numeral)
398.225
398.226 @@ -636,12 +642,12 @@
398.227 unfolding no_sbintr_alt2 by (drule sb_inc_lem') simp
398.228
398.229 lemma sb_dec_lem:
398.230 - "(0::int) <= - (2^k) + a ==> (a + 2^k) mod (2 * 2 ^ k) <= - (2 ^ k) + a"
398.231 - by (rule int_mod_le' [where n = "2 ^ (Suc k)" and b = "a + 2 ^ k", simplified])
398.232 + "(0::int) \<le> - (2 ^ k) + a \<Longrightarrow> (a + 2 ^ k) mod (2 * 2 ^ k) \<le> - (2 ^ k) + a"
398.233 + using int_mod_le'[where n = "2 ^ (Suc k)" and b = "a + 2 ^ k"] by simp
398.234
398.235 lemma sb_dec_lem':
398.236 - "(2::int) ^ k <= a ==> (a + 2 ^ k) mod (2 * 2 ^ k) <= - (2 ^ k) + a"
398.237 - by (rule iffD1 [OF diff_le_eq', THEN sb_dec_lem, simplified])
398.238 + "(2::int) ^ k \<le> a \<Longrightarrow> (a + 2 ^ k) mod (2 * 2 ^ k) \<le> - (2 ^ k) + a"
398.239 + by (rule sb_dec_lem) simp
398.240
398.241 lemma sbintrunc_dec:
398.242 "x >= (2 ^ n) ==> x - 2 ^ (Suc n) >= sbintrunc n x"
399.1 --- a/src/HOL/Word/Misc_Numeric.thy Thu Dec 05 17:52:12 2013 +0100
399.2 +++ b/src/HOL/Word/Misc_Numeric.thy Thu Dec 05 17:58:03 2013 +0100
399.3 @@ -8,10 +8,6 @@
399.4 imports Main Parity
399.5 begin
399.6
399.7 -lemma zmod_zsub_self [simp]: (* FIXME move to Divides.thy *)
399.8 - "((b :: int) - a) mod a = b mod a"
399.9 - by (simp add: mod_diff_right_eq)
399.10 -
399.11 declare iszero_0 [iff]
399.12
399.13 lemma min_pm [simp]: "min a b + (a - b) = (a :: nat)" by arith
400.1 --- a/src/HOL/Word/Word.thy Thu Dec 05 17:52:12 2013 +0100
400.2 +++ b/src/HOL/Word/Word.thy Thu Dec 05 17:58:03 2013 +0100
400.3 @@ -8,6 +8,7 @@
400.4 imports
400.5 Type_Length
400.6 "~~/src/HOL/Library/Boolean_Algebra"
400.7 + Bit_Bit
400.8 Bool_List_Representation
400.9 Misc_Typedef
400.10 Word_Miscellaneous
400.11 @@ -505,10 +506,6 @@
400.12 definition max_word :: "'a::len word" -- "Largest representable machine integer." where
400.13 "max_word = word_of_int (2 ^ len_of TYPE('a) - 1)"
400.14
400.15 -primrec of_bool :: "bool \<Rightarrow> 'a::len word" where
400.16 - "of_bool False = 0"
400.17 -| "of_bool True = 1"
400.18 -
400.19 (* FIXME: only provide one theorem name *)
400.20 lemmas of_nth_def = word_set_bits_def
400.21
400.22 @@ -594,24 +591,24 @@
400.23 declare word_numeral_alt [symmetric, code_abbrev]
400.24
400.25 lemma word_neg_numeral_alt:
400.26 - "neg_numeral b = word_of_int (neg_numeral b)"
400.27 - by (simp only: neg_numeral_def word_numeral_alt wi_hom_neg)
400.28 + "- numeral b = word_of_int (- numeral b)"
400.29 + by (simp only: word_numeral_alt wi_hom_neg)
400.30
400.31 declare word_neg_numeral_alt [symmetric, code_abbrev]
400.32
400.33 lemma word_numeral_transfer [transfer_rule]:
400.34 "(fun_rel op = pcr_word) numeral numeral"
400.35 - "(fun_rel op = pcr_word) neg_numeral neg_numeral"
400.36 - unfolding fun_rel_def word.pcr_cr_eq cr_word_def word_numeral_alt word_neg_numeral_alt
400.37 - by simp_all
400.38 + "(fun_rel op = pcr_word) (- numeral) (- numeral)"
400.39 + apply (simp_all add: fun_rel_def word.pcr_cr_eq cr_word_def)
400.40 + using word_numeral_alt [symmetric] word_neg_numeral_alt [symmetric] by blast+
400.41
400.42 lemma uint_bintrunc [simp]:
400.43 "uint (numeral bin :: 'a word) =
400.44 bintrunc (len_of TYPE ('a :: len0)) (numeral bin)"
400.45 unfolding word_numeral_alt by (rule word_ubin.eq_norm)
400.46
400.47 -lemma uint_bintrunc_neg [simp]: "uint (neg_numeral bin :: 'a word) =
400.48 - bintrunc (len_of TYPE ('a :: len0)) (neg_numeral bin)"
400.49 +lemma uint_bintrunc_neg [simp]: "uint (- numeral bin :: 'a word) =
400.50 + bintrunc (len_of TYPE ('a :: len0)) (- numeral bin)"
400.51 by (simp only: word_neg_numeral_alt word_ubin.eq_norm)
400.52
400.53 lemma sint_sbintrunc [simp]:
400.54 @@ -619,8 +616,8 @@
400.55 sbintrunc (len_of TYPE ('a :: len) - 1) (numeral bin)"
400.56 by (simp only: word_numeral_alt word_sbin.eq_norm)
400.57
400.58 -lemma sint_sbintrunc_neg [simp]: "sint (neg_numeral bin :: 'a word) =
400.59 - sbintrunc (len_of TYPE ('a :: len) - 1) (neg_numeral bin)"
400.60 +lemma sint_sbintrunc_neg [simp]: "sint (- numeral bin :: 'a word) =
400.61 + sbintrunc (len_of TYPE ('a :: len) - 1) (- numeral bin)"
400.62 by (simp only: word_neg_numeral_alt word_sbin.eq_norm)
400.63
400.64 lemma unat_bintrunc [simp]:
400.65 @@ -629,8 +626,8 @@
400.66 by (simp only: unat_def uint_bintrunc)
400.67
400.68 lemma unat_bintrunc_neg [simp]:
400.69 - "unat (neg_numeral bin :: 'a :: len0 word) =
400.70 - nat (bintrunc (len_of TYPE('a)) (neg_numeral bin))"
400.71 + "unat (- numeral bin :: 'a :: len0 word) =
400.72 + nat (bintrunc (len_of TYPE('a)) (- numeral bin))"
400.73 by (simp only: unat_def uint_bintrunc_neg)
400.74
400.75 lemma size_0_eq: "size (w :: 'a :: len0 word) = 0 \<Longrightarrow> v = w"
400.76 @@ -681,7 +678,7 @@
400.77 by (simp only: int_word_uint)
400.78
400.79 lemma uint_neg_numeral:
400.80 - "uint (neg_numeral b :: 'a :: len0 word) = neg_numeral b mod 2 ^ len_of TYPE('a)"
400.81 + "uint (- numeral b :: 'a :: len0 word) = - numeral b mod 2 ^ len_of TYPE('a)"
400.82 unfolding word_neg_numeral_alt
400.83 by (simp only: int_word_uint)
400.84
400.85 @@ -705,13 +702,16 @@
400.86 lemma word_of_int_1 [simp, code_post]: "word_of_int 1 = 1"
400.87 unfolding word_1_wi ..
400.88
400.89 +lemma word_of_int_neg_1 [simp]: "word_of_int (- 1) = - 1"
400.90 + by (simp add: wi_hom_syms)
400.91 +
400.92 lemma word_of_int_numeral [simp] :
400.93 "(word_of_int (numeral bin) :: 'a :: len0 word) = (numeral bin)"
400.94 unfolding word_numeral_alt ..
400.95
400.96 lemma word_of_int_neg_numeral [simp]:
400.97 - "(word_of_int (neg_numeral bin) :: 'a :: len0 word) = (neg_numeral bin)"
400.98 - unfolding neg_numeral_def word_numeral_alt wi_hom_syms ..
400.99 + "(word_of_int (- numeral bin) :: 'a :: len0 word) = (- numeral bin)"
400.100 + unfolding word_numeral_alt wi_hom_syms ..
400.101
400.102 lemma word_int_case_wi:
400.103 "word_int_case f (word_of_int i :: 'b word) =
400.104 @@ -883,8 +883,8 @@
400.105 unfolding word_numeral_alt by (rule to_bl_of_bin)
400.106
400.107 lemma to_bl_neg_numeral [simp]:
400.108 - "to_bl (neg_numeral bin::'a::len0 word) =
400.109 - bin_to_bl (len_of TYPE('a)) (neg_numeral bin)"
400.110 + "to_bl (- numeral bin::'a::len0 word) =
400.111 + bin_to_bl (len_of TYPE('a)) (- numeral bin)"
400.112 unfolding word_neg_numeral_alt by (rule to_bl_of_bin)
400.113
400.114 lemma to_bl_to_bin [simp] : "bl_to_bin (to_bl w) = uint w"
400.115 @@ -1159,11 +1159,8 @@
400.116
400.117 lemmas word_sle_no [simp] = word_sle_def [of "numeral a" "numeral b"] for a b
400.118
400.119 -lemma word_1_no: "(1::'a::len0 word) = Numeral1"
400.120 - by (simp add: word_numeral_alt)
400.121 -
400.122 -lemma word_m1_wi: "-1 = word_of_int -1"
400.123 - by (rule word_neg_numeral_alt)
400.124 +lemma word_m1_wi: "- 1 = word_of_int (- 1)"
400.125 + using word_neg_numeral_alt [of Num.One] by simp
400.126
400.127 lemma word_0_bl [simp]: "of_bl [] = 0"
400.128 unfolding of_bl_def by simp
400.129 @@ -1218,9 +1215,9 @@
400.130 unfolding scast_def by simp
400.131
400.132 lemma sint_n1 [simp] : "sint -1 = -1"
400.133 - unfolding word_m1_wi by (simp add: word_sbin.eq_norm)
400.134 -
400.135 -lemma scast_n1 [simp]: "scast -1 = -1"
400.136 + unfolding word_m1_wi word_sbin.eq_norm by simp
400.137 +
400.138 +lemma scast_n1 [simp]: "scast (- 1) = - 1"
400.139 unfolding scast_def by simp
400.140
400.141 lemma uint_1 [simp]: "uint (1::'a::len word) = 1"
400.142 @@ -1273,8 +1270,8 @@
400.143 lemma succ_pred_no [simp]:
400.144 "word_succ (numeral w) = numeral w + 1"
400.145 "word_pred (numeral w) = numeral w - 1"
400.146 - "word_succ (neg_numeral w) = neg_numeral w + 1"
400.147 - "word_pred (neg_numeral w) = neg_numeral w - 1"
400.148 + "word_succ (- numeral w) = - numeral w + 1"
400.149 + "word_pred (- numeral w) = - numeral w - 1"
400.150 unfolding word_succ_p1 word_pred_m1 by simp_all
400.151
400.152 lemma word_sp_01 [simp] :
400.153 @@ -2154,19 +2151,19 @@
400.154
400.155 lemma word_no_log_defs [simp]:
400.156 "NOT (numeral a) = word_of_int (NOT (numeral a))"
400.157 - "NOT (neg_numeral a) = word_of_int (NOT (neg_numeral a))"
400.158 + "NOT (- numeral a) = word_of_int (NOT (- numeral a))"
400.159 "numeral a AND numeral b = word_of_int (numeral a AND numeral b)"
400.160 - "numeral a AND neg_numeral b = word_of_int (numeral a AND neg_numeral b)"
400.161 - "neg_numeral a AND numeral b = word_of_int (neg_numeral a AND numeral b)"
400.162 - "neg_numeral a AND neg_numeral b = word_of_int (neg_numeral a AND neg_numeral b)"
400.163 + "numeral a AND - numeral b = word_of_int (numeral a AND - numeral b)"
400.164 + "- numeral a AND numeral b = word_of_int (- numeral a AND numeral b)"
400.165 + "- numeral a AND - numeral b = word_of_int (- numeral a AND - numeral b)"
400.166 "numeral a OR numeral b = word_of_int (numeral a OR numeral b)"
400.167 - "numeral a OR neg_numeral b = word_of_int (numeral a OR neg_numeral b)"
400.168 - "neg_numeral a OR numeral b = word_of_int (neg_numeral a OR numeral b)"
400.169 - "neg_numeral a OR neg_numeral b = word_of_int (neg_numeral a OR neg_numeral b)"
400.170 + "numeral a OR - numeral b = word_of_int (numeral a OR - numeral b)"
400.171 + "- numeral a OR numeral b = word_of_int (- numeral a OR numeral b)"
400.172 + "- numeral a OR - numeral b = word_of_int (- numeral a OR - numeral b)"
400.173 "numeral a XOR numeral b = word_of_int (numeral a XOR numeral b)"
400.174 - "numeral a XOR neg_numeral b = word_of_int (numeral a XOR neg_numeral b)"
400.175 - "neg_numeral a XOR numeral b = word_of_int (neg_numeral a XOR numeral b)"
400.176 - "neg_numeral a XOR neg_numeral b = word_of_int (neg_numeral a XOR neg_numeral b)"
400.177 + "numeral a XOR - numeral b = word_of_int (numeral a XOR - numeral b)"
400.178 + "- numeral a XOR numeral b = word_of_int (- numeral a XOR numeral b)"
400.179 + "- numeral a XOR - numeral b = word_of_int (- numeral a XOR - numeral b)"
400.180 by (transfer, rule refl)+
400.181
400.182 text {* Special cases for when one of the arguments equals 1. *}
400.183 @@ -2174,17 +2171,17 @@
400.184 lemma word_bitwise_1_simps [simp]:
400.185 "NOT (1::'a::len0 word) = -2"
400.186 "1 AND numeral b = word_of_int (1 AND numeral b)"
400.187 - "1 AND neg_numeral b = word_of_int (1 AND neg_numeral b)"
400.188 + "1 AND - numeral b = word_of_int (1 AND - numeral b)"
400.189 "numeral a AND 1 = word_of_int (numeral a AND 1)"
400.190 - "neg_numeral a AND 1 = word_of_int (neg_numeral a AND 1)"
400.191 + "- numeral a AND 1 = word_of_int (- numeral a AND 1)"
400.192 "1 OR numeral b = word_of_int (1 OR numeral b)"
400.193 - "1 OR neg_numeral b = word_of_int (1 OR neg_numeral b)"
400.194 + "1 OR - numeral b = word_of_int (1 OR - numeral b)"
400.195 "numeral a OR 1 = word_of_int (numeral a OR 1)"
400.196 - "neg_numeral a OR 1 = word_of_int (neg_numeral a OR 1)"
400.197 + "- numeral a OR 1 = word_of_int (- numeral a OR 1)"
400.198 "1 XOR numeral b = word_of_int (1 XOR numeral b)"
400.199 - "1 XOR neg_numeral b = word_of_int (1 XOR neg_numeral b)"
400.200 + "1 XOR - numeral b = word_of_int (1 XOR - numeral b)"
400.201 "numeral a XOR 1 = word_of_int (numeral a XOR 1)"
400.202 - "neg_numeral a XOR 1 = word_of_int (neg_numeral a XOR 1)"
400.203 + "- numeral a XOR 1 = word_of_int (- numeral a XOR 1)"
400.204 by (transfer, simp)+
400.205
400.206 lemma uint_or: "uint (x OR y) = (uint x) OR (uint y)"
400.207 @@ -2223,8 +2220,8 @@
400.208 by transfer (rule refl)
400.209
400.210 lemma test_bit_neg_numeral [simp]:
400.211 - "(neg_numeral w :: 'a::len0 word) !! n \<longleftrightarrow>
400.212 - n < len_of TYPE('a) \<and> bin_nth (neg_numeral w) n"
400.213 + "(- numeral w :: 'a::len0 word) !! n \<longleftrightarrow>
400.214 + n < len_of TYPE('a) \<and> bin_nth (- numeral w) n"
400.215 by transfer (rule refl)
400.216
400.217 lemma test_bit_1 [simp]: "(1::'a::len word) !! n \<longleftrightarrow> n = 0"
400.218 @@ -2401,7 +2398,7 @@
400.219 unfolding word_numeral_alt by (rule msb_word_of_int)
400.220
400.221 lemma word_msb_neg_numeral [simp]:
400.222 - "msb (neg_numeral w::'a::len word) = bin_nth (neg_numeral w) (len_of TYPE('a) - 1)"
400.223 + "msb (- numeral w::'a::len word) = bin_nth (- numeral w) (len_of TYPE('a) - 1)"
400.224 unfolding word_neg_numeral_alt by (rule msb_word_of_int)
400.225
400.226 lemma word_msb_0 [simp]: "\<not> msb (0::'a::len word)"
400.227 @@ -2531,7 +2528,7 @@
400.228 unfolding word_lsb_alt test_bit_numeral by simp
400.229
400.230 lemma word_lsb_neg_numeral [simp]:
400.231 - "lsb (neg_numeral bin :: 'a :: len word) = (bin_last (neg_numeral bin) = 1)"
400.232 + "lsb (- numeral bin :: 'a :: len word) = (bin_last (- numeral bin) = 1)"
400.233 unfolding word_lsb_alt test_bit_neg_numeral by simp
400.234
400.235 lemma set_bit_word_of_int:
400.236 @@ -2547,8 +2544,8 @@
400.237 unfolding word_numeral_alt by (rule set_bit_word_of_int)
400.238
400.239 lemma word_set_neg_numeral [simp]:
400.240 - "set_bit (neg_numeral bin::'a::len0 word) n b =
400.241 - word_of_int (bin_sc n (if b then 1 else 0) (neg_numeral bin))"
400.242 + "set_bit (- numeral bin::'a::len0 word) n b =
400.243 + word_of_int (bin_sc n (if b then 1 else 0) (- numeral bin))"
400.244 unfolding word_neg_numeral_alt by (rule set_bit_word_of_int)
400.245
400.246 lemma word_set_bit_0 [simp]:
400.247 @@ -2615,8 +2612,14 @@
400.248 apply clarsimp
400.249 apply clarsimp
400.250 apply (drule word_gt_0 [THEN iffD1])
400.251 - apply (safe intro!: word_eqI bin_nth_lem)
400.252 - apply (auto simp add: test_bit_2p nth_2p_bin word_test_bit_def [symmetric])
400.253 + apply (safe intro!: word_eqI)
400.254 + apply (auto simp add: nth_2p_bin)
400.255 + apply (erule notE)
400.256 + apply (simp (no_asm_use) add: uint_word_of_int word_size)
400.257 + apply (subst mod_pos_pos_trivial)
400.258 + apply simp
400.259 + apply (rule power_strict_increasing)
400.260 + apply simp_all
400.261 done
400.262
400.263 lemma word_of_int_2p: "(word_of_int (2 ^ n) :: 'a :: len word) = 2 ^ n"
400.264 @@ -2673,7 +2676,7 @@
400.265 unfolding word_numeral_alt shiftl1_wi by simp
400.266
400.267 lemma shiftl1_neg_numeral [simp]:
400.268 - "shiftl1 (neg_numeral w) = neg_numeral (Num.Bit0 w)"
400.269 + "shiftl1 (- numeral w) = - numeral (Num.Bit0 w)"
400.270 unfolding word_neg_numeral_alt shiftl1_wi by simp
400.271
400.272 lemma shiftl1_0 [simp] : "shiftl1 0 = 0"
400.273 @@ -4238,7 +4241,7 @@
400.274
400.275 lemma max_word_max [simp,intro!]: "n \<le> max_word"
400.276 by (cases n rule: word_int_cases)
400.277 - (simp add: max_word_def word_le_def int_word_uint int_mod_eq')
400.278 + (simp add: max_word_def word_le_def int_word_uint int_mod_eq' del: minus_mod_self1)
400.279
400.280 lemma word_of_int_2p_len: "word_of_int (2 ^ len_of TYPE('a)) = (0::'a::len0 word)"
400.281 by (subst word_uint.Abs_norm [symmetric]) simp
400.282 @@ -4641,9 +4644,6 @@
400.283 "1 + n \<noteq> (0::'a::len word) \<Longrightarrow> unat (1 + n) = Suc (unat n)"
400.284 by unat_arith
400.285
400.286 -lemma word_no_1 [simp]: "(Numeral1::'a::len0 word) = 1"
400.287 - by (fact word_1_no [symmetric])
400.288 -
400.289 declare bin_to_bl_def [simp]
400.290
400.291 ML_file "Tools/word_lib.ML"
401.1 --- a/src/HOL/Word/WordBitwise.thy Thu Dec 05 17:52:12 2013 +0100
401.2 +++ b/src/HOL/Word/WordBitwise.thy Thu Dec 05 17:58:03 2013 +0100
401.3 @@ -65,7 +65,7 @@
401.4
401.5 lemma bl_word_sub:
401.6 "to_bl (x - y) = to_bl (x + (- y))"
401.7 - by (simp add: diff_def)
401.8 + by simp
401.9
401.10 lemma rbl_word_1:
401.11 "rev (to_bl (1 :: ('a :: len0) word))
401.12 @@ -461,18 +461,18 @@
401.13 = True # rev (bin_to_bl n (numeral nm))"
401.14 "rev (bin_to_bl (Suc n) (numeral (num.One)))
401.15 = True # replicate n False"
401.16 - "rev (bin_to_bl (Suc n) (neg_numeral (num.Bit0 nm)))
401.17 - = False # rev (bin_to_bl n (neg_numeral nm))"
401.18 - "rev (bin_to_bl (Suc n) (neg_numeral (num.Bit1 nm)))
401.19 - = True # rev (bin_to_bl n (neg_numeral (nm + num.One)))"
401.20 - "rev (bin_to_bl (Suc n) (neg_numeral (num.One)))
401.21 + "rev (bin_to_bl (Suc n) (- numeral (num.Bit0 nm)))
401.22 + = False # rev (bin_to_bl n (- numeral nm))"
401.23 + "rev (bin_to_bl (Suc n) (- numeral (num.Bit1 nm)))
401.24 + = True # rev (bin_to_bl n (- numeral (nm + num.One)))"
401.25 + "rev (bin_to_bl (Suc n) (- numeral (num.One)))
401.26 = True # replicate n True"
401.27 - "rev (bin_to_bl (Suc n) (neg_numeral (num.Bit0 nm + num.One)))
401.28 - = True # rev (bin_to_bl n (neg_numeral (nm + num.One)))"
401.29 - "rev (bin_to_bl (Suc n) (neg_numeral (num.Bit1 nm + num.One)))
401.30 - = False # rev (bin_to_bl n (neg_numeral (nm + num.One)))"
401.31 - "rev (bin_to_bl (Suc n) (neg_numeral (num.One + num.One)))
401.32 - = False # rev (bin_to_bl n (neg_numeral num.One))"
401.33 + "rev (bin_to_bl (Suc n) (- numeral (num.Bit0 nm + num.One)))
401.34 + = True # rev (bin_to_bl n (- numeral (nm + num.One)))"
401.35 + "rev (bin_to_bl (Suc n) (- numeral (num.Bit1 nm + num.One)))
401.36 + = False # rev (bin_to_bl n (- numeral (nm + num.One)))"
401.37 + "rev (bin_to_bl (Suc n) (- numeral (num.One + num.One)))
401.38 + = False # rev (bin_to_bl n (- numeral num.One))"
401.39 apply (simp_all add: bin_to_bl_def)
401.40 apply (simp_all only: bin_to_bl_aux_alt)
401.41 apply (simp_all)
402.1 --- a/src/HOL/ex/Coercion_Examples.thy Thu Dec 05 17:52:12 2013 +0100
402.2 +++ b/src/HOL/ex/Coercion_Examples.thy Thu Dec 05 17:58:03 2013 +0100
402.3 @@ -37,10 +37,9 @@
402.4
402.5 (* Coercion/type maps definitions *)
402.6
402.7 -primrec nat_of_bool :: "bool \<Rightarrow> nat"
402.8 +abbreviation nat_of_bool :: "bool \<Rightarrow> nat"
402.9 where
402.10 - "nat_of_bool False = 0"
402.11 -| "nat_of_bool True = 1"
402.12 + "nat_of_bool \<equiv> of_bool"
402.13
402.14 declare [[coercion nat_of_bool]]
402.15
402.16 @@ -201,5 +200,5 @@
402.17 declare [[coercion_args uminus -]]
402.18 declare [[coercion_args plus + +]]
402.19 term "- (n + m)"
402.20 -
402.21 +
402.22 end
403.1 --- a/src/HOL/ex/Dedekind_Real.thy Thu Dec 05 17:52:12 2013 +0100
403.2 +++ b/src/HOL/ex/Dedekind_Real.thy Thu Dec 05 17:58:03 2013 +0100
403.3 @@ -1506,7 +1506,6 @@
403.4 instance real :: linorder
403.5 by (intro_classes, rule real_le_linear)
403.6
403.7 -
403.8 lemma real_le_eq_diff: "(x \<le> y) = (x-y \<le> (0::real))"
403.9 apply (cases x, cases y)
403.10 apply (auto simp add: real_le real_zero_def real_diff_def real_add real_minus
403.11 @@ -1520,14 +1519,14 @@
403.12 have "z + x - (z + y) = (z + -z) + (x - y)"
403.13 by (simp add: algebra_simps)
403.14 with le show ?thesis
403.15 - by (simp add: real_le_eq_diff[of x] real_le_eq_diff[of "z+x"] diff_minus)
403.16 + by (simp add: real_le_eq_diff[of x] real_le_eq_diff[of "z+x"])
403.17 qed
403.18
403.19 lemma real_sum_gt_zero_less: "(0 < S + (-W::real)) ==> (W < S)"
403.20 -by (simp add: linorder_not_le [symmetric] real_le_eq_diff [of S] diff_minus)
403.21 +by (simp add: linorder_not_le [symmetric] real_le_eq_diff [of S])
403.22
403.23 lemma real_less_sum_gt_zero: "(W < S) ==> (0 < S + (-W::real))"
403.24 -by (simp add: linorder_not_le [symmetric] real_le_eq_diff [of S] diff_minus)
403.25 +by (simp add: linorder_not_le [symmetric] real_le_eq_diff [of S])
403.26
403.27 lemma real_mult_order: "[| 0 < x; 0 < y |] ==> (0::real) < x * y"
403.28 apply (cases x, cases y)
403.29 @@ -1543,7 +1542,7 @@
403.30 apply (rule real_sum_gt_zero_less)
403.31 apply (drule real_less_sum_gt_zero [of x y])
403.32 apply (drule real_mult_order, assumption)
403.33 -apply (simp add: distrib_left)
403.34 +apply (simp add: algebra_simps)
403.35 done
403.36
403.37 instantiation real :: distrib_lattice
403.38 @@ -1657,7 +1656,6 @@
403.39 lemma real_less_all_real2: "~ 0 < y ==> \<forall>x. y < real_of_preal x"
403.40 by (blast intro!: real_less_all_preal linorder_not_less [THEN iffD1])
403.41
403.42 -
403.43 subsection {* Completeness of Positive Reals *}
403.44
403.45 text {*
403.46 @@ -1759,107 +1757,23 @@
403.47 qed
403.48
403.49 text {*
403.50 - \medskip Completeness properties using @{text "isUb"}, @{text "isLub"} etc.
403.51 -*}
403.52 -
403.53 -lemma posreals_complete:
403.54 - assumes positive_S: "\<forall>x \<in> S. 0 < x"
403.55 - and not_empty_S: "\<exists>x. x \<in> S"
403.56 - and upper_bound_Ex: "\<exists>u. isUb (UNIV::real set) S u"
403.57 - shows "\<exists>t. isLub (UNIV::real set) S t"
403.58 -proof
403.59 - let ?pS = "{w. real_of_preal w \<in> S}"
403.60 -
403.61 - obtain u where "isUb UNIV S u" using upper_bound_Ex ..
403.62 - hence sup: "\<forall>x \<in> S. x \<le> u" by (simp add: isUb_def setle_def)
403.63 -
403.64 - obtain x where x_in_S: "x \<in> S" using not_empty_S ..
403.65 - hence x_gt_zero: "0 < x" using positive_S by simp
403.66 - have "x \<le> u" using sup and x_in_S ..
403.67 - hence "0 < u" using x_gt_zero by arith
403.68 -
403.69 - then obtain pu where u_is_pu: "u = real_of_preal pu"
403.70 - by (auto simp add: real_gt_zero_preal_Ex)
403.71 -
403.72 - have pS_less_pu: "\<forall>pa \<in> ?pS. pa \<le> pu"
403.73 - proof
403.74 - fix pa
403.75 - assume "pa \<in> ?pS"
403.76 - then obtain a where a: "a \<in> S" "a = real_of_preal pa"
403.77 - by simp
403.78 - then have "a \<le> u" using sup by simp
403.79 - with a show "pa \<le> pu"
403.80 - using sup and u_is_pu by (simp add: real_of_preal_le_iff)
403.81 - qed
403.82 -
403.83 - have "\<forall>y \<in> S. y \<le> real_of_preal (psup ?pS)"
403.84 - proof
403.85 - fix y
403.86 - assume y_in_S: "y \<in> S"
403.87 - hence "0 < y" using positive_S by simp
403.88 - then obtain py where y_is_py: "y = real_of_preal py"
403.89 - by (auto simp add: real_gt_zero_preal_Ex)
403.90 - hence py_in_pS: "py \<in> ?pS" using y_in_S by simp
403.91 - with pS_less_pu have "py \<le> psup ?pS"
403.92 - by (rule preal_psup_le)
403.93 - thus "y \<le> real_of_preal (psup ?pS)"
403.94 - using y_is_py by (simp add: real_of_preal_le_iff)
403.95 - qed
403.96 -
403.97 - moreover {
403.98 - fix x
403.99 - assume x_ub_S: "\<forall>y\<in>S. y \<le> x"
403.100 - have "real_of_preal (psup ?pS) \<le> x"
403.101 - proof -
403.102 - obtain "s" where s_in_S: "s \<in> S" using not_empty_S ..
403.103 - hence s_pos: "0 < s" using positive_S by simp
403.104 -
403.105 - hence "\<exists> ps. s = real_of_preal ps" by (simp add: real_gt_zero_preal_Ex)
403.106 - then obtain "ps" where s_is_ps: "s = real_of_preal ps" ..
403.107 - hence ps_in_pS: "ps \<in> {w. real_of_preal w \<in> S}" using s_in_S by simp
403.108 -
403.109 - from x_ub_S have "s \<le> x" using s_in_S ..
403.110 - hence "0 < x" using s_pos by simp
403.111 - hence "\<exists> px. x = real_of_preal px" by (simp add: real_gt_zero_preal_Ex)
403.112 - then obtain "px" where x_is_px: "x = real_of_preal px" ..
403.113 -
403.114 - have "\<forall>pe \<in> ?pS. pe \<le> px"
403.115 - proof
403.116 - fix pe
403.117 - assume "pe \<in> ?pS"
403.118 - hence "real_of_preal pe \<in> S" by simp
403.119 - hence "real_of_preal pe \<le> x" using x_ub_S by simp
403.120 - thus "pe \<le> px" using x_is_px by (simp add: real_of_preal_le_iff)
403.121 - qed
403.122 -
403.123 - moreover have "?pS \<noteq> {}" using ps_in_pS by auto
403.124 - ultimately have "(psup ?pS) \<le> px" by (simp add: psup_le_ub)
403.125 - thus "real_of_preal (psup ?pS) \<le> x" using x_is_px by (simp add: real_of_preal_le_iff)
403.126 - qed
403.127 - }
403.128 - ultimately show "isLub UNIV S (real_of_preal (psup ?pS))"
403.129 - by (simp add: isLub_def leastP_def isUb_def setle_def setge_def)
403.130 -qed
403.131 -
403.132 -text {*
403.133 - \medskip reals Completeness (again!)
403.134 + \medskip Completeness
403.135 *}
403.136
403.137 lemma reals_complete:
403.138 + fixes S :: "real set"
403.139 assumes notempty_S: "\<exists>X. X \<in> S"
403.140 - and exists_Ub: "\<exists>Y. isUb (UNIV::real set) S Y"
403.141 - shows "\<exists>t. isLub (UNIV :: real set) S t"
403.142 + and exists_Ub: "bdd_above S"
403.143 + shows "\<exists>x. (\<forall>s\<in>S. s \<le> x) \<and> (\<forall>y. (\<forall>s\<in>S. s \<le> y) \<longrightarrow> x \<le> y)"
403.144 proof -
403.145 obtain X where X_in_S: "X \<in> S" using notempty_S ..
403.146 - obtain Y where Y_isUb: "isUb (UNIV::real set) S Y"
403.147 - using exists_Ub ..
403.148 + obtain Y where Y_isUb: "\<forall>s\<in>S. s \<le> Y"
403.149 + using exists_Ub by (auto simp: bdd_above_def)
403.150 let ?SHIFT = "{z. \<exists>x \<in>S. z = x + (-X) + 1} \<inter> {x. 0 < x}"
403.151
403.152 {
403.153 fix x
403.154 - assume "isUb (UNIV::real set) S x"
403.155 - hence S_le_x: "\<forall> y \<in> S. y <= x"
403.156 - by (simp add: isUb_def setle_def)
403.157 + assume S_le_x: "\<forall>s\<in>S. s \<le> x"
403.158 {
403.159 fix s
403.160 assume "s \<in> {z. \<exists>x\<in>S. z = x + - X + 1}"
403.161 @@ -1868,86 +1782,74 @@
403.162 then have "x1 \<le> x" using S_le_x by simp
403.163 with x1 have "s \<le> x + - X + 1" by arith
403.164 }
403.165 - then have "isUb (UNIV::real set) ?SHIFT (x + (-X) + 1)"
403.166 - by (auto simp add: isUb_def setle_def)
403.167 + then have "\<forall>s\<in>?SHIFT. s \<le> x + (-X) + 1"
403.168 + by auto
403.169 } note S_Ub_is_SHIFT_Ub = this
403.170
403.171 - hence "isUb UNIV ?SHIFT (Y + (-X) + 1)" using Y_isUb by simp
403.172 - hence "\<exists>Z. isUb UNIV ?SHIFT Z" ..
403.173 + have *: "\<forall>s\<in>?SHIFT. s \<le> Y + (-X) + 1" using Y_isUb by (rule S_Ub_is_SHIFT_Ub)
403.174 + have "\<forall>s\<in>?SHIFT. s < Y + (-X) + 2"
403.175 + proof
403.176 + fix s assume "s\<in>?SHIFT"
403.177 + with * have "s \<le> Y + (-X) + 1" by simp
403.178 + also have "\<dots> < Y + (-X) + 2" by simp
403.179 + finally show "s < Y + (-X) + 2" .
403.180 + qed
403.181 moreover have "\<forall>y \<in> ?SHIFT. 0 < y" by auto
403.182 moreover have shifted_not_empty: "\<exists>u. u \<in> ?SHIFT"
403.183 using X_in_S and Y_isUb by auto
403.184 - ultimately obtain t where t_is_Lub: "isLub UNIV ?SHIFT t"
403.185 - using posreals_complete [of ?SHIFT] by blast
403.186 + ultimately obtain t where t_is_Lub: "\<forall>y. (\<exists>x\<in>?SHIFT. y < x) = (y < t)"
403.187 + using posreal_complete [of ?SHIFT] unfolding bdd_above_def by blast
403.188
403.189 show ?thesis
403.190 proof
403.191 - show "isLub UNIV S (t + X + (-1))"
403.192 - proof (rule isLubI2)
403.193 - {
403.194 - fix x
403.195 - assume "isUb (UNIV::real set) S x"
403.196 - hence "isUb (UNIV::real set) (?SHIFT) (x + (-X) + 1)"
403.197 - using S_Ub_is_SHIFT_Ub by simp
403.198 - hence "t \<le> (x + (-X) + 1)"
403.199 - using t_is_Lub by (simp add: isLub_le_isUb)
403.200 - hence "t + X + -1 \<le> x" by arith
403.201 - }
403.202 - then show "(t + X + -1) <=* Collect (isUb UNIV S)"
403.203 - by (simp add: setgeI)
403.204 + show "(\<forall>s\<in>S. s \<le> (t + X + (-1))) \<and> (\<forall>y. (\<forall>s\<in>S. s \<le> y) \<longrightarrow> (t + X + (-1)) \<le> y)"
403.205 + proof safe
403.206 + fix x
403.207 + assume "\<forall>s\<in>S. s \<le> x"
403.208 + hence "\<forall>s\<in>?SHIFT. s \<le> x + (-X) + 1"
403.209 + using S_Ub_is_SHIFT_Ub by simp
403.210 + then have "\<not> x + (-X) + 1 < t"
403.211 + by (subst t_is_Lub[rule_format, symmetric]) (simp add: not_less)
403.212 + thus "t + X + -1 \<le> x" by arith
403.213 next
403.214 - show "isUb UNIV S (t + X + -1)"
403.215 - proof -
403.216 - {
403.217 - fix y
403.218 - assume y_in_S: "y \<in> S"
403.219 - have "y \<le> t + X + -1"
403.220 - proof -
403.221 - obtain "u" where u_in_shift: "u \<in> ?SHIFT" using shifted_not_empty ..
403.222 - hence "\<exists> x \<in> S. u = x + - X + 1" by simp
403.223 - then obtain "x" where x_and_u: "u = x + - X + 1" ..
403.224 - have u_le_t: "u \<le> t" using u_in_shift and t_is_Lub by (simp add: isLubD2)
403.225 + fix y
403.226 + assume y_in_S: "y \<in> S"
403.227 + obtain "u" where u_in_shift: "u \<in> ?SHIFT" using shifted_not_empty ..
403.228 + hence "\<exists> x \<in> S. u = x + - X + 1" by simp
403.229 + then obtain "x" where x_and_u: "u = x + - X + 1" ..
403.230 + have u_le_t: "u \<le> t"
403.231 + proof (rule dense_le)
403.232 + fix x assume "x < u" then have "x < t"
403.233 + using u_in_shift t_is_Lub by auto
403.234 + then show "x \<le> t" by simp
403.235 + qed
403.236
403.237 - show ?thesis
403.238 - proof cases
403.239 - assume "y \<le> x"
403.240 - moreover have "x = u + X + - 1" using x_and_u by arith
403.241 - moreover have "u + X + - 1 \<le> t + X + -1" using u_le_t by arith
403.242 - ultimately show "y \<le> t + X + -1" by arith
403.243 - next
403.244 - assume "~(y \<le> x)"
403.245 - hence x_less_y: "x < y" by arith
403.246 + show "y \<le> t + X + -1"
403.247 + proof cases
403.248 + assume "y \<le> x"
403.249 + moreover have "x = u + X + - 1" using x_and_u by arith
403.250 + moreover have "u + X + - 1 \<le> t + X + -1" using u_le_t by arith
403.251 + ultimately show "y \<le> t + X + -1" by arith
403.252 + next
403.253 + assume "~(y \<le> x)"
403.254 + hence x_less_y: "x < y" by arith
403.255
403.256 - have "x + (-X) + 1 \<in> ?SHIFT" using x_and_u and u_in_shift by simp
403.257 - hence "0 < x + (-X) + 1" by simp
403.258 - hence "0 < y + (-X) + 1" using x_less_y by arith
403.259 - hence "y + (-X) + 1 \<in> ?SHIFT" using y_in_S by simp
403.260 - hence "y + (-X) + 1 \<le> t" using t_is_Lub by (simp add: isLubD2)
403.261 - thus ?thesis by simp
403.262 - qed
403.263 - qed
403.264 - }
403.265 - then show ?thesis by (simp add: isUb_def setle_def)
403.266 + have "x + (-X) + 1 \<in> ?SHIFT" using x_and_u and u_in_shift by simp
403.267 + hence "0 < x + (-X) + 1" by simp
403.268 + hence "0 < y + (-X) + 1" using x_less_y by arith
403.269 + hence *: "y + (-X) + 1 \<in> ?SHIFT" using y_in_S by simp
403.270 + have "y + (-X) + 1 \<le> t"
403.271 + proof (rule dense_le)
403.272 + fix x assume "x < y + (-X) + 1" then have "x < t"
403.273 + using * t_is_Lub by auto
403.274 + then show "x \<le> t" by simp
403.275 + qed
403.276 + thus ?thesis by simp
403.277 qed
403.278 qed
403.279 qed
403.280 qed
403.281
403.282 -text{*A version of the same theorem without all those predicates!*}
403.283 -lemma reals_complete2:
403.284 - fixes S :: "(real set)"
403.285 - assumes "\<exists>y. y\<in>S" and "\<exists>(x::real). \<forall>y\<in>S. y \<le> x"
403.286 - shows "\<exists>x. (\<forall>y\<in>S. y \<le> x) &
403.287 - (\<forall>z. ((\<forall>y\<in>S. y \<le> z) --> x \<le> z))"
403.288 -proof -
403.289 - have "\<exists>x. isLub UNIV S x"
403.290 - by (rule reals_complete)
403.291 - (auto simp add: isLub_def isUb_def leastP_def setle_def setge_def assms)
403.292 - thus ?thesis
403.293 - by (metis UNIV_I isLub_isUb isLub_le_isUb isUbD isUb_def setleI)
403.294 -qed
403.295 -
403.296 -
403.297 subsection {* The Archimedean Property of the Reals *}
403.298
403.299 theorem reals_Archimedean:
403.300 @@ -1969,34 +1871,30 @@
403.301 by (rule mult_right_mono)
403.302 thus "x * of_nat (Suc n) \<le> 1" by (simp del: of_nat_Suc)
403.303 qed
403.304 - hence "{z. \<exists>n. z = x * (of_nat (Suc n))} *<= 1"
403.305 - by (simp add: setle_def del: of_nat_Suc, safe, rule spec)
403.306 - hence "isUb (UNIV::real set) {z. \<exists>n. z = x * (of_nat (Suc n))} 1"
403.307 - by (simp add: isUbI)
403.308 - hence "\<exists>Y. isUb (UNIV::real set) {z. \<exists>n. z = x* (of_nat (Suc n))} Y" ..
403.309 - moreover have "\<exists>X. X \<in> {z. \<exists>n. z = x* (of_nat (Suc n))}" by auto
403.310 - ultimately have "\<exists>t. isLub UNIV {z. \<exists>n. z = x * of_nat (Suc n)} t"
403.311 - by (simp add: reals_complete)
403.312 - then obtain "t" where
403.313 - t_is_Lub: "isLub UNIV {z. \<exists>n. z = x * of_nat (Suc n)} t" ..
403.314 + hence 2: "bdd_above {z. \<exists>n. z = x * (of_nat (Suc n))}"
403.315 + by (auto intro!: bdd_aboveI[of _ 1])
403.316 + have 1: "\<exists>X. X \<in> {z. \<exists>n. z = x* (of_nat (Suc n))}" by auto
403.317 + obtain t where
403.318 + upper: "\<And>z. z \<in> {z. \<exists>n. z = x * of_nat (Suc n)} \<Longrightarrow> z \<le> t" and
403.319 + least: "\<And>y. (\<And>a. a \<in> {z. \<exists>n. z = x * of_nat (Suc n)} \<Longrightarrow> a \<le> y) \<Longrightarrow> t \<le> y"
403.320 + using reals_complete[OF 1 2] by auto
403.321
403.322 - have "\<forall>n::nat. x * of_nat n \<le> t + - x"
403.323 - proof
403.324 - fix n
403.325 - from t_is_Lub have "x * of_nat (Suc n) \<le> t"
403.326 - by (simp add: isLubD2)
403.327 - hence "x * (of_nat n) + x \<le> t"
403.328 - by (simp add: distrib_left)
403.329 - thus "x * (of_nat n) \<le> t + - x" by arith
403.330 +
403.331 + have "t \<le> t + - x"
403.332 + proof (rule least)
403.333 + fix a assume a: "a \<in> {z. \<exists>n. z = x * (of_nat (Suc n))}"
403.334 + have "\<forall>n::nat. x * of_nat n \<le> t + - x"
403.335 + proof
403.336 + fix n
403.337 + have "x * of_nat (Suc n) \<le> t"
403.338 + by (simp add: upper)
403.339 + hence "x * (of_nat n) + x \<le> t"
403.340 + by (simp add: distrib_left)
403.341 + thus "x * (of_nat n) \<le> t + - x" by arith
403.342 + qed hence "\<forall>m. x * of_nat (Suc m) \<le> t + - x" by (simp del: of_nat_Suc)
403.343 + with a show "a \<le> t + - x"
403.344 + by auto
403.345 qed
403.346 -
403.347 - hence "\<forall>m. x * of_nat (Suc m) \<le> t + - x" by (simp del: of_nat_Suc)
403.348 - hence "{z. \<exists>n. z = x * (of_nat (Suc n))} *<= (t + - x)"
403.349 - by (auto simp add: setle_def)
403.350 - hence "isUb (UNIV::real set) {z. \<exists>n. z = x * (of_nat (Suc n))} (t + (-x))"
403.351 - by (simp add: isUbI)
403.352 - hence "t \<le> t + - x"
403.353 - using t_is_Lub by (simp add: isLub_le_isUb)
403.354 thus False using x_pos by arith
403.355 qed
403.356
404.1 --- a/src/HOL/ex/Gauge_Integration.thy Thu Dec 05 17:52:12 2013 +0100
404.2 +++ b/src/HOL/ex/Gauge_Integration.thy Thu Dec 05 17:58:03 2013 +0100
404.3 @@ -511,9 +511,9 @@
404.4 case False
404.5 then have "inverse (z - x) * (f z - f x - f' x * (z - x)) = (f z - f x) / (z - x) - f' x"
404.6 apply (subst mult_commute)
404.7 - apply (simp add: distrib_right diff_minus)
404.8 + apply (simp add: left_diff_distrib)
404.9 apply (simp add: mult_assoc divide_inverse)
404.10 - apply (simp add: distrib_right)
404.11 + apply (simp add: ring_distribs)
404.12 done
404.13 moreover from False `\<bar>z - x\<bar> < s` have "\<bar>(f z - f x) / (z - x) - f' x\<bar> < e / 2"
404.14 by (rule P)
405.1 --- a/src/HOL/ex/IArray_Examples.thy Thu Dec 05 17:52:12 2013 +0100
405.2 +++ b/src/HOL/ex/IArray_Examples.thy Thu Dec 05 17:58:03 2013 +0100
405.3 @@ -14,6 +14,12 @@
405.4 lemma "IArray.list_of (IArray.of_fun (%n. n*n) 5) = [0,1,4,9,16]"
405.5 by eval
405.6
405.7 +lemma "\<not> IArray.all (\<lambda>x. x > 2) (IArray [1,3::int])"
405.8 +by eval
405.9 +
405.10 +lemma "IArray.exists (\<lambda>x. x > 2) (IArray [1,3::int])"
405.11 +by eval
405.12 +
405.13 fun sum2 :: "'a::monoid_add iarray \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" where
405.14 "sum2 A n s = (if n=0 then s else sum2 A (n - 1) (s + A!!(n - 1)))"
405.15
406.1 --- a/src/HOL/ex/Meson_Test.thy Thu Dec 05 17:52:12 2013 +0100
406.2 +++ b/src/HOL/ex/Meson_Test.thy Thu Dec 05 17:58:03 2013 +0100
406.3 @@ -24,18 +24,21 @@
406.4 "(\<exists>x. P x) & (\<forall>x. L x --> ~ (M x & R x)) & (\<forall>x. P x --> (M x & L x)) & ((\<forall>x. P x --> Q x) | (\<exists>x. P x & R x)) --> (\<exists>x. Q x & P x)"
406.5 apply (rule ccontr)
406.6 ML_prf {*
406.7 + val ctxt = @{context};
406.8 val prem25 = Thm.assume @{cprop "\<not> ?thesis"};
406.9 - val nnf25 = Meson.make_nnf @{context} prem25;
406.10 - val xsko25 = Meson.skolemize @{context} nnf25;
406.11 + val nnf25 = Meson.make_nnf ctxt prem25;
406.12 + val xsko25 = Meson.skolemize ctxt nnf25;
406.13 *}
406.14 apply (tactic {* cut_tac xsko25 1 THEN REPEAT (etac exE 1) *})
406.15 ML_val {*
406.16 - val [_, sko25] = #prems (#1 (Subgoal.focus @{context} 1 (#goal @{Isar.goal})));
406.17 - val clauses25 = Meson.make_clauses @{context} [sko25]; (*7 clauses*)
406.18 + val ctxt = @{context};
406.19 + val [_, sko25] = #prems (#1 (Subgoal.focus ctxt 1 (#goal @{Isar.goal})));
406.20 + val clauses25 = Meson.make_clauses ctxt [sko25]; (*7 clauses*)
406.21 val horns25 = Meson.make_horns clauses25; (*16 Horn clauses*)
406.22 val go25 :: _ = Meson.gocls clauses25;
406.23
406.24 - Goal.prove @{context} [] [] @{prop False} (fn _ =>
406.25 + val (_, ctxt') = Assumption.add_assumes (maps (#hyps o Thm.crep_thm) (go25 :: horns25)) ctxt;
406.26 + Goal.prove ctxt' [] [] @{prop False} (fn _ =>
406.27 rtac go25 1 THEN
406.28 Meson.depth_prolog_tac horns25);
406.29 *}
406.30 @@ -45,18 +48,23 @@
406.31 "((\<exists>x. p x) = (\<exists>x. q x)) & (\<forall>x. \<forall>y. p x & q y --> (r x = s y)) --> ((\<forall>x. p x --> r x) = (\<forall>x. q x --> s x))"
406.32 apply (rule ccontr)
406.33 ML_prf {*
406.34 + val ctxt = @{context};
406.35 val prem26 = Thm.assume @{cprop "\<not> ?thesis"}
406.36 - val nnf26 = Meson.make_nnf @{context} prem26;
406.37 - val xsko26 = Meson.skolemize @{context} nnf26;
406.38 + val nnf26 = Meson.make_nnf ctxt prem26;
406.39 + val xsko26 = Meson.skolemize ctxt nnf26;
406.40 *}
406.41 apply (tactic {* cut_tac xsko26 1 THEN REPEAT (etac exE 1) *})
406.42 ML_val {*
406.43 - val [_, sko26] = #prems (#1 (Subgoal.focus @{context} 1 (#goal @{Isar.goal})));
406.44 - val clauses26 = Meson.make_clauses @{context} [sko26]; (*9 clauses*)
406.45 - val horns26 = Meson.make_horns clauses26; (*24 Horn clauses*)
406.46 + val ctxt = @{context};
406.47 + val [_, sko26] = #prems (#1 (Subgoal.focus ctxt 1 (#goal @{Isar.goal})));
406.48 + val clauses26 = Meson.make_clauses ctxt [sko26];
406.49 + val _ = @{assert} (length clauses26 = 9);
406.50 + val horns26 = Meson.make_horns clauses26;
406.51 + val _ = @{assert} (length horns26 = 24);
406.52 val go26 :: _ = Meson.gocls clauses26;
406.53
406.54 - Goal.prove @{context} [] [] @{prop False} (fn _ =>
406.55 + val (_, ctxt') = Assumption.add_assumes (maps (#hyps o Thm.crep_thm) (go26 :: horns26)) ctxt;
406.56 + Goal.prove ctxt' [] [] @{prop False} (fn _ =>
406.57 rtac go26 1 THEN
406.58 Meson.depth_prolog_tac horns26); (*7 ms*)
406.59 (*Proof is of length 107!!*)
406.60 @@ -67,18 +75,23 @@
406.61 "(\<forall>x. \<forall>y. q x y = (\<forall>z. p z x = (p z y::bool))) --> (\<forall>x. (\<forall>y. q x y = (q y x::bool)))"
406.62 apply (rule ccontr)
406.63 ML_prf {*
406.64 + val ctxt = @{context};
406.65 val prem43 = Thm.assume @{cprop "\<not> ?thesis"};
406.66 - val nnf43 = Meson.make_nnf @{context} prem43;
406.67 - val xsko43 = Meson.skolemize @{context} nnf43;
406.68 + val nnf43 = Meson.make_nnf ctxt prem43;
406.69 + val xsko43 = Meson.skolemize ctxt nnf43;
406.70 *}
406.71 apply (tactic {* cut_tac xsko43 1 THEN REPEAT (etac exE 1) *})
406.72 ML_val {*
406.73 - val [_, sko43] = #prems (#1 (Subgoal.focus @{context} 1 (#goal @{Isar.goal})));
406.74 - val clauses43 = Meson.make_clauses @{context} [sko43]; (*6*)
406.75 - val horns43 = Meson.make_horns clauses43; (*16*)
406.76 + val ctxt = @{context};
406.77 + val [_, sko43] = #prems (#1 (Subgoal.focus ctxt 1 (#goal @{Isar.goal})));
406.78 + val clauses43 = Meson.make_clauses ctxt [sko43];
406.79 + val _ = @{assert} (length clauses43 = 6);
406.80 + val horns43 = Meson.make_horns clauses43;
406.81 + val _ = @{assert} (length horns43 = 16);
406.82 val go43 :: _ = Meson.gocls clauses43;
406.83
406.84 - Goal.prove @{context} [] [] @{prop False} (fn _ =>
406.85 + val (_, ctxt') = Assumption.add_assumes (maps (#hyps o Thm.crep_thm) (go43 :: horns43)) ctxt;
406.86 + Goal.prove ctxt' [] [] @{prop False} (fn _ =>
406.87 rtac go43 1 THEN
406.88 Meson.best_prolog_tac Meson.size_of_subgoals horns43); (*7ms*)
406.89 *}
407.1 --- a/src/HOL/ex/Set_Comprehension_Pointfree_Tests.thy Thu Dec 05 17:52:12 2013 +0100
407.2 +++ b/src/HOL/ex/Set_Comprehension_Pointfree_Tests.thy Thu Dec 05 17:58:03 2013 +0100
407.3 @@ -9,6 +9,8 @@
407.4 imports Main
407.5 begin
407.6
407.7 +declare [[simproc add: finite_Collect]]
407.8 +
407.9 lemma
407.10 "finite (UNIV::'a set) ==> finite {p. EX x::'a. p = (x, x)}"
407.11 by simp
407.12 @@ -114,6 +116,8 @@
407.13 = finite ((\<lambda>(b :: ?'B, a:: ?'A). Pair_Rep a b) ` (UNIV \<times> UNIV))"
407.14 by simp
407.15
407.16 +declare [[simproc del: finite_Collect]]
407.17 +
407.18
407.19 section {* Testing simproc in code generation *}
407.20
408.1 --- a/src/Provers/Arith/cancel_numerals.ML Thu Dec 05 17:52:12 2013 +0100
408.2 +++ b/src/Provers/Arith/cancel_numerals.ML Thu Dec 05 17:58:03 2013 +0100
408.3 @@ -70,7 +70,7 @@
408.4 val prems = Simplifier.prems_of ctxt
408.5 val ([t'], ctxt') = Variable.import_terms true [t] ctxt
408.6 val export = singleton (Variable.export ctxt' ctxt)
408.7 - (* FIXME ctxt cs. ctxt' (!?) *)
408.8 + (* FIXME ctxt vs. ctxt' (!?) *)
408.9
408.10 val (t1,t2) = Data.dest_bal t'
408.11 val terms1 = Data.dest_sum t1
409.1 --- a/src/Provers/splitter.ML Thu Dec 05 17:52:12 2013 +0100
409.2 +++ b/src/Provers/splitter.ML Thu Dec 05 17:58:03 2013 +0100
409.3 @@ -79,6 +79,8 @@
409.4 fold add_thm splits []
409.5 end;
409.6
409.7 +val abss = fold (Term.abs o pair "");
409.8 +
409.9 (* ------------------------------------------------------------------------- *)
409.10 (* mk_case_split_tac *)
409.11 (* ------------------------------------------------------------------------- *)
409.12 @@ -100,31 +102,36 @@
409.13 (Syntax.read_prop_global Pure.thy "P(%x. Q(x)) == P(%x. R(x))")
409.14 (fn {prems, ...} => rewrite_goals_tac prems THEN rtac reflexive_thm 1)
409.15
409.16 +val _ $ _ $ (_ $ (_ $ abs_lift) $ _) = prop_of lift;
409.17 +
409.18 val trlift = lift RS transitive_thm;
409.19 -val _ $ (P $ _) $ _ = concl_of trlift;
409.20
409.21
409.22 (************************************************************************
409.23 Set up term for instantiation of P in the lift-theorem
409.24
409.25 - Ts : types of parameters (i.e. variables bound by meta-quantifiers)
409.26 t : lefthand side of meta-equality in subgoal
409.27 the lift theorem is applied to (see select)
409.28 pos : "path" leading to abstraction, coded as a list
409.29 T : type of body of P(...)
409.30 - maxi : maximum index of Vars
409.31 *************************************************************************)
409.32
409.33 -fun mk_cntxt Ts t pos T maxi =
409.34 - let fun var (t,i) = Var(("X",i),type_of1(Ts,t));
409.35 - fun down [] t i = Bound 0
409.36 - | down (p::ps) t i =
409.37 - let val (h,ts) = strip_comb t
409.38 - val v1 = ListPair.map var (take p ts, i upto (i+p-1))
409.39 - val u::us = drop p ts
409.40 - val v2 = ListPair.map var (us, (i+p) upto (i+length(ts)-2))
409.41 - in list_comb(h,v1@[down ps u (i+length ts)]@v2) end;
409.42 - in Abs("", T, down (rev pos) t maxi) end;
409.43 +fun mk_cntxt t pos T =
409.44 + let
409.45 + fun down [] t = (Bound 0, t)
409.46 + | down (p :: ps) t =
409.47 + let
409.48 + val (h, ts) = strip_comb t
409.49 + val (ts1, u :: ts2) = chop p ts
409.50 + val (u1, u2) = down ps u
409.51 + in
409.52 + (list_comb (incr_boundvars 1 h,
409.53 + map (incr_boundvars 1) ts1 @ u1 ::
409.54 + map (incr_boundvars 1) ts2),
409.55 + u2)
409.56 + end;
409.57 + val (u1, u2) = down (rev pos) t
409.58 + in (Abs ("", T, u1), u2) end;
409.59
409.60
409.61 (************************************************************************
409.62 @@ -301,15 +308,18 @@
409.63 the split theorem is applied to (see cmap)
409.64 T,U,pos : see mk_split_pack
409.65 state : current proof state
409.66 - lift : the lift theorem
409.67 i : no. of subgoal
409.68 **************************************************************)
409.69
409.70 fun inst_lift Ts t (T, U, pos) state i =
409.71 let
409.72 val cert = cterm_of (Thm.theory_of_thm state);
409.73 - val cntxt = mk_cntxt Ts t pos (T --> U) (Thm.maxidx_of trlift);
409.74 - in cterm_instantiate [(cert P, cert cntxt)] trlift
409.75 + val (cntxt, u) = mk_cntxt t pos (T --> U);
409.76 + val trlift' = Thm.lift_rule (Thm.cprem_of state i)
409.77 + (Thm.rename_boundvars abs_lift u trlift);
409.78 + val (P, _) = strip_comb (fst (Logic.dest_equals
409.79 + (Logic.strip_assums_concl (Thm.prop_of trlift'))));
409.80 + in cterm_instantiate [(cert P, cert (abss Ts cntxt))] trlift'
409.81 end;
409.82
409.83
409.84 @@ -333,7 +343,6 @@
409.85 (Logic.strip_assums_concl (Thm.prop_of thm'))));
409.86 val cert = cterm_of (Thm.theory_of_thm state);
409.87 val cntxt = mk_cntxt_splitthm t tt TB;
409.88 - val abss = fold (fn T => fn t => Abs ("", T, t));
409.89 in cterm_instantiate [(cert P, cert (abss Ts cntxt))] thm'
409.90 end;
409.91
409.92 @@ -348,7 +357,7 @@
409.93 fun split_tac [] i = no_tac
409.94 | split_tac splits i =
409.95 let val cmap = cmap_of_split_thms splits
409.96 - fun lift_tac Ts t p st = rtac (inst_lift Ts t p st i) i st
409.97 + fun lift_tac Ts t p st = compose_tac (false, inst_lift Ts t p st i, 2) i st
409.98 fun lift_split_tac state =
409.99 let val (Ts, t, splits) = select cmap state i
409.100 in case splits of
410.1 --- a/src/Pure/Concurrent/future.ML Thu Dec 05 17:52:12 2013 +0100
410.2 +++ b/src/Pure/Concurrent/future.ML Thu Dec 05 17:58:03 2013 +0100
410.3 @@ -438,7 +438,7 @@
410.4 Position.setmp_thread_data pos (fn () =>
410.5 let val id = Position.get_id pos in
410.6 if is_none id orelse is_none exec_id orelse id = exec_id
410.7 - then Output.error_msg' (serial, msg) else ()
410.8 + then Output.error_message' (serial, msg) else ()
410.9 end) ();
410.10
410.11 fun identify_result pos res =
411.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
411.2 +++ b/src/Pure/General/bytes.scala Thu Dec 05 17:58:03 2013 +0100
411.3 @@ -0,0 +1,114 @@
411.4 +/* Title: Pure/General/bytes.scala
411.5 + Module: PIDE
411.6 + Author: Makarius
411.7 +
411.8 +Immutable byte vectors versus UTF8 strings.
411.9 +*/
411.10 +
411.11 +package isabelle
411.12 +
411.13 +
411.14 +import java.io.{File => JFile, OutputStream, FileInputStream}
411.15 +
411.16 +
411.17 +object Bytes
411.18 +{
411.19 + val empty: Bytes = new Bytes(Array[Byte](), 0, 0)
411.20 +
411.21 + def apply(s: CharSequence): Bytes =
411.22 + {
411.23 + val str = s.toString
411.24 + if (str.isEmpty) empty
411.25 + else {
411.26 + val b = str.getBytes(UTF8.charset)
411.27 + new Bytes(b, 0, b.length)
411.28 + }
411.29 + }
411.30 +
411.31 + def apply(a: Array[Byte], offset: Int, length: Int): Bytes =
411.32 + if (length == 0) empty
411.33 + else {
411.34 + val b = new Array[Byte](length)
411.35 + java.lang.System.arraycopy(a, offset, b, 0, length)
411.36 + new Bytes(b, 0, b.length)
411.37 + }
411.38 +
411.39 +
411.40 + /* read */
411.41 +
411.42 + def read(file: JFile): Bytes =
411.43 + {
411.44 + var i = 0
411.45 + var m = 0
411.46 + val n = file.length.toInt
411.47 + val bytes = new Array[Byte](n)
411.48 +
411.49 + val stream = new FileInputStream(file)
411.50 + try {
411.51 + do {
411.52 + m = stream.read(bytes, i, n - i)
411.53 + if (m != -1) i += m
411.54 + } while (m != -1 && n > i)
411.55 + }
411.56 + finally { stream.close }
411.57 +
411.58 + new Bytes(bytes, 0, bytes.length)
411.59 + }
411.60 +}
411.61 +
411.62 +final class Bytes private(
411.63 + protected val bytes: Array[Byte],
411.64 + protected val offset: Int,
411.65 + val length: Int)
411.66 +{
411.67 + /* equality */
411.68 +
411.69 + override def equals(that: Any): Boolean =
411.70 + {
411.71 + that match {
411.72 + case other: Bytes =>
411.73 + if (this eq other) true
411.74 + else if (length != other.length) false
411.75 + else (0 until length).forall(i => bytes(offset + i) == other.bytes(other.offset + i))
411.76 + case _ => false
411.77 + }
411.78 + }
411.79 +
411.80 + private lazy val hash: Int =
411.81 + {
411.82 + var h = 0
411.83 + for (i <- offset until offset + length) {
411.84 + val b = bytes(i).asInstanceOf[Int] & 0xFF
411.85 + h = 31 * h + b
411.86 + }
411.87 + h
411.88 + }
411.89 +
411.90 + override def hashCode(): Int = hash
411.91 +
411.92 +
411.93 + /* content */
411.94 +
411.95 + lazy val sha1_digest: SHA1.Digest = SHA1.digest(bytes)
411.96 +
411.97 + override def toString: String =
411.98 + UTF8.decode_chars(s => s, bytes, offset, offset + length).toString
411.99 +
411.100 + def isEmpty: Boolean = length == 0
411.101 +
411.102 + def +(other: Bytes): Bytes =
411.103 + if (other.isEmpty) this
411.104 + else if (isEmpty) other
411.105 + else {
411.106 + val new_bytes = new Array[Byte](length + other.length)
411.107 + java.lang.System.arraycopy(bytes, offset, new_bytes, 0, length)
411.108 + java.lang.System.arraycopy(other.bytes, other.offset, new_bytes, length, other.length)
411.109 + new Bytes(new_bytes, 0, new_bytes.length)
411.110 + }
411.111 +
411.112 +
411.113 + /* write */
411.114 +
411.115 + def write(stream: OutputStream): Unit = stream.write(bytes, offset, length)
411.116 +}
411.117 +
412.1 --- a/src/Pure/General/file.scala Thu Dec 05 17:52:12 2013 +0100
412.2 +++ b/src/Pure/General/file.scala Thu Dec 05 17:58:03 2013 +0100
412.3 @@ -36,25 +36,7 @@
412.4
412.5 /* read */
412.6
412.7 - def read_bytes(file: JFile): Array[Byte] =
412.8 - {
412.9 - var i = 0
412.10 - var m = 0
412.11 - val n = file.length.toInt
412.12 - val buf = new Array[Byte](n)
412.13 -
412.14 - val stream = new FileInputStream(file)
412.15 - try {
412.16 - do {
412.17 - m = stream.read(buf, i, n - i)
412.18 - if (m != -1) i += m
412.19 - } while (m != -1 && n > i)
412.20 - }
412.21 - finally { stream.close }
412.22 - buf
412.23 - }
412.24 -
412.25 - def read(file: JFile): String = new String(read_bytes(file), UTF8.charset)
412.26 + def read(file: JFile): String = Bytes.read(file).toString
412.27 def read(path: Path): String = read(path.file)
412.28
412.29
413.1 --- a/src/Pure/General/output.ML Thu Dec 05 17:52:12 2013 +0100
413.2 +++ b/src/Pure/General/output.ML Thu Dec 05 17:58:03 2013 +0100
413.3 @@ -31,7 +31,7 @@
413.4 val urgent_message_fn: (output -> unit) Unsynchronized.ref
413.5 val tracing_fn: (output -> unit) Unsynchronized.ref
413.6 val warning_fn: (output -> unit) Unsynchronized.ref
413.7 - val error_fn: (serial * output -> unit) Unsynchronized.ref
413.8 + val error_message_fn: (serial * output -> unit) Unsynchronized.ref
413.9 val prompt_fn: (output -> unit) Unsynchronized.ref
413.10 val status_fn: (output -> unit) Unsynchronized.ref
413.11 val report_fn: (output -> unit) Unsynchronized.ref
413.12 @@ -39,8 +39,8 @@
413.13 val protocol_message_fn: (Properties.T -> output -> unit) Unsynchronized.ref
413.14 end
413.15 val urgent_message: string -> unit
413.16 - val error_msg': serial * string -> unit
413.17 - val error_msg: string -> unit
413.18 + val error_message': serial * string -> unit
413.19 + val error_message: string -> unit
413.20 val prompt: string -> unit
413.21 val status: string -> unit
413.22 val report: string -> unit
413.23 @@ -98,7 +98,8 @@
413.24 val urgent_message_fn = Unsynchronized.ref (fn s => ! writeln_fn s); (*Proof General legacy*)
413.25 val tracing_fn = Unsynchronized.ref (fn s => ! writeln_fn s);
413.26 val warning_fn = Unsynchronized.ref (physical_writeln o prefix_lines "### ");
413.27 - val error_fn = Unsynchronized.ref (fn (_: serial, s) => physical_writeln (prefix_lines "*** " s));
413.28 + val error_message_fn =
413.29 + Unsynchronized.ref (fn (_: serial, s) => physical_writeln (prefix_lines "*** " s));
413.30 val prompt_fn = Unsynchronized.ref physical_stdout;
413.31 val status_fn = Unsynchronized.ref (fn _: output => ());
413.32 val report_fn = Unsynchronized.ref (fn _: output => ());
413.33 @@ -111,8 +112,8 @@
413.34 fun urgent_message s = ! Internal.urgent_message_fn (output s); (*Proof General legacy*)
413.35 fun tracing s = ! Internal.tracing_fn (output s);
413.36 fun warning s = ! Internal.warning_fn (output s);
413.37 -fun error_msg' (i, s) = ! Internal.error_fn (i, output s);
413.38 -fun error_msg s = error_msg' (serial (), s);
413.39 +fun error_message' (i, s) = ! Internal.error_message_fn (i, output s);
413.40 +fun error_message s = error_message' (serial (), s);
413.41 fun prompt s = ! Internal.prompt_fn (output s);
413.42 fun status s = ! Internal.status_fn (output s);
413.43 fun report s = ! Internal.report_fn (output s);
414.1 --- a/src/Pure/General/sha1.scala Thu Dec 05 17:52:12 2013 +0100
414.2 +++ b/src/Pure/General/sha1.scala Thu Dec 05 17:58:03 2013 +0100
414.3 @@ -56,6 +56,8 @@
414.4 make_result(digest)
414.5 }
414.6
414.7 - def digest(string: String): Digest = digest(UTF8.string_bytes(string))
414.8 + def digest(bytes: Bytes): Digest = bytes.sha1_digest
414.9 +
414.10 + def digest(string: String): Digest = digest(Bytes(string))
414.11 }
414.12
415.1 --- a/src/Pure/General/source.ML Thu Dec 05 17:52:12 2013 +0100
415.2 +++ b/src/Pure/General/source.ML Thu Dec 05 17:58:03 2013 +0100
415.3 @@ -156,8 +156,9 @@
415.4 NONE => drain (Scan.error scan) inp
415.5 | SOME (interactive, recover) =>
415.6 (drain (Scan.catch scan) inp handle Fail msg =>
415.7 - (if interactive then Output.error_msg msg else ();
415.8 - drain (Scan.unless (Scan.lift (Scan.one (Scan.is_stopper stopper))) (recover msg)) inp)));
415.9 + (if interactive then Output.error_message msg else ();
415.10 + drain (Scan.unless (Scan.lift (Scan.one (Scan.is_stopper stopper))) (recover msg))
415.11 + inp)));
415.12 in (ys, (state', unget (xs', src'))) end;
415.13
415.14 fun source' init_state stopper scan recover src =
416.1 --- a/src/Pure/Isar/code.ML Thu Dec 05 17:52:12 2013 +0100
416.2 +++ b/src/Pure/Isar/code.ML Thu Dec 05 17:58:03 2013 +0100
416.3 @@ -140,7 +140,7 @@
416.4 fun check_unoverload thy (c, ty) =
416.5 let
416.6 val c' = Axclass.unoverload_const thy (c, ty);
416.7 - val ty_decl = Sign.the_const_type thy c';
416.8 + val ty_decl = const_typ thy c';
416.9 in
416.10 if typscheme_equiv (ty_decl, Logic.varifyT_global ty)
416.11 then c'
416.12 @@ -356,7 +356,7 @@
416.13 fun analyze_constructor thy (c, ty) =
416.14 let
416.15 val _ = Thm.cterm_of thy (Const (c, ty));
416.16 - val ty_decl = Logic.unvarifyT_global (const_typ thy c);
416.17 + val ty_decl = devarify (const_typ thy c);
416.18 fun last_typ c_ty ty =
416.19 let
416.20 val tfrees = Term.add_tfreesT ty [];
416.21 @@ -450,7 +450,7 @@
416.22
416.23 fun check_decl_ty thy (c, ty) =
416.24 let
416.25 - val ty_decl = Sign.the_const_type thy c;
416.26 + val ty_decl = const_typ thy c;
416.27 in if typscheme_equiv (ty_decl, ty) then ()
416.28 else bad_thm ("Type\n" ^ string_of_typ thy ty
416.29 ^ "\nof constant " ^ quote c
416.30 @@ -664,7 +664,7 @@
416.31 handle TERM _ => bad_thm "Not an abstype certificate";
416.32 val _ = if param = rhs then () else bad_thm "Not an abstype certificate";
416.33 val ((tyco, sorts), (abs, (vs, ty'))) =
416.34 - analyze_constructor thy (abs, Logic.unvarifyT_global raw_ty);
416.35 + analyze_constructor thy (abs, devarify raw_ty);
416.36 val ty = domain_type ty';
416.37 val (vs', _) = typscheme thy (abs, ty');
416.38 in (tyco, (vs ~~ sorts, ((abs, (vs', ty)), (rep, thm)))) end;
416.39 @@ -729,7 +729,7 @@
416.40
416.41 fun empty_cert thy c =
416.42 let
416.43 - val raw_ty = Logic.unvarifyT_global (const_typ thy c);
416.44 + val raw_ty = devarify (const_typ thy c);
416.45 val (vs, _) = typscheme thy (c, raw_ty);
416.46 val sortargs = case Axclass.class_of_param thy c
416.47 of SOME class => [[class]]
416.48 @@ -1124,7 +1124,7 @@
416.49 val ([x, y], ctxt) = fold_map Name.variant ["A", "A'"] Name.context;
416.50 val (zs, _) = fold_map Name.variant (replicate (num_args - 1) "") ctxt;
416.51 val (ws, vs) = chop pos zs;
416.52 - val T = Logic.unvarifyT_global (Sign.the_const_type thy case_const);
416.53 + val T = devarify (const_typ thy case_const);
416.54 val Ts = binder_types T;
416.55 val T_cong = nth Ts pos;
416.56 fun mk_prem z = Free (z, T_cong);
417.1 --- a/src/Pure/Isar/expression.ML Thu Dec 05 17:52:12 2013 +0100
417.2 +++ b/src/Pure/Isar/expression.ML Thu Dec 05 17:58:03 2013 +0100
417.3 @@ -676,8 +676,11 @@
417.4 val conjuncts =
417.5 (Drule.equal_elim_rule2 OF [body_eq, rewrite_rule [pred_def] (Thm.assume (cert statement))])
417.6 |> Conjunction.elim_balanced (length ts);
417.7 +
417.8 + val (_, axioms_ctxt) = defs_ctxt
417.9 + |> Assumption.add_assumes (maps (#hyps o Thm.crep_thm) (defs @ conjuncts));
417.10 val axioms = ts ~~ conjuncts |> map (fn (t, ax) =>
417.11 - Element.prove_witness defs_ctxt t
417.12 + Element.prove_witness axioms_ctxt t
417.13 (rewrite_goals_tac defs THEN compose_tac (false, ax, 0) 1));
417.14 in ((statement, intro, axioms), defs_thy) end;
417.15
418.1 --- a/src/Pure/Isar/keyword.ML Thu Dec 05 17:52:12 2013 +0100
418.2 +++ b/src/Pure/Isar/keyword.ML Thu Dec 05 17:58:03 2013 +0100
418.3 @@ -51,7 +51,7 @@
418.4 val get_lexicons: unit -> Scan.lexicon * Scan.lexicon
418.5 val is_keyword: string -> bool
418.6 val command_keyword: string -> T option
418.7 - val command_files: string -> string list
418.8 + val command_files: string -> Path.T -> Path.T list
418.9 val command_tags: string -> string list
418.10 val dest: unit -> string list * string list
418.11 val define: string * T option -> unit
418.12 @@ -196,7 +196,15 @@
418.13 in Scan.is_literal minor syms orelse Scan.is_literal major syms end;
418.14
418.15 fun command_keyword name = Symtab.lookup (get_commands ()) name;
418.16 -val command_files = these o Option.map (#2 o kind_files_of) o command_keyword;
418.17 +
418.18 +fun command_files name path =
418.19 + (case command_keyword name of
418.20 + NONE => []
418.21 + | SOME (Keyword {kind, files, ...}) =>
418.22 + if kind <> kind_of thy_load then []
418.23 + else if null files then [path]
418.24 + else map (fn ext => Path.ext ext path) files);
418.25 +
418.26 val command_tags = these o Option.map tags_of o command_keyword;
418.27
418.28 fun dest () = pairself (sort_strings o Scan.dest_lexicon) (get_lexicons ());
419.1 --- a/src/Pure/Isar/outer_syntax.scala Thu Dec 05 17:52:12 2013 +0100
419.2 +++ b/src/Pure/Isar/outer_syntax.scala Thu Dec 05 17:58:03 2013 +0100
419.3 @@ -56,7 +56,13 @@
419.4 def keyword_kind_files(name: String): Option[(String, List[String])] = keywords.get(name)
419.5 def keyword_kind(name: String): Option[String] = keyword_kind_files(name).map(_._1)
419.6
419.7 - def thy_load_commands: List[(String, List[String])] =
419.8 + def thy_load(span: List[Token]): Option[List[String]] =
419.9 + keywords.get(Command.name(span)) match {
419.10 + case Some((Keyword.THY_LOAD, exts)) => Some(exts)
419.11 + case _ => None
419.12 + }
419.13 +
419.14 + val thy_load_commands: List[(String, List[String])] =
419.15 (for ((name, (Keyword.THY_LOAD, files)) <- keywords.iterator) yield (name, files)).toList
419.16
419.17 def + (name: String, kind: (String, List[String]), replace: Option[String]): Outer_Syntax =
420.1 --- a/src/Pure/Isar/proof.ML Thu Dec 05 17:52:12 2013 +0100
420.2 +++ b/src/Pure/Isar/proof.ML Thu Dec 05 17:58:03 2013 +0100
420.3 @@ -480,28 +480,25 @@
420.4 fun conclude_goal ctxt goal propss =
420.5 let
420.6 val thy = Proof_Context.theory_of ctxt;
420.7 - val string_of_term = Syntax.string_of_term ctxt;
420.8 - val string_of_thm = Display.string_of_thm ctxt;
420.9
420.10 val _ = Thm.no_prems goal orelse error (Proof_Display.string_of_goal ctxt goal);
420.11
420.12 - val extra_hyps = Assumption.extra_hyps ctxt goal;
420.13 - val _ = null extra_hyps orelse
420.14 - error ("Additional hypotheses:\n" ^ cat_lines (map string_of_term extra_hyps));
420.15 + fun lost_structure () = error ("Lost goal structure:\n" ^ Display.string_of_thm ctxt goal);
420.16
420.17 - fun lost_structure () = error ("Lost goal structure:\n" ^ string_of_thm goal);
420.18 + val th =
420.19 + (Goal.conclude (if length (flat propss) > 1 then Thm.norm_proof goal else goal)
420.20 + handle THM _ => lost_structure ())
420.21 + |> Drule.flexflex_unique
420.22 + |> Thm.check_shyps (Variable.sorts_of ctxt)
420.23 + |> Assumption.check_hyps ctxt;
420.24
420.25 - val th = Goal.conclude
420.26 - (if length (flat propss) > 1 then Thm.norm_proof goal else goal)
420.27 - handle THM _ => lost_structure ();
420.28 val goal_propss = filter_out null propss;
420.29 val results =
420.30 Conjunction.elim_balanced (length goal_propss) th
420.31 |> map2 Conjunction.elim_balanced (map length goal_propss)
420.32 handle THM _ => lost_structure ();
420.33 val _ = Unify.matches_list thy (flat goal_propss) (map Thm.prop_of (flat results)) orelse
420.34 - error ("Proved a different theorem:\n" ^ string_of_thm th);
420.35 - val _ = Thm.check_shyps (Variable.sorts_of ctxt) th;
420.36 + error ("Proved a different theorem:\n" ^ Display.string_of_thm ctxt th);
420.37
420.38 fun recover_result ([] :: pss) thss = [] :: recover_result pss thss
420.39 | recover_result (_ :: pss) (ths :: thss) = ths :: recover_result pss thss
421.1 --- a/src/Pure/Isar/token.ML Thu Dec 05 17:52:12 2013 +0100
421.2 +++ b/src/Pure/Isar/token.ML Thu Dec 05 17:58:03 2013 +0100
421.3 @@ -13,7 +13,7 @@
421.4 type file = {src_path: Path.T, text: string, pos: Position.T}
421.5 datatype value =
421.6 Text of string | Typ of typ | Term of term | Fact of thm list |
421.7 - Attribute of morphism -> attribute | Files of file list
421.8 + Attribute of morphism -> attribute | Files of file Exn.result list
421.9 type T
421.10 val str_of_kind: kind -> string
421.11 val position_of: T -> Position.T
421.12 @@ -46,8 +46,8 @@
421.13 val content_of: T -> string
421.14 val unparse: T -> string
421.15 val text_of: T -> string * string
421.16 - val get_files: T -> file list option
421.17 - val put_files: file list -> T -> T
421.18 + val get_files: T -> file Exn.result list
421.19 + val put_files: file Exn.result list -> T -> T
421.20 val get_value: T -> value option
421.21 val map_value: (value -> value) -> T -> T
421.22 val mk_text: string -> T
421.23 @@ -88,7 +88,7 @@
421.24 Term of term |
421.25 Fact of thm list |
421.26 Attribute of morphism -> attribute |
421.27 - Files of file list;
421.28 + Files of file Exn.result list;
421.29
421.30 datatype slot =
421.31 Slot |
421.32 @@ -244,10 +244,11 @@
421.33
421.34 (* inlined file content *)
421.35
421.36 -fun get_files (Token (_, _, Value (SOME (Files files)))) = SOME files
421.37 - | get_files _ = NONE;
421.38 +fun get_files (Token (_, _, Value (SOME (Files files)))) = files
421.39 + | get_files _ = [];
421.40
421.41 -fun put_files files (Token (x, y, Slot)) = Token (x, y, Value (SOME (Files files)))
421.42 +fun put_files [] tok = tok
421.43 + | put_files files (Token (x, y, Slot)) = Token (x, y, Value (SOME (Files files)))
421.44 | put_files _ tok =
421.45 raise Fail ("Cannot put inlined files here" ^ Position.here (position_of tok));
421.46
422.1 --- a/src/Pure/Isar/toplevel.ML Thu Dec 05 17:52:12 2013 +0100
422.2 +++ b/src/Pure/Isar/toplevel.ML Thu Dec 05 17:58:03 2013 +0100
422.3 @@ -242,7 +242,7 @@
422.4 fun program body =
422.5 (body
422.6 |> controlled_execution
422.7 - |> Runtime.toplevel_error (Output.error_msg o ML_Compiler.exn_message)) ();
422.8 + |> Runtime.toplevel_error ML_Compiler.exn_error_message) ();
422.9
422.10 fun thread interrupts body =
422.11 Thread.fork
423.1 --- a/src/Pure/ML/ml_compiler.ML Thu Dec 05 17:52:12 2013 +0100
423.2 +++ b/src/Pure/ML/ml_compiler.ML Thu Dec 05 17:58:03 2013 +0100
423.3 @@ -9,6 +9,7 @@
423.4 val exn_messages_ids: exn -> Runtime.error list
423.5 val exn_messages: exn -> (serial * string) list
423.6 val exn_message: exn -> string
423.7 + val exn_error_message: exn -> unit
423.8 val exn_trace: (unit -> 'a) -> 'a
423.9 val eval: bool -> Position.T -> ML_Lex.token list -> unit
423.10 end
423.11 @@ -23,6 +24,8 @@
423.12 val exn_messages_ids = Runtime.exn_messages_ids exn_info;
423.13 val exn_messages = Runtime.exn_messages exn_info;
423.14 val exn_message = Runtime.exn_message exn_info;
423.15 +
423.16 +val exn_error_message = Output.error_message o exn_message;
423.17 fun exn_trace e = print_exception_trace exn_message e;
423.18
423.19 fun eval verbose pos toks =
424.1 --- a/src/Pure/ML/ml_compiler_polyml.ML Thu Dec 05 17:52:12 2013 +0100
424.2 +++ b/src/Pure/ML/ml_compiler_polyml.ML Thu Dec 05 17:58:03 2013 +0100
424.3 @@ -36,6 +36,8 @@
424.4 val exn_messages_ids = Runtime.exn_messages_ids exn_info;
424.5 val exn_messages = Runtime.exn_messages exn_info;
424.6 val exn_message = Runtime.exn_message exn_info;
424.7 +
424.8 +val exn_error_message = Output.error_message o exn_message;
424.9 fun exn_trace e = print_exception_trace exn_message e;
424.10
424.11
424.12 @@ -103,7 +105,7 @@
424.13
424.14 val writeln_buffer = Unsynchronized.ref Buffer.empty;
424.15 fun write s = Unsynchronized.change writeln_buffer (Buffer.add s);
424.16 - fun output_writeln () = writeln (Buffer.content (! writeln_buffer));
424.17 + fun output_writeln () = writeln (trim_line (Buffer.content (! writeln_buffer)));
424.18
424.19 val warnings = Unsynchronized.ref ([]: string list);
424.20 fun warn msg = Unsynchronized.change warnings (cons msg);
425.1 --- a/src/Pure/PIDE/command.ML Thu Dec 05 17:52:12 2013 +0100
425.2 +++ b/src/Pure/PIDE/command.ML Thu Dec 05 17:58:03 2013 +0100
425.3 @@ -6,13 +6,15 @@
425.4
425.5 signature COMMAND =
425.6 sig
425.7 - val read: (unit -> theory) -> Token.T list -> Toplevel.transition
425.8 + type blob = (string * string option) Exn.result
425.9 + val read_file: Path.T -> Position.T -> Path.T -> Token.file
425.10 + val read: (unit -> theory) -> Path.T -> blob list -> Token.T list -> Toplevel.transition
425.11 type eval
425.12 val eval_eq: eval * eval -> bool
425.13 val eval_running: eval -> bool
425.14 val eval_finished: eval -> bool
425.15 val eval_result_state: eval -> Toplevel.state
425.16 - val eval: (unit -> theory) -> Token.T list -> eval -> eval
425.17 + val eval: (unit -> theory) -> Path.T -> blob list -> Token.T list -> eval -> eval
425.18 type print
425.19 val print: bool -> (string * string list) list -> string ->
425.20 eval -> print list -> print list option
425.21 @@ -84,7 +86,38 @@
425.22
425.23 (* read *)
425.24
425.25 -fun read init span =
425.26 +type blob = (string * string option) Exn.result; (*file node name, digest or text*)
425.27 +
425.28 +fun read_file master_dir pos src_path =
425.29 + let
425.30 + val full_path = File.check_file (File.full_path master_dir src_path);
425.31 + val _ = Position.report pos (Markup.path (Path.implode full_path));
425.32 + in {src_path = src_path, text = File.read full_path, pos = Path.position full_path} end;
425.33 +
425.34 +fun resolve_files master_dir blobs toks =
425.35 + (case Thy_Syntax.parse_spans toks of
425.36 + [span] => span
425.37 + |> Thy_Syntax.resolve_files (fn cmd => fn (path, pos) =>
425.38 + let
425.39 + fun make_file src_path (Exn.Res (_, NONE)) =
425.40 + Exn.interruptible_capture (fn () => read_file master_dir pos src_path) ()
425.41 + | make_file src_path (Exn.Res (file, SOME text)) =
425.42 + let val _ = Position.report pos (Markup.path file)
425.43 + in Exn.Res {src_path = src_path, text = text, pos = Position.file file} end
425.44 + | make_file _ (Exn.Exn e) = Exn.Exn e;
425.45 +
425.46 + val src_paths = Keyword.command_files cmd path;
425.47 + in
425.48 + if null blobs then
425.49 + map2 make_file src_paths (map (K (Exn.Res ("", NONE))) src_paths)
425.50 + else if length src_paths = length blobs then
425.51 + map2 make_file src_paths blobs
425.52 + else error ("Misalignment of inlined files" ^ Position.here pos)
425.53 + end)
425.54 + |> Thy_Syntax.span_content
425.55 + | _ => toks);
425.56 +
425.57 +fun read init master_dir blobs span =
425.58 let
425.59 val outer_syntax = #2 (Outer_Syntax.get_syntax ());
425.60 val command_reports = Outer_Syntax.command_reports outer_syntax;
425.61 @@ -101,7 +134,7 @@
425.62 in
425.63 if is_malformed then Toplevel.malformed pos "Malformed command syntax"
425.64 else
425.65 - (case Outer_Syntax.read_spans outer_syntax span of
425.66 + (case Outer_Syntax.read_spans outer_syntax (resolve_files master_dir blobs span) of
425.67 [tr] =>
425.68 if Keyword.is_control (Toplevel.name_of tr) then
425.69 Toplevel.malformed pos "Illegal control command"
425.70 @@ -183,14 +216,14 @@
425.71
425.72 in
425.73
425.74 -fun eval init span eval0 =
425.75 +fun eval init master_dir blobs span eval0 =
425.76 let
425.77 val exec_id = Document_ID.make ();
425.78 fun process () =
425.79 let
425.80 val tr =
425.81 Position.setmp_thread_data (Position.id_only (Document_ID.print exec_id))
425.82 - (fn () => read init span |> Toplevel.exec_id exec_id) ();
425.83 + (fn () => read init master_dir blobs span |> Toplevel.exec_id exec_id) ();
425.84 in eval_state span tr (eval_result eval0) end;
425.85 in Eval {exec_id = exec_id, eval_process = memo exec_id process} end;
425.86
426.1 --- a/src/Pure/PIDE/command.scala Thu Dec 05 17:52:12 2013 +0100
426.2 +++ b/src/Pure/PIDE/command.scala Thu Dec 05 17:58:03 2013 +0100
426.3 @@ -141,12 +141,16 @@
426.4
426.5 /* make commands */
426.6
426.7 - type Span = List[Token]
426.8 + def name(span: List[Token]): String =
426.9 + span.find(_.is_command) match { case Some(tok) => tok.source case _ => "" }
426.10 +
426.11 + type Blob = Exn.Result[(Document.Node.Name, Option[SHA1.Digest])]
426.12
426.13 def apply(
426.14 id: Document_ID.Command,
426.15 node_name: Document.Node.Name,
426.16 - span: Span,
426.17 + blobs: List[Blob],
426.18 + span: List[Token],
426.19 results: Results = Results.empty,
426.20 markup: Markup_Tree = Markup_Tree.empty): Command =
426.21 {
426.22 @@ -165,14 +169,15 @@
426.23 i += n
426.24 }
426.25
426.26 - new Command(id, node_name, span1.toList, source, results, markup)
426.27 + new Command(id, node_name, blobs, span1.toList, source, results, markup)
426.28 }
426.29
426.30 - val empty = Command(Document_ID.none, Document.Node.Name.empty, Nil)
426.31 + val empty = Command(Document_ID.none, Document.Node.Name.empty, Nil, Nil)
426.32
426.33 def unparsed(id: Document_ID.Command, source: String, results: Results, markup: Markup_Tree)
426.34 : Command =
426.35 - Command(id, Document.Node.Name.empty, List(Token(Token.Kind.UNPARSED, source)), results, markup)
426.36 + Command(id, Document.Node.Name.empty, Nil, List(Token(Token.Kind.UNPARSED, source)),
426.37 + results, markup)
426.38
426.39 def unparsed(source: String): Command =
426.40 unparsed(Document_ID.none, source, Results.empty, Markup_Tree.empty)
426.41 @@ -210,6 +215,7 @@
426.42 final class Command private(
426.43 val id: Document_ID.Command,
426.44 val node_name: Document.Node.Name,
426.45 + val blobs: List[Command.Blob],
426.46 val span: List[Token],
426.47 val source: String,
426.48 val init_results: Command.Results,
426.49 @@ -225,13 +231,21 @@
426.50 val is_malformed: Boolean = !is_ignored && (!span.head.is_command || span.exists(_.is_error))
426.51 def is_command: Boolean = !is_ignored && !is_malformed
426.52
426.53 - def name: String =
426.54 - span.find(_.is_command) match { case Some(tok) => tok.source case _ => "" }
426.55 + def name: String = Command.name(span)
426.56
426.57 override def toString =
426.58 id + "/" + (if (is_command) name else if (is_ignored) "IGNORED" else "MALFORMED")
426.59
426.60
426.61 + /* blobs */
426.62 +
426.63 + def blobs_names: List[Document.Node.Name] =
426.64 + for (Exn.Res((name, _)) <- blobs) yield name
426.65 +
426.66 + def blobs_digests: List[SHA1.Digest] =
426.67 + for (Exn.Res((_, Some(digest))) <- blobs) yield digest
426.68 +
426.69 +
426.70 /* source */
426.71
426.72 def length: Int = source.length
427.1 --- a/src/Pure/PIDE/document.ML Thu Dec 05 17:52:12 2013 +0100
427.2 +++ b/src/Pure/PIDE/document.ML Thu Dec 05 17:58:03 2013 +0100
427.3 @@ -11,14 +11,15 @@
427.4 type node_header = string * Thy_Header.header * string list
427.5 type overlay = Document_ID.command * (string * string list)
427.6 datatype node_edit =
427.7 - Clear | (* FIXME unused !? *)
427.8 Edits of (Document_ID.command option * Document_ID.command option) list |
427.9 Deps of node_header |
427.10 Perspective of bool * Document_ID.command list * overlay list
427.11 type edit = string * node_edit
427.12 type state
427.13 val init_state: state
427.14 - val define_command: Document_ID.command -> string -> string -> state -> state
427.15 + val define_blob: string -> string -> state -> state
427.16 + val define_command: Document_ID.command -> string -> Command.blob list -> string ->
427.17 + state -> state
427.18 val remove_versions: Document_ID.version list -> state -> state
427.19 val start_execution: state -> state
427.20 val update: Document_ID.version -> Document_ID.version -> edit list -> state ->
427.21 @@ -70,15 +71,19 @@
427.22 visible_last = try List.last command_ids,
427.23 overlays = Inttab.make_list overlays};
427.24
427.25 -val no_header = ("", Thy_Header.make ("", Position.none) [] [], ["Bad theory header"]);
427.26 +val no_header = ("", Thy_Header.make ("", Position.none) [] [], ["No theory header"]);
427.27 val no_perspective = make_perspective (false, [], []);
427.28
427.29 val empty_node = make_node (no_header, no_perspective, Entries.empty, NONE);
427.30 -val clear_node = map_node (fn (header, _, _, _) => (header, no_perspective, Entries.empty, NONE));
427.31
427.32
427.33 (* basic components *)
427.34
427.35 +fun master_directory (Node {header = (master, _, _), ...}) =
427.36 + (case try Url.explode master of
427.37 + SOME (Url.File path) => path
427.38 + | _ => Path.current);
427.39 +
427.40 fun set_header header =
427.41 map_node (fn (_, perspective, entries, result) => (header, perspective, entries, result));
427.42
427.43 @@ -88,9 +93,9 @@
427.44
427.45 fun read_header node span =
427.46 let
427.47 - val (dir, {name = (name, _), imports, keywords}) = get_header node;
427.48 + val {name = (name, _), imports, keywords} = #2 (get_header node);
427.49 val {name = (_, pos), imports = imports', ...} = Thy_Header.read_tokens span;
427.50 - in (dir, Thy_Header.make (name, pos) (map #1 imports ~~ map #2 imports') keywords) end;
427.51 + in Thy_Header.make (name, pos) (map #1 imports ~~ map #2 imports') keywords end;
427.52
427.53 fun get_perspective (Node {perspective, ...}) = perspective;
427.54 fun set_perspective args =
427.55 @@ -138,7 +143,6 @@
427.56 type overlay = Document_ID.command * (string * string list);
427.57
427.58 datatype node_edit =
427.59 - Clear |
427.60 Edits of (Document_ID.command option * Document_ID.command option) list |
427.61 Deps of node_header |
427.62 Perspective of bool * Document_ID.command list * overlay list;
427.63 @@ -186,8 +190,7 @@
427.64 fun edit_nodes (name, node_edit) (Version nodes) =
427.65 Version
427.66 (case node_edit of
427.67 - Clear => update_node name clear_node nodes
427.68 - | Edits edits => update_node name (edit_node edits) nodes
427.69 + Edits edits => update_node name (edit_node edits) nodes
427.70 | Deps (master, header, errors) =>
427.71 let
427.72 val imports = map fst (#imports header);
427.73 @@ -231,29 +234,32 @@
427.74
427.75 abstype state = State of
427.76 {versions: version Inttab.table, (*version id -> document content*)
427.77 - commands: (string * Token.T list lazy) Inttab.table, (*command id -> named command span*)
427.78 + blobs: string Symtab.table, (*digest -> text*)
427.79 + commands: (string * Command.blob list * Token.T list lazy) Inttab.table,
427.80 + (*command id -> name, inlined files, command span*)
427.81 execution: execution} (*current execution process*)
427.82 with
427.83
427.84 -fun make_state (versions, commands, execution) =
427.85 - State {versions = versions, commands = commands, execution = execution};
427.86 +fun make_state (versions, blobs, commands, execution) =
427.87 + State {versions = versions, blobs = blobs, commands = commands, execution = execution};
427.88
427.89 -fun map_state f (State {versions, commands, execution}) =
427.90 - make_state (f (versions, commands, execution));
427.91 +fun map_state f (State {versions, blobs, commands, execution}) =
427.92 + make_state (f (versions, blobs, commands, execution));
427.93
427.94 val init_state =
427.95 - make_state (Inttab.make [(Document_ID.none, empty_version)], Inttab.empty, no_execution);
427.96 + make_state (Inttab.make [(Document_ID.none, empty_version)],
427.97 + Symtab.empty, Inttab.empty, no_execution);
427.98
427.99
427.100 (* document versions *)
427.101
427.102 fun define_version version_id version =
427.103 - map_state (fn (versions, commands, {delay_request, frontier, ...}) =>
427.104 + map_state (fn (versions, blobs, commands, {delay_request, frontier, ...}) =>
427.105 let
427.106 val versions' = Inttab.update_new (version_id, version) versions
427.107 handle Inttab.DUP dup => err_dup "document version" dup;
427.108 val execution' = new_execution version_id delay_request frontier;
427.109 - in (versions', commands, execution') end);
427.110 + in (versions', blobs, commands, execution') end);
427.111
427.112 fun the_version (State {versions, ...}) version_id =
427.113 (case Inttab.lookup versions version_id of
427.114 @@ -265,10 +271,23 @@
427.115 handle Inttab.UNDEF _ => err_undef "document version" version_id;
427.116
427.117
427.118 +(* inlined files *)
427.119 +
427.120 +fun define_blob digest text =
427.121 + map_state (fn (versions, blobs, commands, execution) =>
427.122 + let val blobs' = Symtab.update (digest, text) blobs
427.123 + in (versions, blobs', commands, execution) end);
427.124 +
427.125 +fun the_blob (State {blobs, ...}) digest =
427.126 + (case Symtab.lookup blobs digest of
427.127 + NONE => error ("Undefined blob: " ^ digest)
427.128 + | SOME text => text);
427.129 +
427.130 +
427.131 (* commands *)
427.132
427.133 -fun define_command command_id name text =
427.134 - map_state (fn (versions, commands, execution) =>
427.135 +fun define_command command_id name command_blobs text =
427.136 + map_state (fn (versions, blobs, commands, execution) =>
427.137 let
427.138 val id = Document_ID.print command_id;
427.139 val span =
427.140 @@ -279,9 +298,9 @@
427.141 Position.setmp_thread_data (Position.id_only id)
427.142 (fn () => Output.status (Markup.markup_only Markup.accepted)) ();
427.143 val commands' =
427.144 - Inttab.update_new (command_id, (name, span)) commands
427.145 + Inttab.update_new (command_id, (name, command_blobs, span)) commands
427.146 handle Inttab.DUP dup => err_dup "command" dup;
427.147 - in (versions, commands', execution) end);
427.148 + in (versions, blobs, commands', execution) end);
427.149
427.150 fun the_command (State {commands, ...}) command_id =
427.151 (case Inttab.lookup commands command_id of
427.152 @@ -295,7 +314,7 @@
427.153
427.154 (* remove_versions *)
427.155
427.156 -fun remove_versions version_ids state = state |> map_state (fn (versions, _, execution) =>
427.157 +fun remove_versions version_ids state = state |> map_state (fn (versions, _, _, execution) =>
427.158 let
427.159 val _ =
427.160 member (op =) version_ids (#version_id execution) andalso
427.161 @@ -308,12 +327,17 @@
427.162 String_Graph.fold (fn (_, (node, _)) => node |>
427.163 iterate_entries (fn ((_, command_id), _) =>
427.164 SOME o Inttab.insert (K true) (command_id, the_command state command_id))));
427.165 - in (versions', commands', execution) end);
427.166 + val blobs' =
427.167 + (commands', Symtab.empty) |->
427.168 + Inttab.fold (fn (_, (_, blobs, _)) => blobs |>
427.169 + fold (fn Exn.Res (_, SOME b) => Symtab.update (b, the_blob state b) | _ => I));
427.170 +
427.171 + in (versions', blobs', commands', execution) end);
427.172
427.173
427.174 (* document execution *)
427.175
427.176 -fun start_execution state = state |> map_state (fn (versions, commands, execution) =>
427.177 +fun start_execution state = state |> map_state (fn (versions, blobs, commands, execution) =>
427.178 timeit "Document.start_execution" (fn () =>
427.179 let
427.180 val {version_id, execution_id, delay_request, frontier} = execution;
427.181 @@ -350,7 +374,7 @@
427.182 val execution' =
427.183 {version_id = version_id, execution_id = execution_id,
427.184 delay_request = delay_request', frontier = frontier'};
427.185 - in (versions, commands, execution') end));
427.186 + in (versions, blobs, commands, execution') end));
427.187
427.188
427.189
427.190 @@ -391,18 +415,19 @@
427.191 Symtab.update (a, ())) all_visible all_required
427.192 end;
427.193
427.194 +fun loaded_theory name =
427.195 + (case try (unsuffix ".thy") name of
427.196 + SOME a => Thy_Info.lookup_theory a
427.197 + | NONE => NONE);
427.198 +
427.199 fun init_theory deps node span =
427.200 let
427.201 - (* FIXME provide files via Isabelle/Scala, not master_dir *)
427.202 - val (dir, header) = read_header node span;
427.203 - val master_dir =
427.204 - (case try Url.explode dir of
427.205 - SOME (Url.File path) => path
427.206 - | _ => Path.current);
427.207 + val master_dir = master_directory node;
427.208 + val header = read_header node span;
427.209 val imports = #imports header;
427.210 val parents =
427.211 imports |> map (fn (import, _) =>
427.212 - (case Thy_Info.lookup_theory import of
427.213 + (case loaded_theory import of
427.214 SOME thy => thy
427.215 | NONE =>
427.216 Toplevel.end_theory (Position.file_only import)
427.217 @@ -413,7 +438,7 @@
427.218 in Thy_Load.begin_theory master_dir header parents end;
427.219
427.220 fun check_theory full name node =
427.221 - is_some (Thy_Info.lookup_theory name) orelse
427.222 + is_some (loaded_theory name) orelse
427.223 can get_header node andalso (not full orelse is_some (get_result node));
427.224
427.225 fun last_common state node_required node0 node =
427.226 @@ -471,9 +496,13 @@
427.227
427.228 val command_visible = visible_command node command_id';
427.229 val command_overlays = overlays node command_id';
427.230 - val (command_name, span) = the_command state command_id' ||> Lazy.force;
427.231 + val (command_name, blobs0, span0) = the_command state command_id';
427.232 + val blobs = (map o Exn.map_result o apsnd o Option.map) (the_blob state) blobs0;
427.233 + val span = Lazy.force span0;
427.234
427.235 - val eval' = Command.eval (fn () => the_default illegal_init init span) span eval;
427.236 + val eval' =
427.237 + Command.eval (fn () => the_default illegal_init init span)
427.238 + (master_directory node) blobs span eval;
427.239 val prints' = perhaps (Command.print command_visible command_overlays command_name eval') [];
427.240 val exec' = (eval', prints');
427.241
428.1 --- a/src/Pure/PIDE/document.scala Thu Dec 05 17:52:12 2013 +0100
428.2 +++ b/src/Pure/PIDE/document.scala Thu Dec 05 17:58:03 2013 +0100
428.3 @@ -47,6 +47,8 @@
428.4 type Edit_Text = Edit[Text.Edit, Text.Perspective]
428.5 type Edit_Command = Edit[Command.Edit, Command.Perspective]
428.6
428.7 + type Blobs = Map[Node.Name, Bytes]
428.8 +
428.9 object Node
428.10 {
428.11 val empty: Node = new Node()
428.12 @@ -60,13 +62,18 @@
428.13 errors: List[String] = Nil)
428.14 {
428.15 def error(msg: String): Header = copy(errors = errors ::: List(msg))
428.16 +
428.17 + def cat_errors(msg2: String): Header =
428.18 + copy(errors = errors.map(msg1 => Library.cat_message(msg1, msg2)))
428.19 }
428.20
428.21 def bad_header(msg: String): Header = Header(Nil, Nil, List(msg))
428.22
428.23 + val no_header = bad_header("No theory header")
428.24 +
428.25 object Name
428.26 {
428.27 - val empty = Name("", "", "")
428.28 + val empty = Name("")
428.29
428.30 object Ordering extends scala.math.Ordering[Name]
428.31 {
428.32 @@ -74,7 +81,7 @@
428.33 }
428.34 }
428.35
428.36 - sealed case class Name(node: String, dir: String, theory: String)
428.37 + sealed case class Name(node: String, master_dir: String = "", theory: String = "")
428.38 {
428.39 override def hashCode: Int = node.hashCode
428.40 override def equals(that: Any): Boolean =
428.41 @@ -82,7 +89,9 @@
428.42 case other: Name => node == other.node
428.43 case _ => false
428.44 }
428.45 - override def toString: String = theory
428.46 +
428.47 + def is_theory: Boolean = !theory.isEmpty
428.48 + override def toString: String = if (is_theory) theory else node
428.49 }
428.50
428.51
428.52 @@ -118,6 +127,8 @@
428.53 }
428.54 }
428.55 case class Clear[A, B]() extends Edit[A, B]
428.56 + case class Blob[A, B]() extends Edit[A, B]
428.57 +
428.58 case class Edits[A, B](edits: List[A]) extends Edit[A, B]
428.59 case class Deps[A, B](header: Header) extends Edit[A, B]
428.60 case class Perspective[A, B](required: Boolean, visible: B, overlays: Overlays) extends Edit[A, B]
428.61 @@ -148,6 +159,9 @@
428.62
428.63 final class Commands private(val commands: Linear_Set[Command])
428.64 {
428.65 + lazy val thy_load_commands: List[Command] =
428.66 + commands.iterator.filter(cmd => !cmd.blobs.isEmpty).toList
428.67 +
428.68 private lazy val full_index: (Array[(Command, Text.Offset)], Text.Range) =
428.69 {
428.70 val blocks = new mutable.ListBuffer[(Command, Text.Offset)]
428.71 @@ -197,6 +211,7 @@
428.72 perspective.overlays == other_perspective.overlays
428.73
428.74 def commands: Linear_Set[Command] = _commands.commands
428.75 + def thy_load_commands: List[Command] = _commands.thy_load_commands
428.76
428.77 def update_commands(new_commands: Linear_Set[Command]): Node =
428.78 if (new_commands eq _commands.commands) this
428.79 @@ -242,6 +257,14 @@
428.80 def entries: Iterator[(Node.Name, Node)] =
428.81 graph.entries.map({ case (name, (node, _)) => (name, node) })
428.82
428.83 + def thy_load_commands(file_name: Node.Name): List[Command] =
428.84 + (for {
428.85 + (_, node) <- entries
428.86 + cmd <- node.thy_load_commands.iterator
428.87 + name <- cmd.blobs_names.iterator
428.88 + if name == file_name
428.89 + } yield cmd).toList
428.90 +
428.91 def descendants(names: List[Node.Name]): List[Node.Name] = graph.all_succs(names)
428.92 def topological_order: List[Node.Name] = graph.topological_order
428.93 }
428.94 @@ -388,6 +411,7 @@
428.95
428.96 final case class State private(
428.97 val versions: Map[Document_ID.Version, Version] = Map.empty,
428.98 + val blobs: Set[SHA1.Digest] = Set.empty, // inlined files
428.99 val commands: Map[Document_ID.Command, Command.State] = Map.empty, // static markup from define_command
428.100 val execs: Map[Document_ID.Exec, Command.State] = Map.empty, // dynamic markup from execution
428.101 val assignments: Map[Document_ID.Version, State.Assignment] = Map.empty,
428.102 @@ -402,6 +426,9 @@
428.103 assignments = assignments + (id -> assignment.unfinished))
428.104 }
428.105
428.106 + def define_blob(digest: SHA1.Digest): State = copy(blobs = blobs + digest)
428.107 + def defined_blob(digest: SHA1.Digest): Boolean = blobs.contains(digest)
428.108 +
428.109 def define_command(command: Command): State =
428.110 {
428.111 val id = command.id
428.112 @@ -505,6 +532,7 @@
428.113 {
428.114 val versions1 = versions -- removed
428.115 val assignments1 = assignments -- removed
428.116 + var blobs1 = Set.empty[SHA1.Digest]
428.117 var commands1 = Map.empty[Document_ID.Command, Command.State]
428.118 var execs1 = Map.empty[Document_ID.Exec, Command.State]
428.119 for {
428.120 @@ -513,14 +541,19 @@
428.121 (_, node) <- version.nodes.entries
428.122 command <- node.commands.iterator
428.123 } {
428.124 + for (digest <- command.blobs_digests; if !blobs1.contains(digest))
428.125 + blobs1 += digest
428.126 +
428.127 if (!commands1.isDefinedAt(command.id))
428.128 commands.get(command.id).foreach(st => commands1 += (command.id -> st))
428.129 +
428.130 for (exec_id <- command_execs.getOrElse(command.id, Nil)) {
428.131 if (!execs1.isDefinedAt(exec_id))
428.132 execs.get(exec_id).foreach(st => execs1 += (exec_id -> st))
428.133 }
428.134 }
428.135 - copy(versions = versions1, commands = commands1, execs = execs1, assignments = assignments1)
428.136 + copy(versions = versions1, blobs = blobs1, commands = commands1, execs = execs1,
428.137 + assignments = assignments1)
428.138 }
428.139
428.140 def command_state(version: Version, command: Command): Command.State =
429.1 --- a/src/Pure/PIDE/editor.scala Thu Dec 05 17:52:12 2013 +0100
429.2 +++ b/src/Pure/PIDE/editor.scala Thu Dec 05 17:58:03 2013 +0100
429.3 @@ -11,6 +11,7 @@
429.4 {
429.5 def session: Session
429.6 def flush(): Unit
429.7 + def invoke(): Unit
429.8 def current_context: Context
429.9 def current_node(context: Context): Option[Document.Node.Name]
429.10 def current_node_snapshot(context: Context): Option[Document.Snapshot]
430.1 --- a/src/Pure/PIDE/protocol.ML Thu Dec 05 17:52:12 2013 +0100
430.2 +++ b/src/Pure/PIDE/protocol.ML Thu Dec 05 17:58:03 2013 +0100
430.3 @@ -23,9 +23,23 @@
430.4 end);
430.5
430.6 val _ =
430.7 + Isabelle_Process.protocol_command "Document.define_blob"
430.8 + (fn [digest, content] => Document.change_state (Document.define_blob digest content));
430.9 +
430.10 +val _ =
430.11 Isabelle_Process.protocol_command "Document.define_command"
430.12 - (fn [id, name, text] =>
430.13 - Document.change_state (Document.define_command (Document_ID.parse id) name text));
430.14 + (fn [id, name, blobs_yxml, text] =>
430.15 + let
430.16 + val blobs =
430.17 + YXML.parse_body blobs_yxml |>
430.18 + let open XML.Decode in
430.19 + list (variant
430.20 + [fn ([], a) => Exn.Res (pair string (option string) a),
430.21 + fn ([], a) => Exn.Exn (ERROR (string a))])
430.22 + end;
430.23 + in
430.24 + Document.change_state (Document.define_command (Document_ID.parse id) name blobs text)
430.25 + end);
430.26
430.27 val _ =
430.28 Isabelle_Process.protocol_command "Document.discontinue_execution"
430.29 @@ -48,8 +62,7 @@
430.30 let open XML.Decode in
430.31 list (pair string
430.32 (variant
430.33 - [fn ([], []) => Document.Clear, (* FIXME unused !? *)
430.34 - fn ([], a) => Document.Edits (list (pair (option int) (option int)) a),
430.35 + [fn ([], a) => Document.Edits (list (pair (option int) (option int)) a),
430.36 fn ([], a) =>
430.37 let
430.38 val (master, (name, (imports, (keywords, errors)))) =
431.1 --- a/src/Pure/PIDE/protocol.scala Thu Dec 05 17:52:12 2013 +0100
431.2 +++ b/src/Pure/PIDE/protocol.scala Thu Dec 05 17:58:03 2013 +0100
431.3 @@ -308,11 +308,28 @@
431.4
431.5 trait Protocol extends Isabelle_Process
431.6 {
431.7 + /* inlined files */
431.8 +
431.9 + def define_blob(blob: Bytes): Unit =
431.10 + protocol_command_raw("Document.define_blob", Bytes(blob.sha1_digest.toString), blob)
431.11 +
431.12 +
431.13 /* commands */
431.14
431.15 def define_command(command: Command): Unit =
431.16 + {
431.17 + val blobs_yxml =
431.18 + { import XML.Encode._
431.19 + val encode_blob: T[Command.Blob] =
431.20 + variant(List(
431.21 + { case Exn.Res((a, b)) =>
431.22 + (Nil, pair(string, option(string))((a.node, b.map(_.toString)))) },
431.23 + { case Exn.Exn(e) => (Nil, string(Exn.message(e))) }))
431.24 + YXML.string_of_body(list(encode_blob)(command.blobs))
431.25 + }
431.26 protocol_command("Document.define_command",
431.27 - Document_ID(command.id), encode(command.name), encode(command.source))
431.28 + Document_ID(command.id), encode(command.name), blobs_yxml, encode(command.source))
431.29 + }
431.30
431.31
431.32 /* execution */
431.33 @@ -335,10 +352,9 @@
431.34 def encode_edit(name: Document.Node.Name)
431.35 : T[Document.Node.Edit[Command.Edit, Command.Perspective]] =
431.36 variant(List(
431.37 - { case Document.Node.Clear() => (Nil, Nil) }, // FIXME unused !?
431.38 { case Document.Node.Edits(a) => (Nil, list(pair(option(id), option(id)))(a)) },
431.39 { case Document.Node.Deps(header) =>
431.40 - val dir = Isabelle_System.posix_path(name.dir)
431.41 + val master_dir = Isabelle_System.posix_path(name.master_dir)
431.42 val imports = header.imports.map(_.node)
431.43 val keywords = header.keywords.map({ case (a, b, _) => (a, b) })
431.44 (Nil,
431.45 @@ -346,7 +362,7 @@
431.46 pair(list(pair(Encode.string,
431.47 option(pair(pair(Encode.string, list(Encode.string)), list(Encode.string))))),
431.48 list(Encode.string)))))(
431.49 - (dir, (name.theory, (imports, (keywords, header.errors)))))) },
431.50 + (master_dir, (name.theory, (imports, (keywords, header.errors)))))) },
431.51 { case Document.Node.Perspective(a, b, c) =>
431.52 (bool_atom(a) :: b.commands.map(cmd => long_atom(cmd.id)),
431.53 list(pair(id, pair(Encode.string, list(Encode.string))))(c.dest)) }))
432.1 --- a/src/Pure/ROOT.ML Thu Dec 05 17:52:12 2013 +0100
432.2 +++ b/src/Pure/ROOT.ML Thu Dec 05 17:58:03 2013 +0100
432.3 @@ -341,8 +341,6 @@
432.4
432.5 (* ML toplevel commands *)
432.6
432.7 -fun use name = Toplevel.program (fn () => Thy_Load.use_ml (Path.explode name));
432.8 -
432.9 fun use_thys args = Toplevel.program (fn () => Thy_Info.use_thys (map (rpair Position.none) args));
432.10 val use_thy = use_thys o single;
432.11
433.1 --- a/src/Pure/System/command_line.ML Thu Dec 05 17:52:12 2013 +0100
433.2 +++ b/src/Pure/System/command_line.ML Thu Dec 05 17:58:03 2013 +0100
433.3 @@ -19,8 +19,8 @@
433.4 restore_attributes body () handle exn =>
433.5 let
433.6 val _ =
433.7 - Output.error_msg (ML_Compiler.exn_message exn)
433.8 - handle _ => Output.error_msg "Exception raised, but failed to print details!";
433.9 + ML_Compiler.exn_error_message exn
433.10 + handle _ => Output.error_message "Exception raised, but failed to print details!";
433.11 in if Exn.is_interrupt exn then 130 else 1 end;
433.12 in if rc = 0 then () else exit rc end) ();
433.13
434.1 --- a/src/Pure/System/invoke_scala.scala Thu Dec 05 17:52:12 2013 +0100
434.2 +++ b/src/Pure/System/invoke_scala.scala Thu Dec 05 17:58:03 2013 +0100
434.3 @@ -89,15 +89,14 @@
434.4 }
434.5
434.6 private def invoke_scala(
434.7 - prover: Session.Prover, output: Isabelle_Process.Output): Boolean = synchronized
434.8 + prover: Session.Prover, msg: Isabelle_Process.Protocol_Output): Boolean = synchronized
434.9 {
434.10 - output.properties match {
434.11 + msg.properties match {
434.12 case Markup.Invoke_Scala(name, id) =>
434.13 futures += (id ->
434.14 default_thread_pool.submit(() =>
434.15 {
434.16 - val arg = XML.content(output.body)
434.17 - val (tag, result) = Invoke_Scala.method(name, arg)
434.18 + val (tag, result) = Invoke_Scala.method(name, msg.text)
434.19 fulfill(prover, id, tag, result)
434.20 }))
434.21 true
434.22 @@ -106,9 +105,9 @@
434.23 }
434.24
434.25 private def cancel_scala(
434.26 - prover: Session.Prover, output: Isabelle_Process.Output): Boolean = synchronized
434.27 + prover: Session.Prover, msg: Isabelle_Process.Protocol_Output): Boolean = synchronized
434.28 {
434.29 - output.properties match {
434.30 + msg.properties match {
434.31 case Markup.Cancel_Scala(id) =>
434.32 futures.get(id) match {
434.33 case Some(future) => cancel(prover, id, future)
435.1 --- a/src/Pure/System/isabelle_process.ML Thu Dec 05 17:52:12 2013 +0100
435.2 +++ b/src/Pure/System/isabelle_process.ML Thu Dec 05 17:58:03 2013 +0100
435.3 @@ -119,7 +119,7 @@
435.4 Output.Internal.tracing_fn :=
435.5 (fn s => (update_tracing (); standard_message (serial_props ()) Markup.tracingN s));
435.6 Output.Internal.warning_fn := (fn s => standard_message (serial_props ()) Markup.warningN s);
435.7 - Output.Internal.error_fn :=
435.8 + Output.Internal.error_message_fn :=
435.9 (fn (i, s) => standard_message (Markup.serial_properties i) Markup.errorN s);
435.10 Output.Internal.protocol_message_fn := message Markup.protocolN;
435.11 Output.Internal.urgent_message_fn := ! Output.Internal.writeln_fn;
435.12 @@ -167,10 +167,10 @@
435.13 fun loop channel =
435.14 let val continue =
435.15 (case read_command channel of
435.16 - [] => (Output.error_msg "Isabelle process: no input"; true)
435.17 + [] => (Output.error_message "Isabelle process: no input"; true)
435.18 | name :: args => (task_context (fn () => run_command name args); true))
435.19 handle Runtime.TERMINATE => false
435.20 - | exn => (Output.error_msg (ML_Compiler.exn_message exn) handle crash => recover crash; true);
435.21 + | exn => (ML_Compiler.exn_error_message exn handle crash => recover crash; true);
435.22 in
435.23 if continue then loop channel
435.24 else (Future.shutdown (); Execution.reset (); ())
436.1 --- a/src/Pure/System/isabelle_process.scala Thu Dec 05 17:52:12 2013 +0100
436.2 +++ b/src/Pure/System/isabelle_process.scala Thu Dec 05 17:58:03 2013 +0100
436.3 @@ -43,14 +43,12 @@
436.4 def is_system = kind == Markup.SYSTEM
436.5 def is_status = kind == Markup.STATUS
436.6 def is_report = kind == Markup.REPORT
436.7 - def is_protocol = kind == Markup.PROTOCOL
436.8 def is_syslog = is_init || is_exit || is_system || is_stderr
436.9
436.10 override def toString: String =
436.11 {
436.12 val res =
436.13 if (is_status || is_report) message.body.map(_.toString).mkString
436.14 - else if (is_protocol) "..."
436.15 else Pretty.string_of(message.body)
436.16 if (properties.isEmpty)
436.17 kind.toString + " [[" + res + "]]"
436.18 @@ -59,6 +57,12 @@
436.19 (for ((x, y) <- properties) yield x + "=" + y).mkString("{", ",", "}") + " [[" + res + "]]"
436.20 }
436.21 }
436.22 +
436.23 + class Protocol_Output(props: Properties.T, val bytes: Bytes)
436.24 + extends Output(XML.Elem(Markup(Markup.PROTOCOL, props), Nil))
436.25 + {
436.26 + lazy val text: String = bytes.toString
436.27 + }
436.28 }
436.29
436.30
436.31 @@ -89,28 +93,29 @@
436.32 receiver(new Output(XML.Elem(Markup(Markup.SYSTEM, Nil), List(XML.Text(text)))))
436.33 }
436.34
436.35 - private def output_message(kind: String, props: Properties.T, body: XML.Body)
436.36 + private def protocol_output(props: Properties.T, bytes: Bytes)
436.37 + {
436.38 + receiver(new Protocol_Output(props, bytes))
436.39 + }
436.40 +
436.41 + private def output(kind: String, props: Properties.T, body: XML.Body)
436.42 {
436.43 if (kind == Markup.INIT) system_channel.accepted()
436.44 - if (kind == Markup.PROTOCOL)
436.45 - receiver(new Output(XML.Elem(Markup(kind, props), body)))
436.46 - else {
436.47 - val main = XML.Elem(Markup(kind, props), Protocol.clean_message(body))
436.48 - val reports = Protocol.message_reports(props, body)
436.49 - for (msg <- main :: reports) receiver(new Output(xml_cache.elem(msg)))
436.50 - }
436.51 +
436.52 + val main = XML.Elem(Markup(kind, props), Protocol.clean_message(body))
436.53 + val reports = Protocol.message_reports(props, body)
436.54 + for (msg <- main :: reports) receiver(new Output(xml_cache.elem(msg)))
436.55 }
436.56
436.57 private def exit_message(rc: Int)
436.58 {
436.59 - output_message(Markup.EXIT, Markup.Return_Code(rc),
436.60 - List(XML.Text("Return code: " + rc.toString)))
436.61 + output(Markup.EXIT, Markup.Return_Code(rc), List(XML.Text("Return code: " + rc.toString)))
436.62 }
436.63
436.64
436.65 /* command input actor */
436.66
436.67 - private case class Input_Chunks(chunks: List[Array[Byte]])
436.68 + private case class Input_Chunks(chunks: List[Bytes])
436.69
436.70 private case object Close
436.71 private def close(p: (Thread, Actor))
436.72 @@ -232,7 +237,7 @@
436.73 else done = true
436.74 }
436.75 if (result.length > 0) {
436.76 - output_message(markup, Nil, List(XML.Text(decode(result.toString))))
436.77 + output(markup, Nil, List(XML.Text(decode(result.toString))))
436.78 result.length = 0
436.79 }
436.80 else {
436.81 @@ -261,8 +266,8 @@
436.82 //{{{
436.83 receive {
436.84 case Input_Chunks(chunks) =>
436.85 - stream.write(UTF8.string_bytes(chunks.map(_.length).mkString("", ",", "\n")))
436.86 - chunks.foreach(stream.write(_))
436.87 + Bytes(chunks.map(_.length).mkString("", ",", "\n")).write(stream)
436.88 + chunks.foreach(_.write(stream))
436.89 stream.flush
436.90 case Close =>
436.91 stream.close
436.92 @@ -306,7 +311,7 @@
436.93 }
436.94 //}}}
436.95
436.96 - def read_chunk(do_decode: Boolean): XML.Body =
436.97 + def read_chunk_bytes(): (Array[Byte], Int) =
436.98 //{{{
436.99 {
436.100 val n = read_int()
436.101 @@ -325,23 +330,33 @@
436.102 if (i != n)
436.103 throw new Protocol_Error("bad chunk (unexpected EOF after " + i + " of " + n + " bytes)")
436.104
436.105 - if (do_decode)
436.106 - YXML.parse_body_failsafe(UTF8.decode_chars(decode, buf, 0, n))
436.107 - else List(XML.Text(UTF8.decode_chars(s => s, buf, 0, n).toString))
436.108 + (buf, n)
436.109 }
436.110 //}}}
436.111
436.112 + def read_chunk(): XML.Body =
436.113 + {
436.114 + val (buf, n) = read_chunk_bytes()
436.115 + YXML.parse_body_failsafe(UTF8.decode_chars(decode, buf, 0, n))
436.116 + }
436.117 +
436.118 try {
436.119 do {
436.120 try {
436.121 - val header = read_chunk(true)
436.122 + val header = read_chunk()
436.123 header match {
436.124 case List(XML.Elem(Markup(name, props), Nil)) =>
436.125 val kind = name.intern
436.126 - val body = read_chunk(kind != Markup.PROTOCOL)
436.127 - output_message(kind, props, body)
436.128 + if (kind == Markup.PROTOCOL) {
436.129 + val (buf, n) = read_chunk_bytes()
436.130 + protocol_output(props, Bytes(buf, 0, n))
436.131 + }
436.132 + else {
436.133 + val body = read_chunk()
436.134 + output(kind, props, body)
436.135 + }
436.136 case _ =>
436.137 - read_chunk(false)
436.138 + read_chunk()
436.139 throw new Protocol_Error("bad header: " + header.toString)
436.140 }
436.141 }
436.142 @@ -362,13 +377,13 @@
436.143
436.144 /** main methods **/
436.145
436.146 - def protocol_command_raw(name: String, args: Array[Byte]*): Unit =
436.147 - command_input._2 ! Input_Chunks(UTF8.string_bytes(name) :: args.toList)
436.148 + def protocol_command_raw(name: String, args: Bytes*): Unit =
436.149 + command_input._2 ! Input_Chunks(Bytes(name) :: args.toList)
436.150
436.151 def protocol_command(name: String, args: String*)
436.152 {
436.153 receiver(new Input(name, args.toList))
436.154 - protocol_command_raw(name, args.map(UTF8.string_bytes): _*)
436.155 + protocol_command_raw(name, args.map(Bytes(_)): _*)
436.156 }
436.157
436.158 def options(opts: Options): Unit =
437.1 --- a/src/Pure/System/isar.ML Thu Dec 05 17:52:12 2013 +0100
437.2 +++ b/src/Pure/System/isar.ML Thu Dec 05 17:58:03 2013 +0100
437.3 @@ -97,7 +97,7 @@
437.4 | SOME (_, SOME exn_info) =>
437.5 (set_exn (SOME exn_info);
437.6 Toplevel.setmp_thread_position tr
437.7 - Output.error_msg' (serial (), ML_Compiler.exn_message (Runtime.EXCURSION_FAIL exn_info));
437.8 + ML_Compiler.exn_error_message (Runtime.EXCURSION_FAIL exn_info);
437.9 true)
437.10 | SOME (st', NONE) =>
437.11 let
437.12 @@ -144,7 +144,7 @@
437.13 NONE => if secure then quit () else ()
437.14 | SOME (tr, src') => if op >> tr orelse check_secure () then raw_loop secure src' else ())
437.15 handle exn =>
437.16 - (Output.error_msg (ML_Compiler.exn_message exn)
437.17 + (ML_Compiler.exn_error_message exn
437.18 handle crash =>
437.19 (Synchronized.change crashes (cons crash);
437.20 warning "Recovering from Isar toplevel crash -- see also Isar.crashes");
438.1 --- a/src/Pure/System/session.scala Thu Dec 05 17:52:12 2013 +0100
438.2 +++ b/src/Pure/System/session.scala Thu Dec 05 17:58:03 2013 +0100
438.3 @@ -25,7 +25,7 @@
438.4 case class Statistics(props: Properties.T)
438.5 case class Global_Options(options: Options)
438.6 case object Caret_Focus
438.7 - case class Raw_Edits(edits: List[Document.Edit_Text])
438.8 + case class Raw_Edits(doc_blobs: Document.Blobs, edits: List[Document.Edit_Text])
438.9 case class Dialog_Result(id: Document_ID.Generic, serial: Long, result: String)
438.10 case class Commands_Changed(
438.11 assignment: Boolean, nodes: Set[Document.Node.Name], commands: Set[Command])
438.12 @@ -46,12 +46,12 @@
438.13 abstract class Protocol_Handler
438.14 {
438.15 def stop(prover: Prover): Unit = {}
438.16 - val functions: Map[String, (Prover, Isabelle_Process.Output) => Boolean]
438.17 + val functions: Map[String, (Prover, Isabelle_Process.Protocol_Output) => Boolean]
438.18 }
438.19
438.20 class Protocol_Handlers(
438.21 handlers: Map[String, Session.Protocol_Handler] = Map.empty,
438.22 - functions: Map[String, Isabelle_Process.Output => Boolean] = Map.empty)
438.23 + functions: Map[String, Isabelle_Process.Protocol_Output => Boolean] = Map.empty)
438.24 {
438.25 def get(name: String): Option[Protocol_Handler] = handlers.get(name)
438.26
438.27 @@ -71,7 +71,7 @@
438.28 val new_handler = Class.forName(name).newInstance.asInstanceOf[Protocol_Handler]
438.29 val new_functions =
438.30 for ((a, f) <- new_handler.functions.toList) yield
438.31 - (a, (output: Isabelle_Process.Output) => f(prover, output))
438.32 + (a, (msg: Isabelle_Process.Protocol_Output) => f(prover, msg))
438.33
438.34 val dups = for ((a, _) <- new_functions if functions1.isDefinedAt(a)) yield a
438.35 if (!dups.isEmpty) error("Duplicate protocol functions: " + commas_quote(dups))
438.36 @@ -88,10 +88,10 @@
438.37 new Protocol_Handlers(handlers2, functions2)
438.38 }
438.39
438.40 - def invoke(output: Isabelle_Process.Output): Boolean =
438.41 - output.properties match {
438.42 + def invoke(msg: Isabelle_Process.Protocol_Output): Boolean =
438.43 + msg.properties match {
438.44 case Markup.Function(a) if functions.isDefinedAt(a) =>
438.45 - try { functions(a)(output) }
438.46 + try { functions(a)(msg) }
438.47 catch {
438.48 case exn: Throwable =>
438.49 System.err.println("Failed invocation of protocol function: " +
438.50 @@ -167,6 +167,7 @@
438.51 //{{{
438.52 private case class Text_Edits(
438.53 previous: Future[Document.Version],
438.54 + doc_blobs: Document.Blobs,
438.55 text_edits: List[Document.Edit_Text],
438.56 version_result: Promise[Document.Version])
438.57
438.58 @@ -177,14 +178,14 @@
438.59 receive {
438.60 case Stop => finished = true; reply(())
438.61
438.62 - case Text_Edits(previous, text_edits, version_result) =>
438.63 + case Text_Edits(previous, doc_blobs, text_edits, version_result) =>
438.64 val prev = previous.get_finished
438.65 val (doc_edits, version) =
438.66 Timing.timeit("Thy_Load.text_edits", timing) {
438.67 - thy_load.text_edits(reparse_limit, prev, text_edits)
438.68 + thy_load.text_edits(reparse_limit, prev, doc_blobs, text_edits)
438.69 }
438.70 version_result.fulfill(version)
438.71 - sender ! Change(doc_edits, prev, version)
438.72 + sender ! Change(doc_blobs, doc_edits, prev, version)
438.73
438.74 case bad => System.err.println("change_parser: ignoring bad message " + bad)
438.75 }
438.76 @@ -239,7 +240,7 @@
438.77 {
438.78 val header1 =
438.79 if (thy_load.loaded_theories(name.theory))
438.80 - header.error("Attempt to update loaded theory " + quote(name.theory))
438.81 + header.error("Cannot update finished theory " + quote(name.theory))
438.82 else header
438.83 (name, Document.Node.Deps(header1))
438.84 }
438.85 @@ -250,6 +251,7 @@
438.86 private case class Start(args: List[String])
438.87 private case class Cancel_Exec(exec_id: Document_ID.Exec)
438.88 private case class Change(
438.89 + doc_blobs: Document.Blobs,
438.90 doc_edits: List[Document.Edit_Command],
438.91 previous: Document.Version,
438.92 version: Document.Version)
438.93 @@ -281,17 +283,16 @@
438.94 msg match {
438.95 case _: Isabelle_Process.Input =>
438.96 buffer += msg
438.97 + case output: Isabelle_Process.Protocol_Output if output.properties == Markup.Flush =>
438.98 + flush()
438.99 case output: Isabelle_Process.Output =>
438.100 - if (output.is_protocol && output.properties == Markup.Flush) flush()
438.101 - else {
438.102 - buffer += msg
438.103 - if (output.is_syslog)
438.104 - syslog >> (queue =>
438.105 - {
438.106 - val queue1 = queue.enqueue(output.message)
438.107 - if (queue1.length > syslog_limit) queue1.dequeue._2 else queue1
438.108 - })
438.109 - }
438.110 + buffer += msg
438.111 + if (output.is_syslog)
438.112 + syslog >> (queue =>
438.113 + {
438.114 + val queue1 = queue.enqueue(output.message)
438.115 + if (queue1.length > syslog_limit) queue1.dequeue._2 else queue1
438.116 + })
438.117 }
438.118 }
438.119
438.120 @@ -349,7 +350,7 @@
438.121
438.122 /* raw edits */
438.123
438.124 - def handle_raw_edits(edits: List[Document.Edit_Text])
438.125 + def handle_raw_edits(doc_blobs: Document.Blobs, edits: List[Document.Edit_Text])
438.126 //{{{
438.127 {
438.128 prover.get.discontinue_execution()
438.129 @@ -358,8 +359,8 @@
438.130 val version = Future.promise[Document.Version]
438.131 val change = global_state >>> (_.continue_history(previous, edits, version))
438.132
438.133 - raw_edits.event(Session.Raw_Edits(edits))
438.134 - change_parser ! Text_Edits(previous, edits, version)
438.135 + raw_edits.event(Session.Raw_Edits(doc_blobs, edits))
438.136 + change_parser ! Text_Edits(previous, doc_blobs, edits, version)
438.137 }
438.138 //}}}
438.139
438.140 @@ -375,6 +376,18 @@
438.141
438.142 def id_command(command: Command)
438.143 {
438.144 + for {
438.145 + digest <- command.blobs_digests
438.146 + if !global_state().defined_blob(digest)
438.147 + } {
438.148 + change.doc_blobs.collectFirst({ case (_, b) if b.sha1_digest == digest => b }) match {
438.149 + case Some(blob) =>
438.150 + global_state >> (_.define_blob(digest))
438.151 + prover.get.define_blob(blob)
438.152 + case None => System.err.println("Missing blob for SHA1 digest " + digest)
438.153 + }
438.154 + }
438.155 +
438.156 if (!global_state().defined_command(command.id)) {
438.157 global_state >> (_.define_command(command))
438.158 prover.get.define_command(command)
438.159 @@ -414,69 +427,69 @@
438.160 }
438.161 }
438.162
438.163 - if (output.is_protocol) {
438.164 - val handled = _protocol_handlers.invoke(output)
438.165 - if (!handled) {
438.166 + output match {
438.167 + case msg: Isabelle_Process.Protocol_Output =>
438.168 + val handled = _protocol_handlers.invoke(msg)
438.169 + if (!handled) {
438.170 + msg.properties match {
438.171 + case Markup.Protocol_Handler(name) =>
438.172 + _protocol_handlers = _protocol_handlers.add(prover.get, name)
438.173 +
438.174 + case Protocol.Command_Timing(state_id, timing) =>
438.175 + val message = XML.elem(Markup.STATUS, List(XML.Elem(Markup.Timing(timing), Nil)))
438.176 + accumulate(state_id, prover.get.xml_cache.elem(message))
438.177 +
438.178 + case Markup.Assign_Update =>
438.179 + msg.text match {
438.180 + case Protocol.Assign_Update(id, update) =>
438.181 + try {
438.182 + val cmds = global_state >>> (_.assign(id, update))
438.183 + delay_commands_changed.invoke(true, cmds)
438.184 + }
438.185 + catch { case _: Document.State.Fail => bad_output() }
438.186 + case _ => bad_output()
438.187 + }
438.188 + // FIXME separate timeout event/message!?
438.189 + if (prover.isDefined && System.currentTimeMillis() > prune_next) {
438.190 + val old_versions = global_state >>> (_.prune_history(prune_size))
438.191 + if (!old_versions.isEmpty) prover.get.remove_versions(old_versions)
438.192 + prune_next = System.currentTimeMillis() + prune_delay.ms
438.193 + }
438.194 +
438.195 + case Markup.Removed_Versions =>
438.196 + msg.text match {
438.197 + case Protocol.Removed(removed) =>
438.198 + try {
438.199 + global_state >> (_.removed_versions(removed))
438.200 + }
438.201 + catch { case _: Document.State.Fail => bad_output() }
438.202 + case _ => bad_output()
438.203 + }
438.204 +
438.205 + case Markup.ML_Statistics(props) =>
438.206 + statistics.event(Session.Statistics(props))
438.207 +
438.208 + case Markup.Task_Statistics(props) =>
438.209 + // FIXME
438.210 +
438.211 + case _ => bad_output()
438.212 + }
438.213 + }
438.214 + case _ =>
438.215 output.properties match {
438.216 - case Markup.Protocol_Handler(name) =>
438.217 - _protocol_handlers = _protocol_handlers.add(prover.get, name)
438.218 -
438.219 - case Protocol.Command_Timing(state_id, timing) =>
438.220 - val message = XML.elem(Markup.STATUS, List(XML.Elem(Markup.Timing(timing), Nil)))
438.221 - accumulate(state_id, prover.get.xml_cache.elem(message))
438.222 -
438.223 - case Markup.Assign_Update =>
438.224 - XML.content(output.body) match {
438.225 - case Protocol.Assign_Update(id, update) =>
438.226 - try {
438.227 - val cmds = global_state >>> (_.assign(id, update))
438.228 - delay_commands_changed.invoke(true, cmds)
438.229 - }
438.230 - catch { case _: Document.State.Fail => bad_output() }
438.231 - case _ => bad_output()
438.232 - }
438.233 - // FIXME separate timeout event/message!?
438.234 - if (prover.isDefined && System.currentTimeMillis() > prune_next) {
438.235 - val old_versions = global_state >>> (_.prune_history(prune_size))
438.236 - if (!old_versions.isEmpty) prover.get.remove_versions(old_versions)
438.237 - prune_next = System.currentTimeMillis() + prune_delay.ms
438.238 - }
438.239 -
438.240 - case Markup.Removed_Versions =>
438.241 - XML.content(output.body) match {
438.242 - case Protocol.Removed(removed) =>
438.243 - try {
438.244 - global_state >> (_.removed_versions(removed))
438.245 - }
438.246 - catch { case _: Document.State.Fail => bad_output() }
438.247 - case _ => bad_output()
438.248 - }
438.249 -
438.250 - case Markup.ML_Statistics(props) =>
438.251 - statistics.event(Session.Statistics(props))
438.252 -
438.253 - case Markup.Task_Statistics(props) =>
438.254 - // FIXME
438.255 -
438.256 - case _ => bad_output()
438.257 + case Position.Id(state_id) =>
438.258 + accumulate(state_id, output.message)
438.259 +
438.260 + case _ if output.is_init =>
438.261 + phase = Session.Ready
438.262 +
438.263 + case Markup.Return_Code(rc) if output.is_exit =>
438.264 + if (rc == 0) phase = Session.Inactive
438.265 + else phase = Session.Failed
438.266 +
438.267 + case _ => raw_output_messages.event(output)
438.268 }
438.269 }
438.270 - }
438.271 - else {
438.272 - output.properties match {
438.273 - case Position.Id(state_id) =>
438.274 - accumulate(state_id, output.message)
438.275 -
438.276 - case _ if output.is_init =>
438.277 - phase = Session.Ready
438.278 -
438.279 - case Markup.Return_Code(rc) if output.is_exit =>
438.280 - if (rc == 0) phase = Session.Inactive
438.281 - else phase = Session.Failed
438.282 -
438.283 - case _ => raw_output_messages.event(output)
438.284 - }
438.285 - }
438.286 }
438.287 //}}}
438.288
438.289 @@ -511,7 +524,7 @@
438.290 case Update_Options(options) if prover.isDefined =>
438.291 if (is_ready) {
438.292 prover.get.options(options)
438.293 - handle_raw_edits(Nil)
438.294 + handle_raw_edits(Map.empty, Nil)
438.295 }
438.296 global_options.event(Session.Global_Options(options))
438.297 reply(())
438.298 @@ -519,8 +532,8 @@
438.299 case Cancel_Exec(exec_id) if prover.isDefined =>
438.300 prover.get.cancel_exec(exec_id)
438.301
438.302 - case Session.Raw_Edits(edits) if prover.isDefined =>
438.303 - handle_raw_edits(edits)
438.304 + case Session.Raw_Edits(doc_blobs, edits) if prover.isDefined =>
438.305 + handle_raw_edits(doc_blobs, edits)
438.306 reply(())
438.307
438.308 case Session.Dialog_Result(id, serial, result) if prover.isDefined =>
438.309 @@ -573,8 +586,8 @@
438.310
438.311 def cancel_exec(exec_id: Document_ID.Exec) { session_actor ! Cancel_Exec(exec_id) }
438.312
438.313 - def update(edits: List[Document.Edit_Text])
438.314 - { if (!edits.isEmpty) session_actor !? Session.Raw_Edits(edits) }
438.315 + def update(doc_blobs: Document.Blobs, edits: List[Document.Edit_Text])
438.316 + { if (!edits.isEmpty) session_actor !? Session.Raw_Edits(doc_blobs, edits) }
438.317
438.318 def update_options(options: Options)
438.319 { session_actor !? Update_Options(options) }
439.1 --- a/src/Pure/System/utf8.scala Thu Dec 05 17:52:12 2013 +0100
439.2 +++ b/src/Pure/System/utf8.scala Thu Dec 05 17:58:03 2013 +0100
439.3 @@ -20,13 +20,11 @@
439.4 val charset: Charset = Charset.forName(charset_name)
439.5 def codec(): Codec = Codec(charset)
439.6
439.7 - def string_bytes(s: String): Array[Byte] = s.getBytes(charset)
439.8 -
439.9
439.10 /* permissive UTF-8 decoding */
439.11
439.12 // see also http://en.wikipedia.org/wiki/UTF-8#Description
439.13 - // overlong encodings enable byte-stuffing
439.14 + // overlong encodings enable byte-stuffing of low-ASCII
439.15
439.16 def decode_permissive(text: CharSequence): String =
439.17 {
440.1 --- a/src/Pure/Thy/html.ML Thu Dec 05 17:52:12 2013 +0100
440.2 +++ b/src/Pure/Thy/html.ML Thu Dec 05 17:58:03 2013 +0100
440.3 @@ -12,8 +12,6 @@
440.4 val name: string -> text
440.5 val keyword: string -> text
440.6 val command: string -> text
440.7 - val file_name: string -> text
440.8 - val file_path: Url.T -> text
440.9 val href_name: string -> text -> text
440.10 val href_path: Url.T -> text -> text
440.11 val href_opt_path: Url.T option -> text -> text
440.12 @@ -25,10 +23,7 @@
440.13 val begin_session_index: string -> (Url.T * string) list -> Url.T -> text
440.14 val applet_pages: string -> Url.T * string -> (string * string) list
440.15 val theory_entry: Url.T * string -> text
440.16 - val theory_source: text -> text
440.17 - val begin_theory: string -> (Url.T option * string) list ->
440.18 - (Url.T * Url.T * bool) list -> text -> text
440.19 - val external_file: Url.T -> string -> text
440.20 + val theory: string -> (Url.T option * string) list -> text -> text
440.21 end;
440.22
440.23 structure HTML: HTML =
440.24 @@ -58,7 +53,6 @@
440.25 (* FIXME proper unicode -- produced on Scala side *)
440.26 val html_syms = Symtab.make
440.27 [("", (0, "")),
440.28 - ("\n", (0, "<br/>")),
440.29 ("'", (1, "'")),
440.30 ("\\<exclamdown>", (1, "¡")),
440.31 ("\\<cent>", (1, "¢")),
440.32 @@ -246,8 +240,6 @@
440.33 val name = enclose "<span class=\"name\">" "</span>" o output;
440.34 val keyword = enclose "<span class=\"keyword\">" "</span>" o output;
440.35 val command = enclose "<span class=\"command\">" "</span>" o output;
440.36 -val file_name = enclose "<span class=\"filename\">" "</span>" o output;
440.37 -val file_path = file_name o Url.implode;
440.38
440.39
440.40 (* misc *)
440.41 @@ -326,40 +318,12 @@
440.42
440.43 (* theory *)
440.44
440.45 -val theory_source = enclose
440.46 - "\n</div>\n<div class=\"source\">\n<pre>"
440.47 - "</pre>\n";
440.48 -
440.49 -
440.50 -local
440.51 - fun file (href, path, loadit) =
440.52 - href_path href (if loadit then file_path path else enclose "(" ")" (file_path path));
440.53 -
440.54 - fun theory A =
440.55 - begin_document ("Theory " ^ A) ^ "\n" ^ command "theory" ^ " " ^ name A;
440.56 -
440.57 - fun imports Bs =
440.58 - keyword "imports" ^ " " ^ space_implode " " (map (uncurry href_opt_path o apsnd name) Bs);
440.59 -
440.60 - fun uses Ps = keyword "uses" ^ " " ^ space_implode " " (map file Ps) ^ "<br/>\n";
440.61 -in
440.62 -
440.63 -fun begin_theory A Bs Ps body =
440.64 - theory A ^ "<br/>\n" ^
440.65 - imports Bs ^ "<br/>\n" ^
440.66 - (if null Ps then "" else uses Ps) ^
440.67 - body;
440.68 -
440.69 -end;
440.70 -
440.71 -
440.72 -(* external file *)
440.73 -
440.74 -fun external_file path str =
440.75 - begin_document ("File " ^ Url.implode path) ^
440.76 - "\n</div><div class=\"external_source\">\n" ^
440.77 - verbatim str ^
440.78 - "\n</div>\n<div class=\"external_footer\">" ^
440.79 +fun theory A Bs txt =
440.80 + begin_document ("Theory " ^ A) ^ "\n" ^
440.81 + command "theory" ^ " " ^ name A ^ "<br/>\n" ^
440.82 + keyword "imports" ^ " " ^ space_implode " " (map (uncurry href_opt_path o apsnd name) Bs) ^
440.83 + "<br/>\n" ^
440.84 + enclose "\n</div>\n<div class=\"source\">\n<pre>" "</pre>\n" txt ^
440.85 end_document;
440.86
440.87 end;
441.1 --- a/src/Pure/Thy/present.ML Thu Dec 05 17:52:12 2013 +0100
441.2 +++ b/src/Pure/Thy/present.ML Thu Dec 05 17:58:03 2013 +0100
441.3 @@ -7,15 +7,12 @@
441.4 signature PRESENT =
441.5 sig
441.6 val session_name: theory -> string
441.7 - val no_document: ('a -> 'b) -> 'a -> 'b (*not thread-safe!*)
441.8 val read_variant: string -> string * string
441.9 val init: bool -> bool -> Path.T -> string -> bool -> string -> (string * string) list ->
441.10 string * string -> bool * string -> bool -> theory list -> unit (*not thread-safe!*)
441.11 val finish: unit -> unit (*not thread-safe!*)
441.12 - val init_theory: string -> unit
441.13 - val theory_source: string -> (unit -> HTML.text) -> unit
441.14 val theory_output: string -> string -> unit
441.15 - val begin_theory: int -> Path.T -> theory -> theory
441.16 + val begin_theory: int -> (unit -> HTML.text) -> theory -> theory
441.17 val display_drafts: Path.T list -> int
441.18 end;
441.19
441.20 @@ -105,34 +102,33 @@
441.21
441.22 (* type theory_info *)
441.23
441.24 -type theory_info = {tex_source: Buffer.T, html_source: Buffer.T, html: Buffer.T};
441.25 +type theory_info = {tex_source: string, html_source: string};
441.26
441.27 -fun make_theory_info (tex_source, html_source, html) =
441.28 - {tex_source = tex_source, html_source = html_source, html = html}: theory_info;
441.29 +fun make_theory_info (tex_source, html_source) =
441.30 + {tex_source = tex_source, html_source = html_source}: theory_info;
441.31
441.32 -val empty_theory_info = make_theory_info (Buffer.empty, Buffer.empty, Buffer.empty);
441.33 -
441.34 -fun map_theory_info f {tex_source, html_source, html} =
441.35 - make_theory_info (f (tex_source, html_source, html));
441.36 +fun map_theory_info f {tex_source, html_source} =
441.37 + make_theory_info (f (tex_source, html_source));
441.38
441.39
441.40 (* type browser_info *)
441.41
441.42 -type browser_info = {theories: theory_info Symtab.table, files: (Path.T * string) list,
441.43 - tex_index: (int * string) list, html_index: (int * string) list,
441.44 +type browser_info =
441.45 + {theories: theory_info Symtab.table,
441.46 + tex_index: (int * string) list,
441.47 + html_index: (int * string) list,
441.48 graph: (int * Graph_Display.node) list};
441.49
441.50 -fun make_browser_info (theories, files, tex_index, html_index, graph) =
441.51 - {theories = theories, files = files, tex_index = tex_index, html_index = html_index,
441.52 - graph = graph}: browser_info;
441.53 +fun make_browser_info (theories, tex_index, html_index, graph) : browser_info =
441.54 + {theories = theories, tex_index = tex_index, html_index = html_index, graph = graph};
441.55
441.56 -val empty_browser_info = make_browser_info (Symtab.empty, [], [], [], []);
441.57 +val empty_browser_info = make_browser_info (Symtab.empty, [], [], []);
441.58
441.59 fun init_browser_info session thys =
441.60 - make_browser_info (Symtab.empty, [], [], [], init_graph session thys);
441.61 + make_browser_info (Symtab.empty, [], [], init_graph session thys);
441.62
441.63 -fun map_browser_info f {theories, files, tex_index, html_index, graph} =
441.64 - make_browser_info (f (theories, files, tex_index, html_index, graph));
441.65 +fun map_browser_info f {theories, tex_index, html_index, graph} =
441.66 + make_browser_info (f (theories, tex_index, html_index, graph));
441.67
441.68
441.69 (* state *)
441.70 @@ -141,44 +137,29 @@
441.71 fun change_browser_info f =
441.72 CRITICAL (fn () => Unsynchronized.change browser_info (map_browser_info f));
441.73
441.74 -val suppress_tex_source = Unsynchronized.ref false;
441.75 -fun no_document f x = Unsynchronized.setmp suppress_tex_source true f x;
441.76 -
441.77 fun init_theory_info name info =
441.78 - change_browser_info (fn (theories, files, tex_index, html_index, graph) =>
441.79 - (Symtab.update (name, info) theories, files, tex_index, html_index, graph));
441.80 + change_browser_info (fn (theories, tex_index, html_index, graph) =>
441.81 + (Symtab.update (name, info) theories, tex_index, html_index, graph));
441.82
441.83 fun change_theory_info name f =
441.84 - change_browser_info (fn (theories, files, tex_index, html_index, graph) =>
441.85 + change_browser_info (fn (theories, tex_index, html_index, graph) =>
441.86 (case Symtab.lookup theories name of
441.87 NONE => error ("Browser info: cannot access theory document " ^ quote name)
441.88 - | SOME info => (Symtab.update (name, map_theory_info f info) theories, files,
441.89 - tex_index, html_index, graph)));
441.90 + | SOME info =>
441.91 + (Symtab.update (name, map_theory_info f info) theories, tex_index, html_index, graph)));
441.92
441.93
441.94 -fun add_file file =
441.95 - change_browser_info (fn (theories, files, tex_index, html_index, graph) =>
441.96 - (theories, file :: files, tex_index, html_index, graph));
441.97 -
441.98 fun add_tex_index txt =
441.99 - change_browser_info (fn (theories, files, tex_index, html_index, graph) =>
441.100 - (theories, files, txt :: tex_index, html_index, graph));
441.101 + change_browser_info (fn (theories, tex_index, html_index, graph) =>
441.102 + (theories, txt :: tex_index, html_index, graph));
441.103
441.104 fun add_html_index txt =
441.105 - change_browser_info (fn (theories, files, tex_index, html_index, graph) =>
441.106 - (theories, files, tex_index, txt :: html_index, graph));
441.107 + change_browser_info (fn (theories, tex_index, html_index, graph) =>
441.108 + (theories, tex_index, txt :: html_index, graph));
441.109
441.110 fun add_graph_entry entry =
441.111 - change_browser_info (fn (theories, files, tex_index, html_index, graph) =>
441.112 - (theories, files, tex_index, html_index, ins_graph_entry entry graph));
441.113 -
441.114 -fun add_tex_source name txt =
441.115 - if ! suppress_tex_source then ()
441.116 - else change_theory_info name (fn (tex_source, html_source, html) =>
441.117 - (Buffer.add txt tex_source, html_source, html));
441.118 -
441.119 -fun add_html_source name txt = change_theory_info name (fn (tex_source, html_source, html) =>
441.120 - (tex_source, Buffer.add txt html_source, html));
441.121 + change_browser_info (fn (theories, tex_index, html_index, graph) =>
441.122 + (theories, tex_index, html_index, ins_graph_entry entry graph));
441.123
441.124
441.125
441.126 @@ -299,15 +280,14 @@
441.127 with_session_info () (fn {name, chapter, info, info_path, doc_format, doc_graph, doc_output,
441.128 documents, doc_dump = (dump_copy, dump_prefix), verbose, readme, ...} =>
441.129 let
441.130 - val {theories, files, tex_index, html_index, graph} = ! browser_info;
441.131 + val {theories, tex_index, html_index, graph} = ! browser_info;
441.132 val thys = Symtab.dest theories;
441.133
441.134 val chapter_prefix = Path.append info_path (Path.basic chapter);
441.135 val session_prefix = Path.append chapter_prefix (Path.basic name);
441.136
441.137 - fun finish_html (a, {html, ...}: theory_info) =
441.138 - File.write_buffer (Path.append session_prefix (html_path a))
441.139 - (Buffer.add HTML.end_document html);
441.140 + fun finish_html (a, {html_source, ...}: theory_info) =
441.141 + File.write (Path.append session_prefix (html_path a)) html_source;
441.142
441.143 val sorted_graph = sorted_index graph;
441.144 val opt_graphs =
441.145 @@ -328,8 +308,8 @@
441.146 (HTML.applet_pages name (Url.File index_path, name));
441.147 File.copy (Path.explode "~~/etc/isabelle.css") session_prefix;
441.148 List.app finish_html thys;
441.149 - List.app (uncurry File.write) files;
441.150 - if verbose then Output.physical_stderr ("Browser info at " ^ show_path session_prefix ^ "\n")
441.151 + if verbose
441.152 + then Output.physical_stderr ("Browser info at " ^ show_path session_prefix ^ "\n")
441.153 else ())
441.154 else ();
441.155
441.156 @@ -342,7 +322,8 @@
441.157 (File.write (Path.append doc_dir graph_pdf_path) pdf;
441.158 File.write (Path.append doc_dir graph_eps_path) eps));
441.159 write_tex_index tex_index doc_dir;
441.160 - List.app (fn (a, {tex_source, ...}) => write_tex tex_source a doc_dir) thys);
441.161 + List.app (fn (a, {tex_source, ...}) =>
441.162 + write_tex (Buffer.add tex_source Buffer.empty) a doc_dir) thys);
441.163
441.164 val _ =
441.165 if dump_prefix = "" then ()
441.166 @@ -390,56 +371,36 @@
441.167
441.168 (* theory elements *)
441.169
441.170 -fun init_theory name = with_session_info () (fn _ => init_theory_info name empty_theory_info);
441.171 +fun theory_output name s =
441.172 + with_session_info () (fn _ =>
441.173 + change_theory_info name (fn (_, html_source) => (Latex.isabelle_file name s, html_source)));
441.174
441.175 -fun theory_source name mk_text =
441.176 - with_session_info () (fn _ => add_html_source name (HTML.theory_source (mk_text ())));
441.177 +fun begin_theory update_time mk_text thy =
441.178 + with_session_info thy (fn {name = session_name, chapter, ...} =>
441.179 + let
441.180 + val name = Context.theory_name thy;
441.181 + val parents = Theory.parents_of thy;
441.182
441.183 -fun theory_output name s =
441.184 - with_session_info () (fn _ => add_tex_source name (Latex.isabelle_file name s));
441.185 + val parent_specs = parents |> map (fn parent =>
441.186 + (Option.map Url.File (theory_link (chapter, session_name) parent),
441.187 + (Context.theory_name parent)));
441.188 + val html_source = HTML.theory name parent_specs (mk_text ());
441.189
441.190 -
441.191 -fun begin_theory update_time dir thy =
441.192 - with_session_info thy (fn {name = session_name, chapter, info_path, ...} =>
441.193 - let
441.194 - val name = Context.theory_name thy;
441.195 - val parents = Theory.parents_of thy;
441.196 - val parent_specs = parents |> map (fn parent =>
441.197 - (Option.map Url.File (theory_link (chapter, session_name) parent),
441.198 - (Context.theory_name parent)));
441.199 -
441.200 - val files = []; (* FIXME *)
441.201 - val files_html = files |> map (fn (raw_path, loadit) =>
441.202 - let
441.203 - val path = File.check_file (File.full_path dir raw_path);
441.204 - val base = Path.base path;
441.205 - val base_html = html_ext base;
441.206 - (* FIXME retain file path!? *)
441.207 - val session_prefix = Path.appends [info_path, Path.basic chapter, Path.basic name];
441.208 - val _ =
441.209 - add_file (Path.append session_prefix base_html,
441.210 - HTML.external_file (Url.File base) (File.read path));
441.211 - in (Url.File base_html, Url.File raw_path, loadit) end);
441.212 -
441.213 - fun prep_html_source (tex_source, html_source, html) =
441.214 - let val txt = HTML.begin_theory name parent_specs files_html (Buffer.content html_source)
441.215 - in (tex_source, Buffer.empty, Buffer.add txt html) end;
441.216 -
441.217 - val entry =
441.218 - {name = name,
441.219 - ID = ID_of [chapter, session_name] name,
441.220 - dir = session_name,
441.221 - unfold = true,
441.222 - path = Path.implode (html_path name),
441.223 - parents = map ID_of_thy parents,
441.224 - content = []};
441.225 - in
441.226 - change_theory_info name prep_html_source;
441.227 - add_graph_entry (update_time, entry);
441.228 - add_html_index (update_time, HTML.theory_entry (Url.File (html_path name), name));
441.229 - add_tex_index (update_time, Latex.theory_entry name);
441.230 - Browser_Info.put {chapter = chapter, name = session_name} thy
441.231 - end);
441.232 + val graph_entry =
441.233 + {name = name,
441.234 + ID = ID_of [chapter, session_name] name,
441.235 + dir = session_name,
441.236 + unfold = true,
441.237 + path = Path.implode (html_path name),
441.238 + parents = map ID_of_thy parents,
441.239 + content = []};
441.240 + in
441.241 + init_theory_info name (make_theory_info ("", html_source));
441.242 + add_graph_entry (update_time, graph_entry);
441.243 + add_html_index (update_time, HTML.theory_entry (Url.File (html_path name), name));
441.244 + add_tex_index (update_time, Latex.theory_entry name);
441.245 + Browser_Info.put {chapter = chapter, name = session_name} thy
441.246 + end);
441.247
441.248
441.249
442.1 --- a/src/Pure/Thy/thy_info.ML Thu Dec 05 17:52:12 2013 +0100
442.2 +++ b/src/Pure/Thy/thy_info.ML Thu Dec 05 17:58:03 2013 +0100
442.3 @@ -17,7 +17,8 @@
442.4 val loaded_files: string -> Path.T list
442.5 val remove_thy: string -> unit
442.6 val kill_thy: string -> unit
442.7 - val use_theories: {last_timing: Toplevel.transition -> Time.time option, master_dir: Path.T} ->
442.8 + val use_theories:
442.9 + {document: bool, last_timing: Toplevel.transition -> Time.time option, master_dir: Path.T} ->
442.10 (string * Position.T) list -> unit
442.11 val use_thys: (string * Position.T) list -> unit
442.12 val use_thy: string * Position.T -> unit
442.13 @@ -126,6 +127,7 @@
442.14
442.15 val get_imports = Thy_Load.imports_of o get_theory;
442.16
442.17 +(*Proof General legacy*)
442.18 fun loaded_files name = NAMED_CRITICAL "Thy_Info" (fn () =>
442.19 (case get_deps name of
442.20 NONE => []
442.21 @@ -138,7 +140,7 @@
442.22 (* main loader actions *)
442.23
442.24 fun remove_thy name = NAMED_CRITICAL "Thy_Info" (fn () =>
442.25 - if is_finished name then error (loader_msg "attempt to change finished theory" [name])
442.26 + if is_finished name then error (loader_msg "cannot update finished theory" [name])
442.27 else
442.28 let
442.29 val succs = thy_graph String_Graph.all_succs [name];
442.30 @@ -264,7 +266,7 @@
442.31 fun required_by _ [] = ""
442.32 | required_by s initiators = s ^ "(required by " ^ show_path (rev initiators) ^ ")";
442.33
442.34 -fun load_thy last_timing initiators update_time deps text (name, pos) keywords parents =
442.35 +fun load_thy document last_timing initiators update_time deps text (name, pos) keywords parents =
442.36 let
442.37 val _ = kill_thy name;
442.38 val _ = Output.urgent_message ("Loading theory " ^ quote name ^ required_by " " initiators);
442.39 @@ -283,7 +285,7 @@
442.40
442.41 val text_pos = Position.put_id (Document_ID.print exec_id) (Path.position thy_path);
442.42 val (theory, present, weight) =
442.43 - Thy_Load.load_thy last_timing update_time dir header text_pos text
442.44 + Thy_Load.load_thy document last_timing update_time dir header text_pos text
442.45 (if name = Context.PureN then [ML_Context.the_global_context ()] else parents);
442.46 fun commit () = update_thy deps theory;
442.47 in
442.48 @@ -305,14 +307,14 @@
442.49 #2 master = #2 master' andalso
442.50 (case lookup_theory name of
442.51 NONE => false
442.52 - | SOME theory => Thy_Load.load_current theory);
442.53 + | SOME theory => Thy_Load.loaded_files_current theory);
442.54 in (current, deps', theory_pos', imports', keywords') end);
442.55
442.56 in
442.57
442.58 -fun require_thys last_timing initiators dir strs tasks =
442.59 - fold_map (require_thy last_timing initiators dir) strs tasks |>> forall I
442.60 -and require_thy last_timing initiators dir (str, require_pos) tasks =
442.61 +fun require_thys document last_timing initiators dir strs tasks =
442.62 + fold_map (require_thy document last_timing initiators dir) strs tasks |>> forall I
442.63 +and require_thy document last_timing initiators dir (str, require_pos) tasks =
442.64 let
442.65 val path = Path.expand (Path.explode str);
442.66 val name = Path.implode (Path.base path);
442.67 @@ -331,7 +333,7 @@
442.68
442.69 val parents = map (base_name o #1) imports;
442.70 val (parents_current, tasks') =
442.71 - require_thys last_timing (name :: initiators)
442.72 + require_thys document last_timing (name :: initiators)
442.73 (Path.append dir (master_dir (Option.map #1 deps))) imports tasks;
442.74
442.75 val all_current = current andalso parents_current;
442.76 @@ -344,7 +346,7 @@
442.77 let
442.78 val update_time = serial ();
442.79 val load =
442.80 - load_thy last_timing initiators update_time dep
442.81 + load_thy document last_timing initiators update_time dep
442.82 text (name, theory_pos) keywords;
442.83 in Task (parents, load) end);
442.84
442.85 @@ -357,10 +359,10 @@
442.86
442.87 (* use_thy *)
442.88
442.89 -fun use_theories {last_timing, master_dir} imports =
442.90 - schedule_tasks (snd (require_thys last_timing [] master_dir imports String_Graph.empty));
442.91 +fun use_theories {document, last_timing, master_dir} imports =
442.92 + schedule_tasks (snd (require_thys document last_timing [] master_dir imports String_Graph.empty));
442.93
442.94 -val use_thys = use_theories {last_timing = K NONE, master_dir = Path.current};
442.95 +val use_thys = use_theories {document = false, last_timing = K NONE, master_dir = Path.current};
442.96 val use_thy = use_thys o single;
442.97
442.98
442.99 @@ -370,7 +372,7 @@
442.100 let
442.101 val {name = (name, _), imports, ...} = header;
442.102 val _ = kill_thy name;
442.103 - val _ = use_theories {last_timing = K NONE, master_dir = master_dir} imports;
442.104 + val _ = use_theories {document = false, last_timing = K NONE, master_dir = master_dir} imports;
442.105 val _ = Thy_Header.define_keywords header;
442.106 val parents = map (get_theory o base_name o fst) imports;
442.107 in Thy_Load.begin_theory master_dir header parents end;
443.1 --- a/src/Pure/Thy/thy_info.scala Thu Dec 05 17:52:12 2013 +0100
443.2 +++ b/src/Pure/Thy/thy_info.scala Thu Dec 05 17:58:03 2013 +0100
443.3 @@ -58,6 +58,8 @@
443.4
443.5 def deps: List[Dep] = rev_deps.reverse
443.6
443.7 + def errors: List[String] = deps.flatMap(dep => dep.header.errors)
443.8 +
443.9 lazy val syntax: Outer_Syntax = thy_load.base_syntax.add_keywords(keywords)
443.10
443.11 def loaded_theories: Set[String] =
443.12 @@ -68,7 +70,7 @@
443.13 val dep_files =
443.14 rev_deps.par.map(dep =>
443.15 Exn.capture {
443.16 - dep.load_files(syntax).map(a => Path.explode(dep.name.dir) + Path.explode(a))
443.17 + dep.load_files(syntax).map(a => Path.explode(dep.name.master_dir) + Path.explode(a))
443.18 }).toList
443.19 ((Nil: List[Path]) /: dep_files) {
443.20 case (acc_files, files) => Exn.release(files) ::: acc_files
443.21 @@ -86,15 +88,15 @@
443.22 if (required.seen(name)) required
443.23 else if (thy_load.loaded_theories(name.theory)) required + name
443.24 else {
443.25 - def err(msg: String): Nothing =
443.26 - cat_error(msg, "The error(s) above occurred while examining theory " +
443.27 - quote(name.theory) + required_by(initiators))
443.28 + def message: String =
443.29 + "The error(s) above occurred while examining theory " +
443.30 + quote(name.theory) + required_by(initiators)
443.31
443.32 try {
443.33 if (initiators.contains(name)) error(cycle_msg(initiators))
443.34 val header =
443.35 - try { thy_load.check_thy(name) }
443.36 - catch { case ERROR(msg) => err(msg) }
443.37 + try { thy_load.check_thy(name).cat_errors(message) }
443.38 + catch { case ERROR(msg) => cat_error(msg, message) }
443.39 Dep(name, header) :: require_thys(name :: initiators, required + name, header.imports)
443.40 }
443.41 catch {
444.1 --- a/src/Pure/Thy/thy_load.ML Thu Dec 05 17:52:12 2013 +0100
444.2 +++ b/src/Pure/Thy/thy_load.ML Thu Dec 05 17:58:03 2013 +0100
444.3 @@ -1,7 +1,7 @@
444.4 (* Title: Pure/Thy/thy_load.ML
444.5 Author: Makarius
444.6
444.7 -Loading files that contribute to a theory. Global master path for TTY loop.
444.8 +Management of theory sources and auxiliary files.
444.9 *)
444.10
444.11 signature THY_LOAD =
444.12 @@ -9,23 +9,18 @@
444.13 val master_directory: theory -> Path.T
444.14 val imports_of: theory -> (string * Position.T) list
444.15 val thy_path: Path.T -> Path.T
444.16 - val parse_files: string -> (theory -> Token.file list) parser
444.17 val check_thy: Path.T -> string ->
444.18 {master: Path.T * SHA1.digest, text: string, theory_pos: Position.T,
444.19 imports: (string * Position.T) list, keywords: Thy_Header.keywords}
444.20 + val parse_files: string -> (theory -> Token.file list) parser
444.21 val provide: Path.T * SHA1.digest -> theory -> theory
444.22 val provide_parse_files: string -> (theory -> Token.file list * theory) parser
444.23 val load_file: theory -> Path.T -> (Path.T * SHA1.digest) * string
444.24 - val use_file: Path.T -> theory -> string * theory
444.25 val loaded_files: theory -> Path.T list
444.26 - val load_current: theory -> bool
444.27 - val use_ml: Path.T -> unit
444.28 - val exec_ml: Path.T -> generic_theory -> generic_theory
444.29 + val loaded_files_current: theory -> bool
444.30 val begin_theory: Path.T -> Thy_Header.header -> theory list -> theory
444.31 - val load_thy: (Toplevel.transition -> Time.time option) -> int -> Path.T -> Thy_Header.header ->
444.32 - Position.T -> string -> theory list -> theory * (unit -> unit) * int
444.33 - val set_master_path: Path.T -> unit
444.34 - val get_master_path: unit -> Path.T
444.35 + val load_thy: bool -> (Toplevel.transition -> Time.time option) -> int -> Path.T ->
444.36 + Thy_Header.header -> Position.T -> string -> theory list -> theory * (unit -> unit) * int
444.37 end;
444.38
444.39 structure Thy_Load: THY_LOAD =
444.40 @@ -60,72 +55,12 @@
444.41 fun put_deps master_dir imports = map_files (fn _ => (master_dir, imports, []));
444.42
444.43
444.44 -(* inlined files *)
444.45 +(* theory files *)
444.46 +
444.47 +val thy_path = Path.ext "thy";
444.48
444.49 fun check_file dir file = File.check_file (File.full_path dir file);
444.50
444.51 -fun read_files cmd dir (path, pos) =
444.52 - let
444.53 - fun make_file file =
444.54 - let
444.55 - val _ = Position.report pos (Markup.path (Path.implode file));
444.56 - val full_path = check_file dir file;
444.57 - in {src_path = file, text = File.read full_path, pos = Path.position full_path} end;
444.58 - val paths =
444.59 - (case Keyword.command_files cmd of
444.60 - [] => [path]
444.61 - | exts => map (fn ext => Path.ext ext path) exts);
444.62 - in map make_file paths end;
444.63 -
444.64 -fun parse_files cmd =
444.65 - Scan.ahead Parse.not_eof -- Parse.path >> (fn (tok, name) => fn thy =>
444.66 - (case Token.get_files tok of
444.67 - SOME files => files
444.68 - | NONE => read_files cmd (master_directory thy) (Path.explode name, Token.position_of tok)));
444.69 -
444.70 -local
444.71 -
444.72 -fun clean ((i1, t1) :: (i2, t2) :: toks) =
444.73 - if Token.keyword_with (fn s => s = "%" orelse s = "--") t1 then clean toks
444.74 - else (i1, t1) :: clean ((i2, t2) :: toks)
444.75 - | clean toks = toks;
444.76 -
444.77 -fun clean_tokens toks =
444.78 - ((0 upto length toks - 1) ~~ toks)
444.79 - |> filter (fn (_, tok) => Token.is_proper tok)
444.80 - |> clean;
444.81 -
444.82 -fun find_file toks =
444.83 - rev (clean_tokens toks) |> get_first (fn (i, tok) =>
444.84 - if Token.is_name tok then
444.85 - SOME (i, (Path.explode (Token.content_of tok), Token.position_of tok))
444.86 - handle ERROR msg => error (msg ^ Token.pos_of tok)
444.87 - else NONE);
444.88 -
444.89 -in
444.90 -
444.91 -fun resolve_files master_dir span =
444.92 - (case span of
444.93 - Thy_Syntax.Span (Thy_Syntax.Command (cmd, pos), toks) =>
444.94 - if Keyword.is_theory_load cmd then
444.95 - (case find_file toks of
444.96 - NONE => error ("Bad file argument of command " ^ quote cmd ^ Position.here pos)
444.97 - | SOME (i, path) =>
444.98 - let
444.99 - val toks' = toks |> map_index (fn (j, tok) =>
444.100 - if i = j then Token.put_files (read_files cmd master_dir path) tok
444.101 - else tok);
444.102 - in Thy_Syntax.Span (Thy_Syntax.Command (cmd, pos), toks') end)
444.103 - else span
444.104 - | span => span);
444.105 -
444.106 -end;
444.107 -
444.108 -
444.109 -(* check files *)
444.110 -
444.111 -val thy_path = Path.ext "thy";
444.112 -
444.113 fun check_thy dir thy_name =
444.114 let
444.115 val path = thy_path (Path.basic thy_name);
444.116 @@ -144,6 +79,17 @@
444.117
444.118 (* load files *)
444.119
444.120 +fun parse_files cmd =
444.121 + Scan.ahead Parse.not_eof -- Parse.path >> (fn (tok, name) => fn thy =>
444.122 + (case Token.get_files tok of
444.123 + [] =>
444.124 + let
444.125 + val master_dir = master_directory thy;
444.126 + val pos = Token.position_of tok;
444.127 + val src_paths = Keyword.command_files cmd (Path.explode name);
444.128 + in map (Command.read_file master_dir pos) src_paths end
444.129 + | files => map Exn.release files));
444.130 +
444.131 fun provide (src_path, id) =
444.132 map_files (fn (master_dir, imports, provided) =>
444.133 if AList.defined (op =) provided src_path then
444.134 @@ -164,59 +110,31 @@
444.135 val id = SHA1.digest text;
444.136 in ((full_path, id), text) end;
444.137
444.138 -fun use_file src_path thy =
444.139 - let
444.140 - val ((_, id), text) = load_file thy src_path;
444.141 - val thy' = provide (src_path, id) thy;
444.142 - in (text, thy') end;
444.143 -
444.144 -fun loaded_files thy =
444.145 - let val {master_dir, provided, ...} = Files.get thy
444.146 - in map (File.full_path master_dir o #1) provided end;
444.147 -
444.148 -fun load_current thy =
444.149 +fun loaded_files_current thy =
444.150 #provided (Files.get thy) |>
444.151 forall (fn (src_path, id) =>
444.152 (case try (load_file thy) src_path of
444.153 NONE => false
444.154 | SOME ((_, id'), _) => id = id'));
444.155
444.156 +(*Proof General legacy*)
444.157 +fun loaded_files thy =
444.158 + let val {master_dir, provided, ...} = Files.get thy
444.159 + in map (File.full_path master_dir o #1) provided end;
444.160
444.161 -(* provide files *)
444.162
444.163 -fun eval_file path text = ML_Context.eval_text true (Path.position path) text;
444.164 -
444.165 -fun use_ml src_path =
444.166 - if is_none (Context.thread_data ()) then
444.167 - let val path = check_file Path.current src_path
444.168 - in eval_file path (File.read path) end
444.169 - else
444.170 - let
444.171 - val thy = ML_Context.the_global_context ();
444.172 -
444.173 - val ((path, id), text) = load_file thy src_path;
444.174 - val _ = eval_file path text;
444.175 - val _ = Context.>> Local_Theory.propagate_ml_env;
444.176 -
444.177 - val provide = provide (src_path, id);
444.178 - val _ = Context.>> (Context.mapping provide (Local_Theory.background_theory provide));
444.179 - in () end;
444.180 -
444.181 -fun exec_ml src_path = ML_Context.exec (fn () => use_ml src_path);
444.182 -
444.183 -
444.184 -(* load_thy *)
444.185 +(* load theory *)
444.186
444.187 fun begin_theory master_dir {name, imports, keywords} parents =
444.188 Theory.begin_theory name parents
444.189 |> put_deps master_dir imports
444.190 |> fold Thy_Header.declare_keyword keywords;
444.191
444.192 -fun excursion last_timing init elements =
444.193 +fun excursion master_dir last_timing init elements =
444.194 let
444.195 fun prepare_span span =
444.196 Thy_Syntax.span_content span
444.197 - |> Command.read init
444.198 + |> Command.read init master_dir []
444.199 |> (fn tr => Toplevel.put_timing (last_timing tr) tr);
444.200
444.201 fun element_result span_elem (st, _) =
444.202 @@ -232,28 +150,26 @@
444.203 val thy = Toplevel.end_theory end_pos end_state;
444.204 in (results, thy) end;
444.205
444.206 -fun load_thy last_timing update_time master_dir header text_pos text parents =
444.207 +fun load_thy document last_timing update_time master_dir header text_pos text parents =
444.208 let
444.209 val time = ! Toplevel.timing;
444.210
444.211 val {name = (name, _), ...} = header;
444.212 val _ = Thy_Header.define_keywords header;
444.213 - val _ = Present.init_theory name;
444.214 +
444.215 + val lexs = Keyword.get_lexicons ();
444.216 + val toks = Thy_Syntax.parse_tokens lexs text_pos text;
444.217 + val spans = Thy_Syntax.parse_spans toks;
444.218 + val elements = Thy_Syntax.parse_elements spans;
444.219 +
444.220 fun init () =
444.221 begin_theory master_dir header parents
444.222 - |> Present.begin_theory update_time master_dir;
444.223 -
444.224 - val lexs = Keyword.get_lexicons ();
444.225 -
444.226 - val toks = Thy_Syntax.parse_tokens lexs text_pos text;
444.227 - val spans = map (resolve_files master_dir) (Thy_Syntax.parse_spans toks);
444.228 - val elements = Thy_Syntax.parse_elements spans;
444.229 -
444.230 - val _ = Present.theory_source name
444.231 - (fn () => HTML.html_mode (implode o map Thy_Syntax.present_span) spans);
444.232 + |> Present.begin_theory update_time
444.233 + (fn () => HTML.html_mode (implode o map Thy_Syntax.present_span) spans);
444.234
444.235 val _ = if time then writeln ("\n**** Starting theory " ^ quote name ^ " ****") else ();
444.236 - val (results, thy) = cond_timeit time "" (fn () => excursion last_timing init elements);
444.237 + val (results, thy) =
444.238 + cond_timeit time "" (fn () => excursion master_dir last_timing init elements);
444.239 val _ = if time then writeln ("**** Finished theory " ^ quote name ^ " ****\n") else ();
444.240
444.241 fun present () =
444.242 @@ -264,10 +180,11 @@
444.243 if exists (Toplevel.is_skipped_proof o #2) res then
444.244 warning ("Cannot present theory with skipped proofs: " ^ quote name)
444.245 else
444.246 - Thy_Output.present_thy minor Keyword.command_tags
444.247 - (Outer_Syntax.is_markup outer_syntax) res toks
444.248 - |> Buffer.content
444.249 - |> Present.theory_output name
444.250 + let val tex_source =
444.251 + Thy_Output.present_thy minor Keyword.command_tags
444.252 + (Outer_Syntax.is_markup outer_syntax) res toks
444.253 + |> Buffer.content;
444.254 + in if document then Present.theory_output name tex_source else () end
444.255 end;
444.256
444.257 in (thy, present, size text) end;
444.258 @@ -291,16 +208,4 @@
444.259 |> space_implode (Thy_Output.verb_text "/" ^ "\\discretionary{}{}{}")
444.260 end));
444.261
444.262 -
444.263 -(* global master path *) (*Proof General legacy*)
444.264 -
444.265 -local
444.266 - val master_path = Unsynchronized.ref Path.current;
444.267 -in
444.268 -
444.269 -fun set_master_path path = master_path := path;
444.270 -fun get_master_path () = ! master_path;
444.271 -
444.272 end;
444.273 -
444.274 -end;
445.1 --- a/src/Pure/Thy/thy_load.scala Thu Dec 05 17:52:12 2013 +0100
445.2 +++ b/src/Pure/Thy/thy_load.scala Thu Dec 05 17:58:03 2013 +0100
445.3 @@ -21,23 +21,23 @@
445.4 def is_ok(str: String): Boolean =
445.5 try { thy_path(Path.explode(str)); true }
445.6 catch { case ERROR(_) => false }
445.7 +}
445.8
445.9
445.10 +class Thy_Load(val loaded_theories: Set[String] = Set.empty, val base_syntax: Outer_Syntax)
445.11 +{
445.12 /* document node names */
445.13
445.14 - def path_node_name(raw_path: Path): Document.Node.Name =
445.15 + def node_name(raw_path: Path): Document.Node.Name =
445.16 {
445.17 val path = raw_path.expand
445.18 val node = path.implode
445.19 - val dir = path.dir.implode
445.20 - val theory = Thy_Header.thy_name(node) getOrElse error("Bad theory file name: " + path)
445.21 - Document.Node.Name(node, dir, theory)
445.22 + val theory = Thy_Header.thy_name(node).getOrElse("")
445.23 + val master_dir = if (theory == "") "" else path.dir.implode
445.24 + Document.Node.Name(node, master_dir, theory)
445.25 }
445.26 -}
445.27
445.28
445.29 -class Thy_Load(val loaded_theories: Set[String] = Set.empty, val base_syntax: Outer_Syntax)
445.30 -{
445.31 /* file-system operations */
445.32
445.33 def append(dir: String, source_path: Path): String =
445.34 @@ -56,50 +56,24 @@
445.35
445.36 /* theory files */
445.37
445.38 - private def find_file(tokens: List[Token]): Option[String] =
445.39 - {
445.40 - def clean(toks: List[Token]): List[Token] =
445.41 - toks match {
445.42 - case t :: _ :: ts if t.is_keyword && (t.source == "%" || t.source == "--") => clean(ts)
445.43 - case t :: ts => t :: clean(ts)
445.44 - case Nil => Nil
445.45 - }
445.46 - val clean_tokens = clean(tokens.filter(_.is_proper))
445.47 - clean_tokens.reverse.find(_.is_name).map(_.content)
445.48 - }
445.49 -
445.50 def body_files_test(syntax: Outer_Syntax, text: String): Boolean =
445.51 syntax.thy_load_commands.exists({ case (cmd, _) => text.containsSlice(cmd) })
445.52
445.53 def body_files(syntax: Outer_Syntax, text: String): List[String] =
445.54 {
445.55 - val thy_load_commands = syntax.thy_load_commands
445.56 val spans = Thy_Syntax.parse_spans(syntax.scan(text))
445.57 - spans.iterator.map({
445.58 - case toks @ (tok :: _) if tok.is_command =>
445.59 - thy_load_commands.find({ case (cmd, _) => cmd == tok.content }) match {
445.60 - case Some((_, exts)) =>
445.61 - find_file(toks) match {
445.62 - case Some(file) =>
445.63 - if (exts.isEmpty) List(file)
445.64 - else exts.map(ext => file + "." + ext)
445.65 - case None => Nil
445.66 - }
445.67 - case None => Nil
445.68 - }
445.69 - case _ => Nil
445.70 - }).flatten.toList
445.71 + spans.iterator.map(Thy_Syntax.span_files(syntax, _)).flatten.toList
445.72 }
445.73
445.74 def import_name(master: Document.Node.Name, s: String): Document.Node.Name =
445.75 {
445.76 val theory = Thy_Header.base_name(s)
445.77 - if (loaded_theories(theory)) Document.Node.Name(theory, "", theory)
445.78 + if (loaded_theories(theory)) Document.Node.Name(theory + ".thy", "", theory)
445.79 else {
445.80 val path = Path.explode(s)
445.81 - val node = append(master.dir, Thy_Load.thy_path(path))
445.82 - val dir = append(master.dir, path.dir)
445.83 - Document.Node.Name(node, dir, theory)
445.84 + val node = append(master.master_dir, Thy_Load.thy_path(path))
445.85 + val master_dir = append(master.master_dir, path.dir)
445.86 + Document.Node.Name(node, master_dir, theory)
445.87 }
445.88 }
445.89
445.90 @@ -125,8 +99,11 @@
445.91
445.92 /* theory text edits */
445.93
445.94 - def text_edits(reparse_limit: Int, previous: Document.Version, edits: List[Document.Edit_Text])
445.95 - : (List[Document.Edit_Command], Document.Version) =
445.96 - Thy_Syntax.text_edits(base_syntax, reparse_limit, previous, edits)
445.97 + def text_edits(
445.98 + reparse_limit: Int,
445.99 + previous: Document.Version,
445.100 + doc_blobs: Document.Blobs,
445.101 + edits: List[Document.Edit_Text]): (List[Document.Edit_Command], Document.Version) =
445.102 + Thy_Syntax.text_edits(this, reparse_limit, previous, doc_blobs, edits)
445.103 }
445.104
446.1 --- a/src/Pure/Thy/thy_syntax.ML Thu Dec 05 17:52:12 2013 +0100
446.2 +++ b/src/Pure/Thy/thy_syntax.ML Thu Dec 05 17:58:03 2013 +0100
446.3 @@ -15,6 +15,7 @@
446.4 val span_content: span -> Token.T list
446.5 val present_span: span -> Output.output
446.6 val parse_spans: Token.T list -> span list
446.7 + val resolve_files: (string -> Path.T * Position.T -> Token.file Exn.result list) -> span -> span
446.8 datatype 'a element = Element of 'a * ('a element list * 'a) option
446.9 val atom: 'a -> 'a element
446.10 val map_element: ('a -> 'b) -> 'a element -> 'b element
446.11 @@ -142,6 +143,47 @@
446.12 end;
446.13
446.14
446.15 +(* inlined files *)
446.16 +
446.17 +local
446.18 +
446.19 +fun clean ((i1, t1) :: (i2, t2) :: toks) =
446.20 + if Token.keyword_with (fn s => s = "%" orelse s = "--") t1 then clean toks
446.21 + else (i1, t1) :: clean ((i2, t2) :: toks)
446.22 + | clean toks = toks;
446.23 +
446.24 +fun clean_tokens toks =
446.25 + ((0 upto length toks - 1) ~~ toks)
446.26 + |> filter (fn (_, tok) => Token.is_proper tok)
446.27 + |> clean;
446.28 +
446.29 +fun find_file toks =
446.30 + rev (clean_tokens toks) |> get_first (fn (i, tok) =>
446.31 + if Token.is_name tok then
446.32 + SOME (i, (Path.explode (Token.content_of tok), Token.position_of tok))
446.33 + handle ERROR msg => error (msg ^ Token.pos_of tok)
446.34 + else NONE);
446.35 +
446.36 +in
446.37 +
446.38 +fun resolve_files read_files span =
446.39 + (case span of
446.40 + Span (Command (cmd, pos), toks) =>
446.41 + if Keyword.is_theory_load cmd then
446.42 + (case find_file toks of
446.43 + NONE => error ("Bad file argument of command " ^ quote cmd ^ Position.here pos)
446.44 + | SOME (i, path) =>
446.45 + let
446.46 + val toks' = toks |> map_index (fn (j, tok) =>
446.47 + if i = j then Token.put_files (read_files cmd path) tok
446.48 + else tok);
446.49 + in Span (Command (cmd, pos), toks') end)
446.50 + else span
446.51 + | _ => span);
446.52 +
446.53 +end;
446.54 +
446.55 +
446.56
446.57 (** specification elements: commands with optional proof **)
446.58
447.1 --- a/src/Pure/Thy/thy_syntax.scala Thu Dec 05 17:52:12 2013 +0100
447.2 +++ b/src/Pure/Thy/thy_syntax.scala Thu Dec 05 17:58:03 2013 +0100
447.3 @@ -33,7 +33,7 @@
447.4
447.5 def buffer(): mutable.ListBuffer[Entry] = new mutable.ListBuffer[Entry]
447.6 var stack: List[(Int, String, mutable.ListBuffer[Entry])] =
447.7 - List((0, node_name.theory, buffer()))
447.8 + List((0, node_name.toString, buffer()))
447.9
447.10 @tailrec def close(level: Int => Boolean)
447.11 {
447.12 @@ -68,7 +68,7 @@
447.13 /* result structure */
447.14
447.15 val spans = parse_spans(syntax.scan(text))
447.16 - spans.foreach(span => add(Command(Document_ID.none, node_name, span)))
447.17 + spans.foreach(span => add(Command(Document_ID.none, node_name, Nil, span)))
447.18 result()
447.19 }
447.20 }
447.21 @@ -225,23 +225,73 @@
447.22 }
447.23
447.24
447.25 + /* inlined files */
447.26 +
447.27 + private def find_file(tokens: List[Token]): Option[String] =
447.28 + {
447.29 + def clean(toks: List[Token]): List[Token] =
447.30 + toks match {
447.31 + case t :: _ :: ts if t.is_keyword && (t.source == "%" || t.source == "--") => clean(ts)
447.32 + case t :: ts => t :: clean(ts)
447.33 + case Nil => Nil
447.34 + }
447.35 + val clean_tokens = clean(tokens.filter(_.is_proper))
447.36 + clean_tokens.reverse.find(_.is_name).map(_.content)
447.37 + }
447.38 +
447.39 + def span_files(syntax: Outer_Syntax, span: List[Token]): List[String] =
447.40 + syntax.thy_load(span) match {
447.41 + case Some(exts) =>
447.42 + find_file(span) match {
447.43 + case Some(file) =>
447.44 + if (exts.isEmpty) List(file)
447.45 + else exts.map(ext => file + "." + ext)
447.46 + case None => Nil
447.47 + }
447.48 + case None => Nil
447.49 + }
447.50 +
447.51 + def resolve_files(
447.52 + thy_load: Thy_Load,
447.53 + syntax: Outer_Syntax,
447.54 + node_name: Document.Node.Name,
447.55 + span: List[Token],
447.56 + doc_blobs: Document.Blobs)
447.57 + : List[Command.Blob] =
447.58 + {
447.59 + span_files(syntax, span).map(file =>
447.60 + Exn.capture {
447.61 + val name =
447.62 + Document.Node.Name(thy_load.append(node_name.master_dir, Path.explode(file)))
447.63 + (name, doc_blobs.get(name).map(_.sha1_digest))
447.64 + }
447.65 + )
447.66 + }
447.67 +
447.68 +
447.69 /* reparse range of command spans */
447.70
447.71 @tailrec private def chop_common(
447.72 - cmds: List[Command], spans: List[List[Token]]): (List[Command], List[List[Token]]) =
447.73 + cmds: List[Command], spans: List[(List[Command.Blob], List[Token])])
447.74 + : (List[Command], List[(List[Command.Blob], List[Token])]) =
447.75 (cmds, spans) match {
447.76 - case (c :: cs, s :: ss) if c.span == s => chop_common(cs, ss)
447.77 + case (c :: cs, (blobs, span) :: ps) if c.blobs == blobs && c.span == span =>
447.78 + chop_common(cs, ps)
447.79 case _ => (cmds, spans)
447.80 }
447.81
447.82 private def reparse_spans(
447.83 + thy_load: Thy_Load,
447.84 syntax: Outer_Syntax,
447.85 + doc_blobs: Document.Blobs,
447.86 name: Document.Node.Name,
447.87 commands: Linear_Set[Command],
447.88 first: Command, last: Command): Linear_Set[Command] =
447.89 {
447.90 val cmds0 = commands.iterator(first, last).toList
447.91 - val spans0 = parse_spans(syntax.scan(cmds0.iterator.map(_.source).mkString))
447.92 + val spans0 =
447.93 + parse_spans(syntax.scan(cmds0.iterator.map(_.source).mkString)).
447.94 + map(span => (resolve_files(thy_load, syntax, name, span, doc_blobs), span))
447.95
447.96 val (cmds1, spans1) = chop_common(cmds0, spans0)
447.97
447.98 @@ -255,7 +305,8 @@
447.99 commands
447.100 case cmd :: _ =>
447.101 val hook = commands.prev(cmd)
447.102 - val inserted = spans2.map(span => Command(Document_ID.make(), name, span))
447.103 + val inserted =
447.104 + spans2.map({ case (blobs, span) => Command(Document_ID.make(), name, blobs, span) })
447.105 (commands /: cmds2)(_ - _).append_after(hook, inserted)
447.106 }
447.107 }
447.108 @@ -265,7 +316,9 @@
447.109
447.110 // FIXME somewhat slow
447.111 private def recover_spans(
447.112 + thy_load: Thy_Load,
447.113 syntax: Outer_Syntax,
447.114 + doc_blobs: Document.Blobs,
447.115 name: Document.Node.Name,
447.116 perspective: Command.Perspective,
447.117 commands: Linear_Set[Command]): Linear_Set[Command] =
447.118 @@ -281,7 +334,7 @@
447.119 case Some(first_unparsed) =>
447.120 val first = next_invisible_command(cmds.reverse, first_unparsed)
447.121 val last = next_invisible_command(cmds, first_unparsed)
447.122 - recover(reparse_spans(syntax, name, cmds, first, last))
447.123 + recover(reparse_spans(thy_load, syntax, doc_blobs, name, cmds, first, last))
447.124 case None => cmds
447.125 }
447.126 recover(commands)
447.127 @@ -291,7 +344,9 @@
447.128 /* consolidate unfinished spans */
447.129
447.130 private def consolidate_spans(
447.131 + thy_load: Thy_Load,
447.132 syntax: Outer_Syntax,
447.133 + doc_blobs: Document.Blobs,
447.134 reparse_limit: Int,
447.135 name: Document.Node.Name,
447.136 perspective: Command.Perspective,
447.137 @@ -311,7 +366,7 @@
447.138 last = it.next
447.139 i += last.length
447.140 }
447.141 - reparse_spans(syntax, name, commands, first_unfinished, last)
447.142 + reparse_spans(thy_load, syntax, doc_blobs, name, commands, first_unfinished, last)
447.143 case None => commands
447.144 }
447.145 case None => commands
447.146 @@ -332,16 +387,23 @@
447.147 inserted.map(cmd => (new_cmds.prev(cmd), Some(cmd)))
447.148 }
447.149
447.150 - private def text_edit(syntax: Outer_Syntax, reparse_limit: Int,
447.151 + private def text_edit(
447.152 + thy_load: Thy_Load,
447.153 + syntax: Outer_Syntax,
447.154 + doc_blobs: Document.Blobs,
447.155 + reparse_limit: Int,
447.156 node: Document.Node, edit: Document.Edit_Text): Document.Node =
447.157 {
447.158 edit match {
447.159 case (_, Document.Node.Clear()) => node.clear
447.160
447.161 + case (_, Document.Node.Blob()) => node
447.162 +
447.163 case (name, Document.Node.Edits(text_edits)) =>
447.164 val commands0 = node.commands
447.165 val commands1 = edit_text(text_edits, commands0)
447.166 - val commands2 = recover_spans(syntax, name, node.perspective.visible, commands1)
447.167 + val commands2 =
447.168 + recover_spans(thy_load, syntax, doc_blobs, name, node.perspective.visible, commands1)
447.169 node.update_commands(commands2)
447.170
447.171 case (_, Document.Node.Deps(_)) => node
447.172 @@ -353,46 +415,62 @@
447.173 if (node.same_perspective(perspective)) node
447.174 else
447.175 node.update_perspective(perspective).update_commands(
447.176 - consolidate_spans(syntax, reparse_limit, name, visible, node.commands))
447.177 + consolidate_spans(thy_load, syntax, doc_blobs, reparse_limit,
447.178 + name, visible, node.commands))
447.179 }
447.180 }
447.181
447.182 def text_edits(
447.183 - base_syntax: Outer_Syntax,
447.184 + thy_load: Thy_Load,
447.185 reparse_limit: Int,
447.186 previous: Document.Version,
447.187 + doc_blobs: Document.Blobs,
447.188 edits: List[Document.Edit_Text])
447.189 : (List[Document.Edit_Command], Document.Version) =
447.190 {
447.191 - val (syntax, reparse, nodes0, doc_edits0) = header_edits(base_syntax, previous, edits)
447.192 - val reparse_set = reparse.toSet
447.193 + val (syntax, reparse0, nodes0, doc_edits0) =
447.194 + header_edits(thy_load.base_syntax, previous, edits)
447.195
447.196 - var nodes = nodes0
447.197 - val doc_edits = new mutable.ListBuffer[Document.Edit_Command]; doc_edits ++= doc_edits0
447.198 + if (edits.isEmpty)
447.199 + (Nil, Document.Version.make(syntax, previous.nodes))
447.200 + else {
447.201 + val reparse =
447.202 + (reparse0 /: nodes0.entries)({
447.203 + case (reparse, (name, node)) =>
447.204 + if (node.thy_load_commands.isEmpty) reparse
447.205 + else name :: reparse
447.206 + })
447.207 + val reparse_set = reparse.toSet
447.208
447.209 - val node_edits =
447.210 - (edits ::: reparse.map((_, Document.Node.Edits(Nil)))).groupBy(_._1)
447.211 - .asInstanceOf[Map[Document.Node.Name, List[Document.Edit_Text]]] // FIXME ???
447.212 + var nodes = nodes0
447.213 + val doc_edits = new mutable.ListBuffer[Document.Edit_Command]; doc_edits ++= doc_edits0
447.214
447.215 - node_edits foreach {
447.216 - case (name, edits) =>
447.217 - val node = nodes(name)
447.218 - val commands = node.commands
447.219 + val node_edits =
447.220 + (edits ::: reparse.map((_, Document.Node.Edits(Nil)))).groupBy(_._1)
447.221 + .asInstanceOf[Map[Document.Node.Name, List[Document.Edit_Text]]] // FIXME ???
447.222
447.223 - val node1 =
447.224 - if (reparse_set(name) && !commands.isEmpty)
447.225 - node.update_commands(reparse_spans(syntax, name, commands, commands.head, commands.last))
447.226 - else node
447.227 - val node2 = (node1 /: edits)(text_edit(syntax, reparse_limit, _, _))
447.228 + node_edits foreach {
447.229 + case (name, edits) =>
447.230 + val node = nodes(name)
447.231 + val commands = node.commands
447.232
447.233 - if (!(node.same_perspective(node2.perspective)))
447.234 - doc_edits += (name -> node2.perspective)
447.235 + val node1 =
447.236 + if (reparse_set(name) && !commands.isEmpty)
447.237 + node.update_commands(
447.238 + reparse_spans(thy_load, syntax, doc_blobs,
447.239 + name, commands, commands.head, commands.last))
447.240 + else node
447.241 + val node2 = (node1 /: edits)(text_edit(thy_load, syntax, doc_blobs, reparse_limit, _, _))
447.242
447.243 - doc_edits += (name -> Document.Node.Edits(diff_commands(commands, node2.commands)))
447.244 + if (!(node.same_perspective(node2.perspective)))
447.245 + doc_edits += (name -> node2.perspective)
447.246
447.247 - nodes += (name -> node2)
447.248 + doc_edits += (name -> Document.Node.Edits(diff_commands(commands, node2.commands)))
447.249 +
447.250 + nodes += (name -> node2)
447.251 + }
447.252 +
447.253 + (doc_edits.toList, Document.Version.make(syntax, nodes))
447.254 }
447.255 -
447.256 - (doc_edits.toList, Document.Version.make(syntax, nodes))
447.257 }
447.258 }
448.1 --- a/src/Pure/Tools/build.ML Thu Dec 05 17:52:12 2013 +0100
448.2 +++ b/src/Pure/Tools/build.ML Thu Dec 05 17:58:03 2013 +0100
448.3 @@ -97,18 +97,18 @@
448.4
448.5 local
448.6
448.7 -fun no_document options =
448.8 - (case Options.string options "document" of "" => true | "false" => true | _ => false);
448.9 -
448.10 fun use_theories last_timing options =
448.11 - Thy_Info.use_theories {last_timing = last_timing, master_dir = Path.current}
448.12 + Thy_Info.use_theories {
448.13 + document =
448.14 + (case Options.string options "document" of "" => false | "false" => false | _ => true),
448.15 + last_timing = last_timing,
448.16 + master_dir = Path.current}
448.17 |> Unsynchronized.setmp print_mode
448.18 (space_explode "," (Options.string options "print_mode") @ print_mode_value ())
448.19 |> Unsynchronized.setmp Goal.parallel_proofs (Options.int options "parallel_proofs")
448.20 |> Unsynchronized.setmp Multithreading.trace (Options.int options "threads_trace")
448.21 |> Unsynchronized.setmp Multithreading.max_threads (Options.int options "threads")
448.22 |> Unsynchronized.setmp Future.ML_statistics true
448.23 - |> no_document options ? Present.no_document
448.24 |> Unsynchronized.setmp Pretty.margin_default (Options.int options "pretty_margin")
448.25 |> Unsynchronized.setmp Toplevel.timing (Options.bool options "timing");
448.26
449.1 --- a/src/Pure/Tools/build.scala Thu Dec 05 17:52:12 2013 +0100
449.2 +++ b/src/Pure/Tools/build.scala Thu Dec 05 17:58:03 2013 +0100
449.3 @@ -409,64 +409,68 @@
449.4 verbose: Boolean, list_files: Boolean, tree: Session_Tree): Deps =
449.5 Deps((Map.empty[String, Session_Content] /: tree.topological_order)(
449.6 { case (deps, (name, info)) =>
449.7 - val (preloaded, parent_syntax) =
449.8 - info.parent match {
449.9 - case None =>
449.10 - (Set.empty[String], Outer_Syntax.init())
449.11 - case Some(parent_name) =>
449.12 - val parent = deps(parent_name)
449.13 - (parent.loaded_theories, parent.syntax)
449.14 + try {
449.15 + val (preloaded, parent_syntax) =
449.16 + info.parent match {
449.17 + case None =>
449.18 + (Set.empty[String], Outer_Syntax.init())
449.19 + case Some(parent_name) =>
449.20 + val parent = deps(parent_name)
449.21 + (parent.loaded_theories, parent.syntax)
449.22 + }
449.23 + val thy_load = new Thy_Load(preloaded, parent_syntax)
449.24 + val thy_info = new Thy_Info(thy_load)
449.25 +
449.26 + if (verbose || list_files) {
449.27 + val groups =
449.28 + if (info.groups.isEmpty) ""
449.29 + else info.groups.mkString(" (", " ", ")")
449.30 + progress.echo("Session " + info.chapter + "/" + name + groups)
449.31 }
449.32 - val thy_info = new Thy_Info(new Thy_Load(preloaded, parent_syntax))
449.33
449.34 - if (verbose || list_files) {
449.35 - val groups =
449.36 - if (info.groups.isEmpty) ""
449.37 - else info.groups.mkString(" (", " ", ")")
449.38 - progress.echo("Session " + info.chapter + "/" + name + groups)
449.39 - }
449.40 + val thy_deps =
449.41 + thy_info.dependencies(
449.42 + info.theories.map(_._2).flatten.
449.43 + map(thy => thy_load.node_name(info.dir + Thy_Load.thy_path(thy))))
449.44
449.45 - val thy_deps =
449.46 - thy_info.dependencies(
449.47 - info.theories.map(_._2).flatten.
449.48 - map(thy => Thy_Load.path_node_name(info.dir + Thy_Load.thy_path(thy))))
449.49 + thy_deps.errors match {
449.50 + case Nil =>
449.51 + case errs => error(cat_lines(errs))
449.52 + }
449.53
449.54 - val loaded_theories = thy_deps.loaded_theories
449.55 - val keywords = thy_deps.keywords
449.56 - val syntax = thy_deps.syntax
449.57 + val loaded_theories = thy_deps.loaded_theories
449.58 + val keywords = thy_deps.keywords
449.59 + val syntax = thy_deps.syntax
449.60
449.61 - val body_files = if (inlined_files) thy_deps.load_files else Nil
449.62 + val body_files = if (inlined_files) thy_deps.load_files else Nil
449.63
449.64 - val all_files =
449.65 - (thy_deps.deps.map(dep => Path.explode(dep.name.node)) ::: body_files :::
449.66 - info.files.map(file => info.dir + file)).map(_.expand)
449.67 + val all_files =
449.68 + (thy_deps.deps.map(dep => Path.explode(dep.name.node)) ::: body_files :::
449.69 + info.files.map(file => info.dir + file)).map(_.expand)
449.70
449.71 - if (list_files) {
449.72 - progress.echo(cat_lines(all_files.map(_.implode).sorted.map(" " + _)))
449.73 - for {
449.74 - file <- all_files
449.75 - if file.split_ext._2 == "ML"
449.76 - } {
449.77 - val path = info.dir + file
449.78 - try { Symbol.decode_strict(File.read(path)) }
449.79 - catch {
449.80 - case ERROR(msg) =>
449.81 - cat_error(msg,
449.82 - "The error(s) above occurred in session " + quote(name) +
449.83 - " file " + path.toString)
449.84 + if (list_files) {
449.85 + progress.echo(cat_lines(all_files.map(_.implode).sorted.map(" " + _)))
449.86 + for {
449.87 + file <- all_files
449.88 + if file.split_ext._2 == "ML"
449.89 + } {
449.90 + val path = info.dir + file
449.91 + try { Symbol.decode_strict(File.read(path)) }
449.92 + catch {
449.93 + case ERROR(msg) => cat_error(msg, "The error(s) above occurred in file " + path)
449.94 + }
449.95 }
449.96 }
449.97 +
449.98 + val sources = all_files.map(p => (p, SHA1.digest(p.file)))
449.99 +
449.100 + deps + (name -> Session_Content(loaded_theories, keywords, syntax, sources))
449.101 }
449.102 -
449.103 - val sources =
449.104 - try { all_files.map(p => (p, SHA1.digest(p.file))) }
449.105 - catch {
449.106 - case ERROR(msg) =>
449.107 - error(msg + "\nThe error(s) above occurred in session " +
449.108 - quote(name) + Position.here(info.pos))
449.109 - }
449.110 -
449.111 - deps + (name -> Session_Content(loaded_theories, keywords, syntax, sources))
449.112 + catch {
449.113 + case ERROR(msg) =>
449.114 + cat_error(msg, "The error(s) above occurred in session " +
449.115 + quote(name) + Position.here(info.pos))
449.116 + }
449.117 }))
449.118
449.119 def session_dependencies(
450.1 --- a/src/Pure/Tools/proof_general.ML Thu Dec 05 17:52:12 2013 +0100
450.2 +++ b/src/Pure/Tools/proof_general.ML Thu Dec 05 17:58:03 2013 +0100
450.3 @@ -36,6 +36,7 @@
450.4 val tell_clear_response: unit -> unit
450.5 val inform_file_processed: string -> unit
450.6 val inform_file_retracted: string -> unit
450.7 + val master_path: Path.T Unsynchronized.ref
450.8 structure ThyLoad: sig val add_path: string -> unit end
450.9 val thm_deps: bool Unsynchronized.ref
450.10 val proof_generalN: string
450.11 @@ -269,7 +270,7 @@
450.12 Output.Internal.urgent_message_fn := message (special "I") (special "J") "";
450.13 Output.Internal.tracing_fn := message (special "I" ^ special "V") (special "J") "";
450.14 Output.Internal.warning_fn := message (special "K") (special "L") "### ";
450.15 - Output.Internal.error_fn := (fn (_, s) => message (special "M") (special "N") "*** " s);
450.16 + Output.Internal.error_message_fn := (fn (_, s) => message (special "M") (special "N") "*** " s);
450.17 Output.Internal.prompt_fn := (fn s => Output.physical_stdout (render s ^ special "S")));
450.18
450.19
450.20 @@ -293,11 +294,14 @@
450.21
450.22 (** theory loader **)
450.23
450.24 -(* fake old ThyLoad -- with new semantics *)
450.25 +(* global master path *)
450.26
450.27 +val master_path = Unsynchronized.ref Path.current;
450.28 +
450.29 +(*fake old ThyLoad -- with new semantics*)
450.30 structure ThyLoad =
450.31 struct
450.32 - val add_path = Thy_Load.set_master_path o Path.explode;
450.33 + fun add_path path = master_path := Path.explode path;
450.34 end;
450.35
450.36
451.1 --- a/src/Pure/Tools/sledgehammer_params.scala Thu Dec 05 17:52:12 2013 +0100
451.2 +++ b/src/Pure/Tools/sledgehammer_params.scala Thu Dec 05 17:58:03 2013 +0100
451.3 @@ -37,13 +37,10 @@
451.4 def get_provers: String = synchronized { _provers }
451.5
451.6 private def sledgehammer_provers(
451.7 - prover: Session.Prover, output: Isabelle_Process.Output): Boolean =
451.8 + prover: Session.Prover, msg: Isabelle_Process.Protocol_Output): Boolean =
451.9 {
451.10 - output.body match {
451.11 - case Nil => update_provers(""); true
451.12 - case List(XML.Text(s)) => update_provers(s); true
451.13 - case _ => false
451.14 - }
451.15 + update_provers(msg.text)
451.16 + true
451.17 }
451.18
451.19 val functions =
452.1 --- a/src/Pure/assumption.ML Thu Dec 05 17:52:12 2013 +0100
452.2 +++ b/src/Pure/assumption.ML Thu Dec 05 17:58:03 2013 +0100
452.3 @@ -12,7 +12,7 @@
452.4 val assume: cterm -> thm
452.5 val all_assms_of: Proof.context -> cterm list
452.6 val all_prems_of: Proof.context -> thm list
452.7 - val extra_hyps: Proof.context -> thm -> term list
452.8 + val check_hyps: Proof.context -> thm -> thm
452.9 val local_assms_of: Proof.context -> Proof.context -> cterm list
452.10 val local_prems_of: Proof.context -> Proof.context -> thm list
452.11 val add_assms: export -> cterm list -> Proof.context -> thm list * Proof.context
452.12 @@ -76,8 +76,12 @@
452.13 val all_assms_of = maps #2 o all_assumptions_of;
452.14 val all_prems_of = #prems o rep_data;
452.15
452.16 -fun extra_hyps ctxt th =
452.17 - subtract (op aconv) (map Thm.term_of (all_assms_of ctxt)) (Thm.hyps_of th);
452.18 +fun check_hyps ctxt th =
452.19 + let
452.20 + val extra_hyps = subtract (op aconv) (map Thm.term_of (all_assms_of ctxt)) (Thm.hyps_of th);
452.21 + val _ = null extra_hyps orelse
452.22 + error ("Additional hypotheses:\n" ^ cat_lines (map (Syntax.string_of_term ctxt) extra_hyps));
452.23 + in th end;
452.24
452.25
452.26 (* local assumptions *)
453.1 --- a/src/Pure/build-jars Thu Dec 05 17:52:12 2013 +0100
453.2 +++ b/src/Pure/build-jars Thu Dec 05 17:58:03 2013 +0100
453.3 @@ -13,6 +13,7 @@
453.4 Concurrent/future.scala
453.5 Concurrent/simple_thread.scala
453.6 Concurrent/volatile.scala
453.7 + General/bytes.scala
453.8 General/exn.scala
453.9 General/file.scala
453.10 General/graph.scala
454.1 --- a/src/Pure/goal.ML Thu Dec 05 17:52:12 2013 +0100
454.2 +++ b/src/Pure/goal.ML Thu Dec 05 17:58:03 2013 +0100
454.3 @@ -182,7 +182,6 @@
454.4 fun prove_common immediate pri ctxt xs asms props tac =
454.5 let
454.6 val thy = Proof_Context.theory_of ctxt;
454.7 - val string_of_term = Syntax.string_of_term ctxt;
454.8
454.9 val schematic = exists is_schematic props;
454.10 val future = future_enabled 1;
454.11 @@ -191,7 +190,7 @@
454.12 val pos = Position.thread_data ();
454.13 fun err msg = cat_error msg
454.14 ("The error(s) above occurred for the goal statement:\n" ^
454.15 - string_of_term (Logic.list_implies (asms, Logic.mk_conjunction_list props)) ^
454.16 + Syntax.string_of_term ctxt (Logic.list_implies (asms, Logic.mk_conjunction_list props)) ^
454.17 (case Position.here pos of "" => "" | s => "\n" ^ s));
454.18
454.19 fun cert_safe t = Thm.cterm_of thy (Envir.beta_norm (Term.no_dummy_patterns t))
454.20 @@ -215,10 +214,16 @@
454.21 (case SINGLE (tac' {prems = prems, context = ctxt'}) (init stmt) of
454.22 NONE => err "Tactic failed"
454.23 | SOME st =>
454.24 - let val res = finish ctxt' st handle THM (msg, _, _) => err msg in
454.25 - if Unify.matches_list thy [Thm.term_of stmt] [Thm.prop_of res]
454.26 - then Thm.check_shyps sorts res
454.27 - else err ("Proved a different theorem: " ^ string_of_term (Thm.prop_of res))
454.28 + let
454.29 + val res =
454.30 + (finish ctxt' st
454.31 + |> Drule.flexflex_unique
454.32 + |> Thm.check_shyps sorts
454.33 + (* |> Assumption.check_hyps ctxt' FIXME *))
454.34 + handle THM (msg, _, _) => err msg | ERROR msg => err msg;
454.35 + in
454.36 + if Unify.matches_list thy [Thm.term_of stmt] [Thm.prop_of res] then res
454.37 + else err ("Proved a different theorem: " ^ Syntax.string_of_term ctxt' (Thm.prop_of res))
454.38 end);
454.39 val res =
454.40 if immediate orelse schematic orelse not future orelse skip then result ()
455.1 --- a/src/Pure/library.scala Thu Dec 05 17:52:12 2013 +0100
455.2 +++ b/src/Pure/library.scala Thu Dec 05 17:58:03 2013 +0100
455.3 @@ -26,9 +26,12 @@
455.4
455.5 def error(message: String): Nothing = throw ERROR(message)
455.6
455.7 + def cat_message(msg1: String, msg2: String): String =
455.8 + if (msg1 == "") msg2
455.9 + else msg1 + "\n" + msg2
455.10 +
455.11 def cat_error(msg1: String, msg2: String): Nothing =
455.12 - if (msg1 == "") error(msg1)
455.13 - else error(msg1 + "\n" + msg2)
455.14 + error(cat_message(msg1, msg2))
455.15
455.16
455.17 /* separated chunks */
456.1 --- a/src/Pure/pure_syn.ML Thu Dec 05 17:52:12 2013 +0100
456.2 +++ b/src/Pure/pure_syn.ML Thu Dec 05 17:58:03 2013 +0100
456.3 @@ -14,7 +14,7 @@
456.4 (Thy_Header.args >> (fn header =>
456.5 Toplevel.print o
456.6 Toplevel.init_theory
456.7 - (fn () => Thy_Info.toplevel_begin_theory (Thy_Load.get_master_path ()) header)));
456.8 + (fn () => Thy_Info.toplevel_begin_theory (! ProofGeneral.master_path) header)));
456.9
456.10 val _ =
456.11 Outer_Syntax.command
457.1 --- a/src/Pure/simplifier.ML Thu Dec 05 17:52:12 2013 +0100
457.2 +++ b/src/Pure/simplifier.ML Thu Dec 05 17:58:03 2013 +0100
457.3 @@ -8,8 +8,6 @@
457.4 signature BASIC_SIMPLIFIER =
457.5 sig
457.6 include BASIC_RAW_SIMPLIFIER
457.7 - val Addsimprocs: simproc list -> unit
457.8 - val Delsimprocs: simproc list -> unit
457.9 val simp_tac: Proof.context -> int -> tactic
457.10 val asm_simp_tac: Proof.context -> int -> tactic
457.11 val full_simp_tac: Proof.context -> int -> tactic
457.12 @@ -126,16 +124,6 @@
457.13 val cong_del = attrib del_cong;
457.14
457.15
457.16 -(* global simprocs *)
457.17 -
457.18 -fun Addsimprocs args =
457.19 - Theory.setup (map_theory_simpset (fn ctxt => ctxt addsimprocs args));
457.20 -
457.21 -fun Delsimprocs args =
457.22 - Theory.setup (map_theory_simpset (fn ctxt => ctxt delsimprocs args));
457.23 -
457.24 -
457.25 -
457.26 (** named simprocs **)
457.27
457.28 structure Simprocs = Generic_Data
458.1 --- a/src/Tools/Code/lib/Tools/codegen Thu Dec 05 17:52:12 2013 +0100
458.2 +++ b/src/Tools/Code/lib/Tools/codegen Thu Dec 05 17:58:03 2013 +0100
458.3 @@ -13,7 +13,7 @@
458.4 echo "Usage: isabelle $PRG [OPTIONS] IMAGE THYNAME CMD"
458.5 echo
458.6 echo " Options are:"
458.7 - echo " -q run in quick'n'dirty mode"
458.8 + echo " -q run in quick_and_dirty mode"
458.9 echo
458.10 echo " Issues code generation using image IMAGE,"
458.11 echo " theory THYNAME,"
459.1 --- a/src/Tools/jEdit/src/document_model.scala Thu Dec 05 17:52:12 2013 +0100
459.2 +++ b/src/Tools/jEdit/src/document_model.scala Thu Dec 05 17:58:03 2013 +0100
459.3 @@ -14,9 +14,6 @@
459.4
459.5 import org.gjt.sp.jedit.Buffer
459.6 import org.gjt.sp.jedit.buffer.{BufferAdapter, BufferListener, JEditBuffer}
459.7 -import org.gjt.sp.jedit.textarea.TextArea
459.8 -
459.9 -import java.awt.font.TextAttribute
459.10
459.11
459.12 object Document_Model
459.13 @@ -63,17 +60,23 @@
459.14 {
459.15 /* header */
459.16
459.17 + def is_theory: Boolean = node_name.is_theory
459.18 +
459.19 def node_header(): Document.Node.Header =
459.20 {
459.21 Swing_Thread.require()
459.22 - JEdit_Lib.buffer_lock(buffer) {
459.23 - Exn.capture {
459.24 - PIDE.thy_load.check_thy_text(node_name, buffer.getSegment(0, buffer.getLength))
459.25 - } match {
459.26 - case Exn.Res(header) => header
459.27 - case Exn.Exn(exn) => Document.Node.bad_header(Exn.message(exn))
459.28 +
459.29 + if (is_theory) {
459.30 + JEdit_Lib.buffer_lock(buffer) {
459.31 + Exn.capture {
459.32 + PIDE.thy_load.check_thy_text(node_name, buffer.getSegment(0, buffer.getLength))
459.33 + } match {
459.34 + case Exn.Res(header) => header
459.35 + case Exn.Exn(exn) => Document.Node.bad_header(Exn.message(exn))
459.36 + }
459.37 }
459.38 }
459.39 + else Document.Node.no_header
459.40 }
459.41
459.42
459.43 @@ -85,7 +88,7 @@
459.44 def node_required_=(b: Boolean)
459.45 {
459.46 Swing_Thread.require()
459.47 - if (_node_required != b) {
459.48 + if (_node_required != b && is_theory) {
459.49 _node_required = b
459.50 PIDE.options_changed()
459.51 PIDE.editor.flush()
459.52 @@ -99,18 +102,51 @@
459.53 {
459.54 Swing_Thread.require()
459.55
459.56 - if (Isabelle.continuous_checking) {
459.57 + if (Isabelle.continuous_checking && is_theory) {
459.58 val snapshot = this.snapshot()
459.59 - Document.Node.Perspective(node_required, Text.Perspective(
459.60 +
459.61 + val document_view_ranges =
459.62 for {
459.63 doc_view <- PIDE.document_views(buffer)
459.64 range <- doc_view.perspective(snapshot).ranges
459.65 - } yield range), PIDE.editor.node_overlays(node_name))
459.66 + } yield range
459.67 +
459.68 + val thy_load_ranges =
459.69 + for {
459.70 + cmd <- snapshot.node.thy_load_commands
459.71 + blob_name <- cmd.blobs_names
459.72 + blob_buffer <- JEdit_Lib.jedit_buffer(blob_name.node)
459.73 + if !JEdit_Lib.jedit_text_areas(blob_buffer).isEmpty
459.74 + start <- snapshot.node.command_start(cmd)
459.75 + range = snapshot.convert(cmd.proper_range + start)
459.76 + } yield range
459.77 +
459.78 + Document.Node.Perspective(node_required,
459.79 + Text.Perspective(document_view_ranges ::: thy_load_ranges),
459.80 + PIDE.editor.node_overlays(node_name))
459.81 }
459.82 else empty_perspective
459.83 }
459.84
459.85
459.86 + /* blob */
459.87 +
459.88 + private var _blob: Option[Bytes] = None // owned by Swing thread
459.89 +
459.90 + private def reset_blob(): Unit = Swing_Thread.require { _blob = None }
459.91 +
459.92 + def blob(): Bytes =
459.93 + Swing_Thread.require {
459.94 + _blob match {
459.95 + case Some(b) => b
459.96 + case None =>
459.97 + val b = PIDE.thy_load.file_content(buffer)
459.98 + _blob = Some(b)
459.99 + b
459.100 + }
459.101 + }
459.102 +
459.103 +
459.104 /* edits */
459.105
459.106 def init_edits(): List[Document.Edit_Text] =
459.107 @@ -121,22 +157,36 @@
459.108 val text = JEdit_Lib.buffer_text(buffer)
459.109 val perspective = node_perspective()
459.110
459.111 - List(session.header_edit(node_name, header),
459.112 - node_name -> Document.Node.Clear(),
459.113 - node_name -> Document.Node.Edits(List(Text.Edit.insert(0, text))),
459.114 - node_name -> perspective)
459.115 + if (is_theory)
459.116 + List(session.header_edit(node_name, header),
459.117 + node_name -> Document.Node.Clear(),
459.118 + node_name -> Document.Node.Edits(List(Text.Edit.insert(0, text))),
459.119 + node_name -> perspective)
459.120 + else
459.121 + List(node_name -> Document.Node.Blob())
459.122 }
459.123
459.124 - def node_edits(perspective: Document.Node.Perspective_Text, text_edits: List[Text.Edit])
459.125 - : List[Document.Edit_Text] =
459.126 + def node_edits(
459.127 + clear: Boolean,
459.128 + text_edits: List[Text.Edit],
459.129 + perspective: Document.Node.Perspective_Text): List[Document.Edit_Text] =
459.130 {
459.131 Swing_Thread.require()
459.132
459.133 - val header = node_header()
459.134 -
459.135 - List(session.header_edit(node_name, header),
459.136 - node_name -> Document.Node.Edits(text_edits),
459.137 - node_name -> perspective)
459.138 + if (is_theory) {
459.139 + val header_edit = session.header_edit(node_name, node_header())
459.140 + if (clear)
459.141 + List(header_edit,
459.142 + node_name -> Document.Node.Clear(),
459.143 + node_name -> Document.Node.Edits(text_edits),
459.144 + node_name -> perspective)
459.145 + else
459.146 + List(header_edit,
459.147 + node_name -> Document.Node.Edits(text_edits),
459.148 + node_name -> perspective)
459.149 + }
459.150 + else
459.151 + List(node_name -> Document.Node.Blob())
459.152 }
459.153
459.154
459.155 @@ -144,6 +194,7 @@
459.156
459.157 private object pending_edits // owned by Swing thread
459.158 {
459.159 + private var pending_clear = false
459.160 private val pending = new mutable.ListBuffer[Text.Edit]
459.161 private var last_perspective = empty_perspective
459.162
459.163 @@ -151,55 +202,36 @@
459.164
459.165 def flushed_edits(): List[Document.Edit_Text] =
459.166 {
459.167 - Swing_Thread.require()
459.168 -
459.169 + val clear = pending_clear
459.170 val edits = snapshot()
459.171 - val new_perspective = node_perspective()
459.172 - if (!edits.isEmpty || last_perspective != new_perspective) {
459.173 + val perspective = node_perspective()
459.174 + if (clear || !edits.isEmpty || last_perspective != perspective) {
459.175 + pending_clear = false
459.176 pending.clear
459.177 - last_perspective = new_perspective
459.178 - node_edits(new_perspective, edits)
459.179 + last_perspective = perspective
459.180 + node_edits(clear, edits, perspective)
459.181 }
459.182 else Nil
459.183 }
459.184
459.185 - def flush(): Unit = session.update(flushed_edits())
459.186 + def edit(clear: Boolean, e: Text.Edit)
459.187 + {
459.188 + reset_blob()
459.189
459.190 - val delay_flush =
459.191 - Swing_Thread.delay_last(PIDE.options.seconds("editor_input_delay")) { flush() }
459.192 -
459.193 - def +=(edit: Text.Edit)
459.194 - {
459.195 - Swing_Thread.require()
459.196 - pending += edit
459.197 - delay_flush.invoke()
459.198 - }
459.199 -
459.200 - def init()
459.201 - {
459.202 - flush()
459.203 - session.update(init_edits())
459.204 - }
459.205 -
459.206 - def exit()
459.207 - {
459.208 - delay_flush.revoke()
459.209 - flush()
459.210 + if (clear) {
459.211 + pending_clear = true
459.212 + pending.clear
459.213 + }
459.214 + pending += e
459.215 + PIDE.editor.invoke()
459.216 }
459.217 }
459.218
459.219 - def flushed_edits(): List[Document.Edit_Text] = pending_edits.flushed_edits()
459.220 + def snapshot(): Document.Snapshot =
459.221 + Swing_Thread.require { session.snapshot(node_name, pending_edits.snapshot()) }
459.222
459.223 - def update_perspective(): Unit = pending_edits.delay_flush.invoke()
459.224 -
459.225 -
459.226 - /* snapshot */
459.227 -
459.228 - def snapshot(): Document.Snapshot =
459.229 - {
459.230 - Swing_Thread.require()
459.231 - session.snapshot(node_name, pending_edits.snapshot())
459.232 - }
459.233 + def flushed_edits(): List[Document.Edit_Text] =
459.234 + Swing_Thread.require { pending_edits.flushed_edits() }
459.235
459.236
459.237 /* buffer listener */
459.238 @@ -208,21 +240,21 @@
459.239 {
459.240 override def bufferLoaded(buffer: JEditBuffer)
459.241 {
459.242 - pending_edits.init()
459.243 + pending_edits.edit(true, Text.Edit.insert(0, buffer.getText(0, buffer.getLength)))
459.244 }
459.245
459.246 override def contentInserted(buffer: JEditBuffer,
459.247 start_line: Int, offset: Int, num_lines: Int, length: Int)
459.248 {
459.249 if (!buffer.isLoading)
459.250 - pending_edits += Text.Edit.insert(offset, buffer.getText(offset, length))
459.251 + pending_edits.edit(false, Text.Edit.insert(offset, buffer.getText(offset, length)))
459.252 }
459.253
459.254 override def preContentRemoved(buffer: JEditBuffer,
459.255 start_line: Int, offset: Int, num_lines: Int, removed_length: Int)
459.256 {
459.257 if (!buffer.isLoading)
459.258 - pending_edits += Text.Edit.remove(offset, buffer.getText(offset, removed_length))
459.259 + pending_edits.edit(false, Text.Edit.remove(offset, buffer.getText(offset, removed_length)))
459.260 }
459.261 }
459.262
459.263 @@ -232,13 +264,11 @@
459.264 private def activate()
459.265 {
459.266 buffer.addBufferListener(buffer_listener)
459.267 - pending_edits.flush()
459.268 Token_Markup.refresh_buffer(buffer)
459.269 }
459.270
459.271 private def deactivate()
459.272 {
459.273 - pending_edits.exit()
459.274 buffer.removeBufferListener(buffer_listener)
459.275 Token_Markup.refresh_buffer(buffer)
459.276 }
460.1 --- a/src/Tools/jEdit/src/document_view.scala Thu Dec 05 17:52:12 2013 +0100
460.2 +++ b/src/Tools/jEdit/src/document_view.scala Thu Dec 05 17:58:03 2013 +0100
460.3 @@ -10,21 +10,15 @@
460.4
460.5 import isabelle._
460.6
460.7 -import scala.collection.mutable
460.8 -import scala.collection.immutable.SortedMap
460.9 import scala.actors.Actor._
460.10
460.11 -import java.lang.System
460.12 -import java.text.BreakIterator
460.13 -import java.awt.{Color, Graphics2D, Point}
460.14 +import java.awt.Graphics2D
460.15 import java.awt.event.KeyEvent
460.16 import javax.swing.event.{CaretListener, CaretEvent}
460.17
460.18 -import org.gjt.sp.jedit.{jEdit, Debug}
460.19 -import org.gjt.sp.jedit.gui.RolloverButton
460.20 +import org.gjt.sp.jedit.jEdit
460.21 import org.gjt.sp.jedit.options.GutterOptionPane
460.22 -import org.gjt.sp.jedit.textarea.{JEditTextArea, TextArea, TextAreaExtension, TextAreaPainter}
460.23 -import org.gjt.sp.jedit.syntax.SyntaxStyle
460.24 +import org.gjt.sp.jedit.textarea.{JEditTextArea, TextAreaExtension, TextAreaPainter}
460.25
460.26
460.27 object Document_View
460.28 @@ -88,7 +82,7 @@
460.29 PIDE.editor.current_command(view, snapshot) match {
460.30 case Some(command) =>
460.31 snapshot.node.command_start(command) match {
460.32 - case Some(start) => List(command.proper_range + start)
460.33 + case Some(start) => List(snapshot.convert(command.proper_range + start))
460.34 case None => Nil
460.35 }
460.36 case None => Nil
460.37 @@ -112,14 +106,14 @@
460.38 Text.Perspective(active_command ::: visible_lines)
460.39 }
460.40
460.41 - private def update_perspective = new TextAreaExtension
460.42 + private def update_view = new TextAreaExtension
460.43 {
460.44 override def paintScreenLineRange(gfx: Graphics2D,
460.45 first_line: Int, last_line: Int, physical_lines: Array[Int],
460.46 start: Array[Int], end: Array[Int], y: Int, line_height: Int)
460.47 {
460.48 // no robust_body
460.49 - model.update_perspective()
460.50 + PIDE.editor.invoke()
460.51 }
460.52 }
460.53
460.54 @@ -244,7 +238,8 @@
460.55 }
460.56 }
460.57
460.58 - case bad => System.err.println("command_change_actor: ignoring bad message " + bad)
460.59 + case bad =>
460.60 + java.lang.System.err.println("command_change_actor: ignoring bad message " + bad)
460.61 }
460.62 }
460.63 }
460.64 @@ -256,7 +251,7 @@
460.65 {
460.66 val painter = text_area.getPainter
460.67
460.68 - painter.addExtension(TextAreaPainter.LOWEST_LAYER, update_perspective)
460.69 + painter.addExtension(TextAreaPainter.LOWEST_LAYER, update_view)
460.70 rich_text_area.activate()
460.71 text_area.getGutter.addExtension(gutter_painter)
460.72 text_area.addKeyListener(key_listener)
460.73 @@ -277,6 +272,6 @@
460.74 text_area.removeKeyListener(key_listener)
460.75 text_area.getGutter.removeExtension(gutter_painter)
460.76 rich_text_area.deactivate()
460.77 - painter.removeExtension(update_perspective)
460.78 + painter.removeExtension(update_view)
460.79 }
460.80 }
461.1 --- a/src/Tools/jEdit/src/isabelle_sidekick.scala Thu Dec 05 17:52:12 2013 +0100
461.2 +++ b/src/Tools/jEdit/src/isabelle_sidekick.scala Thu Dec 05 17:58:03 2013 +0100
461.3 @@ -133,15 +133,15 @@
461.4
461.5
461.6 class Isabelle_Sidekick_Default extends
461.7 - Isabelle_Sidekick_Structure("isabelle", PIDE.thy_load.buffer_node_name)
461.8 + Isabelle_Sidekick_Structure("isabelle", PIDE.thy_load.theory_node_name)
461.9
461.10
461.11 class Isabelle_Sidekick_Options extends
461.12 - Isabelle_Sidekick_Structure("isabelle-options", PIDE.thy_load.buffer_node_dummy)
461.13 + Isabelle_Sidekick_Structure("isabelle-options", _ => Some(Document.Node.Name("options")))
461.14
461.15
461.16 class Isabelle_Sidekick_Root extends
461.17 - Isabelle_Sidekick_Structure("isabelle-root", PIDE.thy_load.buffer_node_dummy)
461.18 + Isabelle_Sidekick_Structure("isabelle-root", _ => Some(Document.Node.Name("ROOT")))
461.19
461.20
461.21 class Isabelle_Sidekick_Markup extends Isabelle_Sidekick("isabelle-markup")
462.1 --- a/src/Tools/jEdit/src/jedit_editor.scala Thu Dec 05 17:52:12 2013 +0100
462.2 +++ b/src/Tools/jEdit/src/jedit_editor.scala Thu Dec 05 17:58:03 2013 +0100
462.3 @@ -23,19 +23,15 @@
462.4 {
462.5 Swing_Thread.require()
462.6
462.7 - session.update(
462.8 - (List.empty[Document.Edit_Text] /: JEdit_Lib.jedit_buffers().toList) {
462.9 - case (edits, buffer) =>
462.10 - JEdit_Lib.buffer_lock(buffer) {
462.11 - PIDE.document_model(buffer) match {
462.12 - case Some(model) => model.flushed_edits() ::: edits
462.13 - case None => edits
462.14 - }
462.15 - }
462.16 - }
462.17 - )
462.18 + val edits = PIDE.document_models().flatMap(_.flushed_edits())
462.19 + if (!edits.isEmpty) session.update(PIDE.document_blobs(), edits)
462.20 }
462.21
462.22 + private val delay_flush =
462.23 + Swing_Thread.delay_last(PIDE.options.seconds("editor_input_delay")) { flush() }
462.24 +
462.25 + def invoke(): Unit = Swing_Thread.require { delay_flush.invoke() }
462.26 +
462.27
462.28 /* current situation */
462.29
462.30 @@ -67,11 +63,13 @@
462.31 Swing_Thread.require()
462.32
462.33 val text_area = view.getTextArea
462.34 + val buffer = view.getBuffer
462.35 +
462.36 PIDE.document_view(text_area) match {
462.37 case Some(doc_view) =>
462.38 val node = snapshot.version.nodes(doc_view.model.node_name)
462.39 val caret = snapshot.revert(text_area.getCaretPosition)
462.40 - if (caret < text_area.getBuffer.getLength) {
462.41 + if (caret < buffer.getLength) {
462.42 val caret_commands = node.command_range(caret)
462.43 if (caret_commands.hasNext) {
462.44 val (cmd0, _) = caret_commands.next
462.45 @@ -80,7 +78,15 @@
462.46 else None
462.47 }
462.48 else node.commands.reverse.iterator.find(cmd => !cmd.is_ignored)
462.49 - case None => None
462.50 + case None =>
462.51 + PIDE.document_model(buffer) match {
462.52 + case Some(model) if !model.is_theory =>
462.53 + snapshot.version.nodes.thy_load_commands(model.node_name) match {
462.54 + case cmd :: _ => Some(cmd)
462.55 + case Nil => None
462.56 + }
462.57 + case _ => None
462.58 + }
462.59 }
462.60 }
462.61
463.1 --- a/src/Tools/jEdit/src/jedit_thy_load.scala Thu Dec 05 17:52:12 2013 +0100
463.2 +++ b/src/Tools/jEdit/src/jedit_thy_load.scala Thu Dec 05 17:58:03 2013 +0100
463.3 @@ -9,26 +9,31 @@
463.4
463.5 import isabelle._
463.6
463.7 -import java.io.{File => JFile, IOException}
463.8 +import java.io.{File => JFile, IOException, ByteArrayOutputStream}
463.9 import javax.swing.text.Segment
463.10
463.11 import org.gjt.sp.jedit.io.{VFS, FileVFS, VFSFile, VFSManager}
463.12 import org.gjt.sp.jedit.MiscUtilities
463.13 import org.gjt.sp.jedit.{View, Buffer}
463.14 -
463.15 +import org.gjt.sp.jedit.bufferio.BufferIORequest
463.16
463.17 class JEdit_Thy_Load(loaded_theories: Set[String] = Set.empty, base_syntax: Outer_Syntax)
463.18 extends Thy_Load(loaded_theories, base_syntax)
463.19 {
463.20 /* document node names */
463.21
463.22 - def buffer_node_dummy(buffer: Buffer): Option[Document.Node.Name] =
463.23 - Some(Document.Node.Name(JEdit_Lib.buffer_name(buffer), buffer.getDirectory, buffer.getName))
463.24 + def node_name(buffer: Buffer): Document.Node.Name =
463.25 + {
463.26 + val node = JEdit_Lib.buffer_name(buffer)
463.27 + val theory = Thy_Header.thy_name(node).getOrElse("")
463.28 + val master_dir = if (theory == "") "" else buffer.getDirectory
463.29 + Document.Node.Name(node, master_dir, theory)
463.30 + }
463.31
463.32 - def buffer_node_name(buffer: Buffer): Option[Document.Node.Name] =
463.33 + def theory_node_name(buffer: Buffer): Option[Document.Node.Name] =
463.34 {
463.35 - val name = JEdit_Lib.buffer_name(buffer)
463.36 - Thy_Header.thy_name(name).map(theory => Document.Node.Name(name, buffer.getDirectory, theory))
463.37 + val name = node_name(buffer)
463.38 + if (name.is_theory) Some(name) else None
463.39 }
463.40
463.41
463.42 @@ -37,7 +42,7 @@
463.43 override def append(dir: String, source_path: Path): String =
463.44 {
463.45 val path = source_path.expand
463.46 - if (path.is_absolute) Isabelle_System.platform_path(path)
463.47 + if (dir == "" || path.is_absolute) Isabelle_System.platform_path(path)
463.48 else {
463.49 val vfs = VFSManager.getVFSForPath(dir)
463.50 if (vfs.isInstanceOf[FileVFS])
463.51 @@ -83,5 +88,28 @@
463.52 catch { case _: IOException => }
463.53 }
463.54 }
463.55 +
463.56 +
463.57 + /* file content */
463.58 +
463.59 + def file_content(buffer: Buffer): Bytes =
463.60 + {
463.61 + val path = buffer.getPath
463.62 + val vfs = VFSManager.getVFSForPath(path)
463.63 + val content =
463.64 + new BufferIORequest(null, buffer, null, vfs, path) {
463.65 + def _run() { }
463.66 + def apply(): Bytes =
463.67 + {
463.68 + val out =
463.69 + new ByteArrayOutputStream(buffer.getLength + 1) {
463.70 + def content(): Bytes = Bytes(this.buf, 0, this.count)
463.71 + }
463.72 + write(buffer, out)
463.73 + out.content()
463.74 + }
463.75 + }
463.76 + content()
463.77 + }
463.78 }
463.79
464.1 --- a/src/Tools/jEdit/src/plugin.scala Thu Dec 05 17:52:12 2013 +0100
464.2 +++ b/src/Tools/jEdit/src/plugin.scala Thu Dec 05 17:58:03 2013 +0100
464.3 @@ -73,13 +73,22 @@
464.4 def document_views(buffer: Buffer): List[Document_View] =
464.5 for {
464.6 text_area <- JEdit_Lib.jedit_text_areas(buffer).toList
464.7 - doc_view = document_view(text_area)
464.8 - if doc_view.isDefined
464.9 - } yield doc_view.get
464.10 + doc_view <- document_view(text_area)
464.11 + } yield doc_view
464.12 +
464.13 + def document_models(): List[Document_Model] =
464.14 + for {
464.15 + buffer <- JEdit_Lib.jedit_buffers().toList
464.16 + model <- document_model(buffer)
464.17 + } yield model
464.18 +
464.19 + def document_blobs(): Document.Blobs =
464.20 + document_models().filterNot(_.is_theory).map(model => (model.node_name -> model.blob())).toMap
464.21
464.22 def exit_models(buffers: List[Buffer])
464.23 {
464.24 Swing_Thread.now {
464.25 + PIDE.editor.flush()
464.26 buffers.foreach(buffer =>
464.27 JEdit_Lib.buffer_lock(buffer) {
464.28 JEdit_Lib.jedit_text_areas(buffer).foreach(Document_View.exit)
464.29 @@ -91,30 +100,31 @@
464.30 def init_models(buffers: List[Buffer])
464.31 {
464.32 Swing_Thread.now {
464.33 + PIDE.editor.flush()
464.34 val init_edits =
464.35 (List.empty[Document.Edit_Text] /: buffers) { case (edits, buffer) =>
464.36 JEdit_Lib.buffer_lock(buffer) {
464.37 - val (model_edits, opt_model) =
464.38 - thy_load.buffer_node_name(buffer) match {
464.39 - case Some(node_name) =>
464.40 - document_model(buffer) match {
464.41 - case Some(model) if model.node_name == node_name => (Nil, Some(model))
464.42 - case _ =>
464.43 - val model = Document_Model.init(session, buffer, node_name)
464.44 - (model.init_edits(), Some(model))
464.45 - }
464.46 - case None => (Nil, None)
464.47 + if (buffer.getBooleanProperty(Buffer.GZIPPED)) edits
464.48 + else {
464.49 + val node_name = thy_load.node_name(buffer)
464.50 + val (model_edits, model) =
464.51 + document_model(buffer) match {
464.52 + case Some(model) if model.node_name == node_name => (Nil, model)
464.53 + case _ =>
464.54 + val model = Document_Model.init(session, buffer, node_name)
464.55 + (model.init_edits(), model)
464.56 + }
464.57 + if (model.is_theory) {
464.58 + for (text_area <- JEdit_Lib.jedit_text_areas(buffer)) {
464.59 + if (document_view(text_area).map(_.model) != Some(model))
464.60 + Document_View.init(model, text_area)
464.61 + }
464.62 }
464.63 - if (opt_model.isDefined) {
464.64 - for (text_area <- JEdit_Lib.jedit_text_areas(buffer)) {
464.65 - if (document_view(text_area).map(_.model) != opt_model)
464.66 - Document_View.init(opt_model.get, text_area)
464.67 - }
464.68 + model_edits ::: edits
464.69 }
464.70 - model_edits ::: edits
464.71 }
464.72 }
464.73 - session.update(init_edits)
464.74 + session.update(document_blobs(), init_edits)
464.75 }
464.76 }
464.77
464.78 @@ -122,8 +132,8 @@
464.79 {
464.80 JEdit_Lib.swing_buffer_lock(buffer) {
464.81 document_model(buffer) match {
464.82 - case Some(model) => Document_View.init(model, text_area)
464.83 - case None =>
464.84 + case Some(model) if model.is_theory => Document_View.init(model, text_area)
464.85 + case _ =>
464.86 }
464.87 }
464.88 }
464.89 @@ -161,8 +171,11 @@
464.90 buffers.exists(buffer => JEdit_Lib.buffer_name(buffer) == name)
464.91
464.92 val thys =
464.93 - for (buffer <- buffers; model <- PIDE.document_model(buffer))
464.94 - yield model.node_name
464.95 + for {
464.96 + buffer <- buffers
464.97 + model <- PIDE.document_model(buffer)
464.98 + if model.is_theory
464.99 + } yield model.node_name
464.100
464.101 val thy_info = new Thy_Info(PIDE.thy_load)
464.102 // FIXME avoid I/O in Swing thread!?!
465.1 --- a/src/Tools/jEdit/src/rendering.scala Thu Dec 05 17:52:12 2013 +0100
465.2 +++ b/src/Tools/jEdit/src/rendering.scala Thu Dec 05 17:58:03 2013 +0100
465.3 @@ -226,7 +226,7 @@
465.4 {
465.5 case (links, Text.Info(info_range, XML.Elem(Markup.Path(name), _)))
465.6 if Path.is_ok(name) =>
465.7 - val jedit_file = PIDE.thy_load.append(snapshot.node_name.dir, Path.explode(name))
465.8 + val jedit_file = PIDE.thy_load.append(snapshot.node_name.master_dir, Path.explode(name))
465.9 val link = PIDE.editor.hyperlink_file(jedit_file)
465.10 Some(Text.Info(snapshot.convert(info_range), link) :: links)
465.11
465.12 @@ -369,7 +369,7 @@
465.13 Some(add(prev, r, (true, XML.Text(txt1 + txt2))))
465.14 case (prev, Text.Info(r, XML.Elem(Markup.Path(name), _)))
465.15 if Path.is_ok(name) =>
465.16 - val jedit_file = PIDE.thy_load.append(snapshot.node_name.dir, Path.explode(name))
465.17 + val jedit_file = PIDE.thy_load.append(snapshot.node_name.master_dir, Path.explode(name))
465.18 Some(add(prev, r, (true, XML.Text("file " + quote(jedit_file)))))
465.19 case (prev, Text.Info(r, XML.Elem(Markup(name, _), body)))
465.20 if name == Markup.SORTING || name == Markup.TYPING =>
466.1 --- a/src/Tools/jEdit/src/theories_dockable.scala Thu Dec 05 17:52:12 2013 +0100
466.2 +++ b/src/Tools/jEdit/src/theories_dockable.scala Thu Dec 05 17:58:03 2013 +0100
466.3 @@ -187,10 +187,10 @@
466.4 val snapshot = PIDE.session.snapshot()
466.5
466.6 val iterator =
466.7 - restriction match {
466.8 + (restriction match {
466.9 case Some(names) => names.iterator.map(name => (name, snapshot.version.nodes(name)))
466.10 case None => snapshot.version.nodes.entries
466.11 - }
466.12 + }).filter(_._1.is_theory)
466.13 val nodes_status1 =
466.14 (nodes_status /: iterator)({ case (status, (name, node)) =>
466.15 if (PIDE.thy_load.loaded_theories(name.theory)) status
467.1 --- a/src/Tools/subtyping.ML Thu Dec 05 17:52:12 2013 +0100
467.2 +++ b/src/Tools/subtyping.ML Thu Dec 05 17:58:03 2013 +0100
467.3 @@ -125,14 +125,23 @@
467.4 fun instantiate t Ts = Term.subst_TVars
467.5 ((Term.add_tvar_namesT (fastype_of t) []) ~~ rev Ts) t;
467.6
467.7 -exception COERCION_GEN_ERROR of unit -> string;
467.8 +exception COERCION_GEN_ERROR of unit -> (string * Pretty.T list);
467.9 +
467.10 +infixr ++> +@> (* lazy error msg composition *)
467.11 +
467.12 +fun (err : unit -> string * Pretty.T list) ++> (prt : Pretty.T) =
467.13 + err #> apsnd (cons prt);
467.14 +val op +@> = Library.foldl op ++>;
467.15 +
467.16 +fun eval_err err = err ()
467.17 + |> (fn (str, errs) => str ^ Pretty.string_of (Pretty.text_fold (rev errs)));
467.18
467.19 fun inst_collect tye err T U =
467.20 (case (T, Type_Infer.deref tye U) of
467.21 - (TVar (xi, S), U) => [(xi, U)]
467.22 + (TVar (xi, _), U) => [(xi, U)]
467.23 | (Type (a, Ts), Type (b, Us)) =>
467.24 - if a <> b then raise error (err ()) else inst_collects tye err Ts Us
467.25 - | (_, U') => if T <> U' then error (err ()) else [])
467.26 + if a <> b then raise error (eval_err err) else inst_collects tye err Ts Us
467.27 + | (_, U') => if T <> U' then error (eval_err err) else [])
467.28 and inst_collects tye err Ts Us =
467.29 fold2 (fn T => fn U => fn is => inst_collect tye err T U @ is) Ts Us [];
467.30
467.31 @@ -234,13 +243,12 @@
467.32
467.33 (** error messages **)
467.34
467.35 -infixr ++> (* lazy error msg composition *)
467.36 +fun gen_err err msg =
467.37 + err +@> [Pretty.fbrk, Pretty.str "Now trying to infer coercions globally.", Pretty.fbrk,
467.38 + Pretty.fbrk, Pretty.str "Coercion inference failed",
467.39 + Pretty.str (if msg = "" then "" else ":\n" ^ msg), Pretty.fbrk];
467.40
467.41 -fun err ++> str = err #> suffix str
467.42 -
467.43 -fun gen_msg err msg =
467.44 - err () ^ "\nNow trying to infer coercions globally.\n\nCoercion inference failed" ^
467.45 - (if msg = "" then "" else ":\n" ^ msg) ^ "\n";
467.46 +val gen_msg = eval_err oo gen_err
467.47
467.48 fun prep_output ctxt tye bs ts Ts =
467.49 let
467.50 @@ -258,34 +266,34 @@
467.51
467.52 fun err_appl_msg ctxt msg tye bs t T u U () =
467.53 let val ([t', u'], [T', U']) = prep_output ctxt tye bs [t, u] [T, U]
467.54 - in unif_failed msg ^ Type.appl_error ctxt t' T' u' U' ^ "\n" end;
467.55 + in (unif_failed msg ^ Type.appl_error ctxt t' T' u' U' ^ "\n\n", [Pretty.fbrk, Pretty.fbrk,
467.56 + Pretty.str "Coercion Inference:"]) end;
467.57
467.58 -fun err_list ctxt msg tye Ts =
467.59 +fun err_list ctxt err tye Ts =
467.60 let
467.61 val (_, Ts') = prep_output ctxt tye [] [] Ts;
467.62 - val text =
467.63 - msg ^ "\nCannot unify a list of types that should be the same:\n" ^
467.64 - Pretty.string_of (Pretty.list "[" "]" (map (Syntax.pretty_typ ctxt) Ts'));
467.65 + val text = eval_err (err +@> [Pretty.fbrk,
467.66 + Pretty.str "Cannot unify a list of types that should be the same:", Pretty.fbrk,
467.67 + Pretty.list "[" "]" (map (Syntax.pretty_typ ctxt) Ts')]);
467.68 in
467.69 error text
467.70 end;
467.71
467.72 -fun err_bound ctxt msg tye packs =
467.73 +fun err_bound ctxt err tye packs =
467.74 let
467.75 val (ts, Ts) = fold
467.76 (fn (bs, t $ u, U, _, U') => fn (ts, Ts) =>
467.77 let val (t', T') = prep_output ctxt tye bs [t, u] [U', U]
467.78 in (t' :: ts, T' :: Ts) end)
467.79 packs ([], []);
467.80 - val text = msg ^ "\n" ^ Pretty.string_of (
467.81 - Pretty.big_list "Cannot fulfil subtype constraints:"
467.82 + val text = eval_err (err +@> [Pretty.fbrk, Pretty.big_list "Cannot fulfil subtype constraints:"
467.83 (map2 (fn [t, u] => fn [T, U] =>
467.84 Pretty.block [
467.85 Syntax.pretty_typ ctxt T, Pretty.brk 2, Pretty.str "<:", Pretty.brk 2,
467.86 Syntax.pretty_typ ctxt U, Pretty.brk 3,
467.87 Pretty.str "from function application", Pretty.brk 2,
467.88 Pretty.block [Syntax.pretty_term ctxt (t $ u)]])
467.89 - ts Ts))
467.90 + ts Ts)])
467.91 in
467.92 error text
467.93 end;
467.94 @@ -385,8 +393,9 @@
467.95 | CONTRAVARIANT => (swap constraint :: cs, tye_idx)
467.96 | INVARIANT_TO T => (cs, unify_list [T, fst constraint, snd constraint] tye_idx
467.97 handle NO_UNIFIER (msg, _) =>
467.98 - err_list ctxt (gen_msg err
467.99 - "failed to unify invariant arguments w.r.t. to the known map function\n" ^ msg)
467.100 + err_list ctxt (gen_err err
467.101 + ("failed to unify invariant arguments w.r.t. to the known map function\n" ^
467.102 + msg))
467.103 (fst tye_idx) (T :: Ts))
467.104 | INVARIANT => (cs, strong_unify ctxt constraint tye_idx
467.105 handle NO_UNIFIER (msg, _) =>
467.106 @@ -541,7 +550,7 @@
467.107 (fn cycle => fn tye_idx' => (unify_list cycle tye_idx'
467.108 handle NO_UNIFIER (msg, _) =>
467.109 err_bound ctxt
467.110 - (gen_msg err ("constraint cycle not unifiable\n" ^ msg)) (fst tye_idx)
467.111 + (gen_err err ("constraint cycle not unifiable\n" ^ msg)) (fst tye_idx)
467.112 (find_cycle_packs cycle)))
467.113 cycles tye_idx
467.114 in
467.115 @@ -569,7 +578,7 @@
467.116 Graph.is_edge coes_graph (nameT T, nameT U) then (hd nodes, T')
467.117 else if not super andalso
467.118 Graph.is_edge coes_graph (nameT U, nameT T) then (T', hd nodes)
467.119 - else err_bound ctxt (gen_msg err "cycle elimination produces inconsistent graph")
467.120 + else err_bound ctxt (gen_err err "cycle elimination produces inconsistent graph")
467.121 (fst tye_idx)
467.122 (maps find_cycle_packs cycles @ find_error_pack super T')
467.123 end;
467.124 @@ -597,8 +606,8 @@
467.125 val assignment =
467.126 if null bound orelse null not_params then NONE
467.127 else SOME (tightest lower S styps_and_sorts (map nameT not_params)
467.128 - handle BOUND_ERROR msg =>
467.129 - err_bound ctxt (gen_msg err msg) tye (find_error_pack lower key))
467.130 + handle BOUND_ERROR msg => err_bound ctxt (gen_err err msg) tye
467.131 + (maps (find_error_pack (not lower)) raw_bound))
467.132 in
467.133 (case assignment of
467.134 NONE => tye_idx
467.135 @@ -611,10 +620,11 @@
467.136 in
467.137 if subset (op = o apfst nameT) (filter is_typeT other_bound, s :: styps true s)
467.138 then apfst (Vartab.update (xi, T)) tye_idx
467.139 - else err_bound ctxt (gen_msg err ("assigned base type " ^
467.140 + else err_bound ctxt (gen_err err ("assigned base type " ^
467.141 quote (Syntax.string_of_typ ctxt T) ^
467.142 " clashes with the upper bound of variable " ^
467.143 - Syntax.string_of_typ ctxt (TVar(xi, S)))) tye (find_error_pack (not lower) key)
467.144 + Syntax.string_of_typ ctxt (TVar(xi, S)))) tye
467.145 + (maps (find_error_pack lower) other_bound)
467.146 end
467.147 else apfst (Vartab.update (xi, T)) tye_idx)
467.148 end
467.149 @@ -645,7 +655,7 @@
467.150 in
467.151 fold
467.152 (fn Ts => fn tye_idx' => unify_list Ts tye_idx'
467.153 - handle NO_UNIFIER (msg, _) => err_list ctxt (gen_msg err msg) (fst tye_idx) Ts)
467.154 + handle NO_UNIFIER (msg, _) => err_list ctxt (gen_err err msg) (fst tye_idx) Ts)
467.155 to_unify tye_idx
467.156 end;
467.157
467.158 @@ -669,21 +679,24 @@
467.159 then mk_identity T1
467.160 else
467.161 (case Symreltab.lookup (coes_of ctxt) (a, b) of
467.162 - NONE => raise COERCION_GEN_ERROR (err ++> quote (Syntax.string_of_typ ctxt T1) ^
467.163 - " is not a subtype of " ^ quote (Syntax.string_of_typ ctxt T2))
467.164 + NONE => raise COERCION_GEN_ERROR (err +@>
467.165 + [Pretty.quote (Syntax.pretty_typ ctxt T1), Pretty.brk 1,
467.166 + Pretty.str "is not a subtype of", Pretty.brk 1,
467.167 + Pretty.quote (Syntax.pretty_typ ctxt T2)])
467.168 | SOME (co, _) => co)
467.169 | (T1 as Type (a, Ts), T2 as Type (b, Us)) =>
467.170 if a <> b
467.171 then
467.172 (case Symreltab.lookup (coes_of ctxt) (a, b) of
467.173 (*immediate error - cannot fix complex coercion with the global algorithm*)
467.174 - NONE => error (err () ^ "No coercion known for type constructors: " ^
467.175 - quote a ^ " and " ^ quote b)
467.176 + NONE => error (eval_err (err ++> Pretty.strs
467.177 + ["No coercion known for type constructors:", quote a, "and", quote b]))
467.178 | SOME (co, ((Ts', Us'), _)) =>
467.179 let
467.180 val co_before = gen (T1, Type (a, Ts'));
467.181 val coT = range_type (fastype_of co_before);
467.182 - val insts = inst_collect tye (err ++> "Could not insert complex coercion")
467.183 + val insts = inst_collect tye
467.184 + (err ++> Pretty.str "Could not insert complex coercion")
467.185 (domain_type (fastype_of co)) coT;
467.186 val co' = Term.subst_TVars insts co;
467.187 val co_after = gen (Type (b, (map (typ_subst_TVars insts) Us')), T2);
467.188 @@ -705,7 +718,7 @@
467.189 if Type.could_unify (T1, T2)
467.190 then mk_identity T1
467.191 else raise COERCION_GEN_ERROR
467.192 - (err ++> "No map function for " ^ quote a ^ " known")
467.193 + (err ++> Pretty.strs ["No map function for", quote a, "known"])
467.194 | SOME (tmap, variances) =>
467.195 let
467.196 val (used_coes, invarTs) =
467.197 @@ -722,9 +735,10 @@
467.198 | (T, U) =>
467.199 if Type.could_unify (T, U)
467.200 then mk_identity T
467.201 - else raise COERCION_GEN_ERROR (err ++> "Cannot generate coercion from " ^
467.202 - quote (Syntax.string_of_typ ctxt T) ^ " to " ^
467.203 - quote (Syntax.string_of_typ ctxt U)));
467.204 + else raise COERCION_GEN_ERROR (err +@>
467.205 + [Pretty.str "Cannot generate coercion from", Pretty.brk 1,
467.206 + Pretty.quote (Syntax.pretty_typ ctxt T), Pretty.brk 1, Pretty.str "to", Pretty.brk 1,
467.207 + Pretty.quote (Syntax.pretty_typ ctxt U)]));
467.208 in
467.209 gen TU
467.210 end;
467.211 @@ -733,20 +747,21 @@
467.212 (case Type_Infer.deref tye T of
467.213 Type (C, Ts) =>
467.214 (case Symreltab.lookup (coes_of ctxt) (C, "fun") of
467.215 - NONE => error (err () ^ "No complex coercion from " ^ quote C ^ " to fun")
467.216 + NONE => error (eval_err (err ++> Pretty.strs
467.217 + ["No complex coercion from", quote C, "to fun"]))
467.218 | SOME (co, ((Ts', _), _)) =>
467.219 let
467.220 val co_before = gen_coercion ctxt err tye (Type (C, Ts), Type (C, Ts'));
467.221 val coT = range_type (fastype_of co_before);
467.222 - val insts = inst_collect tye (err ++> "Could not insert complex coercion")
467.223 + val insts = inst_collect tye (err ++> Pretty.str "Could not insert complex coercion")
467.224 (domain_type (fastype_of co)) coT;
467.225 val co' = Term.subst_TVars insts co;
467.226 in
467.227 Abs (Name.uu, Type (C, Ts), Library.foldr (op $)
467.228 (filter (not o is_identity) [co', co_before], Bound 0))
467.229 end)
467.230 - | T' => error (err () ^ "No complex coercion from " ^
467.231 - quote (Syntax.string_of_typ ctxt T') ^ " to fun"));
467.232 + | T' => error (eval_err (err +@> [Pretty.str "No complex coercion from", Pretty.brk 1,
467.233 + Pretty.quote (Syntax.pretty_typ ctxt T'), Pretty.brk 1, Pretty.str "to fun"])));
467.234
467.235 fun insert_coercions ctxt (tye, idx) ts =
467.236 let
467.237 @@ -766,7 +781,7 @@
467.238 in
467.239 if can (fn TU => strong_unify ctxt TU (tye, 0)) (U, U')
467.240 then (t' $ u', T)
467.241 - else (t' $ (gen_coercion ctxt (K "") tye (U', U) $ u'), T)
467.242 + else (t' $ (gen_coercion ctxt (K ("", [])) tye (U', U) $ u'), T)
467.243 end
467.244 in
467.245 map (fst o insert []) ts
467.246 @@ -803,21 +818,22 @@
467.247 (t', strong_unify ctxt (W --> V, T) (tye, idx + 2))
467.248 handle NO_UNIFIER _ =>
467.249 let
467.250 - val err' =
467.251 - err ++> "\nLocal coercion insertion on the operator failed:\n";
467.252 + val err' = err ++>
467.253 + Pretty.str "Local coercion insertion on the operator failed:\n";
467.254 val co = function_of ctxt err' tye T;
467.255 val (t'', T'', tye_idx'') = inf coerce bs (co $ t') (tye, idx + 2);
467.256 in
467.257 (t'', strong_unify ctxt (W --> V, T'') tye_idx''
467.258 - handle NO_UNIFIER (msg, _) => error (err' () ^ msg))
467.259 + handle NO_UNIFIER (msg, _) =>
467.260 + error (eval_err (err' ++> Pretty.str msg)))
467.261 end;
467.262 - val err' = err ++>
467.263 - (if t' aconv t'' then ""
467.264 - else "\nSuccessfully coerced the operator to a function of type:\n" ^
467.265 + val err' = err ++> Pretty.str
467.266 + ((if t' aconv t'' then ""
467.267 + else "Successfully coerced the operator to a function of type:\n" ^
467.268 Syntax.string_of_typ ctxt
467.269 (the_single (snd (prep_output ctxt tye' bs [] [W --> V]))) ^ "\n") ^
467.270 - (if coerce' then "\nLocal coercion insertion on the operand failed:\n"
467.271 - else "\nLocal coercion insertion on the operand disallowed:\n");
467.272 + (if coerce' then "Local coercion insertion on the operand failed:\n"
467.273 + else "Local coercion insertion on the operand disallowed:\n"));
467.274 val (u'', U', tye_idx') =
467.275 if coerce' then
467.276 let val co = gen_coercion ctxt err' tye' (U, W);
467.277 @@ -825,7 +841,8 @@
467.278 else (u, U, (tye', idx'));
467.279 in
467.280 (t'' $ u'', strong_unify ctxt (U', W) tye_idx'
467.281 - handle NO_UNIFIER (msg, _) => raise COERCION_GEN_ERROR (err' ++> msg))
467.282 + handle NO_UNIFIER (msg, _) =>
467.283 + raise COERCION_GEN_ERROR (err' ++> Pretty.str msg))
467.284 end;
467.285 in (tu, V, tye_idx'') end;
467.286
467.287 @@ -838,11 +855,11 @@
467.288 let
467.289 fun gen_single t (tye_idx, constraints) =
467.290 let val (_, tye_idx', constraints') =
467.291 - generate_constraints ctxt (err ++> "\n") t tye_idx
467.292 + generate_constraints ctxt (err ++> Pretty.str "\n") t tye_idx
467.293 in (tye_idx', constraints' @ constraints) end;
467.294
467.295 val (tye_idx, constraints) = fold gen_single ts ((Vartab.empty, idx), []);
467.296 - val (tye, idx) = process_constraints ctxt (err ++> "\n") constraints tye_idx;
467.297 + val (tye, idx) = process_constraints ctxt (err ++> Pretty.str "\n") constraints tye_idx;
467.298 in
467.299 (insert_coercions ctxt (tye, idx) ts, (tye, idx))
467.300 end);
467.301 @@ -983,10 +1000,10 @@
467.302 val (T1, T2) = Term.dest_funT (fastype_of t)
467.303 handle TYPE _ => err_coercion false;
467.304
467.305 - val (a, Ts) = dest_Type T1
467.306 + val (a, _) = dest_Type T1
467.307 handle TYPE _ => err_coercion false;
467.308
467.309 - val (b, Us) = dest_Type T2
467.310 + val (b, _) = dest_Type T2
467.311 handle TYPE _ => err_coercion false;
467.312
467.313 fun delete_and_insert tab G =
468.1 --- a/src/ZF/Datatype_ZF.thy Thu Dec 05 17:52:12 2013 +0100
468.2 +++ b/src/ZF/Datatype_ZF.thy Thu Dec 05 17:58:03 2013 +0100
468.3 @@ -107,9 +107,10 @@
468.4 val conv = Simplifier.simproc_global @{theory} "data_free" ["(x::i) = y"] proc;
468.5
468.6 end;
468.7 +*}
468.8
468.9 -
468.10 -Addsimprocs [DataFree.conv];
468.11 +setup {*
468.12 + Simplifier.map_theory_simpset (fn ctxt => ctxt addsimprocs [DataFree.conv])
468.13 *}
468.14
468.15 end
469.1 --- a/src/ZF/arith_data.ML Thu Dec 05 17:52:12 2013 +0100
469.2 +++ b/src/ZF/arith_data.ML Thu Dec 05 17:58:03 2013 +0100
469.3 @@ -221,7 +221,9 @@
469.4
469.5 end;
469.6
469.7 -Addsimprocs ArithData.nat_cancel;
469.8 +val _ =
469.9 + Theory.setup (Simplifier.map_theory_simpset (fn ctxt =>
469.10 + ctxt addsimprocs ArithData.nat_cancel));
469.11
469.12
469.13 (*examples:
470.1 --- a/src/ZF/int_arith.ML Thu Dec 05 17:52:12 2013 +0100
470.2 +++ b/src/ZF/int_arith.ML Thu Dec 05 17:58:03 2013 +0100
470.3 @@ -320,10 +320,12 @@
470.4
470.5 end;
470.6
470.7 -
470.8 -Addsimprocs Int_Numeral_Simprocs.cancel_numerals;
470.9 -Addsimprocs [Int_Numeral_Simprocs.combine_numerals,
470.10 - Int_Numeral_Simprocs.combine_numerals_prod];
470.11 +val _ =
470.12 + Theory.setup (Simplifier.map_theory_simpset (fn ctxt =>
470.13 + ctxt addsimprocs
470.14 + (Int_Numeral_Simprocs.cancel_numerals @
470.15 + [Int_Numeral_Simprocs.combine_numerals,
470.16 + Int_Numeral_Simprocs.combine_numerals_prod])));
470.17
470.18
470.19 (*examples:*)