# HG changeset patch # User paulson # Date 1442590939 -3600 # Node ID 5977962f8e66d0659d86854d7f8764b77587d7f9 # Parent 2bd401e364f93851d569eeaf7b29e87272306c72# Parent 9583ddfc07b37f3f0cd5d76b5b74b65aa59da6cd Merge diff -r 2bd401e364f9 -r 5977962f8e66 Admin/Linux/Isabelle.run --- a/Admin/Linux/Isabelle.run Fri Sep 18 16:27:37 2015 +0100 +++ b/Admin/Linux/Isabelle.run Fri Sep 18 16:42:19 2015 +0100 @@ -17,15 +17,28 @@ source "$ISABELLE_HOME/lib/scripts/isabelle-platform" +# Java runtime options + +ISABELLE_NAME="$(basename "$0" .run)" +if [ -z "$ISABELLE_PLATFORM64" ]; then + declare -a JAVA_OPTIONS=($(perl -p -e 's,#.*$,,g;' "$ISABELLE_HOME/${ISABELLE_NAME}.options32")) +else + declare -a JAVA_OPTIONS=($(perl -p -e 's,#.*$,,g;' "$ISABELLE_HOME/${ISABELLE_NAME}.options64")) +fi + + # main #paranoia setting -- avoid problems of Java/Swing versus XIM/IBus etc. unset XMODIFIERS -exec "$ISABELLE_HOME/contrib/jdk/${ISABELLE_PLATFORM64:-$ISABELLE_PLATFORM32}/jre/bin/java" \ - "-Disabelle.home=$ISABELLE_HOME" \ - {JAVA_ARGS} \ - -classpath "{CLASSPATH}" \ - "-splash:$ISABELLE_HOME/lib/logo/isabelle.gif" \ - isabelle.Main "$@" - +if "$ISABELLE_HOME/bin/isabelle" jedit_client -c +then + "$ISABELLE_HOME/bin/isabelle" jedit_client "$@" +else + exec "$ISABELLE_HOME/contrib/jdk/${ISABELLE_PLATFORM64:-$ISABELLE_PLATFORM32}/jre/bin/java" \ + "-Disabelle.home=$ISABELLE_HOME" "${JAVA_OPTIONS[@]}" \ + -classpath "{CLASSPATH}" \ + "-splash:$ISABELLE_HOME/lib/logo/isabelle.gif" \ + isabelle.Main -server="$("$ISABELLE_HOME/bin/isabelle" jedit_client -n)" "$@" +fi diff -r 2bd401e364f9 -r 5977962f8e66 Admin/MacOS/Info.plist-part1 --- a/Admin/MacOS/Info.plist-part1 Fri Sep 18 16:27:37 2015 +0100 +++ b/Admin/MacOS/Info.plist-part1 Fri Sep 18 16:42:19 2015 +0100 @@ -9,7 +9,7 @@ CFBundleIconFile isabelle.icns CFBundleIdentifier -de.tum.in.isabelle +de.tum.in.isabelle.{ISABELLE_NAME} CFBundleDisplayName {ISABELLE_NAME} CFBundleInfoDictionaryVersion @@ -26,13 +26,34 @@ 1 NSHumanReadableCopyright +LSMinimumSystemVersion +10.7 LSApplicationCategoryType public.app-category.developer-tools NSHighResolutionCapable true +NSSupportsAutomaticGraphicsSwitching +true JVMRuntime -jdk +bundled.jdk JVMMainClassName isabelle.Main +CFBundleDocumentTypes + + +CFBundleTypeExtensions + +thy + +CFBundleTypeIconFile +theory.icns +CFBundleTypeName +Isabelle theory file +CFBundleTypeRole +Editor +LSTypeIsPackage + + + JVMOptions diff -r 2bd401e364f9 -r 5977962f8e66 Admin/Windows/launch4j/isabelle.xml --- a/Admin/Windows/launch4j/isabelle.xml Fri Sep 18 16:27:37 2015 +0100 +++ b/Admin/Windows/launch4j/isabelle.xml Fri Sep 18 16:42:19 2015 +0100 @@ -18,6 +18,10 @@ isabelle.Main {CLASSPATH} + + {ISABELLE_NAME} + {ISABELLE_NAME} + %EXEDIR%\contrib\jdk\{PLATFORM}\jre {PLATFORM_IS_64} diff -r 2bd401e364f9 -r 5977962f8e66 Admin/components/bundled-macos --- a/Admin/components/bundled-macos Fri Sep 18 16:27:37 2015 +0100 +++ b/Admin/components/bundled-macos Fri Sep 18 16:42:19 2015 +0100 @@ -1,2 +1,2 @@ #additional components to be bundled for release -macos_app-20130716 +macos_app-20150916 diff -r 2bd401e364f9 -r 5977962f8e66 Admin/components/components.sha1 --- a/Admin/components/components.sha1 Fri Sep 18 16:27:37 2015 +0100 +++ b/Admin/components/components.sha1 Fri Sep 18 16:42:19 2015 +0100 @@ -81,6 +81,7 @@ 5f95c96bb99927f3a026050f85bd056f37a9189e kodkodi-1.5.2.tar.gz 377e36efb8608e6c828c7718d890e97fde2006a4 linux_app-20131007.tar.gz 0aab4f73ff7f5e36f33276547e10897e1e56fb1d macos_app-20130716.tar.gz +ad5d0e640ce3609a885cecab645389a2204e03bb macos_app-20150916.tar.gz 1c8cb6a8f4cbeaedce2d6d1ba8fc7e2ab3663aeb polyml-5.4.1.tar.gz a3f9c159a0ee9a63b7a5d0c835ed9c2c908f8b56 polyml-5.5.0-1.tar.gz 7d604a99355efbfc1459d80db3279ffa7ade3e39 polyml-5.5.0-2.tar.gz @@ -93,6 +94,9 @@ 5b31ad8556e41dfd6d5e85f407818be399aa3d2a polyml-5.5.2-3.tar.gz 532f6e8814752aeb406c62fabcfd2cc05f8a7ca8 polyml-5.5.2.tar.gz 1c53f699d35c0db6c7cf4ea51f2310adbd1d0dc5 polyml-5.5.3-20150820.tar.gz +b4b624fb5f34d1dc814fb4fb469fafd7d7ea018a polyml-5.5.3-20150908.tar.gz +b668e1f43a41608a8eb365c5e19db6c54c72748a polyml-5.5.3-20150911.tar.gz +1f5cd9b1390dab13861f90dfc06d4180cc107587 polyml-5.5.3-20150916.tar.gz 8ee375cfc38972f080dbc78f07b68dac03efe968 ProofGeneral-3.7.1.1.tar.gz 847b52c0676b5eb0fbf0476f64fc08c2d72afd0c ProofGeneral-4.1.tar.gz 8e0b2b432755ef11d964e20637d1bc567d1c0477 ProofGeneral-4.2-1.tar.gz diff -r 2bd401e364f9 -r 5977962f8e66 Admin/components/main --- a/Admin/components/main Fri Sep 18 16:27:37 2015 +0100 +++ b/Admin/components/main Fri Sep 18 16:42:19 2015 +0100 @@ -9,7 +9,7 @@ jfreechart-1.0.14-1 jortho-1.0-2 kodkodi-1.5.2 -polyml-5.5.3-20150820 +polyml-5.5.3-20150916 scala-2.11.7 spass-3.8ds xz-java-1.2-1 diff -r 2bd401e364f9 -r 5977962f8e66 Admin/lib/Tools/build_doc --- a/Admin/lib/Tools/build_doc Fri Sep 18 16:27:37 2015 +0100 +++ b/Admin/lib/Tools/build_doc Fri Sep 18 16:42:19 2015 +0100 @@ -4,6 +4,17 @@ # # DESCRIPTION: build Isabelle documentation +## settings + +case "$ISABELLE_JAVA_PLATFORM" in + x86-*) + ISABELLE_BUILD_JAVA_OPTIONS="$ISABELLE_BUILD_JAVA_OPTIONS32" + ;; + x86_64-*) + ISABELLE_BUILD_JAVA_OPTIONS="$ISABELLE_BUILD_JAVA_OPTIONS64" + ;; +esac + ## diagnostics diff -r 2bd401e364f9 -r 5977962f8e66 Admin/lib/Tools/makedist_bundle --- a/Admin/lib/Tools/makedist_bundle Fri Sep 18 16:27:37 2015 +0100 +++ b/Admin/lib/Tools/makedist_bundle Fri Sep 18 16:42:19 2015 +0100 @@ -187,6 +187,23 @@ purge_jdk "x86-linux" purge_jdk "x86_64-linux" + for PLATFORM in 32 64 + do + ( + echo "# Java runtime options for ${PLATFORM}bit platform" + declare -a JAVA_ARGS + if [ "$PLATFORM" = 32 ]; then + eval "JAVA_ARGS=($ISABELLE_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_OPTIONS32)" + else + eval "JAVA_ARGS=($ISABELLE_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_OPTIONS64)" + fi + for ARG in "${JAVA_ARGS[@]}" + do + echo "$ARG" + done + ) > "$ISABELLE_TARGET/${ISABELLE_NAME}.options${PLATFORM}" + done + LINUX_CLASSPATH="" for ENTRY in "${DISTRIBITION_CLASSPATH[@]}" do @@ -196,9 +213,9 @@ LINUX_CLASSPATH="$LINUX_CLASSPATH:\\\$ISABELLE_HOME/$ENTRY" fi done + cat "$ISABELLE_HOME/Admin/Linux/Isabelle.run" | \ - perl -p > "$ISABELLE_TARGET/${ISABELLE_NAME}.run" \ - -e "s,{JAVA_ARGS},$JEDIT_JAVA_OPTIONS $JEDIT_SYSTEM_OPTIONS,g; s,{CLASSPATH},$LINUX_CLASSPATH,;" + perl -p > "$ISABELLE_TARGET/${ISABELLE_NAME}.run" -e "s,{CLASSPATH},$LINUX_CLASSPATH,;" chmod +x "$ISABELLE_TARGET/${ISABELLE_NAME}.run" mv "$ISABELLE_TARGET/contrib/linux_app" "$TMP/." @@ -240,9 +257,14 @@ "$ISABELLE_TARGET/src/Tools/jEdit/dist/properties/jEdit.props" ( - echo -e "# Java runtime options\r" declare -a JAVA_ARGS=() - eval "JAVA_ARGS=($ISABELLE_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_OPTIONS $JEDIT_SYSTEM_OPTIONS)" + if [ "$PLATFORM_FAMILY" = windows ]; then + echo -e "# Java runtime options for 32bit platform\r" + eval "JAVA_ARGS=($ISABELLE_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_OPTIONS32)" + else + echo -e "# Java runtime options for 64bit platform\r" + eval "JAVA_ARGS=($ISABELLE_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_OPTIONS64)" + fi for ARG in "${JAVA_ARGS[@]}" do echo -e "$ARG\r" @@ -268,6 +290,7 @@ -e "s,{ICON},$APP_TEMPLATE/isabelle_transparent.ico,g;" \ -e "s,{SPLASH},$APP_TEMPLATE/isabelle.bmp,g;" \ -e "s,{CLASSPATH},$EXE_CLASSPATH,g;" \ + -e "s,{ISABELLE_NAME},$ISABELLE_NAME,g;" \ -e "s,{PLATFORM},$PLATFORM,g;" \ -e "s,{PLATFORM_IS_64},$PLATFORM_IS_64,g;" \ -e "s,{PLATFORM_BITS},$PLATFORM_BITS,g;" \ @@ -335,7 +358,7 @@ cat "$APP_TEMPLATE/Info.plist-part1" declare -a OPTIONS=() - eval "OPTIONS=($ISABELLE_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_OPTIONS $JEDIT_SYSTEM_OPTIONS)" + eval "OPTIONS=($ISABELLE_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_OPTIONS64)" for OPT in "${OPTIONS[@]}" do echo "$OPT" @@ -353,12 +376,13 @@ cp -R "$APP_TEMPLATE/Resources/." "$APP/Contents/Resources/." ln -sf "../Resources/${ISABELLE_NAME}/contrib/jdk/x86_64-darwin" \ - "$APP/Contents/PlugIns/jdk" + "$APP/Contents/PlugIns/bundled.jdk" cp macos_app/JavaAppLauncher "$APP/Contents/MacOS/." && \ chmod +x "$APP/Contents/MacOS/JavaAppLauncher" mv "$ISABELLE_NAME" "$APP/Contents/Resources/." + ln -sf "../../Info.plist" "$APP/Contents/Resources/$ISABELLE_NAME/${ISABELLE_NAME}.plist" ln -sf "Contents/Resources/$ISABELLE_NAME" "$APP/Isabelle" rm -f "${ARCHIVE_DIR}/${ISABELLE_NAME}.dmg" diff -r 2bd401e364f9 -r 5977962f8e66 Admin/polyml/build --- a/Admin/polyml/build Fri Sep 18 16:27:37 2015 +0100 +++ b/Admin/polyml/build Fri Sep 18 16:42:19 2015 +0100 @@ -64,11 +64,11 @@ OPTIONS=() ;; x86-windows) - OPTIONS=(--host=i686-w32-mingw32 CPPFLAGS='-I/mingw32/include') + OPTIONS=(--host=i686-w32-mingw32 CPPFLAGS='-I/mingw32/include' --disable-windows-gui) PATH="/mingw32/bin:$PATH" ;; x86_64-windows) - OPTIONS=(--host=x86_64-w64-mingw32 CPPFLAGS='-I/mingw64/include') + OPTIONS=(--host=x86_64-w64-mingw32 CPPFLAGS='-I/mingw64/include' --disable-windows-gui) PATH="/mingw64/bin:$PATH" ;; *) diff -r 2bd401e364f9 -r 5977962f8e66 Admin/polyml/settings --- a/Admin/polyml/settings Fri Sep 18 16:27:37 2015 +0100 +++ b/Admin/polyml/settings Fri Sep 18 16:42:19 2015 +0100 @@ -3,50 +3,67 @@ POLYML_HOME="$COMPONENT" -# simple settings (example) +# platform preference -#ML_SYSTEM=polyml-5.5.3 -#ML_PLATFORM="$ISABELLE_PLATFORM32" -#ML_HOME="$POLYML_HOME/$ML_PLATFORM" -#ML_OPTIONS="-H 500" -#ML_SOURCES="$POLYML_HOME/src" - - -# smart settings - -ML_SYSTEM=polyml-5.5.3 +if grep "ML_system_64.*=.*true" "$ISABELLE_HOME_USER/etc/preferences" >/dev/null 2>/dev/null +then + ML_SYSTEM_64="true" +else + ML_SYSTEM_64="false" +fi -case "$ISABELLE_PLATFORM" in - *-linux) - if env LD_LIBRARY_PATH="$POLYML_HOME/$ISABELLE_PLATFORM32:$LD_LIBRARY_PATH" \ - "$POLYML_HOME/$ISABELLE_PLATFORM32/poly" -v >/dev/null 2>/dev/null - then - ML_PLATFORM="$ISABELLE_PLATFORM32" - else - ML_PLATFORM="$ISABELLE_PLATFORM64" - if [ -z "$ML_PLATFORM_FALLBACK" ]; then - echo >&2 "### Cannot execute Poly/ML in 32bit mode (missing shared libraries for C/C++)" - echo >&2 "### Using bulky 64bit version of Poly/ML instead" - ML_PLATFORM_FALLBACK="true" - fi - fi +case "${ISABELLE_PLATFORM}:${ML_SYSTEM_64}" in + x86-cygwin:true) + PLATFORMS="x86_64-windows x86-windows" ;; - x86-cygwin) - ML_PLATFORM="x86-windows" + x86-cygwin:*) + PLATFORMS="x86-windows x86_64-windows" + ;; + *:true) + PLATFORMS="$ISABELLE_PLATFORM64 $ISABELLE_PLATFORM32" ;; *) - ML_PLATFORM="$ISABELLE_PLATFORM32" + PLATFORMS="$ISABELLE_PLATFORM32 $ISABELLE_PLATFORM64" ;; esac -case "$ML_PLATFORM" in - x86_64-*) - ML_OPTIONS="-H 1000" - ;; - *) - ML_OPTIONS="-H 500" - ;; -esac + +# check executable + +unset ML_HOME + +for PLATFORM in $PLATFORMS +do + if [ -z "$ML_HOME" ] + then + if "$POLYML_HOME/$PLATFORM/polyml" -v /dev/null 2>/dev/null + then + + # ML settings + + ML_SYSTEM=polyml-5.5.3 + ML_PLATFORM="$PLATFORM" + ML_HOME="$POLYML_HOME/$ML_PLATFORM" + ML_SOURCES="$POLYML_HOME/src" -ML_HOME="$POLYML_HOME/$ML_PLATFORM" -ML_SOURCES="$POLYML_HOME/src" + case "$ML_PLATFORM" in + x86_64-windows) + ML_OPTIONS="-H 1000 --codepage utf8" + ;; + x86-windows) + ML_OPTIONS="-H 500 --codepage utf8" + ;; + x86_64-*) + ML_OPTIONS="-H 1000" + ;; + *) + ML_OPTIONS="-H 500" + ;; + esac + + fi + fi +done + +unset PLATFORM +unset PLATFORMS diff -r 2bd401e364f9 -r 5977962f8e66 NEWS --- a/NEWS Fri Sep 18 16:27:37 2015 +0100 +++ b/NEWS Fri Sep 18 16:42:19 2015 +0100 @@ -21,6 +21,9 @@ At least one Debugger view needs to be active to have any effect on the running ML program. +* The main Isabelle executable is managed as single-instance Desktop +application uniformly on all platforms: Linux, Windows, Mac OS X. + *** Isar *** @@ -116,13 +119,13 @@ sequences. Further explanations and examples are given in the isar-ref manual. -* Proof method "goals" turns the current subgoals into cases within the -context; the conclusion is bound to variable ?case in each case. -For example: +* Proof method "goal_cases" turns the current subgoals into cases within +the context; the conclusion is bound to variable ?case in each case. For +example: lemma "\x. A x \ B x \ C x" and "\y z. U y \ V z \ W y z" -proof goals +proof goal_cases case (1 x) then show ?case using \A x\ \B x\ sorry next @@ -132,7 +135,7 @@ lemma "\x. A x \ B x \ C x" and "\y z. U y \ V z \ W y z" -proof goals +proof goal_cases case prems: 1 then show ?case using prems sorry next @@ -181,6 +184,26 @@ *** HOL *** +* Qualification of various formal entities in the libraries is done more +uniformly via "context begin qualified definition ... end" instead of +old-style "hide_const (open) ...". Consequently, both the defined +constant and its defining fact become qualified, e.g. Option.is_none and +Option.is_none_def. Occasional INCOMPATIBILITY in applications. + +* Combinator to represent case distinction on products is named "uncurry", +with "split" and "prod_case" retained as input abbreviations. +Partially applied occurences of "uncurry" with eta-contracted body +terms are not printed with special syntax, to provide a compact +notation and getting rid of a special-case print translation. +Hence, the "uncurry"-expressions are printed the following way: +a) fully applied "uncurry f p": explicit case-expression; +b) partially applied with explicit double lambda abstraction in +the body term "uncurry (%a b. t [a, b])": explicit paired abstraction; +c) partially applied with eta-contracted body term "uncurry f": +no special syntax, plain "uncurry" combinator. +This aims for maximum readability in a given subterm. +INCOMPATIBILITY. + * Some old and rarely used ASCII replacement syntax has been removed. INCOMPATIBILITY, standard syntax with symbols should be used instead. The subsequent commands help to reproduce the old forms, e.g. to @@ -189,6 +212,10 @@ type_notation Map.map (infixr "~=>" 0) notation Map.map_comp (infixl "o'_m" 55) +* The alternative notation "\" for type and sort constraints has been +removed: in LaTeX document output it looks the same as "::". +INCOMPATIBILITY, use plain "::" instead. + * Theory Map: lemma map_of_is_SomeD was a clone of map_of_SomeD and has been removed. INCOMPATIBILITY. @@ -276,9 +303,24 @@ * Theory Library/Old_Recdef: discontinued obsolete 'defer_recdef' command. Minor INCOMPATIBILITY, use 'function' instead. +* Recursive function definitions ('fun', 'function', 'partial_function') +no longer expose the low-level "_def" facts of the internal +construction. INCOMPATIBILITY, enable option "function_defs" in the +context for rare situations where these facts are really needed. + +* Imperative_HOL: obsolete theory Legacy_Mrec has been removed. + +* Library/Omega_Words_Fun: Infinite words modeled as functions nat => 'a. + *** ML *** +* Simproc programming interfaces have been simplified: +Simplifier.make_simproc and Simplifier.define_simproc supersede various +forms of Simplifier.mk_simproc, Simplifier.simproc_global etc. Note that +term patterns for the left-hand sides are specified with implicitly +fixed variables, like top-level theorem statements. INCOMPATIBILITY. + * Instantiation rules have been re-organized as follows: Thm.instantiate (*low-level instantiation with named arguments*) @@ -307,12 +349,38 @@ *** System *** +* Property values in etc/symbols may contain spaces, if written with the +replacement character "␣" (Unicode point 0x2324). For example: + + \ code: 0x0022c6 group: operator font: Deja␣Vu␣Sans␣Mono + +* Command-line tool "isabelle jedit_client" allows to connect to already +running Isabelle/jEdit process. This achieves the effect of +single-instance applications seen on common GUI desktops. + +* Poly/ML default platform architecture may be changed from 32bit to +64bit via system option ML_system_64. A system restart (and rebuild) +is required after change. + * Poly/ML 5.5.3 runs natively on x86-windows and x86_64-windows, which both allow larger heap space than former x86-cygwin. * Java runtime environment for x86_64-windows allows to use larger heap space. +* Java runtime options are determined separately for 32bit vs. 64bit +platforms as follows. + + - Isabelle desktop application: platform-specific files that are + associated with the main app bundle + + - isabelle jedit: settings + JEDIT_JAVA_SYSTEM_OPTIONS + JEDIT_JAVA_OPTIONS32 vs. JEDIT_JAVA_OPTIONS64 + + - isabelle build: settings + ISABELLE_BUILD_JAVA_OPTIONS32 vs. ISABELLE_BUILD_JAVA_OPTIONS64 + New in Isabelle2015 (May 2015) diff -r 2bd401e364f9 -r 5977962f8e66 etc/options --- a/etc/options Fri Sep 18 16:27:37 2015 +0100 +++ b/etc/options Fri Sep 18 16:42:19 2015 +0100 @@ -107,6 +107,9 @@ public option ML_statistics : bool = true -- "ML run-time system statistics" +public option ML_system_64 : bool = false + -- "ML system for 64bit platform is used if possible (change requires restart)" + section "Editor Reactivity" diff -r 2bd401e364f9 -r 5977962f8e66 etc/settings --- a/etc/settings Fri Sep 18 16:27:37 2015 +0100 +++ b/etc/settings Fri Sep 18 16:42:19 2015 +0100 @@ -38,7 +38,9 @@ ### ISABELLE_BUILD_OPTIONS="" -ISABELLE_BUILD_JAVA_OPTIONS="-Djava.awt.headless=true -Xmx1024m -Xss1m" + +ISABELLE_BUILD_JAVA_OPTIONS32="-Djava.awt.headless=true -Xms128m -Xmx1024m -Xss1m" +ISABELLE_BUILD_JAVA_OPTIONS64="-Djava.awt.headless=true -Xms512m -Xmx2560m -Xss4m" ### diff -r 2bd401e364f9 -r 5977962f8e66 lib/Tools/build --- a/lib/Tools/build Fri Sep 18 16:27:37 2015 +0100 +++ b/lib/Tools/build Fri Sep 18 16:42:19 2015 +0100 @@ -4,6 +4,17 @@ # # DESCRIPTION: build and manage Isabelle sessions +## settings + +case "$ISABELLE_JAVA_PLATFORM" in + x86-*) + ISABELLE_BUILD_JAVA_OPTIONS="$ISABELLE_BUILD_JAVA_OPTIONS32" + ;; + x86_64-*) + ISABELLE_BUILD_JAVA_OPTIONS="$ISABELLE_BUILD_JAVA_OPTIONS64" + ;; +esac + ## diagnostics @@ -14,6 +25,8 @@ local PREFIX="$1" echo "${PREFIX}ISABELLE_BUILD_OPTIONS=\"$ISABELLE_BUILD_OPTIONS\"" echo + echo "${PREFIX}ISABELLE_BUILD_JAVA_OPTIONS=\"$ISABELLE_BUILD_JAVA_OPTIONS\"" + echo echo "${PREFIX}ML_PLATFORM=\"$ML_PLATFORM\"" echo "${PREFIX}ML_HOME=\"$ML_HOME\"" echo "${PREFIX}ML_SYSTEM=\"$ML_SYSTEM\"" diff -r 2bd401e364f9 -r 5977962f8e66 lib/Tools/console --- a/lib/Tools/console Fri Sep 18 16:27:37 2015 +0100 +++ b/lib/Tools/console Fri Sep 18 16:42:19 2015 +0100 @@ -4,6 +4,20 @@ # # DESCRIPTION: run Isabelle process with raw ML console and line editor +## settings + +case "$ISABELLE_JAVA_PLATFORM" in + x86-*) + ISABELLE_BUILD_JAVA_OPTIONS="$ISABELLE_BUILD_JAVA_OPTIONS32" + ;; + x86_64-*) + ISABELLE_BUILD_JAVA_OPTIONS="$ISABELLE_BUILD_JAVA_OPTIONS64" + ;; +esac + + +## diagnostics + PRG="$(basename "$0")" function usage() diff -r 2bd401e364f9 -r 5977962f8e66 lib/scripts/feeder.pl --- a/lib/scripts/feeder.pl Fri Sep 18 16:27:37 2015 +0100 +++ b/lib/scripts/feeder.pl Fri Sep 18 16:42:19 2015 +0100 @@ -19,14 +19,18 @@ #buffer lines $| = 1; +sub emit { + my ($text) = @_; + if ($text) { + utf8::upgrade($text); + $text =~ s/([\x80-\xff])/\\${\(ord($1))}/g; + print $text, "\n"; + } +} $emitpid && (print $$, "\n"); -if ($head) { - utf8::upgrade($head); - $head =~ s/([\x80-\xff])/\\${\(ord($1))}/g; - print $head, "\n"; -} +emit("$head"); if (!$quit) { while () { @@ -34,7 +38,7 @@ } } -$tail && (print "$tail", "\n"); +emit("$tail"); # wait forever diff -r 2bd401e364f9 -r 5977962f8e66 lib/scripts/getsettings --- a/lib/scripts/getsettings Fri Sep 18 16:27:37 2015 +0100 +++ b/lib/scripts/getsettings Fri Sep 18 16:42:19 2015 +0100 @@ -240,21 +240,29 @@ { local BASE="$1" local CATALOG="$2" + local COMPONENT="" + local -a COMPONENTS=() if [ ! -f "$CATALOG" ]; then echo >&2 "Bad component catalog file: \"$CATALOG\"" exit 2 fi + { while { unset REPLY; read -r; test "$?" = 0 -o -n "$REPLY"; } do case "$REPLY" in \#* | "") ;; - /*) init_component "$REPLY" ;; - *) init_component "$BASE/$REPLY" ;; + /*) COMPONENTS["${#COMPONENTS[@]}"]="$REPLY" ;; + *) COMPONENTS["${#COMPONENTS[@]}"]="$BASE/$REPLY" ;; esac done } < "$CATALOG" + + for COMPONENT in "${COMPONENTS[@]}" + do + init_component "$COMPONENT" + done } #main components diff -r 2bd401e364f9 -r 5977962f8e66 src/Doc/Codegen/Adaptation.thy --- a/src/Doc/Codegen/Adaptation.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Doc/Codegen/Adaptation.thy Fri Sep 18 16:42:19 2015 +0100 @@ -346,7 +346,7 @@ definition %quote "HOL.equal (x::bar) y \ x = y" -instance %quote by default (simp add: equal_bar_def) +instance %quote by standard (simp add: equal_bar_def) end %quote (*<*) diff -r 2bd401e364f9 -r 5977962f8e66 src/Doc/Codegen/Setup.thy --- a/src/Doc/Codegen/Setup.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Doc/Codegen/Setup.thy Fri Sep 18 16:42:19 2015 +0100 @@ -11,18 +11,13 @@ ML_file "../antiquote_setup.ML" ML_file "../more_antiquote.ML" -setup \ -let - val typ = Simple_Syntax.read_typ; -in - Sign.del_syntax (Symbol.xsymbolsN, false) - [("_constrain", typ "logic => type => logic", Mixfix ("_\_", [4, 0], 3)), - ("_constrain", typ "prop' => type => prop'", Mixfix ("_\_", [4, 0], 3))] #> - Sign.add_syntax (Symbol.xsymbolsN, false) - [("_constrain", typ "logic => type => logic", Mixfix ("_ \ _", [4, 0], 3)), - ("_constrain", typ "prop' => type => prop'", Mixfix ("_ \ _", [4, 0], 3))] -end -\ +no_syntax (output) + "_constrain" :: "logic => type => logic" ("_::_" [4, 0] 3) + "_constrain" :: "prop' => type => prop'" ("_::_" [4, 0] 3) + +syntax (output) + "_constrain" :: "logic => type => logic" ("_ :: _" [4, 0] 3) + "_constrain" :: "prop' => type => prop'" ("_ :: _" [4, 0] 3) declare [[default_code_width = 74]] diff -r 2bd401e364f9 -r 5977962f8e66 src/Doc/Isar_Ref/Inner_Syntax.thy --- a/src/Doc/Isar_Ref/Inner_Syntax.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Doc/Isar_Ref/Inner_Syntax.thy Fri Sep 18 16:42:19 2015 +0100 @@ -839,10 +839,6 @@ input is likely to be ambiguous. The correct form is @{text "x < (y :: nat)"}. - \item Constraints may be either written with two literal colons - ``@{verbatim "::"}'' or the double-colon symbol @{verbatim "\"}, - which actually looks exactly the same in some {\LaTeX} styles. - \item Dummy variables (written as underscore) may occur in different roles. diff -r 2bd401e364f9 -r 5977962f8e66 src/Doc/Isar_Ref/Proof.thy --- a/src/Doc/Isar_Ref/Proof.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Doc/Isar_Ref/Proof.thy Fri Sep 18 16:42:19 2015 +0100 @@ -832,7 +832,7 @@ \begin{matharray}{rcl} @{command_def "print_rules"}@{text "\<^sup>*"} & : & @{text "context \"} \\[0.5ex] @{method_def "-"} & : & @{text method} \\ - @{method_def "goals"} & : & @{text method} \\ + @{method_def "goal_cases"} & : & @{text method} \\ @{method_def "fact"} & : & @{text method} \\ @{method_def "assumption"} & : & @{text method} \\ @{method_def "this"} & : & @{text method} \\ @@ -847,7 +847,7 @@ \end{matharray} @{rail \ - @@{method goals} (@{syntax name}*) + @@{method goal_cases} (@{syntax name}*) ; @@{method fact} @{syntax thmrefs}? ; @@ -886,10 +886,10 @@ method; thus a plain \emph{do-nothing} proof step would be ``@{command "proof"}~@{text "-"}'' rather than @{command "proof"} alone. - \item @{method "goals"}~@{text "a\<^sub>1 \ a\<^sub>n"} is like ``@{method "-"}'', but - the current subgoals are turned into cases within the context (see also - \secref{sec:cases-induct}). The specified case names are used if present; - otherwise cases are numbered starting from 1. + \item @{method "goal_cases"}~@{text "a\<^sub>1 \ a\<^sub>n"} turns the current subgoals + into cases within the context (see also \secref{sec:cases-induct}). The + specified case names are used if present; otherwise cases are numbered + starting from 1. Invoking cases in the subsequent proof body via the @{command_ref case} command will @{command fix} goal parameters, @{command assume} goal diff -r 2bd401e364f9 -r 5977962f8e66 src/Doc/JEdit/JEdit.thy --- a/src/Doc/JEdit/JEdit.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Doc/JEdit/JEdit.thy Fri Sep 18 16:42:19 2015 +0100 @@ -226,12 +226,12 @@ Usage: isabelle jedit [OPTIONS] [FILES ...] Options are: - -J OPTION add JVM runtime option (default JEDIT_JAVA_OPTIONS) + -J OPTION add JVM runtime option -b build only -d DIR include session directory -f fresh build - -j OPTION add jEdit runtime option (default JEDIT_OPTIONS) - -l NAME logic image name (default ISABELLE_LOGIC) + -j OPTION add jEdit runtime option + -l NAME logic image name -m MODE add print mode for output -n no build of session image on startup -s system build mode for session image diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Algebra/AbelCoset.thy --- a/src/HOL/Algebra/AbelCoset.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Algebra/AbelCoset.thy Fri Sep 18 16:42:19 2015 +0100 @@ -236,7 +236,7 @@ by (rule a_normal) show "abelian_subgroup H G" - by default (simp add: a_comm) + by standard (simp add: a_comm) qed lemma abelian_subgroupI2: diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Algebra/Divisibility.thy --- a/src/HOL/Algebra/Divisibility.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Algebra/Divisibility.thy Fri Sep 18 16:42:19 2015 +0100 @@ -25,14 +25,14 @@ and r_cancel: "\a b c. \a \ c = b \ c; a \ carrier G; b \ carrier G; c \ carrier G\ \ a = b" shows "monoid_cancel G" - by default fact+ + by standard fact+ lemma (in monoid_cancel) is_monoid_cancel: "monoid_cancel G" .. sublocale group \ monoid_cancel - by default simp_all + by standard simp_all locale comm_monoid_cancel = monoid_cancel + comm_monoid @@ -3640,7 +3640,7 @@ done sublocale factorial_monoid \ primeness_condition_monoid - by default (rule irreducible_is_prime) + by standard (rule irreducible_is_prime) lemma (in factorial_monoid) primeness_condition: @@ -3649,10 +3649,10 @@ lemma (in factorial_monoid) gcd_condition [simp]: shows "gcd_condition_monoid G" - by default (rule gcdof_exists) + by standard (rule gcdof_exists) sublocale factorial_monoid \ gcd_condition_monoid - by default (rule gcdof_exists) + by standard (rule gcdof_exists) lemma (in factorial_monoid) division_weak_lattice [simp]: shows "weak_lattice (division_rel G)" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Algebra/Group.thy --- a/src/HOL/Algebra/Group.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Algebra/Group.thy Fri Sep 18 16:42:19 2015 +0100 @@ -286,7 +286,8 @@ qed then have carrier_subset_Units: "carrier G <= Units G" by (unfold Units_def) fast - show ?thesis by default (auto simp: r_one m_assoc carrier_subset_Units) + show ?thesis + by standard (auto simp: r_one m_assoc carrier_subset_Units) qed lemma (in monoid) group_l_invI: @@ -730,7 +731,7 @@ assumes m_comm: "!!x y. [| x \ carrier G; y \ carrier G |] ==> x \ y = y \ x" shows "comm_group G" - by default (simp_all add: m_comm) + by standard (simp_all add: m_comm) lemma comm_groupI: fixes G (structure) @@ -758,7 +759,7 @@ theorem (in group) subgroups_partial_order: "partial_order \carrier = {H. subgroup H G}, eq = op =, le = op \\" - by default simp_all + by standard simp_all lemma (in group) subgroup_self: "subgroup (carrier G) G" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Algebra/IntRing.thy --- a/src/HOL/Algebra/IntRing.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Algebra/IntRing.thy Fri Sep 18 16:42:19 2015 +0100 @@ -60,7 +60,7 @@ and "pow \ x n = x^n" proof - -- "Specification" - show "monoid \" by default auto + show "monoid \" by standard auto then interpret int: monoid \ . -- "Carrier" @@ -76,7 +76,7 @@ where "finprod \ f A = setprod f A" proof - -- "Specification" - show "comm_monoid \" by default auto + show "comm_monoid \" by standard auto then interpret int: comm_monoid \ . -- "Operations" @@ -94,7 +94,7 @@ and int_finsum_eq: "finsum \ f A = setsum f A" proof - -- "Specification" - show "abelian_monoid \" by default auto + show "abelian_monoid \" by standard auto then interpret int: abelian_monoid \ . -- "Carrier" @@ -178,7 +178,7 @@ and "lless \carrier = UNIV::int set, eq = op =, le = op \\ x y = (x < y)" proof - show "partial_order \carrier = UNIV::int set, eq = op =, le = op \\" - by default simp_all + by standard simp_all show "carrier \carrier = UNIV::int set, eq = op =, le = op \\ = UNIV" by simp show "le \carrier = UNIV::int set, eq = op =, le = op \\ x y = (x \ y)" @@ -215,7 +215,7 @@ interpretation int (* [unfolded UNIV] *) : total_order "\carrier = UNIV::int set, eq = op =, le = op \\" - by default clarsimp + by standard clarsimp subsection {* Generated Ideals of @{text "\"} *} diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Algebra/Lattice.thy --- a/src/HOL/Algebra/Lattice.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Algebra/Lattice.thy Fri Sep 18 16:42:19 2015 +0100 @@ -921,7 +921,7 @@ lemma (in weak_partial_order) weak_total_orderI: assumes total: "!!x y. [| x \ carrier L; y \ carrier L |] ==> x \ y | y \ x" shows "weak_total_order L" - by default (rule total) + by standard (rule total) text {* Total orders are lattices. *} @@ -985,7 +985,7 @@ and inf_exists: "!!A. [| A \ carrier L |] ==> EX i. greatest L i (Lower L A)" shows "weak_complete_lattice L" - by default (auto intro: sup_exists inf_exists) + by standard (auto intro: sup_exists inf_exists) definition top :: "_ => 'a" ("\\") @@ -1133,14 +1133,14 @@ "[| x \ carrier L; y \ carrier L |] ==> EX s. least L s (Upper L {x, y})" sublocale upper_semilattice < weak: weak_upper_semilattice - by default (rule sup_of_two_exists) + by standard (rule sup_of_two_exists) locale lower_semilattice = partial_order + assumes inf_of_two_exists: "[| x \ carrier L; y \ carrier L |] ==> EX s. greatest L s (Lower L {x, y})" sublocale lower_semilattice < weak: weak_lower_semilattice - by default (rule inf_of_two_exists) + by standard (rule inf_of_two_exists) locale lattice = upper_semilattice + lower_semilattice @@ -1191,19 +1191,19 @@ assumes total_order_total: "[| x \ carrier L; y \ carrier L |] ==> x \ y | y \ x" sublocale total_order < weak: weak_total_order - by default (rule total_order_total) + by standard (rule total_order_total) text {* Introduction rule: the usual definition of total order *} lemma (in partial_order) total_orderI: assumes total: "!!x y. [| x \ carrier L; y \ carrier L |] ==> x \ y | y \ x" shows "total_order L" - by default (rule total) + by standard (rule total) text {* Total orders are lattices. *} sublocale total_order < weak: lattice - by default (auto intro: sup_of_two_exists inf_of_two_exists) + by standard (auto intro: sup_of_two_exists inf_of_two_exists) text {* Complete lattices *} @@ -1215,7 +1215,7 @@ "[| A \ carrier L |] ==> EX i. greatest L i (Lower L A)" sublocale complete_lattice < weak: weak_complete_lattice - by default (auto intro: sup_exists inf_exists) + by standard (auto intro: sup_exists inf_exists) text {* Introduction rule: the usual definition of complete lattice *} @@ -1225,7 +1225,7 @@ and inf_exists: "!!A. [| A \ carrier L |] ==> EX i. greatest L i (Lower L A)" shows "complete_lattice L" - by default (auto intro: sup_exists inf_exists) + by standard (auto intro: sup_exists inf_exists) theorem (in partial_order) complete_lattice_criterion1: assumes top_exists: "EX g. greatest L g (carrier L)" @@ -1282,7 +1282,7 @@ (is "complete_lattice ?L") proof (rule partial_order.complete_latticeI) show "partial_order ?L" - by default auto + by standard auto next fix B assume "B \ carrier ?L" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Algebra/RingHom.thy --- a/src/HOL/Algebra/RingHom.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Algebra/RingHom.thy Fri Sep 18 16:42:19 2015 +0100 @@ -17,7 +17,7 @@ and hom_one [simp] = ring_hom_one [OF homh] sublocale ring_hom_cring \ ring: ring_hom_ring - by default (rule homh) + by standard (rule homh) sublocale ring_hom_ring \ abelian_group: abelian_group_hom R S apply (rule abelian_group_homI) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Algebra/UnivPoly.thy --- a/src/HOL/Algebra/UnivPoly.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Algebra/UnivPoly.thy Fri Sep 18 16:42:19 2015 +0100 @@ -1760,7 +1760,7 @@ and deg_r_0: "deg R r = 0" shows "r = monom P (eval R R id a f) 0" proof - - interpret UP_pre_univ_prop R R id P by default simp + interpret UP_pre_univ_prop R R id P by standard simp have eval_ring_hom: "eval R R id a \ ring_hom P R" using eval_ring_hom [OF a] by simp have "eval R R id a f = eval R R id a ?gq \\<^bsub>R\<^esub> eval R R id a r" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/BNF_Fixpoint_Base.thy --- a/src/HOL/BNF_Fixpoint_Base.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/BNF_Fixpoint_Base.thy Fri Sep 18 16:42:19 2015 +0100 @@ -15,10 +15,10 @@ begin lemma False_imp_eq_True: "(False \ Q) \ Trueprop True" - by default simp_all + by standard simp_all lemma conj_imp_eq_imp_imp: "(P \ Q \ PROP R) \ (P \ Q \ PROP R)" - by default simp_all + by standard simp_all lemma mp_conj: "(P \ Q) \ R \ P \ R \ Q" by auto diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Basic_BNF_LFPs.thy --- a/src/HOL/Basic_BNF_LFPs.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Basic_BNF_LFPs.thy Fri Sep 18 16:42:19 2015 +0100 @@ -30,7 +30,7 @@ lemmas xtor_inject = xtor_rel[of "op ="] lemma xtor_rel_induct: "(\x y. vimage2p id_bnf id_bnf R x y \ IR (xtor x) (xtor y)) \ R \ IR" - unfolding xtor_def vimage2p_def id_bnf_def by default + unfolding xtor_def vimage2p_def id_bnf_def .. lemma Inl_def_alt: "Inl \ (\a. xtor (id_bnf (Inl a)))" unfolding xtor_def id_bnf_def by (rule reflexive) @@ -60,10 +60,10 @@ by (cases p) auto lemma ex_neg_all_pos: "((\x. P x) \ Q) \ (\x. P x \ Q)" - by default blast+ + by standard blast+ lemma hypsubst_in_prems: "(\x. y = x \ z = f x \ P) \ (z = f y \ P)" - by default blast+ + by standard blast+ lemma isl_map_sum: "isl (map_sum f g s) = isl s" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Codegenerator_Test/Candidates.thy --- a/src/HOL/Codegenerator_Test/Candidates.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Codegenerator_Test/Candidates.thy Fri Sep 18 16:42:19 2015 +0100 @@ -12,6 +12,8 @@ "~~/src/HOL/ex/Records" begin +text \Drop technical stuff from @{theory Quickcheck_Narrowing} which is tailored towards Haskell\ + setup \ fn thy => let @@ -19,7 +21,9 @@ val consts = map_filter (try (curry (Axclass.param_of_inst thy) @{const_name "Quickcheck_Narrowing.partial_term_of"})) tycos; in fold Code.del_eqns consts thy end -\ -- \drop technical stuff from @{text Quickcheck_Narrowing} which is tailored towards Haskell\ +\ + +text \Simple example for the predicate compiler.\ inductive sublist :: "'a list \ 'a list \ bool" where @@ -29,6 +33,32 @@ code_pred sublist . -code_reserved SML upto -- {* avoid popular infix *} +text \Avoid popular infix.\ + +code_reserved SML upto + +text \Explicit check in @{text OCaml} for correct precedence of let expressions in list expressions\ + +definition funny_list :: "bool list" +where + "funny_list = [let b = True in b, False]" + +definition funny_list' :: "bool list" +where + "funny_list' = funny_list" + +lemma [code]: + "funny_list' = [True, False]" + by (simp add: funny_list_def funny_list'_def) + +definition check_list :: unit +where + "check_list = (if funny_list = funny_list' then () else undefined)" + +text \Explicit check in @{text Scala} for correct bracketing of abstractions\ + +definition funny_funs :: "(bool \ bool) list \ (bool \ bool) list" +where + "funny_funs fs = (\x. x \ True) # (\x. x \ False) # fs" end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Complete_Partial_Order.thy --- a/src/HOL/Complete_Partial_Order.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Complete_Partial_Order.thy Fri Sep 18 16:42:19 2015 +0100 @@ -293,7 +293,7 @@ end instance complete_lattice \ ccpo - by default (fast intro: Sup_upper Sup_least)+ + by standard (fast intro: Sup_upper Sup_least)+ lemma lfp_eq_fixp: assumes f: "mono f" shows "lfp f = fixp f" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Conditionally_Complete_Lattices.thy --- a/src/HOL/Conditionally_Complete_Lattices.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Conditionally_Complete_Lattices.thy Fri Sep 18 16:42:19 2015 +0100 @@ -371,7 +371,7 @@ end instance complete_lattice \ conditionally_complete_lattice - by default (auto intro: Sup_upper Sup_least Inf_lower Inf_greatest) + by standard (auto intro: Sup_upper Sup_least Inf_lower Inf_greatest) lemma cSup_eq: fixes a :: "'a :: {conditionally_complete_lattice, no_bot}" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Decision_Procs/Dense_Linear_Order.thy --- a/src/HOL/Decision_Procs/Dense_Linear_Order.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Decision_Procs/Dense_Linear_Order.thy Fri Sep 18 16:42:19 2015 +0100 @@ -578,7 +578,7 @@ begin sublocale dlo: unbounded_dense_linorder -proof (unfold_locales, goals) +proof (unfold_locales, goal_cases) case (1 x y) then show ?case using between_less [of x y] by auto diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Decision_Procs/Reflected_Multivariate_Polynomial.thy --- a/src/HOL/Decision_Procs/Reflected_Multivariate_Polynomial.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Decision_Procs/Reflected_Multivariate_Polynomial.thy Fri Sep 18 16:42:19 2015 +0100 @@ -891,7 +891,7 @@ subsection \Miscellaneous lemmas about indexes, decrementation, substitution etc ...\ lemma isnpolyh_polybound0: "isnpolyh p (Suc n) \ polybound0 p" -proof (induct p arbitrary: n rule: poly.induct, auto, goals) +proof (induct p arbitrary: n rule: poly.induct, auto, goal_cases) case prems: (1 c n p n') then have "n = Suc (n - 1)" by simp diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Decision_Procs/langford.ML --- a/src/HOL/Decision_Procs/langford.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Decision_Procs/langford.ML Fri Sep 18 16:42:19 2015 +0100 @@ -170,11 +170,8 @@ in val reduce_ex_simproc = - Simplifier.make_simproc - {lhss = [@{cpat "\x. ?P x"}], - name = "reduce_ex_simproc", - proc = K proc, - identifier = []}; + Simplifier.make_simproc @{context} "reduce_ex_simproc" + {lhss = [@{term "\x. P x"}], proc = K proc, identifier = []}; end; diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Enum.thy --- a/src/HOL/Enum.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Enum.thy Fri Sep 18 16:42:19 2015 +0100 @@ -446,9 +446,10 @@ "enum_ex P = enum_ex (%x. enum_ex (%y. P (x, y)))" -instance by default - (simp_all add: enum_prod_def distinct_product - enum_UNIV enum_distinct enum_all_prod_def enum_ex_prod_def) +instance + by standard + (simp_all add: enum_prod_def distinct_product + enum_UNIV enum_distinct enum_all_prod_def enum_ex_prod_def) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Finite_Set.thy --- a/src/HOL/Finite_Set.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Finite_Set.thy Fri Sep 18 16:42:19 2015 +0100 @@ -573,7 +573,7 @@ end instance prod :: (finite, finite) finite - by default (simp only: UNIV_Times_UNIV [symmetric] finite_cartesian_product finite) + by standard (simp only: UNIV_Times_UNIV [symmetric] finite_cartesian_product finite) lemma inj_graph: "inj (%f. {(x, y). y = f x})" by (rule inj_onI, auto simp add: set_eq_iff fun_eq_iff) @@ -593,16 +593,16 @@ qed instance bool :: finite - by default (simp add: UNIV_bool) + by standard (simp add: UNIV_bool) instance set :: (finite) finite - by default (simp only: Pow_UNIV [symmetric] finite_Pow_iff finite) + by standard (simp only: Pow_UNIV [symmetric] finite_Pow_iff finite) instance unit :: finite - by default (simp add: UNIV_unit) + by standard (simp add: UNIV_unit) instance sum :: (finite, finite) finite - by default (simp only: UNIV_Plus_UNIV [symmetric] finite_Plus finite) + by standard (simp only: UNIV_Plus_UNIV [symmetric] finite_Plus finite) subsection \A basic fold functional for finite sets\ @@ -967,7 +967,7 @@ "comp_fun_commute (\x A'. if P x then Set.insert x A' else A')" proof - interpret comp_fun_idem Set.insert by (fact comp_fun_idem_insert) - show ?thesis by default (auto simp: fun_eq_iff) + show ?thesis by standard (auto simp: fun_eq_iff) qed lemma Set_filter_fold: @@ -988,7 +988,7 @@ shows "image f A = fold (\k A. Set.insert (f k) A) {} A" using assms proof - - interpret comp_fun_commute "\k A. Set.insert (f k) A" by default auto + interpret comp_fun_commute "\k A. Set.insert (f k) A" by standard auto show ?thesis using assms by (induct A) auto qed @@ -997,7 +997,7 @@ shows "Ball A P = fold (\k s. s \ P k) True A" using assms proof - - interpret comp_fun_commute "\k s. s \ P k" by default auto + interpret comp_fun_commute "\k s. s \ P k" by standard auto show ?thesis using assms by (induct A) auto qed @@ -1006,7 +1006,7 @@ shows "Bex A P = fold (\k s. s \ P k) False A" using assms proof - - interpret comp_fun_commute "\k s. s \ P k" by default auto + interpret comp_fun_commute "\k s. s \ P k" by standard auto show ?thesis using assms by (induct A) auto qed @@ -1027,14 +1027,14 @@ assumes "finite B" shows "(\y\B. {(x, y)}) \ A = fold (\y. Set.insert (x, y)) A B" proof - - interpret comp_fun_commute "\y. Set.insert (x, y)" by default auto + interpret comp_fun_commute "\y. Set.insert (x, y)" by standard auto show ?thesis using assms by (induct B arbitrary: A) simp_all qed lemma comp_fun_commute_product_fold: assumes "finite B" shows "comp_fun_commute (\x z. fold (\y. Set.insert (x, y)) z B)" -by default (auto simp: fold_union_pair[symmetric] assms) + by standard (auto simp: fold_union_pair[symmetric] assms) lemma product_fold: assumes "finite A" @@ -1122,18 +1122,16 @@ begin interpretation fold?: comp_fun_commute f - by default (insert comp_fun_commute, simp add: fun_eq_iff) + by standard (insert comp_fun_commute, simp add: fun_eq_iff) definition F :: "'a set \ 'b" where eq_fold: "F A = fold f z A" -lemma empty [simp]: - "F {} = z" +lemma empty [simp]:"F {} = z" by (simp add: eq_fold) -lemma infinite [simp]: - "\ finite A \ F A = z" +lemma infinite [simp]: "\ finite A \ F A = z" by (simp add: eq_fold) lemma insert [simp]: @@ -1172,7 +1170,7 @@ declare insert [simp del] interpretation fold?: comp_fun_idem f - by default (insert comp_fun_commute comp_fun_idem, simp add: fun_eq_iff) + by standard (insert comp_fun_commute comp_fun_idem, simp add: fun_eq_iff) lemma insert_idem [simp]: assumes "finite A" @@ -1202,7 +1200,7 @@ where "folding.F (\_. Suc) 0 = card" proof - - show "folding (\_. Suc)" by default rule + show "folding (\_. Suc)" by standard rule then interpret card!: folding "\_. Suc" 0 . from card_def show "folding.F (\_. Suc) 0 = card" by rule qed diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/GCD.thy --- a/src/HOL/GCD.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/GCD.thy Fri Sep 18 16:42:19 2015 +0100 @@ -1975,7 +1975,7 @@ and "Sup.SUPREMUM Lcm A f = Lcm (f ` A)" proof - show "class.complete_lattice Gcd Lcm gcd Rings.dvd (\m n. m dvd n \ \ n dvd m) lcm 1 (0::nat)" - by default (auto simp add: Gcd_nat_def Lcm_nat_empty Lcm_nat_infinite) + by standard (auto simp add: Gcd_nat_def Lcm_nat_empty Lcm_nat_infinite) then interpret gcd_lcm_complete_lattice_nat: complete_lattice Gcd Lcm gcd Rings.dvd "\m n. m dvd n \ \ n dvd m" lcm 1 "0::nat" . from gcd_lcm_complete_lattice_nat.INF_def show "Inf.INFIMUM Gcd A f = Gcd (f ` A)" . diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Groups.thy --- a/src/HOL/Groups.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Groups.thy Fri Sep 18 16:42:19 2015 +0100 @@ -71,7 +71,7 @@ begin sublocale monoid - by default (simp_all add: commute comm_neutral) + by standard (simp_all add: commute comm_neutral) end @@ -132,7 +132,7 @@ begin sublocale add!: semigroup plus - by default (fact add_assoc) + by standard (fact add_assoc) end @@ -143,7 +143,7 @@ begin sublocale add!: abel_semigroup plus - by default (fact add_commute) + by standard (fact add_commute) declare add.left_commute [algebra_simps, field_simps] @@ -160,7 +160,7 @@ begin sublocale mult!: semigroup times - by default (fact mult_assoc) + by standard (fact mult_assoc) end @@ -171,7 +171,7 @@ begin sublocale mult!: abel_semigroup times - by default (fact mult_commute) + by standard (fact mult_commute) declare mult.left_commute [algebra_simps, field_simps] @@ -189,7 +189,7 @@ begin sublocale add!: monoid plus 0 - by default (fact add_0_left add_0_right)+ + by standard (fact add_0_left add_0_right)+ end @@ -201,10 +201,10 @@ begin subclass monoid_add - by default (simp_all add: add_0 add.commute [of _ 0]) + by standard (simp_all add: add_0 add.commute [of _ 0]) sublocale add!: comm_monoid plus 0 - by default (simp add: ac_simps) + by standard (simp add: ac_simps) end @@ -214,7 +214,7 @@ begin sublocale mult!: monoid times 1 - by default (fact mult_1_left mult_1_right)+ + by standard (fact mult_1_left mult_1_right)+ end @@ -226,10 +226,10 @@ begin subclass monoid_mult - by default (simp_all add: mult_1 mult.commute [of _ 1]) + by standard (simp_all add: mult_1 mult.commute [of _ 1]) sublocale mult!: comm_monoid times 1 - by default (simp add: ac_simps) + by standard (simp add: ac_simps) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Groups_Big.thy --- a/src/HOL/Groups_Big.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Groups_Big.thy Fri Sep 18 16:42:19 2015 +0100 @@ -18,7 +18,7 @@ begin interpretation comp_fun_commute f - by default (simp add: fun_eq_iff left_commute) + by standard (simp add: fun_eq_iff left_commute) interpretation comp?: comp_fun_commute "f \ g" by (fact comp_comp_fun_commute) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOL.thy --- a/src/HOL/HOL.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOL.thy Fri Sep 18 16:42:19 2015 +0100 @@ -1254,10 +1254,10 @@ qed lemma implies_True_equals: "(PROP P \ True) \ Trueprop True" -by default (intro TrueI) + by standard (intro TrueI) lemma False_implies_equals: "(False \ P) \ Trueprop True" -by default simp_all + by standard simp_all (* This is not made a simp rule because it does not improve any proofs but slows some AFP entries down by 5% (cpu time). May 2015 *) @@ -1446,25 +1446,29 @@ declaration \ fn _ => Induct.map_simpset (fn ss => ss addsimprocs - [Simplifier.simproc_global @{theory} "swap_induct_false" - ["induct_false \ PROP P \ PROP Q"] - (fn _ => - (fn _ $ (P as _ $ @{const induct_false}) $ (_ $ Q $ _) => - if P <> Q then SOME Drule.swap_prems_eq else NONE - | _ => NONE)), - Simplifier.simproc_global @{theory} "induct_equal_conj_curry" - ["induct_conj P Q \ PROP R"] - (fn _ => - (fn _ $ (_ $ P) $ _ => - let - fun is_conj (@{const induct_conj} $ P $ Q) = - is_conj P andalso is_conj Q - | is_conj (Const (@{const_name induct_equal}, _) $ _ $ _) = true - | is_conj @{const induct_true} = true - | is_conj @{const induct_false} = true - | is_conj _ = false - in if is_conj P then SOME @{thm induct_conj_curry} else NONE end - | _ => NONE))] + [Simplifier.make_simproc @{context} "swap_induct_false" + {lhss = [@{term "induct_false \ PROP P \ PROP Q"}], + proc = fn _ => fn _ => fn ct => + (case Thm.term_of ct of + _ $ (P as _ $ @{const induct_false}) $ (_ $ Q $ _) => + if P <> Q then SOME Drule.swap_prems_eq else NONE + | _ => NONE), + identifier = []}, + Simplifier.make_simproc @{context} "induct_equal_conj_curry" + {lhss = [@{term "induct_conj P Q \ PROP R"}], + proc = fn _ => fn _ => fn ct => + (case Thm.term_of ct of + _ $ (_ $ P) $ _ => + let + fun is_conj (@{const induct_conj} $ P $ Q) = + is_conj P andalso is_conj Q + | is_conj (Const (@{const_name induct_equal}, _) $ _ $ _) = true + | is_conj @{const induct_true} = true + | is_conj @{const induct_false} = true + | is_conj _ = false + in if is_conj P then SOME @{thm induct_conj_curry} else NONE end + | _ => NONE), + identifier = []}] |> Simplifier.set_mksimps (fn ctxt => Simpdata.mksimps Simpdata.mksimps_pairs ctxt #> map (rewrite_rule ctxt (map Thm.symmetric @{thms induct_rulify_fallback})))) @@ -1731,8 +1735,14 @@ setup \ Code_Preproc.map_pre (fn ctxt => - ctxt addsimprocs [Simplifier.simproc_global_i @{theory} "equal" [@{term HOL.eq}] - (fn _ => fn Const (_, Type ("fun", [Type _, _])) => SOME @{thm eq_equal} | _ => NONE)]) + ctxt addsimprocs + [Simplifier.make_simproc @{context} "equal" + {lhss = [@{term HOL.eq}], + proc = fn _ => fn _ => fn ct => + (case Thm.term_of ct of + Const (_, Type (@{type_name fun}, [Type _, _])) => SOME @{thm eq_equal} + | _ => NONE), + identifier = []}]) \ diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Bifinite.thy --- a/src/HOL/HOLCF/Bifinite.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Bifinite.thy Fri Sep 18 16:42:19 2015 +0100 @@ -162,7 +162,7 @@ qed instance u :: (profinite) bifinite - by default (rule profinite) + by standard (rule profinite) text {* Types @{typ "'a \ 'b"} and @{typ "'a u \! 'b"} are isomorphic. @@ -256,10 +256,10 @@ by (simp add: approx_chain_def cfun_eq_iff finite_deflation_bottom) instance unit :: bifinite - by default (fast intro!: approx_chain_unit) + by standard (fast intro!: approx_chain_unit) instance discr :: (countable) profinite - by default (fast intro!: discr_approx) + by standard (fast intro!: discr_approx) instance lift :: (countable) bifinite proof diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Completion.thy --- a/src/HOL/HOLCF/Completion.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Completion.thy Fri Sep 18 16:42:19 2015 +0100 @@ -116,7 +116,7 @@ assumes type: "type_definition Rep Abs {S. ideal S}" assumes below: "\x y. x \ y \ Rep x \ Rep y" shows "OFCLASS('b, cpo_class)" -by (default, rule exI, erule typedef_ideal_lub [OF type below]) + by standard (rule exI, erule typedef_ideal_lub [OF type below]) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/ConvexPD.thy --- a/src/HOL/HOLCF/ConvexPD.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/ConvexPD.thy Fri Sep 18 16:42:19 2015 +0100 @@ -414,14 +414,14 @@ by (simp add: convex_map_def convex_bind_bind) lemma ep_pair_convex_map: "ep_pair e p \ ep_pair (convex_map\e) (convex_map\p)" -apply default +apply standard apply (induct_tac x rule: convex_pd_induct, simp_all add: ep_pair.e_inverse) apply (induct_tac y rule: convex_pd_induct) apply (simp_all add: ep_pair.e_p_below monofun_cfun) done lemma deflation_convex_map: "deflation d \ deflation (convex_map\d)" -apply default +apply standard apply (induct_tac x rule: convex_pd_induct, simp_all add: deflation.idem) apply (induct_tac x rule: convex_pd_induct) apply (simp_all add: deflation.below monofun_cfun) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Deflation.thy --- a/src/HOL/HOLCF/Deflation.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Deflation.thy Fri Sep 18 16:42:19 2015 +0100 @@ -161,7 +161,7 @@ unfolding finite_deflation_def by simp lemma finite_deflation_bottom: "finite_deflation \" -by default simp_all +by standard simp_all subsection {* Continuous embedding-projection pairs *} @@ -358,7 +358,7 @@ subsection {* Composing ep-pairs *} lemma ep_pair_ID_ID: "ep_pair ID ID" -by default simp_all +by standard simp_all lemma ep_pair_comp: assumes "ep_pair e1 p1" and "ep_pair e2 p2" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Discrete.thy --- a/src/HOL/HOLCF/Discrete.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Discrete.thy Fri Sep 18 16:42:19 2015 +0100 @@ -19,7 +19,7 @@ "(op \ :: 'a discr \ 'a discr \ bool) = (op =)" instance -by default (simp add: below_discr_def) + by standard (simp add: below_discr_def) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Domain.thy --- a/src/HOL/HOLCF/Domain.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Domain.thy Fri Sep 18 16:42:19 2015 +0100 @@ -125,7 +125,7 @@ unfolding prj_beta emb_beta by (simp add: type_definition.Abs_inverse [OF type]) show "ep_pair (emb :: 'a \ udom) prj" - apply default + apply standard apply (simp add: prj_emb) apply (simp add: emb_prj cast.below) done diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Fun_Cpo.thy --- a/src/HOL/HOLCF/Fun_Cpo.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Fun_Cpo.thy Fri Sep 18 16:42:19 2015 +0100 @@ -93,7 +93,7 @@ by (simp add: below_fun_def) instance "fun" :: (type, pcpo) pcpo -by default (fast intro: minimal_fun) +by standard (fast intro: minimal_fun) lemma inst_fun_pcpo: "\ = (\x. \)" by (rule minimal_fun [THEN bottomI, symmetric]) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Library/Defl_Bifinite.thy --- a/src/HOL/HOLCF/Library/Defl_Bifinite.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Library/Defl_Bifinite.thy Fri Sep 18 16:42:19 2015 +0100 @@ -490,7 +490,7 @@ by (fast intro: below_antisym meet_defl_below2 meet_defl_greatest) interpretation meet_defl: semilattice "\a b. meet_defl\a\b" -by default +by standard (fast intro: below_antisym meet_defl_greatest meet_defl_below1 [THEN below_trans] meet_defl_below2 [THEN below_trans])+ diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Library/List_Predomain.thy --- a/src/HOL/HOLCF/Library/List_Predomain.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Library/List_Predomain.thy Fri Sep 18 16:42:19 2015 +0100 @@ -143,7 +143,7 @@ lemma deflation_list_map [domain_deflation]: "deflation d \ deflation (list_map d)" -apply default +apply standard apply (induct_tac x, simp_all add: deflation.idem) apply (induct_tac x, simp_all add: deflation.below) done diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Library/Option_Cpo.thy --- a/src/HOL/HOLCF/Library/Option_Cpo.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Library/Option_Cpo.thy Fri Sep 18 16:42:19 2015 +0100 @@ -269,7 +269,7 @@ lemma deflation_option_map [domain_deflation]: "deflation d \ deflation (option_map d)" -apply default +apply standard apply (induct_tac x, simp_all add: deflation.idem) apply (induct_tac x, simp_all add: deflation.below) done diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Library/Sum_Cpo.thy --- a/src/HOL/HOLCF/Library/Sum_Cpo.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Library/Sum_Cpo.thy Fri Sep 18 16:42:19 2015 +0100 @@ -342,7 +342,7 @@ lemma deflation_map_sum [domain_deflation]: "\deflation d1; deflation d2\ \ deflation (map_sum' d1 d2)" -apply default +apply standard apply (induct_tac x, simp_all add: deflation.idem) apply (induct_tac x, simp_all add: deflation.below) done diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/LowerPD.thy --- a/src/HOL/HOLCF/LowerPD.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/LowerPD.thy Fri Sep 18 16:42:19 2015 +0100 @@ -407,14 +407,14 @@ by (simp add: lower_map_def lower_bind_bind) lemma ep_pair_lower_map: "ep_pair e p \ ep_pair (lower_map\e) (lower_map\p)" -apply default +apply standard apply (induct_tac x rule: lower_pd_induct, simp_all add: ep_pair.e_inverse) apply (induct_tac y rule: lower_pd_induct) apply (simp_all add: ep_pair.e_p_below monofun_cfun del: lower_plus_below_iff) done lemma deflation_lower_map: "deflation d \ deflation (lower_map\d)" -apply default +apply standard apply (induct_tac x rule: lower_pd_induct, simp_all add: deflation.idem) apply (induct_tac x rule: lower_pd_induct) apply (simp_all add: deflation.below monofun_cfun del: lower_plus_below_iff) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Map_Functions.thy --- a/src/HOL/HOLCF/Map_Functions.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Map_Functions.thy Fri Sep 18 16:42:19 2015 +0100 @@ -195,13 +195,13 @@ by (simp add: cfcomp1 u_map_map eta_cfun) lemma ep_pair_u_map: "ep_pair e p \ ep_pair (u_map\e) (u_map\p)" -apply default +apply standard apply (case_tac x, simp, simp add: ep_pair.e_inverse) apply (case_tac y, simp, simp add: ep_pair.e_p_below) done lemma deflation_u_map: "deflation d \ deflation (u_map\d)" -apply default +apply standard apply (case_tac x, simp, simp add: deflation.idem) apply (case_tac x, simp, simp add: deflation.below) done diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Pcpo.thy --- a/src/HOL/HOLCF/Pcpo.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Pcpo.thy Fri Sep 18 16:42:19 2015 +0100 @@ -198,7 +198,7 @@ begin subclass cpo -apply default +apply standard apply (frule chfin) apply (blast intro: lub_finch1) done @@ -213,7 +213,7 @@ begin subclass chfin -apply default +apply standard apply (unfold max_in_chain_def) apply (case_tac "\i. Y i = \") apply simp diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Representable.thy --- a/src/HOL/HOLCF/Representable.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Representable.thy Fri Sep 18 16:42:19 2015 +0100 @@ -119,10 +119,10 @@ qed instance "domain" \ bifinite -by default (rule approx_chain_ep_cast [OF ep_pair_emb_prj cast_DEFL]) +by standard (rule approx_chain_ep_cast [OF ep_pair_emb_prj cast_DEFL]) instance predomain \ profinite -by default (rule approx_chain_ep_cast [OF predomain_ep cast_liftdefl]) +by standard (rule approx_chain_ep_cast [OF predomain_ep cast_liftdefl]) subsection {* Universal domain ep-pairs *} diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Tools/cont_proc.ML --- a/src/HOL/HOLCF/Tools/cont_proc.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Tools/cont_proc.ML Fri Sep 18 16:42:19 2015 +0100 @@ -8,7 +8,7 @@ val cont_thms: term -> thm list val all_cont_thms: term -> thm list val cont_tac: Proof.context -> int -> tactic - val cont_proc: theory -> simproc + val cont_proc: simproc val setup: theory -> theory end @@ -119,15 +119,17 @@ end local - fun solve_cont ctxt t = + fun solve_cont ctxt ct = let + val t = Thm.term_of ct val tr = Thm.instantiate' [] [SOME (Thm.cterm_of ctxt t)] @{thm Eq_TrueI} in Option.map fst (Seq.pull (cont_tac ctxt 1 tr)) end in - fun cont_proc thy = - Simplifier.simproc_global thy "cont_proc" ["cont f"] solve_cont + val cont_proc = + Simplifier.make_simproc @{context} "cont_proc" + {lhss = [@{term "cont f"}], proc = K solve_cont, identifier = []} end -fun setup thy = map_theory_simpset (fn ctxt => ctxt addsimprocs [cont_proc thy]) thy +val setup = map_theory_simpset (fn ctxt => ctxt addsimprocs [cont_proc]) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Tools/cpodef.ML --- a/src/HOL/HOLCF/Tools/cpodef.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Tools/cpodef.ML Fri Sep 18 16:42:19 2015 +0100 @@ -15,27 +15,27 @@ Rep_bottom_iff: thm, Abs_bottom_iff: thm } val add_podef: binding * (string * sort) list * mixfix -> - term -> (binding * binding) option -> (Proof.context -> tactic) -> theory -> + term -> Typedef.bindings option -> (Proof.context -> tactic) -> theory -> (Typedef.info * thm) * theory val add_cpodef: binding * (string * sort) list * mixfix -> - term -> (binding * binding) option -> (Proof.context -> tactic) * (Proof.context -> tactic) -> + term -> Typedef.bindings option -> (Proof.context -> tactic) * (Proof.context -> tactic) -> theory -> (Typedef.info * cpo_info) * theory val add_pcpodef: binding * (string * sort) list * mixfix -> - term -> (binding * binding) option -> (Proof.context -> tactic) * (Proof.context -> tactic) -> + term -> Typedef.bindings option -> (Proof.context -> tactic) * (Proof.context -> tactic) -> theory -> (Typedef.info * cpo_info * pcpo_info) * theory val cpodef_proof: (binding * (string * sort) list * mixfix) * term - * (binding * binding) option -> theory -> Proof.state + * Typedef.bindings option -> theory -> Proof.state val cpodef_proof_cmd: (binding * (string * string option) list * mixfix) * string - * (binding * binding) option -> theory -> Proof.state + * Typedef.bindings option -> theory -> Proof.state val pcpodef_proof: (binding * (string * sort) list * mixfix) * term - * (binding * binding) option -> theory -> Proof.state + * Typedef.bindings option -> theory -> Proof.state val pcpodef_proof_cmd: (binding * (string * string option) list * mixfix) * string - * (binding * binding) option -> theory -> Proof.state + * Typedef.bindings option -> theory -> Proof.state end structure Cpodef : CPODEF = @@ -63,13 +63,14 @@ fun prove_cpo (name: binding) (newT: typ) - (Rep_name: binding, Abs_name: binding) + opt_bindings (type_definition: thm) (* type_definition Rep Abs A *) (below_def: thm) (* op << == %x y. Rep x << Rep y *) (admissible: thm) (* adm (%x. x : set) *) (thy: theory) = let + val {Rep_name, Abs_name, ...} = Typedef.make_bindings name opt_bindings; val cpo_thms = map (Thm.transfer thy) [type_definition, below_def, admissible] val (full_tname, Ts) = dest_Type newT val lhs_sorts = map (snd o dest_TFree) Ts @@ -102,13 +103,14 @@ fun prove_pcpo (name: binding) (newT: typ) - (Rep_name: binding, Abs_name: binding) + opt_bindings (type_definition: thm) (* type_definition Rep Abs A *) (below_def: thm) (* op << == %x y. Rep x << Rep y *) (bottom_mem: thm) (* bottom : set *) (thy: theory) = let + val {Rep_name, Abs_name, ...} = Typedef.make_bindings name opt_bindings; val pcpo_thms = map (Thm.transfer thy) [type_definition, below_def, bottom_mem] val (full_tname, Ts) = dest_Type newT val lhs_sorts = map (snd o dest_TFree) Ts @@ -138,7 +140,7 @@ (* prepare_cpodef *) -fun prepare prep_term name (tname, raw_args, _) raw_set opt_morphs thy = +fun prepare prep_term name (tname, raw_args, _) raw_set thy = let (*rhs*) val tmp_ctxt = @@ -155,18 +157,15 @@ val lhs_tfrees = map (Proof_Context.check_tfree tmp_ctxt') raw_args val full_tname = Sign.full_name thy tname val newT = Type (full_tname, map TFree lhs_tfrees) - - val morphs = opt_morphs - |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name) in - (newT, oldT, set, morphs) + (newT, oldT, set) end -fun add_podef typ set opt_morphs tac thy = +fun add_podef typ set opt_bindings tac thy = let val name = #1 typ val ((full_tname, info as ({Rep_name, ...}, {type_definition, ...})), thy) = thy - |> Typedef.add_typedef_global false typ set opt_morphs tac + |> Typedef.add_typedef_global typ set opt_bindings tac val oldT = #rep_type (#1 info) val newT = #abs_type (#1 info) val lhs_tfrees = map dest_TFree (snd (dest_Type newT)) @@ -189,13 +188,12 @@ (prep_term: Proof.context -> 'a -> term) (typ: binding * (string * sort) list * mixfix) (raw_set: 'a) - (opt_morphs: (binding * binding) option) + opt_bindings (thy: theory) : term * term * (thm -> thm -> theory -> (Typedef.info * cpo_info) * theory) = let val name = #1 typ - val (newT, oldT, set, morphs) = - prepare prep_term name typ raw_set opt_morphs thy + val (newT, oldT, set) = prepare prep_term name typ raw_set thy val goal_nonempty = HOLogic.mk_Trueprop (HOLogic.mk_exists ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set))) @@ -205,9 +203,9 @@ fun cpodef_result nonempty admissible thy = let val ((info as (_, {type_definition, ...}), below_def), thy) = thy - |> add_podef typ set opt_morphs (fn ctxt => resolve_tac ctxt [nonempty] 1) + |> add_podef typ set opt_bindings (fn ctxt => resolve_tac ctxt [nonempty] 1) val (cpo_info, thy) = thy - |> prove_cpo name newT morphs type_definition below_def admissible + |> prove_cpo name newT opt_bindings type_definition below_def admissible in ((info, cpo_info), thy) end @@ -221,13 +219,12 @@ (prep_term: Proof.context -> 'a -> term) (typ: binding * (string * sort) list * mixfix) (raw_set: 'a) - (opt_morphs: (binding * binding) option) + opt_bindings (thy: theory) : term * term * (thm -> thm -> theory -> (Typedef.info * cpo_info * pcpo_info) * theory) = let val name = #1 typ - val (newT, oldT, set, morphs) = - prepare prep_term name typ raw_set opt_morphs thy + val (newT, oldT, set) = prepare prep_term name typ raw_set thy val goal_bottom_mem = HOLogic.mk_Trueprop (HOLogic.mk_mem (Const (@{const_name bottom}, oldT), set)) @@ -239,11 +236,11 @@ let fun tac ctxt = resolve_tac ctxt [exI] 1 THEN resolve_tac ctxt [bottom_mem] 1 val ((info as (_, {type_definition, ...}), below_def), thy) = thy - |> add_podef typ set opt_morphs tac + |> add_podef typ set opt_bindings tac val (cpo_info, thy) = thy - |> prove_cpo name newT morphs type_definition below_def admissible + |> prove_cpo name newT opt_bindings type_definition below_def admissible val (pcpo_info, thy) = thy - |> prove_pcpo name newT morphs type_definition below_def bottom_mem + |> prove_pcpo name newT opt_bindings type_definition below_def bottom_mem in ((info, cpo_info, pcpo_info), thy) end @@ -256,10 +253,10 @@ (* tactic interface *) -fun add_cpodef typ set opt_morphs (tac1, tac2) thy = +fun add_cpodef typ set opt_bindings (tac1, tac2) thy = let val (goal1, goal2, cpodef_result) = - prepare_cpodef Syntax.check_term typ set opt_morphs thy + prepare_cpodef Syntax.check_term typ set opt_bindings thy val thm1 = Goal.prove_global thy [] [] goal1 (tac1 o #context) handle ERROR msg => cat_error msg ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set)) @@ -268,10 +265,10 @@ ("Failed to prove admissibility of " ^ quote (Syntax.string_of_term_global thy set)) in cpodef_result thm1 thm2 thy end -fun add_pcpodef typ set opt_morphs (tac1, tac2) thy = +fun add_pcpodef typ set opt_bindings (tac1, tac2) thy = let val (goal1, goal2, pcpodef_result) = - prepare_pcpodef Syntax.check_term typ set opt_morphs thy + prepare_pcpodef Syntax.check_term typ set opt_bindings thy val thm1 = Goal.prove_global thy [] [] goal1 (tac1 o #context) handle ERROR msg => cat_error msg ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set)) @@ -286,23 +283,23 @@ local fun gen_cpodef_proof prep_term prep_constraint - ((b, raw_args, mx), set, opt_morphs) thy = + ((b, raw_args, mx), set, opt_bindings) thy = let val ctxt = Proof_Context.init_global thy val args = map (apsnd (prep_constraint ctxt)) raw_args val (goal1, goal2, make_result) = - prepare_cpodef prep_term (b, args, mx) set opt_morphs thy + prepare_cpodef prep_term (b, args, mx) set opt_bindings thy fun after_qed [[th1, th2]] = Proof_Context.background_theory (snd o make_result th1 th2) | after_qed _ = raise Fail "cpodef_proof" in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end fun gen_pcpodef_proof prep_term prep_constraint - ((b, raw_args, mx), set, opt_morphs) thy = + ((b, raw_args, mx), set, opt_bindings) thy = let val ctxt = Proof_Context.init_global thy val args = map (apsnd (prep_constraint ctxt)) raw_args val (goal1, goal2, make_result) = - prepare_pcpodef prep_term (b, args, mx) set opt_morphs thy + prepare_pcpodef prep_term (b, args, mx) set opt_bindings thy fun after_qed [[th1, th2]] = Proof_Context.background_theory (snd o make_result th1 th2) | after_qed _ = raise Fail "pcpodef_proof" in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end @@ -321,24 +318,30 @@ (** outer syntax **) -val typedef_proof_decl = +local + +fun cpodef pcpo = (Parse.type_args_constrained -- Parse.binding) -- Parse.opt_mixfix -- (@{keyword "="} |-- Parse.term) -- Scan.option (@{keyword "morphisms"} |-- Parse.!!! (Parse.binding -- Parse.binding)) + >> (fn ((((args, t), mx), A), morphs) => + Toplevel.theory_to_proof + ((if pcpo then pcpodef_proof_cmd else cpodef_proof_cmd) + ((t, args, mx), A, SOME (Typedef.make_morphisms t morphs)))) -fun mk_pcpodef_proof pcpo ((((args, t), mx), A), morphs) = - (if pcpo then pcpodef_proof_cmd else cpodef_proof_cmd) - ((t, args, mx), A, morphs) +in val _ = Outer_Syntax.command @{command_keyword pcpodef} "HOLCF type definition (requires admissibility proof)" - (typedef_proof_decl >> (Toplevel.theory_to_proof o mk_pcpodef_proof true)) + (cpodef true) val _ = Outer_Syntax.command @{command_keyword cpodef} "HOLCF type definition (requires admissibility proof)" - (typedef_proof_decl >> (Toplevel.theory_to_proof o mk_pcpodef_proof false)) + (cpodef false) end + +end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Tools/domaindef.ML --- a/src/HOL/HOLCF/Tools/domaindef.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Tools/domaindef.ML Fri Sep 18 16:42:19 2015 +0100 @@ -18,11 +18,11 @@ } val add_domaindef: binding * (string * sort) list * mixfix -> - term -> (binding * binding) option -> theory -> + term -> Typedef.bindings option -> theory -> (Typedef.info * Cpodef.cpo_info * Cpodef.pcpo_info * rep_info) * theory val domaindef_cmd: (binding * (string * string option) list * mixfix) * string - * (binding * binding) option -> theory -> theory + * Typedef.bindings option -> theory -> theory end structure Domaindef : DOMAINDEF = @@ -80,7 +80,7 @@ (prep_term: Proof.context -> 'a -> term) (typ as (tname, raw_args, _) : binding * (string * sort) list * mixfix) (raw_defl: 'a) - (opt_morphs: (binding * binding) option) + (opt_bindings: Typedef.bindings option) (thy: theory) : (Typedef.info * Cpodef.cpo_info * Cpodef.pcpo_info * rep_info) * theory = let @@ -100,10 +100,6 @@ val full_tname = Sign.full_name thy tname val newT = Type (full_tname, map TFree lhs_tfrees) - (*morphisms*) - val morphs = opt_morphs - |> the_default (Binding.prefix_name "Rep_" tname, Binding.prefix_name "Abs_" tname) - (*set*) val set = @{term "defl_set :: udom defl => udom set"} $ defl @@ -111,7 +107,7 @@ fun tac1 ctxt = resolve_tac ctxt @{thms defl_set_bottom} 1 fun tac2 ctxt = resolve_tac ctxt @{thms adm_defl_set} 1 val ((info, cpo_info, pcpo_info), thy) = thy - |> Cpodef.add_pcpodef typ set (SOME morphs) (tac1, tac2) + |> Cpodef.add_pcpodef typ set opt_bindings (tac1, tac2) (*definitions*) val Rep_const = Const (#Rep_name (#1 info), newT --> udomT) @@ -187,8 +183,8 @@ handle ERROR msg => cat_error msg ("The error(s) above occurred in domaindef " ^ Binding.print tname) -fun add_domaindef typ defl opt_morphs thy = - gen_add_domaindef Syntax.check_term typ defl opt_morphs thy +fun add_domaindef typ defl opt_bindings thy = + gen_add_domaindef Syntax.check_term typ defl opt_bindings thy fun domaindef_cmd ((b, raw_args, mx), A, morphs) thy = let @@ -199,17 +195,13 @@ (** outer syntax **) -val domaindef_decl = - (Parse.type_args_constrained -- Parse.binding) -- - Parse.opt_mixfix -- (@{keyword "="} |-- Parse.term) -- - Scan.option - (@{keyword "morphisms"} |-- Parse.!!! (Parse.binding -- Parse.binding)) - -fun mk_domaindef (((((args, t)), mx), A), morphs) = - domaindef_cmd ((t, args, mx), A, morphs) - val _ = Outer_Syntax.command @{command_keyword domaindef} "HOLCF definition of domains from deflations" - (domaindef_decl >> (Toplevel.theory o mk_domaindef)) + ((Parse.type_args_constrained -- Parse.binding) -- + Parse.opt_mixfix -- (@{keyword "="} |-- Parse.term) -- + Scan.option + (@{keyword "morphisms"} |-- Parse.!!! (Parse.binding -- Parse.binding)) >> + (fn (((((args, t)), mx), A), morphs) => + Toplevel.theory (domaindef_cmd ((t, args, mx), A, SOME (Typedef.make_morphisms t morphs))))); end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/Universal.thy --- a/src/HOL/HOLCF/Universal.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/Universal.thy Fri Sep 18 16:42:19 2015 +0100 @@ -98,7 +98,7 @@ done interpretation udom: preorder ubasis_le -apply default +apply standard apply (rule ubasis_le_refl) apply (erule (1) ubasis_le_trans) done @@ -879,7 +879,7 @@ done lemma ep_pair_udom: "ep_pair udom_emb udom_prj" - apply default + apply standard apply (rule compact_basis.principal_induct, simp) apply (simp add: udom_emb_principal udom_prj_principal) apply (simp add: basis_prj_basis_emb) @@ -986,7 +986,7 @@ qed instance udom :: bifinite - by default (fast intro: udom_approx) + by standard (fast intro: udom_approx) hide_const (open) node diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/HOLCF/UpperPD.thy --- a/src/HOL/HOLCF/UpperPD.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/HOLCF/UpperPD.thy Fri Sep 18 16:42:19 2015 +0100 @@ -400,14 +400,14 @@ by (simp add: upper_map_def upper_bind_bind) lemma ep_pair_upper_map: "ep_pair e p \ ep_pair (upper_map\e) (upper_map\p)" -apply default +apply standard apply (induct_tac x rule: upper_pd_induct, simp_all add: ep_pair.e_inverse) apply (induct_tac y rule: upper_pd_induct) apply (simp_all add: ep_pair.e_p_below monofun_cfun del: upper_below_plus_iff) done lemma deflation_upper_map: "deflation d \ deflation (upper_map\d)" -apply default +apply standard apply (induct_tac x rule: upper_pd_induct, simp_all add: deflation.idem) apply (induct_tac x rule: upper_pd_induct) apply (simp_all add: deflation.below monofun_cfun del: upper_below_plus_iff) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Hoare/hoare_syntax.ML --- a/src/HOL/Hoare/hoare_syntax.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Hoare/hoare_syntax.ML Fri Sep 18 16:42:19 2015 +0100 @@ -28,7 +28,7 @@ fun mk_abstuple [x] body = Syntax_Trans.abs_tr [x, body] | mk_abstuple (x :: xs) body = - Syntax.const @{const_syntax case_prod} $ Syntax_Trans.abs_tr [x, mk_abstuple xs body]; + Syntax.const @{const_syntax uncurry} $ Syntax_Trans.abs_tr [x, mk_abstuple xs body]; fun mk_fbody x e [y] = if eq_idt (x, y) then e else y | mk_fbody x e (y :: xs) = @@ -82,21 +82,21 @@ local fun dest_abstuple - (Const (@{const_syntax case_prod}, _) $ Abs (v, _, body)) = + (Const (@{const_syntax uncurry}, _) $ Abs (v, _, body)) = subst_bound (Syntax.free v, dest_abstuple body) | dest_abstuple (Abs (v,_, body)) = subst_bound (Syntax.free v, body) | dest_abstuple tm = tm; -fun abs2list (Const (@{const_syntax case_prod}, _) $ Abs (x, T, t)) = Free (x, T) :: abs2list t +fun abs2list (Const (@{const_syntax uncurry}, _) $ Abs (x, T, t)) = Free (x, T) :: abs2list t | abs2list (Abs (x, T, _)) = [Free (x, T)] | abs2list _ = []; -fun mk_ts (Const (@{const_syntax case_prod}, _) $ Abs (_, _, t)) = mk_ts t +fun mk_ts (Const (@{const_syntax uncurry}, _) $ Abs (_, _, t)) = mk_ts t | mk_ts (Abs (_, _, t)) = mk_ts t | mk_ts (Const (@{const_syntax Pair}, _) $ a $ b) = a :: mk_ts b | mk_ts t = [t]; -fun mk_vts (Const (@{const_syntax case_prod},_) $ Abs (x, _, t)) = +fun mk_vts (Const (@{const_syntax uncurry},_) $ Abs (x, _, t)) = (Syntax.free x :: abs2list t, mk_ts t) | mk_vts (Abs (x, _, t)) = ([Syntax.free x], [t]) | mk_vts _ = raise Match; @@ -106,7 +106,7 @@ if t = Bound i then find_ch vts (i - 1) xs else (true, (v, subst_bounds (xs, t))); -fun is_f (Const (@{const_syntax case_prod}, _) $ Abs _) = true +fun is_f (Const (@{const_syntax uncurry}, _) $ Abs _) = true | is_f (Abs _) = true | is_f _ = false; diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Hoare/hoare_tac.ML --- a/src/HOL/Hoare/hoare_tac.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Hoare/hoare_tac.ML Fri Sep 18 16:42:19 2015 +0100 @@ -26,7 +26,7 @@ local (** maps (%x1 ... xn. t) to [x1,...,xn] **) -fun abs2list (Const (@{const_name case_prod}, _) $ Abs (x, T, t)) = Free (x, T) :: abs2list t +fun abs2list (Const (@{const_name uncurry}, _) $ Abs (x, T, t)) = Free (x, T) :: abs2list t | abs2list (Abs (x, T, _)) = [Free (x, T)] | abs2list _ = []; @@ -47,7 +47,7 @@ Abs (_, T, _) => T | Const (_, Type (_, [_, Type (_, [T, _])])) $ _ => T); in - Const (@{const_name case_prod}, + Const (@{const_name uncurry}, (T --> T2 --> HOLogic.boolT) --> HOLogic.mk_prodT (T, T2) --> HOLogic.boolT) $ absfree (x, T) z end; diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/IMP/Abs_Int0.thy --- a/src/HOL/IMP/Abs_Int0.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/IMP/Abs_Int0.thy Fri Sep 18 16:42:19 2015 +0100 @@ -31,14 +31,15 @@ lemma Some_le[simp]: "(Some x \ u) = (\y. u = Some y \ x \ y)" by (cases u) auto -instance proof - case goal1 show ?case by(rule less_option_def) +instance +proof (standard, goal_cases) + case 1 show ?case by(rule less_option_def) next - case goal2 show ?case by(cases x, simp_all) + case (2 x) show ?case by(cases x, simp_all) next - case goal3 thus ?case by(cases z, simp, cases y, simp, cases x, auto) + case (3 x y z) thus ?case by(cases z, simp, cases y, simp, cases x, auto) next - case goal4 thus ?case by(cases y, simp, cases x, auto) + case (4 x y) thus ?case by(cases y, simp, cases x, auto) qed end @@ -63,14 +64,15 @@ definition top_option where "\ = Some \" -instance proof - case goal4 show ?case by(cases a, simp_all add: top_option_def) +instance +proof (standard, goal_cases) + case (4 a) show ?case by(cases a, simp_all add: top_option_def) next - case goal1 thus ?case by(cases x, simp, cases y, simp_all) + case (1 x y) thus ?case by(cases x, simp, cases y, simp_all) next - case goal2 thus ?case by(cases y, simp, cases x, simp_all) + case (2 x y) thus ?case by(cases y, simp, cases x, simp_all) next - case goal3 thus ?case by(cases z, simp, cases y, simp, cases x, simp_all) + case (3 x y z) thus ?case by(cases z, simp, cases y, simp, cases x, simp_all) qed end @@ -85,8 +87,8 @@ "\ = None" instance -proof - case goal1 thus ?case by(auto simp: bot_option_def) +proof (standard, goal_cases) + case 1 thus ?case by(auto simp: bot_option_def) qed end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/IMP/Abs_Int1_const.thy --- a/src/HOL/IMP/Abs_Int1_const.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/IMP/Abs_Int1_const.thy Fri Sep 18 16:42:19 2015 +0100 @@ -32,22 +32,22 @@ definition "\ = Any" instance -proof - case goal1 thus ?case by (rule less_const_def) +proof (standard, goal_cases) + case 1 thus ?case by (rule less_const_def) next - case goal2 show ?case by (cases x) simp_all + case (2 x) show ?case by (cases x) simp_all next - case goal3 thus ?case by(cases z, cases y, cases x, simp_all) + case (3 x y z) thus ?case by(cases z, cases y, cases x, simp_all) next - case goal4 thus ?case by(cases x, cases y, simp_all, cases y, simp_all) + case (4 x y) thus ?case by(cases x, cases y, simp_all, cases y, simp_all) next - case goal6 thus ?case by(cases x, cases y, simp_all) + case (6 x y) thus ?case by(cases x, cases y, simp_all) next - case goal5 thus ?case by(cases y, cases x, simp_all) + case (5 x y) thus ?case by(cases y, cases x, simp_all) next - case goal7 thus ?case by(cases z, cases y, cases x, simp_all) + case (7 x y z) thus ?case by(cases z, cases y, cases x, simp_all) next - case goal8 thus ?case by(simp add: top_const_def) + case 8 thus ?case by(simp add: top_const_def) qed end @@ -55,16 +55,15 @@ permanent_interpretation Val_semilattice where \ = \_const and num' = Const and plus' = plus_const -proof - case goal1 thus ?case +proof (standard, goal_cases) + case (1 a b) thus ?case by(cases a, cases b, simp, simp, cases b, simp, simp) next - case goal2 show ?case by(simp add: top_const_def) + case 2 show ?case by(simp add: top_const_def) next - case goal3 show ?case by simp + case 3 show ?case by simp next - case goal4 thus ?case - by(auto simp: plus_const_cases split: const.split) + case 4 thus ?case by(auto simp: plus_const_cases split: const.split) qed permanent_interpretation Abs_Int @@ -123,9 +122,8 @@ permanent_interpretation Abs_Int_mono where \ = \_const and num' = Const and plus' = plus_const -proof - case goal1 thus ?case - by(auto simp: plus_const_cases split: const.split) +proof (standard, goal_cases) + case 1 thus ?case by(auto simp: plus_const_cases split: const.split) qed text{* Termination: *} @@ -136,10 +134,10 @@ permanent_interpretation Abs_Int_measure where \ = \_const and num' = Const and plus' = plus_const and m = m_const and h = "1" -proof - case goal1 thus ?case by(auto simp: m_const_def split: const.splits) +proof (standard, goal_cases) + case 1 thus ?case by(auto simp: m_const_def split: const.splits) next - case goal2 thus ?case by(auto simp: m_const_def less_const_def split: const.splits) + case 2 thus ?case by(auto simp: m_const_def less_const_def split: const.splits) qed thm AI_Some_measure diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/IMP/Abs_Int1_parity.thy --- a/src/HOL/IMP/Abs_Int1_parity.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/IMP/Abs_Int1_parity.thy Fri Sep 18 16:42:19 2015 +0100 @@ -58,21 +58,21 @@ definition top_parity where "\ = Either" -text{* Now the instance proof. This time we take a lazy shortcut: we do not -write out the proof obligations but use the @{text goali} primitive to refer -to the assumptions of subgoal i and @{text "case?"} to refer to the -conclusion of subgoal i. The class axioms are presented in the same order as -in the class definition. Warning: this is brittle! *} +text{* Now the instance proof. This time we take a shortcut with the help of +proof method @{text goal_cases}: it creates cases 1 ... n for the subgoals +1 ... n; in case i, i is also the name of the assumptions of subgoal i and +@{text "case?"} refers to the conclusion of subgoal i. +The class axioms are presented in the same order as in the class definition. *} instance -proof - case goal1 (*sup1*) show ?case by(auto simp: less_eq_parity_def sup_parity_def) +proof (standard, goal_cases) + case 1 (*sup1*) show ?case by(auto simp: less_eq_parity_def sup_parity_def) next - case goal2 (*sup2*) show ?case by(auto simp: less_eq_parity_def sup_parity_def) + case 2 (*sup2*) show ?case by(auto simp: less_eq_parity_def sup_parity_def) next - case goal3 (*sup least*) thus ?case by(auto simp: less_eq_parity_def sup_parity_def) + case 3 (*sup least*) thus ?case by(auto simp: less_eq_parity_def sup_parity_def) next - case goal4 (*top*) show ?case by(auto simp: less_eq_parity_def top_parity_def) + case 4 (*top*) show ?case by(auto simp: less_eq_parity_def top_parity_def) qed end @@ -104,21 +104,22 @@ permanent_interpretation Val_semilattice where \ = \_parity and num' = num_parity and plus' = plus_parity -proof txt{* of the locale axioms *} - fix a b :: parity - assume "a \ b" thus "\_parity a \ \_parity b" - by(auto simp: less_eq_parity_def) -next txt{* The rest in the lazy, implicit way *} - case goal2 show ?case by(auto simp: top_parity_def) +proof (standard, goal_cases) txt{* subgoals are the locale axioms *} + case 1 thus ?case by(auto simp: less_eq_parity_def) next - case goal3 show ?case by auto + case 2 show ?case by(auto simp: top_parity_def) next - txt{* Warning: this subproof refers to the names @{text a1} and @{text a2} - from the statement of the axiom. *} - case goal4 thus ?case + case 3 show ?case by auto +next + case (4 _ a1 _ a2) thus ?case by (induction a1 a2 rule: plus_parity.induct) (auto simp add:mod_add_eq) qed +text{* In case 4 we needed to refer to particular variables. +Writing (i x y z) fixes the names of the variables in case i to be x, y and z +in the left-to-right order in which the variables occur in the subgoal. +Underscores are anonymous placeholders for variable names we don't care to fix. *} + text{* Instantiating the abstract interpretation locale requires no more proofs (they happened in the instatiation above) but delivers the instantiated abstract interpreter which we call @{text AI_parity}: *} @@ -156,8 +157,8 @@ permanent_interpretation Abs_Int_mono where \ = \_parity and num' = num_parity and plus' = plus_parity -proof - case goal1 thus ?case +proof (standard, goal_cases) + case (1 _ a1 _ a2) thus ?case by(induction a1 a2 rule: plus_parity.induct) (auto simp add:less_eq_parity_def) qed @@ -168,10 +169,10 @@ permanent_interpretation Abs_Int_measure where \ = \_parity and num' = num_parity and plus' = plus_parity and m = m_parity and h = "1" -proof - case goal1 thus ?case by(auto simp add: m_parity_def less_eq_parity_def) +proof (standard, goal_cases) + case 1 thus ?case by(auto simp add: m_parity_def less_eq_parity_def) next - case goal2 thus ?case by(auto simp add: m_parity_def less_eq_parity_def less_parity_def) + case 2 thus ?case by(auto simp add: m_parity_def less_eq_parity_def less_parity_def) qed thm AI_Some_measure diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/IMP/Abs_Int2.thy --- a/src/HOL/IMP/Abs_Int2.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/IMP/Abs_Int2.thy Fri Sep 18 16:42:19 2015 +0100 @@ -11,14 +11,14 @@ definition "less_prod p1 p2 = (p1 \ p2 \ \ p2 \ (p1::'a*'b))" instance -proof - case goal1 show ?case by(rule less_prod_def) +proof (standard, goal_cases) + case 1 show ?case by(rule less_prod_def) next - case goal2 show ?case by(simp add: less_eq_prod_def) + case 2 show ?case by(simp add: less_eq_prod_def) next - case goal3 thus ?case unfolding less_eq_prod_def by(metis order_trans) + case 3 thus ?case unfolding less_eq_prod_def by(metis order_trans) next - case goal4 thus ?case by(simp add: less_eq_prod_def)(metis eq_iff surjective_pairing) + case 4 thus ?case by(simp add: less_eq_prod_def)(metis eq_iff surjective_pairing) qed end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/IMP/Abs_Int2_ivl.thy --- a/src/HOL/IMP/Abs_Int2_ivl.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/IMP/Abs_Int2_ivl.thy Fri Sep 18 16:42:19 2015 +0100 @@ -104,22 +104,22 @@ by(auto simp add: is_empty_rep_def max_def min_def split: if_splits) instance -proof - case goal1 show ?case by (rule less_ivl_def) +proof (standard, goal_cases) + case 1 show ?case by (rule less_ivl_def) next - case goal2 show ?case by transfer (simp add: le_rep_def split: prod.splits) + case 2 show ?case by transfer (simp add: le_rep_def split: prod.splits) next - case goal3 thus ?case by transfer (auto simp: le_rep_def split: if_splits) + case 3 thus ?case by transfer (auto simp: le_rep_def split: if_splits) next - case goal4 thus ?case by transfer (auto simp: le_rep_def eq_ivl_iff split: if_splits) + case 4 thus ?case by transfer (auto simp: le_rep_def eq_ivl_iff split: if_splits) next - case goal5 thus ?case by transfer (auto simp add: le_rep_def sup_rep_def is_empty_min_max) + case 5 thus ?case by transfer (auto simp add: le_rep_def sup_rep_def is_empty_min_max) next - case goal6 thus ?case by transfer (auto simp add: le_rep_def sup_rep_def is_empty_min_max) + case 6 thus ?case by transfer (auto simp add: le_rep_def sup_rep_def is_empty_min_max) next - case goal7 thus ?case by transfer (auto simp add: le_rep_def sup_rep_def) + case 7 thus ?case by transfer (auto simp add: le_rep_def sup_rep_def) next - case goal8 show ?case by transfer (simp add: le_rep_def is_empty_rep_def) + case 8 show ?case by transfer (simp add: le_rep_def is_empty_rep_def) qed end @@ -132,8 +132,8 @@ "equal_ivl i1 (i2::ivl) = (i1\i2 \ i2 \ i1)" instance -proof - case goal1 show ?case by(simp add: equal_ivl_def eq_iff) +proof (standard, goal_cases) + case 1 show ?case by(simp add: equal_ivl_def eq_iff) qed end @@ -161,14 +161,14 @@ definition "\ = empty_ivl" instance -proof - case goal1 thus ?case by (simp add: \_inf le_ivl_iff_subset) +proof (standard, goal_cases) + case 1 thus ?case by (simp add: \_inf le_ivl_iff_subset) next - case goal2 thus ?case by (simp add: \_inf le_ivl_iff_subset) + case 2 thus ?case by (simp add: \_inf le_ivl_iff_subset) next - case goal3 thus ?case by (simp add: \_inf le_ivl_iff_subset) + case 3 thus ?case by (simp add: \_inf le_ivl_iff_subset) next - case goal4 show ?case + case 4 show ?case unfolding bot_ivl_def by transfer (auto simp: le_iff_subset) qed @@ -304,14 +304,14 @@ permanent_interpretation Val_semilattice where \ = \_ivl and num' = num_ivl and plus' = "op +" -proof - case goal1 thus ?case by transfer (simp add: le_iff_subset) +proof (standard, goal_cases) + case 1 thus ?case by transfer (simp add: le_iff_subset) next - case goal2 show ?case by transfer (simp add: \_rep_def) + case 2 show ?case by transfer (simp add: \_rep_def) next - case goal3 show ?case by transfer (simp add: \_rep_def) + case 3 show ?case by transfer (simp add: \_rep_def) next - case goal4 thus ?case + case 4 thus ?case apply transfer apply(auto simp: \_rep_def plus_rep_def add_mono_le_Fin add_mono_Fin_le) by(auto simp: empty_rep_def is_empty_rep_def) @@ -321,26 +321,26 @@ permanent_interpretation Val_lattice_gamma where \ = \_ivl and num' = num_ivl and plus' = "op +" defining aval_ivl = aval' -proof - case goal1 show ?case by(simp add: \_inf) +proof (standard, goal_cases) + case 1 show ?case by(simp add: \_inf) next - case goal2 show ?case unfolding bot_ivl_def by transfer simp + case 2 show ?case unfolding bot_ivl_def by transfer simp qed permanent_interpretation Val_inv where \ = \_ivl and num' = num_ivl and plus' = "op +" and test_num' = in_ivl and inv_plus' = inv_plus_ivl and inv_less' = inv_less_ivl -proof - case goal1 thus ?case by transfer (auto simp: \_rep_def) +proof (standard, goal_cases) + case 1 thus ?case by transfer (auto simp: \_rep_def) next - case goal2 thus ?case + case (2 _ _ _ _ _ i1 i2) thus ?case unfolding inv_plus_ivl_def minus_ivl_def apply(clarsimp simp add: \_inf) using gamma_plus'[of "i1+i2" _ "-i1"] gamma_plus'[of "i1+i2" _ "-i2"] by(simp add: \_uminus) next - case goal3 thus ?case + case (3 i1 i2) thus ?case unfolding inv_less_ivl_def minus_ivl_def one_extended_def apply(clarsimp simp add: \_inf split: if_splits) using gamma_plus'[of "i1+1" _ "-1"] gamma_plus'[of "i2 - 1" _ "1"] @@ -388,14 +388,14 @@ where \ = \_ivl and num' = num_ivl and plus' = "op +" and test_num' = in_ivl and inv_plus' = inv_plus_ivl and inv_less' = inv_less_ivl -proof - case goal1 thus ?case by (rule mono_plus_ivl) +proof (standard, goal_cases) + case 1 thus ?case by (rule mono_plus_ivl) next - case goal2 thus ?case + case 2 thus ?case unfolding inv_plus_ivl_def minus_ivl_def less_eq_prod_def by (auto simp: le_infI1 le_infI2 mono_plus_ivl mono_minus_ivl) next - case goal3 thus ?case + case 3 thus ?case unfolding less_eq_prod_def inv_less_ivl_def minus_ivl_def by (auto simp: le_infI1 le_infI2 mono_plus_ivl mono_above mono_below) qed diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/IMP/Abs_Int3.thy --- a/src/HOL/IMP/Abs_Int3.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/IMP/Abs_Int3.thy Fri Sep 18 16:42:19 2015 +0100 @@ -63,18 +63,14 @@ by(auto simp: eq_st_def) instance -proof - case goal1 thus ?case - by transfer (simp add: less_eq_st_rep_iff widen1) +proof (standard, goal_cases) + case 1 thus ?case by transfer (simp add: less_eq_st_rep_iff widen1) next - case goal2 thus ?case - by transfer (simp add: less_eq_st_rep_iff widen2) + case 2 thus ?case by transfer (simp add: less_eq_st_rep_iff widen2) next - case goal3 thus ?case - by transfer (simp add: less_eq_st_rep_iff narrow1) + case 3 thus ?case by transfer (simp add: less_eq_st_rep_iff narrow1) next - case goal4 thus ?case - by transfer (simp add: less_eq_st_rep_iff narrow2) + case 4 thus ?case by transfer (simp add: less_eq_st_rep_iff narrow2) qed end @@ -94,17 +90,17 @@ "(Some x) \ (Some y) = Some(x \ y)" instance -proof - case goal1 thus ?case +proof (standard, goal_cases) + case (1 x y) thus ?case by(induct x y rule: widen_option.induct)(simp_all add: widen1) next - case goal2 thus ?case + case (2 x y) thus ?case by(induct x y rule: widen_option.induct)(simp_all add: widen2) next - case goal3 thus ?case + case (3 x y) thus ?case by(induct x y rule: narrow_option.induct) (simp_all add: narrow1) next - case goal4 thus ?case + case (4 y x) thus ?case by(induct x y rule: narrow_option.induct) (simp_all add: narrow2) qed @@ -550,14 +546,14 @@ and test_num' = in_ivl and inv_plus' = inv_plus_ivl and inv_less' = inv_less_ivl and m = m_ivl and n = n_ivl and h = 3 -proof - case goal2 thus ?case by(rule m_ivl_anti_mono) +proof (standard, goal_cases) + case 2 thus ?case by(rule m_ivl_anti_mono) next - case goal1 thus ?case by(rule m_ivl_height) + case 1 thus ?case by(rule m_ivl_height) next - case goal3 thus ?case by(rule m_ivl_widen) + case 3 thus ?case by(rule m_ivl_widen) next - case goal4 from goal4(2) show ?case by(rule n_ivl_narrow) + case 4 from 4(2) show ?case by(rule n_ivl_narrow) -- "note that the first assms is unnecessary for intervals" qed diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/IMP/Abs_State.thy --- a/src/HOL/IMP/Abs_State.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/IMP/Abs_State.thy Fri Sep 18 16:42:19 2015 +0100 @@ -66,15 +66,14 @@ definition less_st where "F < (G::'a st) = (F \ G \ \ G \ F)" instance -proof - case goal1 show ?case by(rule less_st_def) -next - case goal2 show ?case by transfer (auto simp: less_eq_st_rep_def) +proof (standard, goal_cases) + case 1 show ?case by(rule less_st_def) next - case goal3 thus ?case - by transfer (metis less_eq_st_rep_iff order_trans) + case 2 show ?case by transfer (auto simp: less_eq_st_rep_def) next - case goal4 thus ?case + case 3 thus ?case by transfer (metis less_eq_st_rep_iff order_trans) +next + case 4 thus ?case by transfer (metis less_eq_st_rep_iff eq_st_def fun_eq_iff antisym) qed @@ -105,15 +104,14 @@ lift_definition top_st :: "'a st" is "[]" . instance -proof - case goal1 show ?case by transfer (simp add:less_eq_st_rep_iff) -next - case goal2 show ?case by transfer (simp add:less_eq_st_rep_iff) +proof (standard, goal_cases) + case 1 show ?case by transfer (simp add:less_eq_st_rep_iff) next - case goal3 thus ?case by transfer (simp add:less_eq_st_rep_iff) + case 2 show ?case by transfer (simp add:less_eq_st_rep_iff) next - case goal4 show ?case - by transfer (simp add:less_eq_st_rep_iff fun_rep_map_of) + case 3 thus ?case by transfer (simp add:less_eq_st_rep_iff) +next + case 4 show ?case by transfer (simp add:less_eq_st_rep_iff fun_rep_map_of) qed end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/IMP/Collecting.thy --- a/src/HOL/IMP/Collecting.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/IMP/Collecting.thy Fri Sep 18 16:42:19 2015 +0100 @@ -45,14 +45,14 @@ "less_acom x y = (x \ y \ \ y \ x)" instance -proof - case goal1 show ?case by(simp add: less_acom_def) +proof (standard, goal_cases) + case 1 show ?case by(simp add: less_acom_def) next - case goal2 thus ?case by(auto simp: less_eq_acom_def) + case 2 thus ?case by(auto simp: less_eq_acom_def) next - case goal3 thus ?case by(fastforce simp: less_eq_acom_def size_annos) + case 3 thus ?case by(fastforce simp: less_eq_acom_def size_annos) next - case goal4 thus ?case + case 4 thus ?case by(fastforce simp: le_antisym less_eq_acom_def size_annos eq_acom_iff_strip_anno) qed @@ -97,14 +97,14 @@ permanent_interpretation Complete_Lattice "{C. strip C = c}" "Inf_acom c" for c -proof - case goal1 thus ?case +proof (standard, goal_cases) + case 1 thus ?case by(auto simp: Inf_acom_def less_eq_acom_def size_annos intro:INF_lower) next - case goal2 thus ?case + case 2 thus ?case by(auto simp: Inf_acom_def less_eq_acom_def size_annos intro:INF_greatest) next - case goal3 thus ?case by(auto simp: Inf_acom_def) + case 3 thus ?case by(auto simp: Inf_acom_def) qed diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/IMP/Compiler.thy --- a/src/HOL/IMP/Compiler.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/IMP/Compiler.thy Fri Sep 18 16:42:19 2015 +0100 @@ -81,8 +81,6 @@ where "exec P \ star (exec1 P)" -declare star.step[intro] - lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)] code_pred exec1 by (metis exec1_def) @@ -107,7 +105,7 @@ by (auto simp: exec1_def) lemma exec_appendR: "P \ c \* c' \ P@P' \ c \* c'" -by (induction rule: star.induct) (fastforce intro: exec1_appendR)+ +by (induction rule: star.induct) (fastforce intro: star.step exec1_appendR)+ lemma exec1_appendL: fixes i i' :: int @@ -122,7 +120,7 @@ shows "P \ (i,s,stk) \* (i',s',stk') \ P' @ P \ (size(P')+i,s,stk) \* (size(P')+i',s',stk')" - by (induction rule: exec_induct) (blast intro!: exec1_appendL)+ + by (induction rule: exec_induct) (blast intro: star.step exec1_appendL)+ text{* Now we specialise the above lemmas to enable automatic proofs of @{prop "P \ c \* c'"} where @{text P} is a mixture of concrete instructions and diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/IMP/Compiler2.thy --- a/src/HOL/IMP/Compiler2.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/IMP/Compiler2.thy Fri Sep 18 16:42:19 2015 +0100 @@ -44,7 +44,7 @@ lemma exec_n_exec: "P \ c \^n c' \ P \ c \* c'" - by (induct n arbitrary: c) auto + by (induct n arbitrary: c) (auto intro: star.step) lemma exec_0 [intro!]: "P \ c \^0 c" by simp diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Imperative_HOL/Imperative_HOL_ex.thy --- a/src/HOL/Imperative_HOL/Imperative_HOL_ex.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Imperative_HOL/Imperative_HOL_ex.thy Fri Sep 18 16:42:19 2015 +0100 @@ -8,7 +8,6 @@ theory Imperative_HOL_ex imports Imperative_HOL Overview "ex/Imperative_Quicksort" "ex/Imperative_Reverse" "ex/Linked_Lists" "ex/SatChecker" - Legacy_Mrec begin definition "everything = (Array.new, Array.of_list, Array.make, Array.len, Array.nth, diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Imperative_HOL/Legacy_Mrec.thy --- a/src/HOL/Imperative_HOL/Legacy_Mrec.thy Fri Sep 18 16:27:37 2015 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,169 +0,0 @@ -theory Legacy_Mrec -imports Heap_Monad -begin - -subsubsection {* A monadic combinator for simple recursive functions *} - -text {* - NOTE: The use of this obsolete combinator is discouraged. Instead, use the - @{text "partal_function (heap)"} command. -*} - -text {* Using a locale to fix arguments f and g of MREC *} - -locale mrec = - fixes f :: "'a \ ('b + 'a) Heap" - and g :: "'a \ 'a \ 'b \ 'b Heap" -begin - -function (default "\(x, h). None") mrec :: "'a \ heap \ ('b \ heap) option" where - "mrec x h = (case execute (f x) h of - Some (Inl r, h') \ Some (r, h') - | Some (Inr s, h') \ (case mrec s h' of - Some (z, h'') \ execute (g x s z) h'' - | None \ None) - | None \ None)" -by auto - -lemma graph_implies_dom: - "mrec_graph x y \ mrec_dom x" -apply (induct rule:mrec_graph.induct) -apply (rule accpI) -apply (erule mrec_rel.cases) -by simp - -lemma mrec_default: "\ mrec_dom (x, h) \ mrec x h = None" - unfolding mrec_def - by (rule fundef_default_value[OF mrec_sumC_def graph_implies_dom, of _ _ "(x, h)", simplified]) - -lemma mrec_di_reverse: - assumes "\ mrec_dom (x, h)" - shows " - (case execute (f x) h of - Some (Inl r, h') \ False - | Some (Inr s, h') \ \ mrec_dom (s, h') - | None \ False - )" -using assms apply (auto split: option.split sum.split) -apply (rule ccontr) -apply (erule notE, rule accpI, elim mrec_rel.cases, auto)+ -done - -lemma mrec_rule: - "mrec x h = - (case execute (f x) h of - Some (Inl r, h') \ Some (r, h') - | Some (Inr s, h') \ - (case mrec s h' of - Some (z, h'') \ execute (g x s z) h'' - | None \ None) - | None \ None - )" -apply (cases "mrec_dom (x,h)", simp add: mrec.psimps) -apply (frule mrec_default) -apply (frule mrec_di_reverse, simp) -by (auto split: sum.split option.split simp: mrec_default) - -definition - "MREC x = Heap_Monad.Heap (mrec x)" - -lemma MREC_rule: - "MREC x = - do { y \ f x; - (case y of - Inl r \ return r - | Inr s \ - do { z \ MREC s ; - g x s z })}" - unfolding MREC_def - unfolding bind_def return_def - apply simp - apply (rule ext) - apply (unfold mrec_rule[of x]) - by (auto simp add: execute_simps split: option.splits prod.splits sum.splits) - -lemma MREC_pinduct: - assumes "execute (MREC x) h = Some (r, h')" - assumes non_rec_case: "\ x h h' r. execute (f x) h = Some (Inl r, h') \ P x h h' r" - assumes rec_case: "\ x h h1 h2 h' s z r. execute (f x) h = Some (Inr s, h1) \ execute (MREC s) h1 = Some (z, h2) \ P s h1 h2 z - \ execute (g x s z) h2 = Some (r, h') \ P x h h' r" - shows "P x h h' r" -proof - - from assms(1) have mrec: "mrec x h = Some (r, h')" - unfolding MREC_def execute.simps . - from mrec have dom: "mrec_dom (x, h)" - apply - - apply (rule ccontr) - apply (drule mrec_default) by auto - from mrec have h'_r: "h' = snd (the (mrec x h))" "r = fst (the (mrec x h))" - by auto - from mrec have "P x h (snd (the (mrec x h))) (fst (the (mrec x h)))" - proof (induct arbitrary: r h' rule: mrec.pinduct[OF dom]) - case (1 x h) - obtain rr h' where "the (mrec x h) = (rr, h')" by fastforce - show ?case - proof (cases "execute (f x) h") - case (Some result) - then obtain a h1 where exec_f: "execute (f x) h = Some (a, h1)" by fastforce - note Inl' = this - show ?thesis - proof (cases a) - case (Inl aa) - from this Inl' 1(1) exec_f mrec non_rec_case show ?thesis - by (auto simp: mrec.psimps) - next - case (Inr b) - note Inr' = this - show ?thesis - proof (cases "mrec b h1") - case (Some result) - then obtain aaa h2 where mrec_rec: "mrec b h1 = Some (aaa, h2)" by fastforce - moreover from mrec_rec have "P b h1 (snd (the (mrec b h1))) (fst (the (mrec b h1)))" - apply (intro 1(2)) - apply (auto simp add: Inr Inl') - done - moreover note mrec mrec_rec exec_f Inl' Inr' 1(1) 1(3) - ultimately show ?thesis - apply auto - apply (rule rec_case) - apply auto - unfolding MREC_def by (auto simp: mrec.psimps) - next - case None - from this 1(1) exec_f mrec Inr' 1(3) show ?thesis by (auto simp: mrec.psimps) - qed - qed - next - case None - from this 1(1) mrec 1(3) show ?thesis by (simp add: mrec.psimps) - qed - qed - from this h'_r show ?thesis by simp -qed - -end - -text {* Providing global versions of the constant and the theorems *} - -abbreviation "MREC == mrec.MREC" -lemmas MREC_rule = mrec.MREC_rule -lemmas MREC_pinduct = mrec.MREC_pinduct - -lemma MREC_induct: - assumes "effect (MREC f g x) h h' r" - assumes "\ x h h' r. effect (f x) h h' (Inl r) \ P x h h' r" - assumes "\ x h h1 h2 h' s z r. effect (f x) h h1 (Inr s) \ effect (MREC f g s) h1 h2 z \ P s h1 h2 z - \ effect (g x s z) h2 h' r \ P x h h' r" - shows "P x h h' r" -proof (rule MREC_pinduct[OF assms(1) [unfolded effect_def]]) - fix x h h1 h2 h' s z r - assume "Heap_Monad.execute (f x) h = Some (Inr s, h1)" - "Heap_Monad.execute (MREC f g s) h1 = Some (z, h2)" - "P s h1 h2 z" - "Heap_Monad.execute (g x s z) h2 = Some (r, h')" - from assms(3) [unfolded effect_def, OF this(1) this(2) this(3) this(4)] - show "P x h h' r" . -next -qed (auto simp add: assms(2)[unfolded effect_def]) - -end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Imperative_HOL/Overview.thy --- a/src/HOL/Imperative_HOL/Overview.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Imperative_HOL/Overview.thy Fri Sep 18 16:42:19 2015 +0100 @@ -8,18 +8,14 @@ begin (* type constraints with spacing *) -setup {* -let - val typ = Simple_Syntax.read_typ; -in - Sign.del_syntax (Symbol.xsymbolsN, false) - [("_constrain", typ "logic => type => logic", Mixfix ("_\_", [4, 0], 3)), - ("_constrain", typ "prop' => type => prop'", Mixfix ("_\_", [4, 0], 3))] #> - Sign.add_syntax (Symbol.xsymbolsN, false) - [("_constrain", typ "logic => type => logic", Mixfix ("_ \ _", [4, 0], 3)), - ("_constrain", typ "prop' => type => prop'", Mixfix ("_ \ _", [4, 0], 3))] -end -*}(*>*) +no_syntax (output) + "_constrain" :: "logic => type => logic" ("_::_" [4, 0] 3) + "_constrain" :: "prop' => type => prop'" ("_::_" [4, 0] 3) + +syntax (output) + "_constrain" :: "logic => type => logic" ("_ :: _" [4, 0] 3) + "_constrain" :: "prop' => type => prop'" ("_ :: _" [4, 0] 3) +(*>*) text {* @{text "Imperative HOL"} is a leightweight framework for reasoning diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Import/import_rule.ML --- a/src/HOL/Import/import_rule.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Import/import_rule.ML Fri Sep 18 16:42:19 2015 +0100 @@ -218,9 +218,12 @@ | _ => error "type_introduction: bad type definition theorem" val tfrees = Term.add_tfrees c [] val tnames = sort_strings (map fst tfrees) + val typedef_bindings = + Typedef.make_morphisms (Binding.name tycname) + (SOME (Binding.name rep_name, Binding.name abs_name)) val ((_, typedef_info), thy') = - Typedef.add_typedef_global false (Binding.name tycname, map (rpair dummyS) tnames, NoSyn) c - (SOME (Binding.name rep_name, Binding.name abs_name)) (fn ctxt => resolve_tac ctxt [th2] 1) thy + Typedef.add_typedef_global (Binding.name tycname, map (rpair dummyS) tnames, NoSyn) c + (SOME typedef_bindings) (fn ctxt => resolve_tac ctxt [th2] 1) thy val aty = #abs_type (#1 typedef_info) val th = freezeT thy' (#type_definition (#2 typedef_info)) val (th_s, _) = Thm.dest_comb (Thm.dest_arg (Thm.cprop_of th)) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Int.thy --- a/src/HOL/Int.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Int.thy Fri Sep 18 16:42:19 2015 +0100 @@ -66,7 +66,7 @@ qed instance - by default (transfer, clarsimp simp: algebra_simps)+ + by standard (transfer, clarsimp simp: algebra_simps)+ end @@ -99,7 +99,7 @@ by auto instance - by default (transfer, force)+ + by standard (transfer, force)+ end @@ -305,13 +305,13 @@ instance int :: no_top - apply default + apply standard apply (rule_tac x="x + 1" in exI) apply simp done instance int :: no_bot - apply default + apply standard apply (rule_tac x="x - 1" in exI) apply simp done @@ -775,9 +775,9 @@ declaration \K Int_Arith.setup\ simproc_setup fast_arith ("(m::'a::linordered_idom) < n" | - "(m::'a::linordered_idom) <= n" | + "(m::'a::linordered_idom) \ n" | "(m::'a::linordered_idom) = n") = - \fn _ => fn ss => fn ct => Lin_Arith.simproc ss (Thm.term_of ct)\ + \K Lin_Arith.simproc\ subsection\More Inequality Reasoning\ @@ -1526,7 +1526,8 @@ definition "HOL.equal k l \ k = (l::int)" -instance by default (rule equal_int_def) +instance + by standard (rule equal_int_def) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Lattices.thy --- a/src/HOL/Lattices.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Lattices.thy Fri Sep 18 16:42:19 2015 +0100 @@ -145,7 +145,7 @@ begin sublocale ordering_top less_eq less 1 - by default (simp add: order_iff) + by standard (simp add: order_iff) end @@ -283,7 +283,7 @@ qed sublocale inf!: semilattice_order inf less_eq less - by default (auto simp add: le_iff_inf less_le) + by standard (auto simp add: le_iff_inf less_le) lemma inf_assoc: "(x \ y) \ z = x \ (y \ z)" by (fact inf.assoc) @@ -328,7 +328,7 @@ qed sublocale sup!: semilattice_order sup greater_eq greater - by default (auto simp add: le_iff_sup sup.commute less_le) + by standard (auto simp add: le_iff_sup sup.commute less_le) lemma sup_assoc: "(x \ y) \ z = x \ (y \ z)" by (fact sup.assoc) @@ -717,7 +717,7 @@ sublocale min!: semilattice_order min less_eq less + max!: semilattice_order max greater_eq greater - by default (auto simp add: min_def max_def) + by standard (auto simp add: min_def max_def) lemma min_le_iff_disj: "min x y \ z \ x \ z \ y \ z" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Lattices_Big.thy --- a/src/HOL/Lattices_Big.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Lattices_Big.thy Fri Sep 18 16:42:19 2015 +0100 @@ -21,7 +21,7 @@ begin interpretation comp_fun_idem f - by default (simp_all add: fun_eq_iff left_commute) + by standard (simp_all add: fun_eq_iff left_commute) definition F :: "'a set \ 'a" where @@ -33,7 +33,7 @@ proof (rule sym) let ?f = "\x y. Some (case y of None \ x | Some z \ f x z)" interpret comp_fun_idem "?f" - by default (simp_all add: fun_eq_iff commute left_commute split: option.split) + by standard (simp_all add: fun_eq_iff commute left_commute split: option.split) from assms show "Finite_Set.fold f x A = F (insert x A)" proof induct case empty then show ?case by (simp add: eq_fold') @@ -189,7 +189,7 @@ begin interpretation comp_fun_idem f - by default (simp_all add: fun_eq_iff left_commute) + by standard (simp_all add: fun_eq_iff left_commute) definition F :: "'a set \ 'a" where @@ -496,9 +496,9 @@ "semilattice_set.F min = Min" and "semilattice_set.F max = Max" proof - - show "semilattice_order_set min less_eq less" by default (auto simp add: min_def) + show "semilattice_order_set min less_eq less" by standard (auto simp add: min_def) then interpret Min!: semilattice_order_set min less_eq less . - show "semilattice_order_set max greater_eq greater" by default (auto simp add: max_def) + show "semilattice_order_set max greater_eq greater" by standard (auto simp add: max_def) then interpret Max!: semilattice_order_set max greater_eq greater . from Min_def show "semilattice_set.F min = Min" by rule from Max_def show "semilattice_set.F max = Max" by rule diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Cardinality.thy --- a/src/HOL/Library/Cardinality.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Cardinality.thy Fri Sep 18 16:42:19 2015 +0100 @@ -410,7 +410,10 @@ possibly slow dictionary constructions. \ -definition card_UNIV' :: "'a card_UNIV" +context +begin + +qualified definition card_UNIV' :: "'a card_UNIV" where [code del]: "card_UNIV' = Phantom('a) CARD('a)" lemma CARD_code [code_unfold]: @@ -421,7 +424,7 @@ "card_UNIV' = card_UNIV" by(simp add: card_UNIV card_UNIV'_def) -hide_const (open) card_UNIV' +end lemma card_Compl: "finite A \ card (- A) = card (UNIV :: 'a set) - card (A :: 'a set)" @@ -430,7 +433,7 @@ context fixes xs :: "'a :: finite_UNIV list" begin -definition finite' :: "'a set \ bool" +qualified definition finite' :: "'a set \ bool" where [simp, code del, code_abbrev]: "finite' = finite" lemma finite'_code [code]: @@ -443,7 +446,7 @@ context fixes xs :: "'a :: card_UNIV list" begin -definition card' :: "'a set \ nat" +qualified definition card' :: "'a set \ nat" where [simp, code del, code_abbrev]: "card' = card" lemma card'_code [code]: @@ -452,7 +455,7 @@ by(simp_all add: List.card_set card_Compl card_UNIV) -definition subset' :: "'a set \ 'a set \ bool" +qualified definition subset' :: "'a set \ 'a set \ bool" where [simp, code del, code_abbrev]: "subset' = op \" lemma subset'_code [code]: @@ -462,7 +465,7 @@ by(auto simp add: Let_def card_gt_0_iff dest: card_eq_UNIV_imp_eq_UNIV intro: arg_cong[where f=card]) (metis finite_compl finite_set rev_finite_subset) -definition eq_set :: "'a set \ 'a set \ bool" +qualified definition eq_set :: "'a set \ 'a set \ bool" where [simp, code del, code_abbrev]: "eq_set = op =" lemma eq_set_code [code]: @@ -476,7 +479,7 @@ and "eq_set (set ys) (List.coset xs) \ rhs" and "eq_set (set xs) (set ys) \ (\x \ set xs. x \ set ys) \ (\y \ set ys. y \ set xs)" and "eq_set (List.coset xs) (List.coset ys) \ (\x \ set xs. x \ set ys) \ (\y \ set ys. y \ set xs)" -proof goals +proof goal_cases { case 1 show ?case (is "?lhs \ ?rhs") @@ -538,7 +541,4 @@ by eval end -hide_const (open) card' finite' subset' eq_set - end - diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Code_Binary_Nat.thy --- a/src/HOL/Library/Code_Binary_Nat.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Code_Binary_Nat.thy Fri Sep 18 16:42:19 2015 +0100 @@ -40,6 +40,9 @@ subsection \Basic arithmetic\ +context +begin + lemma [code, code del]: "(plus :: nat \ _) = plus" .. @@ -51,7 +54,7 @@ text \Bounded subtraction needs some auxiliary\ -definition dup :: "nat \ nat" where +qualified definition dup :: "nat \ nat" where "dup n = n + n" lemma dup_code [code]: @@ -59,7 +62,7 @@ "dup (nat_of_num k) = nat_of_num (Num.Bit0 k)" by (simp_all add: dup_def numeral_Bit0) -definition sub :: "num \ num \ nat option" where +qualified definition sub :: "num \ num \ nat option" where "sub k l = (if k \ l then Some (numeral k - numeral l) else None)" lemma sub_code [code]: @@ -139,6 +142,8 @@ "divmod_nat 0 n = (0, 0)" by (simp_all add: prod_eq_iff nat_of_num_numeral) +end + subsection \Conversions\ @@ -155,7 +160,4 @@ code_module Code_Binary_Nat \ (SML) Arith and (OCaml) Arith and (Haskell) Arith -hide_const (open) dup sub - end - diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Code_Real_Approx_By_Float.thy --- a/src/HOL/Library/Code_Real_Approx_By_Float.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Code_Real_Approx_By_Float.thy Fri Sep 18 16:42:19 2015 +0100 @@ -85,20 +85,23 @@ and (OCaml) "Pervasives.sqrt" declare sqrt_def[code del] -definition real_exp :: "real \ real" where "real_exp = exp" +context +begin + +qualified definition real_exp :: "real \ real" where "real_exp = exp" lemma exp_eq_real_exp[code_unfold]: "exp = real_exp" unfolding real_exp_def .. +end + code_printing - constant real_exp \ + constant Code_Real_Approx_By_Float.real_exp \ (SML) "Math.exp" and (OCaml) "Pervasives.exp" -declare real_exp_def[code del] +declare Code_Real_Approx_By_Float.real_exp_def[code del] declare exp_def[code del] -hide_const (open) real_exp - code_printing constant ln \ (SML) "Math.ln" @@ -149,7 +152,10 @@ (SML) "Real.fromInt" and (OCaml) "Pervasives.float (Big'_int.int'_of'_big'_int (_))" -definition real_of_int :: "int \ real" where +context +begin + +qualified definition real_of_int :: "int \ real" where [code_abbrev]: "real_of_int = of_int" lemma [code]: @@ -172,7 +178,7 @@ "- numeral k \ (of_rat (- numeral k) :: real)" by simp -hide_const (open) real_of_int +end code_printing constant Ratreal \ (SML) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Countable.thy --- a/src/HOL/Library/Countable.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Countable.thy Fri Sep 18 16:42:19 2015 +0100 @@ -66,15 +66,17 @@ subsection \Automatically proving countability of old-style datatypes\ -inductive finite_item :: "'a Old_Datatype.item \ bool" where +context +begin + +qualified inductive finite_item :: "'a Old_Datatype.item \ bool" where undefined: "finite_item undefined" | In0: "finite_item x \ finite_item (Old_Datatype.In0 x)" | In1: "finite_item x \ finite_item (Old_Datatype.In1 x)" | Leaf: "finite_item (Old_Datatype.Leaf a)" | Scons: "\finite_item x; finite_item y\ \ finite_item (Old_Datatype.Scons x y)" -function - nth_item :: "nat \ ('a::countable) Old_Datatype.item" +qualified function nth_item :: "nat \ ('a::countable) Old_Datatype.item" where "nth_item 0 = undefined" | "nth_item (Suc n) = @@ -97,7 +99,7 @@ lemma le_sum_encode_Inr: "x \ y \ x \ sum_encode (Inr y)" unfolding sum_encode_def by simp -termination +qualified termination by (relation "measure id") (auto simp add: sum_encode_eq [symmetric] prod_encode_eq [symmetric] le_imp_less_Suc le_sum_encode_Inl le_sum_encode_Inr @@ -193,7 +195,7 @@ end) \ -hide_const (open) finite_item nth_item +end subsection \Automatically proving countability of datatypes\ diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/DAList_Multiset.thy --- a/src/HOL/Library/DAList_Multiset.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/DAList_Multiset.thy Fri Sep 18 16:42:19 2015 +0100 @@ -275,10 +275,13 @@ "fold_impl fn e ((a,n) # ms) = (fold_impl fn ((fn a n) e) ms)" | "fold_impl fn e [] = e" -definition fold :: "('a \ nat \ 'b \ 'b) \ 'b \ ('a, nat) alist \ 'b" +context +begin + +qualified definition fold :: "('a \ nat \ 'b \ 'b) \ 'b \ ('a, nat) alist \ 'b" where "fold f e al = fold_impl f e (DAList.impl_of al)" -hide_const (open) fold +end context comp_fun_commute begin @@ -348,7 +351,10 @@ end -lift_definition single_alist_entry :: "'a \ 'b \ ('a, 'b) alist" is "\a b. [(a, b)]" +context +begin + +private lift_definition single_alist_entry :: "'a \ 'b \ ('a, 'b) alist" is "\a b. [(a, b)]" by auto lemma image_mset_Bag [code]: @@ -368,7 +374,7 @@ qed qed -hide_const single_alist_entry +end (* we cannot use (\a n. op + (a * n)) for folding, since * is not defined in comm_monoid_add *) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Debug.thy --- a/src/HOL/Library/Debug.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Debug.thy Fri Sep 18 16:42:19 2015 +0100 @@ -6,37 +6,40 @@ imports Main begin -definition trace :: "String.literal \ unit" where +context +begin + +qualified definition trace :: "String.literal \ unit" where [simp]: "trace s = ()" -definition tracing :: "String.literal \ 'a \ 'a" where +qualified definition tracing :: "String.literal \ 'a \ 'a" where [simp]: "tracing s = id" lemma [code]: "tracing s = (let u = trace s in id)" by simp -definition flush :: "'a \ unit" where +qualified definition flush :: "'a \ unit" where [simp]: "flush x = ()" -definition flushing :: "'a \ 'b \ 'b" where +qualified definition flushing :: "'a \ 'b \ 'b" where [simp]: "flushing x = id" lemma [code, code_unfold]: "flushing x = (let u = flush x in id)" by simp -definition timing :: "String.literal \ ('a \ 'b) \ 'a \ 'b" where +qualified definition timing :: "String.literal \ ('a \ 'b) \ 'a \ 'b" where [simp]: "timing s f x = f x" +end + code_printing - constant trace \ (Eval) "Output.tracing" -| constant flush \ (Eval) "Output.tracing/ (@{make'_string} _)" -- \note indirection via antiquotation\ -| constant timing \ (Eval) "Timing.timeap'_msg" + constant Debug.trace \ (Eval) "Output.tracing" +| constant Debug.flush \ (Eval) "Output.tracing/ (@{make'_string} _)" -- \note indirection via antiquotation\ +| constant Debug.timing \ (Eval) "Timing.timeap'_msg" code_reserved Eval Output Timing -hide_const (open) trace tracing flush flushing timing - end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Discrete.thy --- a/src/HOL/Library/Discrete.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Discrete.thy Fri Sep 18 16:42:19 2015 +0100 @@ -8,7 +8,10 @@ subsection \Discrete logarithm\ -fun log :: "nat \ nat" +context +begin + +qualified fun log :: "nat \ nat" where [simp del]: "log n = (if n < 2 then 0 else Suc (log (n div 2)))" lemma log_zero [simp]: "log 0 = 0" @@ -67,7 +70,7 @@ subsection \Discrete square root\ -definition sqrt :: "nat \ nat" +qualified definition sqrt :: "nat \ nat" where "sqrt n = Max {m. m\<^sup>2 \ n}" lemma sqrt_aux: @@ -173,7 +176,6 @@ lemma sqrt_le: "sqrt n \ n" using sqrt_aux [of n] by (auto simp add: sqrt_def intro: power2_nat_le_imp_le) -hide_const (open) log sqrt - end +end \ No newline at end of file diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Dlist.thy --- a/src/HOL/Library/Dlist.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Dlist.thy Fri Sep 18 16:42:19 2015 +0100 @@ -46,61 +46,71 @@ text \Fundamental operations:\ -definition empty :: "'a dlist" where +context +begin + +qualified definition empty :: "'a dlist" where "empty = Dlist []" -definition insert :: "'a \ 'a dlist \ 'a dlist" where +qualified definition insert :: "'a \ 'a dlist \ 'a dlist" where "insert x dxs = Dlist (List.insert x (list_of_dlist dxs))" -definition remove :: "'a \ 'a dlist \ 'a dlist" where +qualified definition remove :: "'a \ 'a dlist \ 'a dlist" where "remove x dxs = Dlist (remove1 x (list_of_dlist dxs))" -definition map :: "('a \ 'b) \ 'a dlist \ 'b dlist" where +qualified definition map :: "('a \ 'b) \ 'a dlist \ 'b dlist" where "map f dxs = Dlist (remdups (List.map f (list_of_dlist dxs)))" -definition filter :: "('a \ bool) \ 'a dlist \ 'a dlist" where +qualified definition filter :: "('a \ bool) \ 'a dlist \ 'a dlist" where "filter P dxs = Dlist (List.filter P (list_of_dlist dxs))" +end + text \Derived operations:\ -definition null :: "'a dlist \ bool" where +context +begin + +qualified definition null :: "'a dlist \ bool" where "null dxs = List.null (list_of_dlist dxs)" -definition member :: "'a dlist \ 'a \ bool" where +qualified definition member :: "'a dlist \ 'a \ bool" where "member dxs = List.member (list_of_dlist dxs)" -definition length :: "'a dlist \ nat" where +qualified definition length :: "'a dlist \ nat" where "length dxs = List.length (list_of_dlist dxs)" -definition fold :: "('a \ 'b \ 'b) \ 'a dlist \ 'b \ 'b" where +qualified definition fold :: "('a \ 'b \ 'b) \ 'a dlist \ 'b \ 'b" where "fold f dxs = List.fold f (list_of_dlist dxs)" -definition foldr :: "('a \ 'b \ 'b) \ 'a dlist \ 'b \ 'b" where +qualified definition foldr :: "('a \ 'b \ 'b) \ 'a dlist \ 'b \ 'b" where "foldr f dxs = List.foldr f (list_of_dlist dxs)" +end + subsection \Executable version obeying invariant\ lemma list_of_dlist_empty [simp, code abstract]: - "list_of_dlist empty = []" - by (simp add: empty_def) + "list_of_dlist Dlist.empty = []" + by (simp add: Dlist.empty_def) lemma list_of_dlist_insert [simp, code abstract]: - "list_of_dlist (insert x dxs) = List.insert x (list_of_dlist dxs)" - by (simp add: insert_def) + "list_of_dlist (Dlist.insert x dxs) = List.insert x (list_of_dlist dxs)" + by (simp add: Dlist.insert_def) lemma list_of_dlist_remove [simp, code abstract]: - "list_of_dlist (remove x dxs) = remove1 x (list_of_dlist dxs)" - by (simp add: remove_def) + "list_of_dlist (Dlist.remove x dxs) = remove1 x (list_of_dlist dxs)" + by (simp add: Dlist.remove_def) lemma list_of_dlist_map [simp, code abstract]: - "list_of_dlist (map f dxs) = remdups (List.map f (list_of_dlist dxs))" - by (simp add: map_def) + "list_of_dlist (Dlist.map f dxs) = remdups (List.map f (list_of_dlist dxs))" + by (simp add: Dlist.map_def) lemma list_of_dlist_filter [simp, code abstract]: - "list_of_dlist (filter P dxs) = List.filter P (list_of_dlist dxs)" - by (simp add: filter_def) + "list_of_dlist (Dlist.filter P dxs) = List.filter P (list_of_dlist dxs)" + by (simp add: Dlist.filter_def) text \Explicit executable conversion\ @@ -134,28 +144,29 @@ subsection \Induction principle and case distinction\ lemma dlist_induct [case_names empty insert, induct type: dlist]: - assumes empty: "P empty" - assumes insrt: "\x dxs. \ member dxs x \ P dxs \ P (insert x dxs)" + assumes empty: "P Dlist.empty" + assumes insrt: "\x dxs. \ Dlist.member dxs x \ P dxs \ P (Dlist.insert x dxs)" shows "P dxs" proof (cases dxs) case (Abs_dlist xs) - then have "distinct xs" and dxs: "dxs = Dlist xs" by (simp_all add: Dlist_def distinct_remdups_id) + then have "distinct xs" and dxs: "dxs = Dlist xs" + by (simp_all add: Dlist_def distinct_remdups_id) from \distinct xs\ have "P (Dlist xs)" proof (induct xs) - case Nil from empty show ?case by (simp add: empty_def) + case Nil from empty show ?case by (simp add: Dlist.empty_def) next case (Cons x xs) - then have "\ member (Dlist xs) x" and "P (Dlist xs)" - by (simp_all add: member_def List.member_def) - with insrt have "P (insert x (Dlist xs))" . - with Cons show ?case by (simp add: insert_def distinct_remdups_id) + then have "\ Dlist.member (Dlist xs) x" and "P (Dlist xs)" + by (simp_all add: Dlist.member_def List.member_def) + with insrt have "P (Dlist.insert x (Dlist xs))" . + with Cons show ?case by (simp add: Dlist.insert_def distinct_remdups_id) qed with dxs show "P dxs" by simp qed lemma dlist_case [cases type: dlist]: - obtains (empty) "dxs = empty" - | (insert) x dys where "\ member dys x" and "dxs = insert x dys" + obtains (empty) "dxs = Dlist.empty" + | (insert) x dys where "\ Dlist.member dys x" and "dxs = Dlist.insert x dys" proof (cases dxs) case (Abs_dlist xs) then have dxs: "dxs = Dlist xs" and distinct: "distinct xs" @@ -163,13 +174,13 @@ show thesis proof (cases xs) case Nil with dxs - have "dxs = empty" by (simp add: empty_def) + have "dxs = Dlist.empty" by (simp add: Dlist.empty_def) with empty show ?thesis . next case (Cons x xs) - with dxs distinct have "\ member (Dlist xs) x" - and "dxs = insert x (Dlist xs)" - by (simp_all add: member_def List.member_def insert_def distinct_remdups_id) + with dxs distinct have "\ Dlist.member (Dlist xs) x" + and "dxs = Dlist.insert x (Dlist xs)" + by (simp_all add: Dlist.member_def List.member_def Dlist.insert_def distinct_remdups_id) with insert show ?thesis . qed qed @@ -178,14 +189,11 @@ subsection \Functorial structure\ functor map: map - by (simp_all add: List.map.id remdups_map_remdups fun_eq_iff dlist_eq_iff) + by (simp_all add: remdups_map_remdups fun_eq_iff dlist_eq_iff) subsection \Quickcheck generators\ -quickcheck_generator dlist predicate: distinct constructors: empty, insert - - -hide_const (open) member fold foldr empty insert remove map filter null member length fold +quickcheck_generator dlist predicate: distinct constructors: Dlist.empty, Dlist.insert end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Extended_Real.thy --- a/src/HOL/Library/Extended_Real.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Extended_Real.thy Fri Sep 18 16:42:19 2015 +0100 @@ -333,7 +333,7 @@ | "ereal r + -\ = - \" | "-\ + ereal p = -(\::ereal)" | "-\ + -\ = -(\::ereal)" -proof goals +proof goal_cases case prems: (1 P x) then obtain a b where "x = (a, b)" by (cases x) auto @@ -437,7 +437,7 @@ | "ereal x < \ \ True" | " -\ < ereal r \ True" | " -\ < (\::ereal) \ True" -proof goals +proof goal_cases case prems: (1 P x) then obtain a b where "x = (a,b)" by (cases x) auto with prems show P by (cases rule: ereal2_cases[of a b]) auto @@ -860,7 +860,7 @@ | "-(\::ereal) * \ = -\" | "(\::ereal) * -\ = -\" | "-(\::ereal) * -\ = \" -proof goals +proof goal_cases case prems: (1 P x) then obtain a b where "x = (a, b)" by (cases x) auto @@ -913,7 +913,7 @@ lemma ereal_times[simp]: "1 \ (\::ereal)" "(\::ereal) \ 1" "1 \ -(\::ereal)" "-(\::ereal) \ 1" - by (auto simp add: times_ereal_def one_ereal_def) + by (auto simp: one_ereal_def) lemma ereal_plus_1[simp]: "1 + ereal r = ereal (r + 1)" @@ -2195,7 +2195,7 @@ show "ereal_of_enat (Sup A) \ (SUP a : A. ereal_of_enat a)" proof cases assume "finite A" - with `A \ {}` obtain a where "a \ A" "ereal_of_enat (Sup A) = ereal_of_enat a" + with \A \ {}\ obtain a where "a \ A" "ereal_of_enat (Sup A) = ereal_of_enat a" using Max_in[of A] by (auto simp: Sup_enat_def simp del: Max_in) then show ?thesis by (auto intro: SUP_upper) @@ -2208,11 +2208,11 @@ then obtain n :: nat where "x < n" using less_PInf_Ex_of_nat top_ereal_def by auto obtain a where "a \ A - enat ` {.. n}" - by (metis `\ finite A` all_not_in_conv finite_Diff2 finite_atMost finite_imageI finite.emptyI) + by (metis \\ finite A\ all_not_in_conv finite_Diff2 finite_atMost finite_imageI finite.emptyI) then have "a \ A" "ereal n \ ereal_of_enat a" by (auto simp: image_iff Ball_def) (metis enat_iless enat_ord_simps(1) ereal_of_enat_less_iff ereal_of_enat_simps(1) less_le not_less) - with `x < n` show "\i\A. x < ereal_of_enat i" + with \x < n\ show "\i\A. x < ereal_of_enat i" by (auto intro!: bexI[of _ a]) qed show ?thesis diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Fraction_Field.thy --- a/src/HOL/Library/Fraction_Field.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Fraction_Field.thy Fri Sep 18 16:42:19 2015 +0100 @@ -13,24 +13,23 @@ subsubsection \Construction of the type of fractions\ -definition fractrel :: "(('a::idom * 'a ) * ('a * 'a)) set" where - "fractrel = {(x, y). snd x \ 0 \ snd y \ 0 \ fst x * snd y = fst y * snd x}" +context idom begin + +definition fractrel :: "'a \ 'a \ 'a * 'a \ bool" where + "fractrel = (\x y. snd x \ 0 \ snd y \ 0 \ fst x * snd y = fst y * snd x)" lemma fractrel_iff [simp]: - "(x, y) \ fractrel \ snd x \ 0 \ snd y \ 0 \ fst x * snd y = fst y * snd x" + "fractrel x y \ snd x \ 0 \ snd y \ 0 \ fst x * snd y = fst y * snd x" by (simp add: fractrel_def) -lemma refl_fractrel: "refl_on {x. snd x \ 0} fractrel" - by (auto simp add: refl_on_def fractrel_def) - -lemma sym_fractrel: "sym fractrel" - by (simp add: fractrel_def sym_def) +lemma symp_fractrel: "symp fractrel" + by (simp add: symp_def) -lemma trans_fractrel: "trans fractrel" -proof (rule transI, unfold split_paired_all) +lemma transp_fractrel: "transp fractrel" +proof (rule transpI, unfold split_paired_all) fix a b a' b' a'' b'' :: 'a - assume A: "((a, b), (a', b')) \ fractrel" - assume B: "((a', b'), (a'', b'')) \ fractrel" + assume A: "fractrel (a, b) (a', b')" + assume B: "fractrel (a', b') (a'', b'')" have "b' * (a * b'') = b'' * (a * b')" by (simp add: ac_simps) also from A have "a * b' = a' * b" by auto also have "b'' * (a' * b) = b * (a' * b'')" by (simp add: ac_simps) @@ -39,46 +38,27 @@ finally have "b' * (a * b'') = b' * (a'' * b)" . moreover from B have "b' \ 0" by auto ultimately have "a * b'' = a'' * b" by simp - with A B show "((a, b), (a'', b'')) \ fractrel" by auto + with A B show "fractrel (a, b) (a'', b'')" by auto qed -lemma equiv_fractrel: "equiv {x. snd x \ 0} fractrel" - by (rule equivI [OF refl_fractrel sym_fractrel trans_fractrel]) - -lemmas UN_fractrel = UN_equiv_class [OF equiv_fractrel] -lemmas UN_fractrel2 = UN_equiv_class2 [OF equiv_fractrel equiv_fractrel] - -lemma equiv_fractrel_iff [iff]: - assumes "snd x \ 0" and "snd y \ 0" - shows "fractrel `` {x} = fractrel `` {y} \ (x, y) \ fractrel" - by (rule eq_equiv_class_iff, rule equiv_fractrel) (auto simp add: assms) - -definition "fract = {(x::'a\'a). snd x \ (0::'a::idom)} // fractrel" +lemma part_equivp_fractrel: "part_equivp fractrel" +using _ symp_fractrel transp_fractrel +by(rule part_equivpI)(rule exI[where x="(0, 1)"]; simp) -typedef 'a fract = "fract :: ('a * 'a::idom) set set" - unfolding fract_def -proof - have "(0::'a, 1::'a) \ {x. snd x \ 0}" by simp - then show "fractrel `` {(0::'a, 1)} \ {x. snd x \ 0} // fractrel" - by (rule quotientI) -qed +end -lemma fractrel_in_fract [simp]: "snd x \ 0 \ fractrel `` {x} \ fract" - by (simp add: fract_def quotientI) - -declare Abs_fract_inject [simp] Abs_fract_inverse [simp] - +quotient_type 'a fract = "'a :: idom \ 'a" / partial: "fractrel" +by(rule part_equivp_fractrel) subsubsection \Representation and basic operations\ -definition Fract :: "'a::idom \ 'a \ 'a fract" - where "Fract a b = Abs_fract (fractrel `` {if b = 0 then (0, 1) else (a, b)})" - -code_datatype Fract +lift_definition Fract :: "'a :: idom \ 'a \ 'a fract" + is "\a b. if b = 0 then (0, 1) else (a, b)" + by simp lemma Fract_cases [cases type: fract]: obtains (Fract) a b where "q = Fract a b" "b \ 0" - by (cases q) (clarsimp simp add: Fract_def fract_def quotient_def) +by transfer simp lemma Fract_induct [case_names Fract, induct type: fract]: "(\a b. b \ 0 \ P (Fract a b)) \ P q" @@ -88,40 +68,37 @@ shows "\a b c d. b \ 0 \ d \ 0 \ Fract a b = Fract c d \ a * d = c * b" and "\a. Fract a 0 = Fract 0 1" and "\a c. Fract 0 a = Fract 0 c" - by (simp_all add: Fract_def) +by(transfer; simp)+ instantiation fract :: (idom) "{comm_ring_1,power}" begin -definition Zero_fract_def [code_unfold]: "0 = Fract 0 1" +lift_definition zero_fract :: "'a fract" is "(0, 1)" by simp -definition One_fract_def [code_unfold]: "1 = Fract 1 1" +lemma Zero_fract_def: "0 = Fract 0 1" +by transfer simp + +lift_definition one_fract :: "'a fract" is "(1, 1)" by simp -definition add_fract_def: - "q + r = Abs_fract (\x \ Rep_fract q. \y \ Rep_fract r. - fractrel `` {(fst x * snd y + fst y * snd x, snd x * snd y)})" +lemma One_fract_def: "1 = Fract 1 1" +by transfer simp + +lift_definition plus_fract :: "'a fract \ 'a fract \ 'a fract" + is "\q r. (fst q * snd r + fst r * snd q, snd q * snd r)" +by(auto simp add: algebra_simps) lemma add_fract [simp]: - assumes "b \ (0::'a::idom)" - and "d \ 0" - shows "Fract a b + Fract c d = Fract (a * d + c * b) (b * d)" -proof - - have "(\x y. fractrel``{(fst x * snd y + fst y * snd x, snd x * snd y :: 'a)}) respects2 fractrel" - by (rule equiv_fractrel [THEN congruent2_commuteI]) (simp_all add: algebra_simps) - with assms show ?thesis by (simp add: Fract_def add_fract_def UN_fractrel2) -qed + "\ b \ 0; d \ 0 \ \ Fract a b + Fract c d = Fract (a * d + c * b) (b * d)" +by transfer simp -definition minus_fract_def: - "- q = Abs_fract (\x \ Rep_fract q. fractrel `` {(- fst x, snd x)})" +lift_definition uminus_fract :: "'a fract \ 'a fract" + is "\x. (- fst x, snd x)" +by simp -lemma minus_fract [simp, code]: +lemma minus_fract [simp]: fixes a b :: "'a::idom" shows "- Fract a b = Fract (- a) b" -proof - - have "(\x. fractrel `` {(- fst x, snd x :: 'a)}) respects fractrel" - by (simp add: congruent_def split_paired_all) - then show ?thesis by (simp add: Fract_def minus_fract_def UN_fractrel) -qed +by transfer simp lemma minus_fract_cancel [simp]: "Fract (- a) (- b) = Fract a b" by (cases "b = 0") (simp_all add: eq_fract) @@ -129,31 +106,19 @@ definition diff_fract_def: "q - r = q + - (r::'a fract)" lemma diff_fract [simp]: - assumes "b \ 0" - and "d \ 0" - shows "Fract a b - Fract c d = Fract (a * d - c * b) (b * d)" - using assms by (simp add: diff_fract_def) + "\ b \ 0; d \ 0 \ \ Fract a b - Fract c d = Fract (a * d - c * b) (b * d)" + by (simp add: diff_fract_def) -definition mult_fract_def: - "q * r = Abs_fract (\x \ Rep_fract q. \y \ Rep_fract r. - fractrel``{(fst x * fst y, snd x * snd y)})" +lift_definition times_fract :: "'a fract \ 'a fract \ 'a fract" + is "\q r. (fst q * fst r, snd q * snd r)" +by(simp add: algebra_simps) lemma mult_fract [simp]: "Fract (a::'a::idom) b * Fract c d = Fract (a * c) (b * d)" -proof - - have "(\x y. fractrel `` {(fst x * fst y, snd x * snd y :: 'a)}) respects2 fractrel" - by (rule equiv_fractrel [THEN congruent2_commuteI]) (simp_all add: algebra_simps) - then show ?thesis by (simp add: Fract_def mult_fract_def UN_fractrel2) -qed +by transfer simp lemma mult_fract_cancel: - assumes "c \ (0::'a)" - shows "Fract (c * a) (c * b) = Fract a b" -proof - - from assms have "Fract c c = Fract 1 1" - by (simp add: Fract_def) - then show ?thesis - by (simp add: mult_fract [symmetric]) -qed + "c \ 0 \ Fract (c * a) (c * b) = Fract a b" +by transfer simp instance proof @@ -188,14 +153,13 @@ lemma Fract_of_nat_eq: "Fract (of_nat k) 1 = of_nat k" by (rule of_nat_fract [symmetric]) -lemma fract_collapse [code_post]: +lemma fract_collapse: "Fract 0 k = 0" "Fract 1 1 = 1" "Fract k 0 = 0" - by (cases "k = 0") - (simp_all add: Zero_fract_def One_fract_def eq_fract Fract_def) +by(transfer; simp)+ -lemma fract_expand [code_unfold]: +lemma fract_expand: "0 = Fract 0 1" "1 = Fract 1 1" by (simp_all add: fract_collapse) @@ -227,19 +191,12 @@ instantiation fract :: (idom) field begin -definition inverse_fract_def: - "inverse q = Abs_fract (\x \ Rep_fract q. - fractrel `` {if fst x = 0 then (0, 1) else (snd x, fst x)})" +lift_definition inverse_fract :: "'a fract \ 'a fract" + is "\x. if fst x = 0 then (0, 1) else (snd x, fst x)" +by(auto simp add: algebra_simps) lemma inverse_fract [simp]: "inverse (Fract a b) = Fract (b::'a::idom) a" -proof - - have *: "\x. (0::'a) = x \ x = 0" - by auto - have "(\x. fractrel `` {if fst x = 0 then (0, 1) else (snd x, fst x :: 'a)}) respects fractrel" - by (auto simp add: congruent_def * algebra_simps) - then show ?thesis - by (simp add: Fract_def inverse_fract_def UN_fractrel) -qed +by transfer simp definition divide_fract_def: "q div r = q * inverse (r:: 'a fract)" @@ -266,16 +223,16 @@ subsubsection \The ordered field of fractions over an ordered idom\ -lemma le_congruent2: - "(\x y::'a \ 'a::linordered_idom. - {(fst x * snd y)*(snd x * snd y) \ (fst y * snd x)*(snd x * snd y)}) - respects2 fractrel" -proof (clarsimp simp add: congruent2_def) - fix a b a' b' c d c' d' :: 'a - assume neq: "b \ 0" "b' \ 0" "d \ 0" "d' \ 0" - assume eq1: "a * b' = a' * b" - assume eq2: "c * d' = c' * d" +instantiation fract :: (linordered_idom) linorder +begin +lemma less_eq_fract_respect: + fixes a b a' b' c d c' d' :: 'a + assumes neq: "b \ 0" "b' \ 0" "d \ 0" "d' \ 0" + assumes eq1: "a * b' = a' * b" + assumes eq2: "c * d' = c' * d" + shows "((a * d) * (b * d) \ (c * b) * (b * d)) \ ((a' * d') * (b' * d') \ (c' * b') * (b' * d'))" +proof - let ?le = "\a b c d. ((a * d) * (b * d) \ (c * b) * (b * d))" { fix a b c d x :: 'a @@ -309,25 +266,18 @@ finally show "?le a b c d = ?le a' b' c' d'" . qed -instantiation fract :: (linordered_idom) linorder -begin - -definition le_fract_def: - "q \ r \ the_elem (\x \ Rep_fract q. \y \ Rep_fract r. - {(fst x * snd y) * (snd x * snd y) \ (fst y * snd x) * (snd x * snd y)})" +lift_definition less_eq_fract :: "'a fract \ 'a fract \ bool" + is "\q r. (fst q * snd r) * (snd q * snd r) \ (fst r * snd q) * (snd q * snd r)" +by (clarsimp simp add: less_eq_fract_respect) definition less_fract_def: "z < (w::'a fract) \ z \ w \ \ w \ z" lemma le_fract [simp]: - assumes "b \ 0" - and "d \ 0" - shows "Fract a b \ Fract c d \ (a * d) * (b * d) \ (c * b) * (b * d)" - by (simp add: Fract_def le_fract_def le_congruent2 UN_fractrel2 assms) + "\ b \ 0; d \ 0 \ \ Fract a b \ Fract c d \ (a * d) * (b * d) \ (c * b) * (b * d)" + by transfer simp lemma less_fract [simp]: - assumes "b \ 0" - and "d \ 0" - shows "Fract a b < Fract c d \ (a * d) * (b * d) < (c * b) * (b * d)" + "\ b \ 0; d \ 0 \ \ Fract a b < Fract c d \ (a * d) * (b * d) < (c * b) * (b * d)" by (simp add: less_fract_def less_le_not_le ac_simps assms) instance @@ -406,14 +356,14 @@ instantiation fract :: (linordered_idom) "{distrib_lattice,abs_if,sgn_if}" begin -definition abs_fract_def: "\q\ = (if q < 0 then -q else (q::'a fract))" +definition abs_fract_def2: "\q\ = (if q < 0 then -q else (q::'a fract))" definition sgn_fract_def: "sgn (q::'a fract) = (if q = 0 then 0 else if 0 < q then 1 else - 1)" theorem abs_fract [simp]: "\Fract a b\ = Fract \a\ \b\" - by (auto simp add: abs_fract_def Zero_fract_def le_less - eq_fract zero_less_mult_iff mult_less_0_iff split: abs_split) +unfolding abs_fract_def2 not_le[symmetric] +by transfer(auto simp add: zero_less_mult_iff le_less) definition inf_fract_def: "(inf :: 'a fract \ 'a fract \ 'a fract) = min" @@ -422,9 +372,7 @@ "(sup :: 'a fract \ 'a fract \ 'a fract) = max" instance - by intro_classes - (auto simp add: abs_fract_def sgn_fract_def - max_min_distrib2 inf_fract_def sup_fract_def) +by intro_classes (simp_all add: abs_fract_def2 sgn_fract_def inf_fract_def sup_fract_def max_min_distrib2) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/IArray.thy --- a/src/HOL/Library/IArray.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/IArray.thy Fri Sep 18 16:42:19 2015 +0100 @@ -13,36 +13,35 @@ lists first. Arrays could be converted back into lists for printing if they were wrapped up in an additional constructor.\ +context +begin + datatype 'a iarray = IArray "'a list" -primrec list_of :: "'a iarray \ 'a list" where +qualified primrec list_of :: "'a iarray \ 'a list" where "list_of (IArray xs) = xs" -hide_const (open) list_of -definition of_fun :: "(nat \ 'a) \ nat \ 'a iarray" where +qualified definition of_fun :: "(nat \ 'a) \ nat \ 'a iarray" where [simp]: "of_fun f n = IArray (map f [0.. nat \ 'a" (infixl "!!" 100) where +qualified definition sub :: "'a iarray \ nat \ 'a" (infixl "!!" 100) where [simp]: "as !! n = IArray.list_of as ! n" -hide_const (open) sub -definition length :: "'a iarray \ nat" where +qualified definition length :: "'a iarray \ nat" where [simp]: "length as = List.length (IArray.list_of as)" -hide_const (open) length -fun all :: "('a \ bool) \ 'a iarray \ bool" where +qualified fun all :: "('a \ bool) \ 'a iarray \ bool" where "all p (IArray as) = (ALL a : set as. p a)" -hide_const (open) all -fun exists :: "('a \ bool) \ 'a iarray \ bool" where +qualified fun exists :: "('a \ bool) \ 'a iarray \ bool" where "exists p (IArray as) = (EX a : set as. p a)" -hide_const (open) exists lemma list_of_code [code]: "IArray.list_of as = map (\n. as !! n) [0 ..< IArray.length as]" by (cases as) (simp add: map_nth) +end + subsection "Code Generation" @@ -86,10 +85,13 @@ "HOL.equal as bs \ HOL.equal (IArray.list_of as) (IArray.list_of bs)" by (cases as, cases bs) (simp add: equal) -primrec tabulate :: "integer \ (integer \ 'a) \ 'a iarray" where +context +begin + +qualified primrec tabulate :: "integer \ (integer \ 'a) \ 'a iarray" where "tabulate (n, f) = IArray (map (f \ integer_of_nat) [0.. nat_of_integer)" @@ -98,10 +100,13 @@ code_printing constant IArray.tabulate \ (SML) "Vector.tabulate" -primrec sub' :: "'a iarray \ integer \ 'a" where +context +begin + +qualified primrec sub' :: "'a iarray \ integer \ 'a" where [code del]: "sub' (as, n) = IArray.list_of as ! nat_of_integer n" -hide_const (open) sub' +end lemma [code]: "IArray.sub' (IArray as, n) = as ! nat_of_integer n" @@ -114,10 +119,13 @@ code_printing constant IArray.sub' \ (SML) "Vector.sub" -definition length' :: "'a iarray \ integer" where +context +begin + +qualified definition length' :: "'a iarray \ integer" where [code del, simp]: "length' as = integer_of_nat (List.length (IArray.list_of as))" -hide_const (open) length' +end lemma [code]: "IArray.length' (IArray as) = integer_of_nat (List.length as)" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Library.thy --- a/src/HOL/Library/Library.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Library.thy Fri Sep 18 16:42:19 2015 +0100 @@ -45,6 +45,7 @@ More_List Multiset_Order Numeral_Type + Omega_Words_Fun OptionalSugar Option_ord Order_Continuity diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Multiset.thy --- a/src/HOL/Library/Multiset.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Multiset.thy Fri Sep 18 16:42:19 2015 +0100 @@ -1408,14 +1408,14 @@ proof (rule properties_for_sort_key) from mset_equal show "mset ys = mset xs" by simp - from `sorted (map f ys)` + from \sorted (map f ys)\ show "sorted (map f ys)" . show "[x\ys . f k = f x] = [x\xs . f k = f x]" if "k \ set ys" for k proof - from mset_equal have set_equal: "set xs = set ys" by (rule mset_eq_setD) with that have "insert k (set ys) = set ys" by auto - with `inj_on f (set xs)` have inj: "inj_on f (insert k (set ys))" + with \inj_on f (set xs)\ have inj: "inj_on f (insert k (set ys))" by (simp add: set_equal) from inj have "[x\ys . f k = f x] = filter (HOL.eq k) ys" by (auto intro!: inj_on_filter_key_eq) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Old_SMT/old_smt_real.ML --- a/src/HOL/Library/Old_SMT/old_smt_real.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Old_SMT/old_smt_real.ML Fri Sep 18 16:42:19 2015 +0100 @@ -114,8 +114,10 @@ "x + y = y + x" by auto} -val real_linarith_proc = Simplifier.simproc_global @{theory} "fast_real_arith" [ - "(m::real) < n", "(m::real) <= n", "(m::real) = n"] Lin_Arith.simproc +val real_linarith_proc = + Simplifier.make_simproc @{context} "fast_real_arith" + {lhss = [@{term "(m::real) < n"}, @{term "(m::real) \ n"}, @{term "(m::real) = n"}], + proc = K Lin_Arith.simproc, identifier = []} (* setup *) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Old_SMT/old_z3_proof_tools.ML --- a/src/HOL/Library/Old_SMT/old_z3_proof_tools.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Old_SMT/old_z3_proof_tools.ML Fri Sep 18 16:42:19 2015 +0100 @@ -304,9 +304,9 @@ fun dest_binop ((c as Const _) $ t $ u) = (c, t, u) | dest_binop t = raise TERM ("dest_binop", [t]) - fun prove_antisym_le ctxt t = + fun prove_antisym_le ctxt ct = let - val (le, r, s) = dest_binop t + val (le, r, s) = dest_binop (Thm.term_of ct) val less = Const (@{const_name less}, Term.fastype_of le) val prems = Simplifier.prems_of ctxt in @@ -318,9 +318,9 @@ end handle THM _ => NONE - fun prove_antisym_less ctxt t = + fun prove_antisym_less ctxt ct = let - val (less, r, s) = dest_binop (HOLogic.dest_not t) + val (less, r, s) = dest_binop (HOLogic.dest_not (Thm.term_of ct)) val le = Const (@{const_name less_eq}, Term.fastype_of less) val prems = Simplifier.prems_of ctxt in @@ -343,12 +343,15 @@ addsimps @{thms z3div_def} addsimps @{thms z3mod_def} addsimprocs [@{simproc numeral_divmod}] addsimprocs [ - Simplifier.simproc_global @{theory} "fast_int_arith" [ - "(m::int) < n", "(m::int) <= n", "(m::int) = n"] Lin_Arith.simproc, - Simplifier.simproc_global @{theory} "antisym_le" ["(x::'a::order) <= y"] - prove_antisym_le, - Simplifier.simproc_global @{theory} "antisym_less" ["~ (x::'a::linorder) < y"] - prove_antisym_less]) + Simplifier.make_simproc @{context} "fast_int_arith" + {lhss = [@{term "(m::int) < n"}, @{term "(m::int) \ n"}, @{term "(m::int) = n"}], + proc = K Lin_Arith.simproc, identifier = []}, + Simplifier.make_simproc @{context} "antisym_le" + {lhss = [@{term "(x::'a::order) \ y"}], + proc = K prove_antisym_le, identifier = []}, + Simplifier.make_simproc @{context} "antisym_less" + {lhss = [@{term "\ (x::'a::linorder) < y"}], + proc = K prove_antisym_less, identifier = []}]) structure Simpset = Generic_Data ( diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Omega_Words_Fun.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Library/Omega_Words_Fun.thy Fri Sep 18 16:42:19 2015 +0100 @@ -0,0 +1,971 @@ +(* + Author: Stefan Merz + Author: Salomon Sickert + Author: Julian Brunner + Author: Peter Lammich +*) + +section \$\omega$-words\ + +theory Omega_Words_Fun + +imports Infinite_Set +begin + +text \Note: This theory is based on Stefan Merz's work.\ + +text \ + Automata recognize languages, which are sets of words. For the + theory of $\omega$-automata, we are mostly interested in + $\omega$-words, but it is sometimes useful to reason about + finite words, too. We are modeling finite words as lists; this + lets us benefit from the existing library. Other formalizations + could be investigated, such as representing words as functions + whose domains are initial intervals of the natural numbers. +\ + + +subsection \Type declaration and elementary operations\ + +text \ + We represent $\omega$-words as functions from the natural numbers + to the alphabet type. Other possible formalizations include + a coinductive definition or a uniform encoding of finite and + infinite words, as studied by M\"uller et al. +\ + +type_synonym + 'a word = "nat \ 'a" + +text \ + We can prefix a finite word to an $\omega$-word, and a way + to obtain an $\omega$-word from a finite, non-empty word is by + $\omega$-iteration. +\ + +definition + conc :: "['a list, 'a word] \ 'a word" (infixr "conc" 65) + where "w conc x == \n. if n < length w then w!n else x (n - length w)" + +definition + iter :: "'a list \ 'a word" + where "iter w == if w = [] then undefined else (\n. w!(n mod (length w)))" + +notation (xsymbols) + conc (infixr "\" 65) and + iter ("(_\<^sup>\)" [1000]) + +lemma conc_empty[simp]: "[] \ w = w" + unfolding conc_def by auto + +lemma conc_fst[simp]: "n < length w \ (w \ x) n = w!n" + by (simp add: conc_def) + +lemma conc_snd[simp]: "\(n < length w) \ (w \ x) n = x (n - length w)" + by (simp add: conc_def) + +lemma iter_nth [simp]: "0 < length w \ w\<^sup>\ n = w!(n mod (length w))" + by (simp add: iter_def) + +lemma conc_conc[simp]: "u \ v \ w = (u @ v) \ w" (is "?lhs = ?rhs") +proof + fix n + have u: "n < length u \ ?lhs n = ?rhs n" + by (simp add: conc_def nth_append) + have v: "\ \(n < length u); n < length u + length v \ \ ?lhs n = ?rhs n" + by (simp add: conc_def nth_append, arith) + have w: "\(n < length u + length v) \ ?lhs n = ?rhs n" + by (simp add: conc_def nth_append, arith) + from u v w show "?lhs n = ?rhs n" by blast +qed + +lemma range_conc[simp]: "range (w\<^sub>1 \ w\<^sub>2) = set w\<^sub>1 \ range w\<^sub>2" +proof (intro equalityI subsetI) + fix a + assume "a \ range (w\<^sub>1 \ w\<^sub>2)" + then obtain i where 1: "a = (w\<^sub>1 \ w\<^sub>2) i" by auto + then show "a \ set w\<^sub>1 \ range w\<^sub>2" + unfolding 1 by (cases "i < length w\<^sub>1") simp_all +next + fix a + assume a: "a \ set w\<^sub>1 \ range w\<^sub>2" + then show "a \ range (w\<^sub>1 \ w\<^sub>2)" + proof + assume "a \ set w\<^sub>1" + then obtain i where 1: "i < length w\<^sub>1" "a = w\<^sub>1 ! i" + using in_set_conv_nth by metis + show ?thesis + proof + show "a = (w\<^sub>1 \ w\<^sub>2) i" using 1 by auto + show "i \ UNIV" by rule + qed + next + assume "a \ range w\<^sub>2" + then obtain i where 1: "a = w\<^sub>2 i" by auto + show ?thesis + proof + show "a = (w\<^sub>1 \ w\<^sub>2) (length w\<^sub>1 + i)" using 1 by simp + show "length w\<^sub>1 + i \ UNIV" by rule + qed + qed +qed + + +lemma iter_unroll: "0 < length w \ w\<^sup>\ = w \ w\<^sup>\" + by (rule ext) (simp add: conc_def mod_geq) + + +subsection \Subsequence, Prefix, and Suffix\ + +definition suffix :: "[nat, 'a word] \ 'a word" + where "suffix k x \ \n. x (k+n)" + +definition subsequence :: "'a word \ nat \ nat \ 'a list" ("_ [_ \ _]" 900) + where "subsequence w i j \ map w [i.. 'a word \ 'a list" + where "prefix n w \ subsequence w 0 n" + +lemma suffix_nth [simp]: "(suffix k x) n = x (k+n)" + by (simp add: suffix_def) + +lemma suffix_0 [simp]: "suffix 0 x = x" + by (simp add: suffix_def) + +lemma suffix_suffix [simp]: "suffix m (suffix k x) = suffix (k+m) x" + by (rule ext) (simp add: suffix_def add.assoc) + +lemma subsequence_append: "prefix (i + j) w = prefix i w @ (w [i \ i + j])" + unfolding map_append[symmetric] upt_add_eq_append[OF le0] subsequence_def .. + +lemma subsequence_drop[simp]: "drop i (w [j \ k]) = w [j + i \ k]" + by (simp add: subsequence_def drop_map) + +lemma subsequence_empty[simp]: "w [i \ j] = [] \ j \ i" + by (auto simp add: subsequence_def) + +lemma subsequence_length[simp]: "length (subsequence w i j) = j - i" + by (simp add: subsequence_def) + +lemma subsequence_nth[simp]: "k < j - i \ (w [i \ j]) ! k = w (i + k)" + unfolding subsequence_def + by auto + +lemma subseq_to_zero[simp]: "w[i\0] = []" + by simp + +lemma subseq_to_smaller[simp]: "i\j \ w[i\j] = []" + by simp + +lemma subseq_to_Suc[simp]: "i\j \ w [i \ Suc j] = w [ i \ j ] @ [w j]" + by (auto simp: subsequence_def) + +lemma subsequence_singleton[simp]: "w [i \ Suc i] = [w i]" + by (auto simp: subsequence_def) + + +lemma subsequence_prefix_suffix: "prefix (j - i) (suffix i w) = w [i \ j]" +proof (cases "i \ j") + case True + have "w [i \ j] = map w (map (\n. n + i) [0.. = map (\n. w (n + i)) [0.. (suffix n x)" + by (rule ext) (simp add: subsequence_def conc_def) + +declare prefix_suffix[symmetric, simp] + + +lemma word_split: obtains v\<^sub>1 v\<^sub>2 where "v = v\<^sub>1 \ v\<^sub>2" "length v\<^sub>1 = k" +proof + show "v = prefix k v \ suffix k v" + by (rule prefix_suffix) + show "length (prefix k v) = k" + by simp +qed + + +lemma set_subsequence[simp]: "set (w[i\j]) = w`{i.. k]) = w [j \ min (j + i) k]" + by (simp add: subsequence_def take_map min_def) + +lemma subsequence_shift[simp]: "(suffix i w) [j \ k] = w [i + j \ i + k]" + by (metis add_diff_cancel_left subsequence_prefix_suffix suffix_suffix) + +lemma suffix_subseq_join[simp]: "i \ j \ v [i \ j] \ suffix j v = suffix i v" + by (metis (no_types, lifting) Nat.add_0_right le_add_diff_inverse prefix_suffix + subsequence_shift suffix_suffix) + +lemma prefix_conc_fst[simp]: + assumes "j \ length w" + shows "prefix j (w \ w') = take j w" +proof - + have "\i < j. (prefix j (w \ w')) ! i = (take j w) ! i" + using assms by (simp add: conc_fst subsequence_def) + thus ?thesis + by (simp add: assms list_eq_iff_nth_eq min.absorb2) +qed + +lemma prefix_conc_snd[simp]: + assumes "n \ length u" + shows "prefix n (u \ v) = u @ prefix (n - length u) v" +proof (intro nth_equalityI allI impI) + show "length (prefix n (u \ v)) = length (u @ prefix (n - length u) v)" + using assms by simp + fix i + assume "i < length (prefix n (u \ v))" + then show "prefix n (u \ v) ! i = (u @ prefix (n - length u) v) ! i" + by (cases "i < length u") (auto simp: nth_append) +qed + +lemma prefix_conc_length[simp]: "prefix (length w) (w \ w') = w" + by simp + +lemma suffix_conc_fst[simp]: + assumes "n \ length u" + shows "suffix n (u \ v) = drop n u \ v" +proof + show "suffix n (u \ v) i = (drop n u \ v) i" for i + using assms by (cases "n + i < length u") (auto simp: algebra_simps) +qed + +lemma suffix_conc_snd[simp]: + assumes "n \ length u" + shows "suffix n (u \ v) = suffix (n - length u) v" +proof + show "suffix n (u \ v) i = suffix (n - length u) v i" for i + using assms by simp +qed + +lemma suffix_conc_length[simp]: "suffix (length w) (w \ w') = w'" + unfolding conc_def by force + +lemma concat_eq[iff]: + assumes "length v\<^sub>1 = length v\<^sub>2" + shows "v\<^sub>1 \ u\<^sub>1 = v\<^sub>2 \ u\<^sub>2 \ v\<^sub>1 = v\<^sub>2 \ u\<^sub>1 = u\<^sub>2" + (is "?lhs \ ?rhs") +proof + assume ?lhs + then have 1: "(v\<^sub>1 \ u\<^sub>1) i = (v\<^sub>2 \ u\<^sub>2) i" for i by auto + show ?rhs + proof (intro conjI ext nth_equalityI allI impI) + show "length v\<^sub>1 = length v\<^sub>2" by (rule assms(1)) + next + fix i + assume 2: "i < length v\<^sub>1" + have 3: "i < length v\<^sub>2" using assms(1) 2 by simp + show "v\<^sub>1 ! i = v\<^sub>2 ! i" using 1[of i] 2 3 by simp + next + show "u\<^sub>1 i = u\<^sub>2 i" for i + using 1[of "length v\<^sub>1 + i"] assms(1) by simp + qed +next + assume ?rhs + then show ?lhs by simp +qed + +lemma same_concat_eq[iff]: "u \ v = u \ w \ v = w" + by simp + +lemma comp_concat[simp]: "f \ u \ v = map f u \ (f \ v)" +proof + fix i + show "(f \ u \ v) i = (map f u \ (f \ v)) i" + by (cases "i < length u") simp_all +qed + + +subsection \Prepending\ + +primrec build :: "'a \ 'a word \ 'a word" (infixr "##" 65) + where "(a ## w) 0 = a" | "(a ## w) (Suc i) = w i" + +lemma build_eq[iff]: "a\<^sub>1 ## w\<^sub>1 = a\<^sub>2 ## w\<^sub>2 \ a\<^sub>1 = a\<^sub>2 \ w\<^sub>1 = w\<^sub>2" +proof + assume 1: "a\<^sub>1 ## w\<^sub>1 = a\<^sub>2 ## w\<^sub>2" + have 2: "(a\<^sub>1 ## w\<^sub>1) i = (a\<^sub>2 ## w\<^sub>2) i" for i + using 1 by auto + show "a\<^sub>1 = a\<^sub>2 \ w\<^sub>1 = w\<^sub>2" + proof (intro conjI ext) + show "a\<^sub>1 = a\<^sub>2" + using 2[of "0"] by simp + show "w\<^sub>1 i = w\<^sub>2 i" for i + using 2[of "Suc i"] by simp + qed +next + assume 1: "a\<^sub>1 = a\<^sub>2 \ w\<^sub>1 = w\<^sub>2" + show "a\<^sub>1 ## w\<^sub>1 = a\<^sub>2 ## w\<^sub>2" using 1 by simp +qed + +lemma build_cons[simp]: "(a # u) \ v = a ## u \ v" +proof + fix i + show "((a # u) \ v) i = (a ## u \ v) i" + proof (cases i) + case 0 + show ?thesis unfolding 0 by simp + next + case (Suc j) + show ?thesis unfolding Suc by (cases "j < length u", simp+) + qed +qed + +lemma build_append[simp]: "(w @ a # u) \ v = w \ a ## u \ v" + unfolding conc_conc[symmetric] by simp + +lemma build_first[simp]: "w 0 ## suffix (Suc 0) w = w" +proof + show "(w 0 ## suffix (Suc 0) w) i = w i" for i + by (cases i) simp_all +qed + +lemma build_split[intro]: "w = w 0 ## suffix 1 w" + by simp + +lemma build_range[simp]: "range (a ## w) = insert a (range w)" +proof safe + show "(a ## w) i \ range w \ (a ## w) i = a" for i + by (cases i) auto + show "a \ range (a ## w)" + proof (rule range_eqI) + show "a = (a ## w) 0" by simp + qed + show "w i \ range (a ## w)" for i + proof (rule range_eqI) + show "w i = (a ## w) (Suc i)" by simp + qed +qed + +lemma suffix_singleton_suffix[simp]: "w i ## suffix (Suc i) w = suffix i w" + using suffix_subseq_join[of i "Suc i" w] + by simp + +text \Find the first occurrence of a letter from a given set\ +lemma word_first_split_set: + assumes "A \ range w \ {}" + obtains u a v where "w = u \ [a] \ v" "A \ set u = {}" "a \ A" +proof - + def i \ "LEAST i. w i \ A" + show ?thesis + proof + show "w = prefix i w \ [w i] \ suffix (Suc i) w" + by simp + show "A \ set (prefix i w) = {}" + apply safe + subgoal premises prems for a + proof - + from prems obtain k where 3: "k < i" "w k = a" + by auto + have 4: "w k \ A" + using not_less_Least 3(1) unfolding i_def . + show ?thesis + using prems(1) 3(2) 4 by auto + qed + done + show "w i \ A" + using LeastI assms(1) unfolding i_def by fast + qed +qed + + +subsection \The limit set of an $\omega$-word\ + +text \ + The limit set (also called infinity set) of an $\omega$-word + is the set of letters that appear infinitely often in the word. + This set plays an important role in defining acceptance conditions + of $\omega$-automata. +\ + +definition limit :: "'a word \ 'a set" + where "limit x \ {a . \\<^sub>\n . x n = a}" + +lemma limit_iff_frequent: "a \ limit x \ (\\<^sub>\n . x n = a)" + by (simp add: limit_def) + +text \ + The following is a different way to define the limit, + using the reverse image, making the laws about reverse + image applicable to the limit set. + (Might want to change the definition above?) +\ + +lemma limit_vimage: "(a \ limit x) = infinite (x -` {a})" + by (simp add: limit_def Inf_many_def vimage_def) + +lemma two_in_limit_iff: + "({a, b} \ limit x) = + ((\n. x n =a ) \ (\n. x n = a \ (\m>n. x m = b)) \ (\m. x m = b \ (\n>m. x n = a)))" + (is "?lhs = (?r1 \ ?r2 \ ?r3)") +proof + assume lhs: "?lhs" + hence 1: "?r1" by (auto simp: limit_def elim: INFM_EX) + from lhs have "\n. \m>n. x m = b" by (auto simp: limit_def INFM_nat) + hence 2: "?r2" by simp + from lhs have "\m. \n>m. x n = a" by (auto simp: limit_def INFM_nat) + hence 3: "?r3" by simp + from 1 2 3 show "?r1 \ ?r2 \ ?r3" by simp +next + assume "?r1 \ ?r2 \ ?r3" + hence 1: "?r1" and 2: "?r2" and 3: "?r3" by simp+ + have infa: "\m. \n\m. x n = a" + proof + fix m + show "\n\m. x n = a" (is "?A m") + proof (induct m) + from 1 show "?A 0" by simp + next + fix m + assume ih: "?A m" + then obtain n where n: "n \ m" "x n = a" by auto + with 2 obtain k where k: "k>n" "x k = b" by auto + with 3 obtain l where l: "l>k" "x l = a" by auto + from n k l have "l \ Suc m" by auto + with l show "?A (Suc m)" by auto + qed + qed + hence infa': "\\<^sub>\n. x n = a" by (simp add: INFM_nat_le) + have "\n. \m>n. x m = b" + proof + fix n + from infa obtain k where k1: "k\n" and k2: "x k = a" by auto + from 2 k2 obtain l where l1: "l>k" and l2: "x l = b" by auto + from k1 l1 have "l > n" by auto + with l2 show "\m>n. x m = b" by auto + qed + hence "\\<^sub>\m. x m = b" by (simp add: INFM_nat) + with infa' show "?lhs" by (auto simp: limit_def) +qed + +text \ + For $\omega$-words over a finite alphabet, the limit set is + non-empty. Moreover, from some position onward, any such word + contains only letters from its limit set. +\ + +lemma limit_nonempty: + assumes fin: "finite (range x)" + shows "\a. a \ limit x" +proof - + from fin obtain a where "a \ range x \ infinite (x -` {a})" + by (rule inf_img_fin_domE) auto + hence "a \ limit x" + by (auto simp add: limit_vimage) + thus ?thesis .. +qed + +lemmas limit_nonemptyE = limit_nonempty[THEN exE] + +lemma limit_inter_INF: + assumes hyp: "limit w \ S \ {}" + shows "\\<^sub>\ n. w n \ S" +proof - + from hyp obtain x where "\\<^sub>\ n. w n = x" and "x \ S" + by (auto simp add: limit_def) + thus ?thesis + by (auto elim: INFM_mono) +qed + +text \ + The reverse implication is true only if $S$ is finite. +\ + +lemma INF_limit_inter: + assumes hyp: "\\<^sub>\ n. w n \ S" + and fin: "finite (S \ range w)" + shows "\a. a \ limit w \ S" +proof (rule ccontr) + assume contra: "\(\a. a \ limit w \ S)" + hence "\a\S. finite {n. w n = a}" + by (auto simp add: limit_def Inf_many_def) + with fin have "finite (UN a:S \ range w. {n. w n = a})" + by auto + moreover + have "(UN a:S \ range w. {n. w n = a}) = {n. w n \ S}" + by auto + moreover + note hyp + ultimately show "False" + by (simp add: Inf_many_def) +qed + +lemma fin_ex_inf_eq_limit: "finite A \ (\\<^sub>\i. w i \ A) \ limit w \ A \ {}" + by (metis INF_limit_inter equals0D finite_Int limit_inter_INF) + +lemma limit_in_range_suffix: "limit x \ range (suffix k x)" +proof + fix a + assume "a \ limit x" + then obtain l where + kl: "k < l" and xl: "x l = a" + by (auto simp add: limit_def INFM_nat) + from kl obtain m where "l = k+m" + by (auto simp add: less_iff_Suc_add) + with xl show "a \ range (suffix k x)" + by auto +qed + +lemma limit_in_range: "limit r \ range r" + using limit_in_range_suffix[of r 0] by simp + +lemmas limit_in_range_suffixD = limit_in_range_suffix[THEN subsetD] + +lemma limit_subset: "limit f \ f ` {n..}" + using limit_in_range_suffix[of f n] unfolding suffix_def by auto + +theorem limit_is_suffix: + assumes fin: "finite (range x)" + shows "\k. limit x = range (suffix k x)" +proof - + have "\k. range (suffix k x) \ limit x" + proof - + -- "The set of letters that are not in the limit is certainly finite." + from fin have "finite (range x - limit x)" + by simp + -- "Moreover, any such letter occurs only finitely often" + moreover + have "\a \ range x - limit x. finite (x -` {a})" + by (auto simp add: limit_vimage) + -- "Thus, there are only finitely many occurrences of such letters." + ultimately have "finite (UN a : range x - limit x. x -` {a})" + by (blast intro: finite_UN_I) + -- "Therefore these occurrences are within some initial interval." + then obtain k where "(UN a : range x - limit x. x -` {a}) \ {..m. k \ m \ x m \ limit x" + by (auto simp add: limit_vimage) + hence "range (suffix k x) \ limit x" + by auto + thus ?thesis .. + qed + then obtain k where "range (suffix k x) \ limit x" .. + with limit_in_range_suffix + have "limit x = range (suffix k x)" + by (rule subset_antisym) + thus ?thesis .. +qed + +theorems limit_is_suffixE = limit_is_suffix[THEN exE] + + +text \ + The limit set enjoys some simple algebraic laws with respect + to concatenation, suffixes, iteration, and renaming. +\ + +theorem limit_conc [simp]: "limit (w \ x) = limit x" +proof (auto) + fix a assume a: "a \ limit (w \ x)" + have "\m. \n. m x n = a" + proof + fix m + from a obtain n where "m + length w < n \ (w \ x) n = a" + by (auto simp add: limit_def Inf_many_def infinite_nat_iff_unbounded) + hence "m < n - length w \ x (n - length w) = a" + by (auto simp add: conc_def) + thus "\n. m x n = a" .. + qed + hence "infinite {n . x n = a}" + by (simp add: infinite_nat_iff_unbounded) + thus "a \ limit x" + by (simp add: limit_def Inf_many_def) +next + fix a assume a: "a \ limit x" + have "\m. length w < m \ (\n. m (w \ x) n = a)" + proof (clarify) + fix m + assume m: "length w < m" + with a obtain n where "m - length w < n \ x n = a" + by (auto simp add: limit_def Inf_many_def infinite_nat_iff_unbounded) + with m have "m < n + length w \ (w \ x) (n + length w) = a" + by (simp add: conc_def, arith) + thus "\n. m (w \ x) n = a" .. + qed + hence "infinite {n . (w \ x) n = a}" + by (simp add: unbounded_k_infinite) + thus "a \ limit (w \ x)" + by (simp add: limit_def Inf_many_def) +qed + +theorem limit_suffix [simp]: "limit (suffix n x) = limit x" +proof - + have "x = (prefix n x) \ (suffix n x)" + by (simp add: prefix_suffix) + hence "limit x = limit (prefix n x \ suffix n x)" + by simp + also have "\ = limit (suffix n x)" + by (rule limit_conc) + finally show ?thesis + by (rule sym) +qed + +theorem limit_iter [simp]: + assumes nempty: "0 < length w" + shows "limit w\<^sup>\ = set w" +proof + have "limit w\<^sup>\ \ range w\<^sup>\" + by (auto simp add: limit_def dest: INFM_EX) + also from nempty have "\ \ set w" + by auto + finally show "limit w\<^sup>\ \ set w" . +next + { + fix a assume a: "a \ set w" + then obtain k where k: "k < length w \ w!k = a" + by (auto simp add: set_conv_nth) + -- "the following bound is terrible, but it simplifies the proof" + from nempty k have "\m. w\<^sup>\ ((Suc m)*(length w) + k) = a" + by (simp add: mod_add_left_eq) + moreover + -- "why is the following so hard to prove??" + have "\m. m < (Suc m)*(length w) + k" + proof + fix m + from nempty have "1 \ length w" by arith + hence "m*1 \ m*length w" by simp + hence "m \ m*length w" by simp + with nempty have "m < length w + (m*length w) + k" by arith + thus "m < (Suc m)*(length w) + k" by simp + qed + moreover note nempty + ultimately have "a \ limit w\<^sup>\" + by (auto simp add: limit_iff_frequent INFM_nat) + } + then show "set w \ limit w\<^sup>\" by auto +qed + +lemma limit_o [simp]: + assumes a: "a \ limit w" + shows "f a \ limit (f \ w)" +proof - + from a + have "\\<^sub>\n. w n = a" + by (simp add: limit_iff_frequent) + hence "\\<^sub>\n. f (w n) = f a" + by (rule INFM_mono, simp) + thus "f a \ limit (f \ w)" + by (simp add: limit_iff_frequent) +qed + +text \ + The converse relation is not true in general: $f(a)$ can be in the + limit of $f \circ w$ even though $a$ is not in the limit of $w$. + However, @{text limit} commutes with renaming if the function is + injective. More generally, if $f(a)$ is the image of only finitely + many elements, some of these must be in the limit of $w$. +\ + +lemma limit_o_inv: + assumes fin: "finite (f -` {x})" + and x: "x \ limit (f \ w)" + shows "\a \ (f -` {x}). a \ limit w" +proof (rule ccontr) + assume contra: "\ ?thesis" + -- "hence, every element in the pre-image occurs only finitely often" + then have "\a \ (f -` {x}). finite {n. w n = a}" + by (simp add: limit_def Inf_many_def) + -- "so there are only finitely many occurrences of any such element" + with fin have "finite (\ a \ (f -` {x}). {n. w n = a})" + by auto + -- \these are precisely those positions where $x$ occurs in $f \circ w$\ + moreover + have "(\ a \ (f -` {x}). {n. w n = a}) = {n. f(w n) = x}" + by auto + ultimately + -- "so $x$ can occur only finitely often in the translated word" + have "finite {n. f(w n) = x}" + by simp + -- \\ldots\ which yields a contradiction\ + with x show "False" + by (simp add: limit_def Inf_many_def) +qed + +theorem limit_inj [simp]: + assumes inj: "inj f" + shows "limit (f \ w) = f ` (limit w)" +proof + show "f ` limit w \ limit (f \ w)" + by auto + show "limit (f \ w) \ f ` limit w" + proof + fix x + assume x: "x \ limit (f \ w)" + from inj have "finite (f -` {x})" + by (blast intro: finite_vimageI) + with x obtain a where a: "a \ (f -` {x}) \ a \ limit w" + by (blast dest: limit_o_inv) + thus "x \ f ` (limit w)" + by auto + qed +qed + +lemma limit_inter_empty: + assumes fin: "finite (range w)" + assumes hyp: "limit w \ S = {}" + shows "\\<^sub>\n. w n \ S" +proof - + from fin obtain k where k_def: "limit w = range (suffix k w)" + using limit_is_suffix by blast + have "w (k + k') \ S" for k' + using hyp unfolding k_def suffix_def image_def by blast + thus ?thesis + unfolding MOST_nat_le using le_Suc_ex by blast +qed + +text \If the limit is the suffix of the sequence's range, + we may increase the suffix index arbitrarily\ +lemma limit_range_suffix_incr: + assumes "limit r = range (suffix i r)" + assumes "j\i" + shows "limit r = range (suffix j r)" + (is "?lhs = ?rhs") +proof - + have "?lhs = range (suffix i r)" + using assms by simp + moreover + have "\ \ ?rhs" using \j\i\ + by (metis (mono_tags, lifting) assms(2) + image_subsetI le_Suc_ex range_eqI suffix_def suffix_suffix) + moreover + have "\ \ ?lhs" by (rule limit_in_range_suffix) + ultimately + show "?lhs = ?rhs" + by (metis antisym_conv limit_in_range_suffix) +qed + +text \For two finite sequences, we can find a common suffix index such + that the limits can be represented as these suffixes' ranges.\ +lemma common_range_limit: + assumes "finite (range x)" + and "finite (range y)" + obtains i where "limit x = range (suffix i x)" + and "limit y = range (suffix i y)" +proof - + obtain i j where 1: "limit x = range (suffix i x)" + and 2: "limit y = range (suffix j y)" + using assms limit_is_suffix by metis + have "limit x = range (suffix (max i j) x)" + and "limit y = range (suffix (max i j) y)" + using limit_range_suffix_incr[OF 1] limit_range_suffix_incr[OF 2] + by auto + thus ?thesis + using that by metis +qed + + +subsection \Index sequences and piecewise definitions\ + +text \ + A word can be defined piecewise: given a sequence of words $w_0, w_1, \ldots$ + and a strictly increasing sequence of integers $i_0, i_1, \ldots$ where $i_0=0$, + a single word is obtained by concatenating subwords of the $w_n$ as given by + the integers: the resulting word is + \[ + (w_0)_{i_0} \ldots (w_0)_{i_1-1} (w_1)_{i_1} \ldots (w_1)_{i_2-1} \ldots + \] + We prepare the field by proving some trivial facts about such sequences of + indexes. +\ + +definition idx_sequence :: "nat word \ bool" + where "idx_sequence idx \ (idx 0 = 0) \ (\n. idx n < idx (Suc n))" + +lemma idx_sequence_less: + assumes iseq: "idx_sequence idx" + shows "idx n < idx (Suc(n+k))" +proof (induct k) + from iseq show "idx n < idx (Suc (n + 0))" + by (simp add: idx_sequence_def) +next + fix k + assume ih: "idx n < idx (Suc(n+k))" + from iseq have "idx (Suc(n+k)) < idx (Suc(n + Suc k))" + by (simp add: idx_sequence_def) + with ih show "idx n < idx (Suc(n + Suc k))" + by (rule less_trans) +qed + +lemma idx_sequence_inj: + assumes iseq: "idx_sequence idx" + and eq: "idx m = idx n" + shows "m = n" +proof (rule nat_less_cases) + assume "n n" + shows "idx m \ idx n" +proof (cases "m=n") + case True + thus ?thesis by simp +next + case False + with m have "m < n" by simp + then obtain k where "n = Suc(m+k)" + by (auto simp add: less_iff_Suc_add) + with iseq have "idx m < idx n" + by (simp add: idx_sequence_less) + thus ?thesis by simp +qed + +text \ + Given an index sequence, every natural number is contained in the + interval defined by two adjacent indexes, and in fact this interval + is determined uniquely. +\ + +lemma idx_sequence_idx: + assumes "idx_sequence idx" + shows "idx k \ {idx k ..< idx (Suc k)}" +using assms by (auto simp add: idx_sequence_def) + +lemma idx_sequence_interval: + assumes iseq: "idx_sequence idx" + shows "\k. n \ {idx k ..< idx (Suc k) }" + (is "?P n" is "\k. ?in n k") +proof (induct n) + from iseq have "0 = idx 0" + by (simp add: idx_sequence_def) + moreover + from iseq have "idx 0 \ {idx 0 ..< idx (Suc 0) }" + by (rule idx_sequence_idx) + ultimately + show "?P 0" by auto +next + fix n + assume "?P n" + then obtain k where k: "?in n k" .. + show "?P (Suc n)" + proof (cases "Suc n < idx (Suc k)") + case True + with k have "?in (Suc n) k" + by simp + thus ?thesis .. + next + case False + with k have "Suc n = idx (Suc k)" + by auto + with iseq have "?in (Suc n) (Suc k)" + by (simp add: idx_sequence_def) + thus ?thesis .. + qed +qed + +lemma idx_sequence_interval_unique: + assumes iseq: "idx_sequence idx" + and k: "n \ {idx k ..< idx (Suc k)}" + and m: "n \ {idx m ..< idx (Suc m)}" + shows "k = m" +proof (rule nat_less_cases) + assume "k < m" + hence "Suc k \ m" by simp + with iseq have "idx (Suc k) \ idx m" + by (rule idx_sequence_mono) + with m have "idx (Suc k) \ n" + by auto + with k have "False" + by simp + thus ?thesis .. +next + assume "m < k" + hence "Suc m \ k" by simp + with iseq have "idx (Suc m) \ idx k" + by (rule idx_sequence_mono) + with k have "idx (Suc m) \ n" + by auto + with m have "False" + by simp + thus ?thesis .. +qed (simp) + +lemma idx_sequence_unique_interval: + assumes iseq: "idx_sequence idx" + shows "\! k. n \ {idx k ..< idx (Suc k) }" +proof (rule ex_ex1I) + from iseq show "\k. n \ {idx k ..< idx (Suc k)}" + by (rule idx_sequence_interval) +next + fix k y + assume "n \ {idx k.. {idx y.. + Now we can define the piecewise construction of a word using + an index sequence. +\ + +definition merge :: "'a word word \ nat word \ 'a word" + where "merge ws idx \ \n. let i = THE i. n \ {idx i ..< idx (Suc i) } in ws i n" + +lemma merge: + assumes idx: "idx_sequence idx" + and n: "n \ {idx i ..< idx (Suc i)}" + shows "merge ws idx n = ws i n" +proof - + from n have "(THE k. n \ {idx k ..< idx (Suc k) }) = i" + by (rule the_equality[OF _ sym[OF idx_sequence_interval_unique[OF idx n]]]) simp + thus ?thesis + by (simp add: merge_def Let_def) +qed + +lemma merge0: + assumes idx: "idx_sequence idx" + shows "merge ws idx 0 = ws 0 0" +proof (rule merge[OF idx]) + from idx have "idx 0 < idx (Suc 0)" + unfolding idx_sequence_def by blast + with idx show "0 \ {idx 0 ..< idx (Suc 0)}" + by (simp add: idx_sequence_def) +qed + +lemma merge_Suc: + assumes idx: "idx_sequence idx" + and n: "n \ {idx i ..< idx (Suc i)}" + shows "merge ws idx (Suc n) = (if Suc n = idx (Suc i) then ws (Suc i) else ws i) (Suc n)" +proof auto + assume eq: "Suc n = idx (Suc i)" + from idx have "idx (Suc i) < idx (Suc(Suc i))" + unfolding idx_sequence_def by blast + with eq idx show "merge ws idx (idx (Suc i)) = ws (Suc i) (idx (Suc i))" + by (simp add: merge) +next + assume neq: "Suc n \ idx (Suc i)" + with n have "Suc n \ {idx i ..< idx (Suc i) }" + by auto + with idx show "merge ws idx (Suc n) = ws i (Suc n)" + by (rule merge) +qed + +end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/OptionalSugar.thy --- a/src/HOL/Library/OptionalSugar.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/OptionalSugar.thy Fri Sep 18 16:42:19 2015 +0100 @@ -48,14 +48,13 @@ "_bind (CONST DUMMY # p) e" <= "_bind p (CONST tl e)" (* type constraints with spacing *) +no_syntax (output) + "_constrain" :: "logic => type => logic" ("_::_" [4, 0] 3) + "_constrain" :: "prop' => type => prop'" ("_::_" [4, 0] 3) -no_syntax (xsymbols output) - "_constrain" :: "logic => type => logic" ("_\_" [4, 0] 3) - "_constrain" :: "prop' => type => prop'" ("_\_" [4, 0] 3) - -syntax (xsymbols output) - "_constrain" :: "logic => type => logic" ("_ \ _" [4, 0] 3) - "_constrain" :: "prop' => type => prop'" ("_ \ _" [4, 0] 3) +syntax (output) + "_constrain" :: "logic => type => logic" ("_ :: _" [4, 0] 3) + "_constrain" :: "prop' => type => prop'" ("_ :: _" [4, 0] 3) (* sorts as intersections *) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Predicate_Compile_Alternative_Defs.thy --- a/src/HOL/Library/Predicate_Compile_Alternative_Defs.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Predicate_Compile_Alternative_Defs.thy Fri Sep 18 16:42:19 2015 +0100 @@ -22,7 +22,7 @@ section \Pairs\ -setup \Predicate_Compile_Data.ignore_consts [@{const_name fst}, @{const_name snd}, @{const_name case_prod}]\ +setup \Predicate_Compile_Data.ignore_consts [@{const_name fst}, @{const_name snd}, @{const_name uncurry}]\ section \Filters\ @@ -212,6 +212,30 @@ done qed +subsection \Alternative rules for membership in lists\ + +declare in_set_member[code_pred_inline] + +lemma member_intros [code_pred_intro]: + "List.member (x#xs) x" + "List.member xs x \ List.member (y#xs) x" +by(simp_all add: List.member_def) + +code_pred List.member + by(auto simp add: List.member_def elim: list.set_cases) + +code_identifier constant member_i_i + \ (SML) "List.member_i_i" + and (OCaml) "List.member_i_i" + and (Haskell) "List.member_i_i" + and (Scala) "List.member_i_i" + +code_identifier constant member_i_o + \ (SML) "List.member_i_o" + and (OCaml) "List.member_i_o" + and (Haskell) "List.member_i_o" + and (Scala) "List.member_i_o" + section \Setup for String.literal\ setup \Predicate_Compile_Data.ignore_consts [@{const_name "STR"}]\ diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/Product_Order.thy --- a/src/HOL/Library/Product_Order.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/Product_Order.thy Fri Sep 18 16:42:19 2015 +0100 @@ -233,7 +233,7 @@ (* Contribution: Alessandro Coglio *) instance prod :: (complete_distrib_lattice, complete_distrib_lattice) complete_distrib_lattice -proof (standard, goals) +proof (standard, goal_cases) case 1 then show ?case by (auto simp: sup_prod_def Inf_prod_def INF_prod_alt_def sup_Inf sup_INF comp_def) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/RBT_Impl.thy --- a/src/HOL/Library/RBT_Impl.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/RBT_Impl.thy Fri Sep 18 16:42:19 2015 +0100 @@ -1757,9 +1757,9 @@ compare.eq.refl compare.eq.simps compare.EQ_def compare.GT_def compare.LT_def equal_compare_def - skip_red_def skip_red.simps skip_red.cases skip_red.induct + skip_red.simps skip_red.cases skip_red.induct skip_black_def - compare_height_def compare_height.simps + compare_height.simps subsection \union and intersection of sorted associative lists\ diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/While_Combinator.thy --- a/src/HOL/Library/While_Combinator.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/While_Combinator.thy Fri Sep 18 16:42:19 2015 +0100 @@ -157,7 +157,7 @@ note b = this(1) and body = this(2) and inv = this(3) hence k': "f ((c ^^ k') s) = (c' ^^ k') (f s)" by auto ultimately show ?thesis unfolding Suc using b - proof (intro Least_equality[symmetric], goals) + proof (intro Least_equality[symmetric], goal_cases) case 1 hence Test: "\ b' (f ((c ^^ Suc k') s))" by (auto simp: BodyCommute inv b) @@ -314,10 +314,10 @@ and x :: 'a begin -fun rtrancl_while_test :: "'a list \ 'a set \ bool" +qualified fun rtrancl_while_test :: "'a list \ 'a set \ bool" where "rtrancl_while_test (ws,_) = (ws \ [] \ p(hd ws))" -fun rtrancl_while_step :: "'a list \ 'a set \ 'a list \ 'a set" +qualified fun rtrancl_while_step :: "'a list \ 'a set \ 'a list \ 'a set" where "rtrancl_while_step (ws, Z) = (let x = hd ws; new = remdups (filter (\y. y \ Z) (f x)) in (new @ tl ws, set new \ Z))" @@ -325,12 +325,12 @@ definition rtrancl_while :: "('a list * 'a set) option" where "rtrancl_while = while_option rtrancl_while_test rtrancl_while_step ([x],{x})" -fun rtrancl_while_invariant :: "'a list \ 'a set \ bool" +qualified fun rtrancl_while_invariant :: "'a list \ 'a set \ bool" where "rtrancl_while_invariant (ws, Z) = (x \ Z \ set ws \ Z \ distinct ws \ {(x,y). y \ set(f x)} `` (Z - set ws) \ Z \ Z \ {(x,y). y \ set(f x)}^* `` {x} \ (\z\Z - set ws. p z))" -lemma rtrancl_while_invariant: +qualified lemma rtrancl_while_invariant: assumes inv: "rtrancl_while_invariant st" and test: "rtrancl_while_test st" shows "rtrancl_while_invariant (rtrancl_while_step st)" proof (cases st) @@ -392,7 +392,4 @@ end -hide_const (open) rtrancl_while_test rtrancl_while_step rtrancl_while_invariant -hide_fact (open) rtrancl_while_invariant - end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/bnf_axiomatization.ML --- a/src/HOL/Library/bnf_axiomatization.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/bnf_axiomatization.ML Fri Sep 18 16:42:19 2015 +0100 @@ -86,9 +86,10 @@ fun mk_wit_thms set_maps = Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) (fn {context = ctxt, prems = _} => mk_wits_tac ctxt set_maps) + |> Thm.close_derivation |> Conjunction.elim_balanced (length wit_goals) |> map2 (Conjunction.elim_balanced o length) wit_goalss - |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0)); + |> (map o map) (Thm.forall_elim_vars 0); val phi = Proof_Context.export_morphism lthy_old lthy; val thms = unflat all_goalss (Morphism.fact phi raw_thms); diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Library/old_recdef.ML --- a/src/HOL/Library/old_recdef.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Library/old_recdef.ML Fri Sep 18 16:42:19 2015 +0100 @@ -551,7 +551,7 @@ local fun mk_uncurry (xt, yt, zt) = - Const(@{const_name case_prod}, (xt --> yt --> zt) --> prod_ty xt yt --> zt) + Const(@{const_name uncurry}, (xt --> yt --> zt) --> prod_ty xt yt --> zt) fun dest_pair(Const(@{const_name Pair},_) $ M $ N) = {fst=M, snd=N} | dest_pair _ = raise USYN_ERR "dest_pair" "not a pair" fun is_var (Var _) = true | is_var (Free _) = true | is_var _ = false @@ -631,7 +631,7 @@ | dest_pair _ = raise USYN_ERR "dest_pair" "not a pair"; -local fun ucheck t = (if #Name (dest_const t) = @{const_name case_prod} then t +local fun ucheck t = (if #Name (dest_const t) = @{const_name uncurry} then t else raise Match) in fun dest_pabs used tm = diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Limits.thy --- a/src/HOL/Limits.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Limits.thy Fri Sep 18 16:42:19 2015 +0100 @@ -710,13 +710,15 @@ lemma (in bounded_bilinear) flip: "bounded_bilinear (\x y. y ** x)" - apply default + apply standard apply (rule add_right) apply (rule add_left) apply (rule scaleR_right) apply (rule scaleR_left) apply (subst mult.commute) - using bounded by fast + using bounded + apply fast + done lemma (in bounded_bilinear) Bfun_prod_Zfun: assumes f: "Bfun f F" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/List.thy --- a/src/HOL/List.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/List.thy Fri Sep 18 16:42:19 2015 +0100 @@ -2868,7 +2868,7 @@ "F (set (x # xs)) = fold f xs x" proof - interpret comp_fun_idem f - by default (simp_all add: fun_eq_iff left_commute) + by standard (simp_all add: fun_eq_iff left_commute) show ?thesis by (simp add: eq_fold fold_set_fold) qed @@ -5161,7 +5161,7 @@ "folding.F insort [] = sorted_list_of_set" proof - interpret comp_fun_commute insort by (fact comp_fun_commute_insort) - show "folding insort" by default (fact comp_fun_commute) + show "folding insort" by standard (fact comp_fun_commute) show "folding.F insort [] = sorted_list_of_set" by (simp only: sorted_list_of_set_def) qed diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Matrix_LP/Matrix.thy --- a/src/HOL/Matrix_LP/Matrix.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Matrix_LP/Matrix.thy Fri Sep 18 16:42:19 2015 +0100 @@ -1448,7 +1448,7 @@ definition "sup = combine_matrix sup" instance - by default (auto simp add: le_infI le_matrix_def inf_matrix_def sup_matrix_def) + by standard (auto simp add: le_infI le_matrix_def inf_matrix_def sup_matrix_def) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Matrix_LP/SparseMatrix.thy --- a/src/HOL/Matrix_LP/SparseMatrix.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Matrix_LP/SparseMatrix.thy Fri Sep 18 16:42:19 2015 +0100 @@ -120,8 +120,11 @@ done instance matrix :: (lattice_ab_group_add_abs) lattice_ab_group_add_abs -apply default -unfolding abs_matrix_def .. (*FIXME move*) + apply standard + unfolding abs_matrix_def + apply rule + done + (*FIXME move*) lemma sparse_row_vector_abs: "sorted_spvec (v :: 'a::lattice_ring spvec) \ sparse_row_vector (abs_spvec v) = abs (sparse_row_vector v)" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/MicroJava/J/State.thy --- a/src/HOL/MicroJava/J/State.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/MicroJava/J/State.thy Fri Sep 18 16:42:19 2015 +0100 @@ -191,7 +191,7 @@ begin definition "HOL.equal (l :: loc') l' \ l = l'" -instance by default (simp add: equal_loc'_def) +instance by standard (simp add: equal_loc'_def) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/MicroJava/J/Type.thy --- a/src/HOL/MicroJava/J/Type.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/MicroJava/J/Type.thy Fri Sep 18 16:42:19 2015 +0100 @@ -13,7 +13,7 @@ begin definition "HOL.equal (cn :: cnam) cn' \ cn = cn'" -instance by default (simp add: equal_cnam_def) +instance by standard (simp add: equal_cnam_def) end @@ -63,7 +63,7 @@ begin definition "HOL.equal (vn :: vnam) vn' \ vn = vn'" -instance by default (simp add: equal_vnam_def) +instance by standard (simp add: equal_vnam_def) end @@ -98,7 +98,7 @@ begin definition "HOL.equal (M :: mname) M' \ M = M'" -instance by default (simp add: equal_mname_def) +instance by standard (simp add: equal_mname_def) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Multivariate_Analysis/Bounded_Continuous_Function.thy --- a/src/HOL/Multivariate_Analysis/Bounded_Continuous_Function.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Multivariate_Analysis/Bounded_Continuous_Function.thy Fri Sep 18 16:42:19 2015 +0100 @@ -315,7 +315,7 @@ by (simp add: scaleR_bcontfun_def Abs_bcontfun_inverse scaleR_cont Rep_bcontfun) instance - by default + by standard (simp_all add: plus_bcontfun_def zero_bcontfun_def minus_bcontfun_def scaleR_bcontfun_def Abs_bcontfun_inverse Rep_bcontfun_inverse Rep_bcontfun algebra_simps plus_cont const_bcontfun minus_cont scaleR_cont) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Multivariate_Analysis/Brouwer_Fixpoint.thy --- a/src/HOL/Multivariate_Analysis/Brouwer_Fixpoint.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Multivariate_Analysis/Brouwer_Fixpoint.thy Fri Sep 18 16:42:19 2015 +0100 @@ -589,7 +589,7 @@ using enum_Suc[of 0] na[rule_format, OF \enum 1 \ s - {a}\] \a = enum 0\ by (auto simp: \upd 0 = n\) show ?thesis - proof (rule ksimplex.intros, default) + proof (rule ksimplex.intros, standard) show "bij_betw (upd\Suc) {..< n} {..< n}" by fact show "base(n := p) \ {.. {..i. n\i \ (base(n := p)) i = p" using base base_out by (auto simp: Pi_iff) @@ -620,7 +620,7 @@ def u \ "\i. case i of 0 \ n | Suc i \ upd i" have "ksimplex p (Suc n) (s' \ {b})" - proof (rule ksimplex.intros, default) + proof (rule ksimplex.intros, standard) show "b \ {.. {..0 < p\ unfolding lessThan_Suc b_def by (auto simp: PiE_iff) show "\i. Suc n \ i \ b i = p" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Multivariate_Analysis/Cartesian_Euclidean_Space.thy --- a/src/HOL/Multivariate_Analysis/Cartesian_Euclidean_Space.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Multivariate_Analysis/Cartesian_Euclidean_Space.thy Fri Sep 18 16:42:19 2015 +0100 @@ -73,7 +73,7 @@ end instance vec:: (order, finite) order - by default (auto simp: less_eq_vec_def less_vec_def vec_eq_iff + by standard (auto simp: less_eq_vec_def less_vec_def vec_eq_iff intro: order.trans order.antisym order.strict_implies_order) instance vec :: (linorder, cart_one) linorder @@ -183,26 +183,26 @@ subsection \Some frequently useful arithmetic lemmas over vectors.\ instance vec :: (semigroup_mult, finite) semigroup_mult - by default (vector mult.assoc) + by standard (vector mult.assoc) instance vec :: (monoid_mult, finite) monoid_mult - by default vector+ + by standard vector+ instance vec :: (ab_semigroup_mult, finite) ab_semigroup_mult - by default (vector mult.commute) + by standard (vector mult.commute) instance vec :: (comm_monoid_mult, finite) comm_monoid_mult - by default vector + by standard vector instance vec :: (semiring, finite) semiring - by default (vector field_simps)+ + by standard (vector field_simps)+ instance vec :: (semiring_0, finite) semiring_0 - by default (vector field_simps)+ + by standard (vector field_simps)+ instance vec :: (semiring_1, finite) semiring_1 - by default vector + by standard vector instance vec :: (comm_semiring, finite) comm_semiring - by default (vector field_simps)+ + by standard (vector field_simps)+ instance vec :: (comm_semiring_0, finite) comm_semiring_0 .. instance vec :: (cancel_comm_monoid_add, finite) cancel_comm_monoid_add .. @@ -215,7 +215,7 @@ instance vec :: (ring_1, finite) ring_1 .. instance vec :: (real_algebra, finite) real_algebra - by default (simp_all add: vec_eq_iff) + by standard (simp_all add: vec_eq_iff) instance vec :: (real_algebra_1, finite) real_algebra_1 .. diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Multivariate_Analysis/Derivative.thy --- a/src/HOL/Multivariate_Analysis/Derivative.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Multivariate_Analysis/Derivative.thy Fri Sep 18 16:42:19 2015 +0100 @@ -1191,8 +1191,9 @@ have lem1: "\e>0. \d>0. \z. norm (z - y) < d \ norm (g z - g y - g'(z - y)) \ e * norm (g z - g y)" proof (rule, rule) - case goal1 - have *: "e / C > 0" using \e > 0\ C(1) by auto + fix e :: real + assume "e > 0" + with C(1) have *: "e / C > 0" by auto obtain d0 where d0: "0 < d0" "\ya. norm (ya - g y) < d0 \ norm (f ya - f (g y) - f' (ya - g y)) \ e / C * norm (ya - g y)" @@ -1213,7 +1214,7 @@ using assms(6) by blast obtain d where d: "0 < d" "d < d1" "d < d2" using real_lbound_gt_zero[OF d1(1) d2(1)] by blast - then show ?case + then show "\d>0. \z. norm (z - y) < d \ norm (g z - g y - g' (z - y)) \ e * norm (g z - g y)" apply (rule_tac x=d in exI) apply rule defer @@ -1257,14 +1258,13 @@ def B \ "C * 2" have "B > 0" unfolding B_def using C by auto - have lem2: "\z. norm(z - y) < d \ norm (g z - g y) \ B * norm (z - y)" - proof (rule, rule) - case goal1 + have lem2: "norm (g z - g y) \ B * norm (z - y)" if z: "norm(z - y) < d" for z + proof - have "norm (g z - g y) \ norm(g' (z - y)) + norm ((g z - g y) - g'(z - y))" by (rule norm_triangle_sub) also have "\ \ norm (g' (z - y)) + 1 / 2 * norm (g z - g y)" apply (rule add_left_mono) - using d and goal1 + using d and z apply auto done also have "\ \ norm (z - y) * C + 1 / 2 * norm (g z - g y)" @@ -1272,7 +1272,7 @@ using C apply auto done - finally show ?case + finally show "norm (g z - g y) \ B * norm (z - y)" unfolding B_def by (auto simp add: field_simps) qed @@ -1283,15 +1283,16 @@ apply rule apply rule proof - - case goal1 - hence *: "e / B >0" by (metis \0 < B\ divide_pos_pos) + fix e :: real + assume "e > 0" + then have *: "e / B > 0" by (metis \B > 0\ divide_pos_pos) obtain d' where d': "0 < d'" "\z. norm (z - y) < d' \ norm (g z - g y - g' (z - y)) \ e / B * norm (g z - g y)" using lem1 * by blast obtain k where k: "0 < k" "k < d" "k < d'" using real_lbound_gt_zero[OF d(1) d'(1)] by blast - show ?case + show "\d>0. \ya. norm (ya - y) < d \ norm (g ya - g y - g' (ya - y)) \ e * norm (ya - y)" apply (rule_tac x=k in exI) apply auto proof - @@ -1301,7 +1302,7 @@ using d' k by auto also have "\ \ e * norm (z - y)" unfolding times_divide_eq_left pos_divide_le_eq[OF \B>0\] - using lem2[THEN spec[where x=z]] + using lem2[of z] using k as using \e > 0\ by (auto simp add: field_simps) finally show "norm (g z - g y - g' (z - y)) \ e * norm (z - y)" @@ -1650,7 +1651,8 @@ apply rule apply rule proof - - case goal1 + fix y + assume "0 < dist y (f x) \ dist y (f x) < d" then have "g y \ g ` f ` (ball x e \ s)" using d(2)[unfolded subset_eq,THEN bspec[where x=y]] by (auto simp add: dist_commute) @@ -1667,13 +1669,12 @@ using interior_open[OF assms(1)] and \x \ s\ apply auto done - moreover have "\y. y \ interior (f ` s) \ f (g y) = y" + moreover have "f (g y) = y" if "y \ interior (f ` s)" for y proof - - case goal1 - then have "y \ f ` s" + from that have "y \ f ` s" using interior_subset by auto then obtain z where "z \ s" "y = f z" unfolding image_iff .. - then show ?case + then show ?thesis using assms(4) by auto qed ultimately show ?thesis using assms @@ -1882,11 +1883,13 @@ shows "\e>0. \N. \m\N. \n\N. \x\s. \y\s. norm ((f m x - f n x) - (f m y - f n y)) \ e * norm (x - y)" proof (rule, rule) - case goal1 have *: "2 * (1/2* e) = e" "1/2 * e >0" - using \e > 0\ by auto + fix e :: real + assume "e > 0" + then have *: "2 * (1/2* e) = e" "1/2 * e >0" + by auto obtain N where "\n\N. \x\s. \h. norm (f' n x h - g' x h) \ 1 / 2 * e * norm h" using assms(3) *(2) by blast - then show ?case + then show "\N. \m\N. \n\N. \x\s. \y\s. norm (f m x - f n x - (f m y - f n y)) \ e * norm (x - y)" apply (rule_tac x=N in exI) apply (rule has_derivative_sequence_lipschitz_lemma[where e="1/2 *e", unfolded *]) using assms \e > 0\ @@ -2060,9 +2063,10 @@ qed show "\e>0. eventually (\y. norm (g y - g x - g' x (y - x)) \ e * norm (y - x)) (at x within s)" proof (rule, rule) - case goal1 - have *: "e / 3 > 0" - using goal1 by auto + fix e :: real + assume "e > 0" + then have *: "e / 3 > 0" + by auto obtain N1 where N1: "\n\N1. \x\s. \h. norm (f' n x h - g' x h) \ e / 3 * norm h" using assms(3) * by blast obtain N2 where @@ -2073,7 +2077,7 @@ using assms(2)[unfolded has_derivative_within_alt2] and \x \ s\ and * by fast moreover have "eventually (\y. y \ s) (at x within s)" unfolding eventually_at by (fast intro: zero_less_one) - ultimately show ?case + ultimately show "\\<^sub>F y in at x within s. norm (g y - g x - g' x (y - x)) \ e * norm (y - x)" proof (rule eventually_elim2) fix y assume "y \ s" @@ -2150,15 +2154,20 @@ using reals_Archimedean[OF \e>0\] .. show "\N. \n\N. \x\s. \h. norm (f' n x h - g' x h) \ e * norm h" apply (rule_tac x=N in exI) - proof rule+ - case goal1 + apply rule + apply rule + apply rule + apply rule + proof - + fix n x h + assume n: "N \ n" and x: "x \ s" have *: "inverse (real (Suc n)) \ e" apply (rule order_trans[OF _ N[THEN less_imp_le]]) - using goal1(1) + using n apply (auto simp add: field_simps) done - show ?case - using f[rule_format,THEN conjunct2,OF goal1(2), of n, THEN spec[where x=h]] + show "norm (f' n x h - g' x h) \ e * norm h" + using f[rule_format,THEN conjunct2, OF x, of n, THEN spec[where x=h]] apply (rule order_trans) using N * apply (cases "h = 0") diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Multivariate_Analysis/Euclidean_Space.thy --- a/src/HOL/Multivariate_Analysis/Euclidean_Space.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Multivariate_Analysis/Euclidean_Space.thy Fri Sep 18 16:42:19 2015 +0100 @@ -139,7 +139,7 @@ [simp]: "Basis = {1::real}" instance - by default auto + by standard auto end @@ -155,7 +155,7 @@ "Basis = {1, ii}" instance - by default (auto simp add: Basis_complex_def intro: complex_eqI split: split_if_asm) + by standard (auto simp add: Basis_complex_def intro: complex_eqI split: split_if_asm) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Multivariate_Analysis/Extended_Real_Limits.thy --- a/src/HOL/Multivariate_Analysis/Extended_Real_Limits.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Multivariate_Analysis/Extended_Real_Limits.thy Fri Sep 18 16:42:19 2015 +0100 @@ -53,7 +53,7 @@ qed instance ereal :: second_countable_topology -proof (default, intro exI conjI) +proof (standard, intro exI conjI) let ?B = "(\r\\. {{..< r}, {r <..}} :: ereal set set)" show "countable ?B" by (auto intro: countable_rat) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Multivariate_Analysis/Fashoda.thy --- a/src/HOL/Multivariate_Analysis/Fashoda.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Multivariate_Analysis/Fashoda.thy Fri Sep 18 16:42:19 2015 +0100 @@ -175,9 +175,8 @@ qed have 3: "(negatex \ sqprojection \ ?F) ` cbox (-1) 1 \ cbox (-1) 1" unfolding subset_eq - apply rule - proof - - case goal1 + proof (rule, goal_cases) + case (1 x) then obtain y :: "real^2" where y: "y \ cbox (- 1) 1" "x = (negatex \ sqprojection \ (\w. (f \ (\x. x $ 1)) w - (g \ (\x. x $ 2)) w)) y" @@ -198,8 +197,9 @@ apply - apply rule proof - - case goal1 - then show ?case + fix i + assume "max \x $ 1\ \x $ 2\ = 1" + then show "(- 1) $ i \ x $ i \ x $ i \ 1 $ i" apply (cases "i = 1") defer apply (drule 21) @@ -834,15 +834,14 @@ z \ closed_segment (pathfinish g) (vector [pathfinish g $ 1, a $ 2 - 1])) \ z \ closed_segment (vector [pathfinish g $ 1, a $ 2 - 1]) (vector [b $ 1 + 1, a $ 2 - 1])) \ z \ closed_segment (vector [b $ 1 + 1, a $ 2 - 1]) (vector [b $ 1 + 1, b $ 2 + 3]) \ False" - apply (simp only: segment_vertical segment_horizontal vector_2) - proof - - case goal1 note as=this + proof (simp only: segment_vertical segment_horizontal vector_2, goal_cases) + case prems: 1 have "pathfinish f \ cbox a b" using assms(3) pathfinish_in_path_image[of f] by auto then have "1 + b $ 1 \ pathfinish f $ 1 \ False" unfolding mem_interval_cart forall_2 by auto then have "z$1 \ pathfinish f$1" - using as(2) + using prems(2) using assms ab by (auto simp add: field_simps) moreover have "pathstart f \ cbox a b" @@ -852,13 +851,13 @@ unfolding mem_interval_cart forall_2 by auto then have "z$1 \ pathstart f$1" - using as(2) using assms ab + using prems(2) using assms ab by (auto simp add: field_simps) ultimately have *: "z$2 = a$2 - 2" - using goal1(1) + using prems(1) by auto have "z$1 \ pathfinish g$1" - using as(2) + using prems(2) using assms ab by (auto simp add: field_simps *) moreover have "pathstart g \ cbox a b" @@ -866,11 +865,11 @@ by auto note this[unfolded mem_interval_cart forall_2] then have "z$1 \ pathstart g$1" - using as(1) + using prems(1) using assms ab by (auto simp add: field_simps *) ultimately have "a $ 2 - 1 \ z $ 2 \ z $ 2 \ b $ 2 + 3 \ b $ 2 + 3 \ z $ 2 \ z $ 2 \ a $ 2 - 1" - using as(2) + using prems(2) unfolding * assms by (auto simp add: field_simps) then show False diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Multivariate_Analysis/Finite_Cartesian_Product.thy --- a/src/HOL/Multivariate_Analysis/Finite_Cartesian_Product.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Multivariate_Analysis/Finite_Cartesian_Product.thy Fri Sep 18 16:42:19 2015 +0100 @@ -95,30 +95,30 @@ unfolding uminus_vec_def by simp instance vec :: (semigroup_add, finite) semigroup_add - by default (simp add: vec_eq_iff add.assoc) + by standard (simp add: vec_eq_iff add.assoc) instance vec :: (ab_semigroup_add, finite) ab_semigroup_add - by default (simp add: vec_eq_iff add.commute) + by standard (simp add: vec_eq_iff add.commute) instance vec :: (monoid_add, finite) monoid_add - by default (simp_all add: vec_eq_iff) + by standard (simp_all add: vec_eq_iff) instance vec :: (comm_monoid_add, finite) comm_monoid_add - by default (simp add: vec_eq_iff) + by standard (simp add: vec_eq_iff) instance vec :: (cancel_semigroup_add, finite) cancel_semigroup_add - by default (simp_all add: vec_eq_iff) + by standard (simp_all add: vec_eq_iff) instance vec :: (cancel_ab_semigroup_add, finite) cancel_ab_semigroup_add - by default (simp_all add: vec_eq_iff diff_diff_eq) + by standard (simp_all add: vec_eq_iff diff_diff_eq) instance vec :: (cancel_comm_monoid_add, finite) cancel_comm_monoid_add .. instance vec :: (group_add, finite) group_add - by default (simp_all add: vec_eq_iff) + by standard (simp_all add: vec_eq_iff) instance vec :: (ab_group_add, finite) ab_group_add - by default (simp_all add: vec_eq_iff) + by standard (simp_all add: vec_eq_iff) subsection \Real vector space\ @@ -132,7 +132,7 @@ unfolding scaleR_vec_def by simp instance - by default (simp_all add: vec_eq_iff scaleR_left_distrib scaleR_right_distrib) + by standard (simp_all add: vec_eq_iff scaleR_left_distrib scaleR_right_distrib) end @@ -412,7 +412,7 @@ by (rule member_le_setL2) simp_all lemma bounded_linear_vec_nth: "bounded_linear (\x. x $ i)" -apply default +apply standard apply (rule vector_add_component) apply (rule vector_scaleR_component) apply (rule_tac x="1" in exI, simp add: norm_nth_le) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Multivariate_Analysis/Integration.thy --- a/src/HOL/Multivariate_Analysis/Integration.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Multivariate_Analysis/Integration.thy Fri Sep 18 16:42:19 2015 +0100 @@ -15,7 +15,7 @@ shows "S \ {} \ (\x. x\S \ \x\ \ a) \ \Sup S\ \ a" by (auto simp add: abs_le_interval_iff intro: cSup_least) (metis cSup_upper2 bdd_aboveI) -lemma cInf_abs_ge: +lemma cInf_abs_ge: fixes S :: "real set" shows "S \ {} \ (\x. x\S \ \x\ \ a) \ \Inf S\ \ a" using cSup_abs_le [of "uminus ` S"] @@ -248,156 +248,153 @@ have lem1: "\x e s U. ball x e \ s \ interior U \ ball x e \ s \ U" using interior_subset by auto (meson Topology_Euclidean_Space.open_ball contra_subsetD interior_maximal mem_ball) - have "\f. finite f \ \t\f. \a b. t = cbox a b \ - \x. x \ s \ interior (\f) \ \t\f. \x. \e>0. ball x e \ s \ t" - proof - - case goal1 - then show ?case - proof (induct rule: finite_induct) - case empty - obtain x where "x \ s \ interior (\{})" - using empty(2) .. - then have False - unfolding Union_empty interior_empty by auto - then show ?case by auto + have "\t\f. \x. \e>0. ball x e \ s \ t" + if "finite f" and "\t\f. \a b. t = cbox a b" and "\x. x \ s \ interior (\f)" for f + using that + proof (induct rule: finite_induct) + case empty + obtain x where "x \ s \ interior (\{})" + using empty(2) .. + then have False + unfolding Union_empty interior_empty by auto + then show ?case by auto + next + case (insert i f) + obtain x where x: "x \ s \ interior (\insert i f)" + using insert(5) .. + then obtain e where e: "0 < e \ ball x e \ s \ interior (\insert i f)" + unfolding open_contains_ball_eq[OF open_Int[OF assms(2) open_interior], rule_format] .. + obtain a where "\b. i = cbox a b" + using insert(4)[rule_format,OF insertI1] .. + then obtain b where ab: "i = cbox a b" .. + show ?case + proof (cases "x \ i") + case False + then have "x \ UNIV - cbox a b" + unfolding ab by auto + then obtain d where "0 < d \ ball x d \ UNIV - cbox a b" + unfolding open_contains_ball_eq[OF open_Diff[OF open_UNIV closed_cbox],rule_format] .. + then have "0 < d" "ball x (min d e) \ UNIV - i" + unfolding ab ball_min_Int by auto + then have "ball x (min d e) \ s \ interior (\f)" + using e unfolding lem1 unfolding ball_min_Int by auto + then have "x \ s \ interior (\f)" using \d>0\ e by auto + then have "\t\f. \x e. 0 < e \ ball x e \ s \ t" + using insert.hyps(3) insert.prems(1) by blast + then show ?thesis by auto next - case (insert i f) - obtain x where x: "x \ s \ interior (\insert i f)" - using insert(5) .. - then obtain e where e: "0 < e \ ball x e \ s \ interior (\insert i f)" - unfolding open_contains_ball_eq[OF open_Int[OF assms(2) open_interior], rule_format] .. - obtain a where "\b. i = cbox a b" - using insert(4)[rule_format,OF insertI1] .. - then obtain b where ab: "i = cbox a b" .. - show ?case - proof (cases "x \ i") + case True show ?thesis + proof (cases "x\box a b") + case True + then obtain d where "0 < d \ ball x d \ box a b" + unfolding open_contains_ball_eq[OF open_box,rule_format] .. + then show ?thesis + apply (rule_tac x=i in bexI, rule_tac x=x in exI, rule_tac x="min d e" in exI) + unfolding ab + using box_subset_cbox[of a b] and e + apply fastforce+ + done + next case False - then have "x \ UNIV - cbox a b" - unfolding ab by auto - then obtain d where "0 < d \ ball x d \ UNIV - cbox a b" - unfolding open_contains_ball_eq[OF open_Diff[OF open_UNIV closed_cbox],rule_format] .. - then have "0 < d" "ball x (min d e) \ UNIV - i" - unfolding ab ball_min_Int by auto - then have "ball x (min d e) \ s \ interior (\f)" - using e unfolding lem1 unfolding ball_min_Int by auto - then have "x \ s \ interior (\f)" using \d>0\ e by auto - then have "\t\f. \x e. 0 < e \ ball x e \ s \ t" - using insert.hyps(3) insert.prems(1) by blast - then show ?thesis by auto - next - case True show ?thesis - proof (cases "x\box a b") - case True - then obtain d where "0 < d \ ball x d \ box a b" - unfolding open_contains_ball_eq[OF open_box,rule_format] .. - then show ?thesis - apply (rule_tac x=i in bexI, rule_tac x=x in exI, rule_tac x="min d e" in exI) - unfolding ab - using box_subset_cbox[of a b] and e - apply fastforce+ + then obtain k where "x\k \ a\k \ x\k \ b\k" and k: "k \ Basis" + unfolding mem_box by (auto simp add: not_less) + then have "x\k = a\k \ x\k = b\k" + using True unfolding ab and mem_box + apply (erule_tac x = k in ballE) + apply auto done - next - case False - then obtain k where "x\k \ a\k \ x\k \ b\k" and k: "k \ Basis" - unfolding mem_box by (auto simp add: not_less) - then have "x\k = a\k \ x\k = b\k" - using True unfolding ab and mem_box - apply (erule_tac x = k in ballE) + then have "\x. ball x (e/2) \ s \ (\f)" + proof (rule disjE) + let ?z = "x - (e/2) *\<^sub>R k" + assume as: "x\k = a\k" + have "ball ?z (e / 2) \ i = {}" + proof (clarsimp simp only: all_not_in_conv [symmetric]) + fix y + assume "y \ ball ?z (e / 2)" and yi: "y \ i" + then have "dist ?z y < e/2" by auto + then have "\(?z - y) \ k\ < e/2" + using Basis_le_norm[OF k, of "?z - y"] unfolding dist_norm by auto + then have "y\k < a\k" + using e k + by (auto simp add: field_simps abs_less_iff as inner_simps) + then have "y \ i" + unfolding ab mem_box by (auto intro!: bexI[OF _ k]) + then show False using yi by auto + qed + moreover + have "ball ?z (e/2) \ s \ (\insert i f)" + apply (rule order_trans[OF _ e[THEN conjunct2, unfolded lem1]]) + proof + fix y + assume as: "y \ ball ?z (e/2)" + have "norm (x - y) \ \e\ / 2 + norm (x - y - (e / 2) *\<^sub>R k)" + apply (rule order_trans,rule norm_triangle_sub[of "x - y" "(e/2) *\<^sub>R k"]) + unfolding norm_scaleR norm_Basis[OF k] apply auto done - then have "\x. ball x (e/2) \ s \ (\f)" - proof (rule disjE) - let ?z = "x - (e/2) *\<^sub>R k" - assume as: "x\k = a\k" - have "ball ?z (e / 2) \ i = {}" - proof (clarsimp simp only: all_not_in_conv [symmetric]) - fix y - assume "y \ ball ?z (e / 2)" and yi: "y \ i" - then have "dist ?z y < e/2" by auto - then have "\(?z - y) \ k\ < e/2" - using Basis_le_norm[OF k, of "?z - y"] unfolding dist_norm by auto - then have "y\k < a\k" - using e k - by (auto simp add: field_simps abs_less_iff as inner_simps) - then have "y \ i" - unfolding ab mem_box by (auto intro!: bexI[OF _ k]) - then show False using yi by auto - qed - moreover - have "ball ?z (e/2) \ s \ (\insert i f)" - apply (rule order_trans[OF _ e[THEN conjunct2, unfolded lem1]]) - proof - fix y - assume as: "y \ ball ?z (e/2)" - have "norm (x - y) \ \e\ / 2 + norm (x - y - (e / 2) *\<^sub>R k)" - apply (rule order_trans,rule norm_triangle_sub[of "x - y" "(e/2) *\<^sub>R k"]) - unfolding norm_scaleR norm_Basis[OF k] - apply auto - done - also have "\ < \e\ / 2 + \e\ / 2" - apply (rule add_strict_left_mono) - using as e - apply (auto simp add: field_simps dist_norm) - done - finally show "y \ ball x e" - unfolding mem_ball dist_norm using e by (auto simp add:field_simps) - qed - ultimately show ?thesis - apply (rule_tac x="?z" in exI) - unfolding Union_insert - apply auto + also have "\ < \e\ / 2 + \e\ / 2" + apply (rule add_strict_left_mono) + using as e + apply (auto simp add: field_simps dist_norm) done - next - let ?z = "x + (e/2) *\<^sub>R k" - assume as: "x\k = b\k" - have "ball ?z (e / 2) \ i = {}" - proof (clarsimp simp only: all_not_in_conv [symmetric]) - fix y - assume "y \ ball ?z (e / 2)" and yi: "y \ i" - then have "dist ?z y < e/2" - by auto - then have "\(?z - y) \ k\ < e/2" - using Basis_le_norm[OF k, of "?z - y"] - unfolding dist_norm by auto - then have "y\k > b\k" - using e k - by (auto simp add:field_simps inner_simps inner_Basis as) - then have "y \ i" - unfolding ab mem_box by (auto intro!: bexI[OF _ k]) - then show False using yi by auto - qed - moreover - have "ball ?z (e/2) \ s \ (\insert i f)" - apply (rule order_trans[OF _ e[THEN conjunct2, unfolded lem1]]) - proof - fix y - assume as: "y\ ball ?z (e/2)" - have "norm (x - y) \ \e\ / 2 + norm (x - y + (e / 2) *\<^sub>R k)" - apply (rule order_trans,rule norm_triangle_sub[of "x - y" "- (e/2) *\<^sub>R k"]) - unfolding norm_scaleR - apply (auto simp: k) - done - also have "\ < \e\ / 2 + \e\ / 2" - apply (rule add_strict_left_mono) - using as unfolding mem_ball dist_norm - using e apply (auto simp add: field_simps) - done - finally show "y \ ball x e" - unfolding mem_ball dist_norm using e by (auto simp add:field_simps) - qed - ultimately show ?thesis - apply (rule_tac x="?z" in exI) - unfolding Union_insert - apply auto + finally show "y \ ball x e" + unfolding mem_ball dist_norm using e by (auto simp add:field_simps) + qed + ultimately show ?thesis + apply (rule_tac x="?z" in exI) + unfolding Union_insert + apply auto + done + next + let ?z = "x + (e/2) *\<^sub>R k" + assume as: "x\k = b\k" + have "ball ?z (e / 2) \ i = {}" + proof (clarsimp simp only: all_not_in_conv [symmetric]) + fix y + assume "y \ ball ?z (e / 2)" and yi: "y \ i" + then have "dist ?z y < e/2" + by auto + then have "\(?z - y) \ k\ < e/2" + using Basis_le_norm[OF k, of "?z - y"] + unfolding dist_norm by auto + then have "y\k > b\k" + using e k + by (auto simp add:field_simps inner_simps inner_Basis as) + then have "y \ i" + unfolding ab mem_box by (auto intro!: bexI[OF _ k]) + then show False using yi by auto + qed + moreover + have "ball ?z (e/2) \ s \ (\insert i f)" + apply (rule order_trans[OF _ e[THEN conjunct2, unfolded lem1]]) + proof + fix y + assume as: "y\ ball ?z (e/2)" + have "norm (x - y) \ \e\ / 2 + norm (x - y + (e / 2) *\<^sub>R k)" + apply (rule order_trans,rule norm_triangle_sub[of "x - y" "- (e/2) *\<^sub>R k"]) + unfolding norm_scaleR + apply (auto simp: k) done + also have "\ < \e\ / 2 + \e\ / 2" + apply (rule add_strict_left_mono) + using as unfolding mem_ball dist_norm + using e apply (auto simp add: field_simps) + done + finally show "y \ ball x e" + unfolding mem_ball dist_norm using e by (auto simp add:field_simps) qed - then obtain x where "ball x (e / 2) \ s \ \f" .. - then have "x \ s \ interior (\f)" - unfolding lem1[where U="\f", symmetric] - using centre_in_ball e by auto - then show ?thesis - using insert.hyps(3) insert.prems(1) by blast + ultimately show ?thesis + apply (rule_tac x="?z" in exI) + unfolding Union_insert + apply auto + done qed + then obtain x where "ball x (e / 2) \ s \ \f" .. + then have "x \ s \ interior (\f)" + unfolding lem1[where U="\f", symmetric] + using centre_in_ball e by auto + then show ?thesis + using insert.hyps(3) insert.prems(1) by blast qed qed qed @@ -1097,15 +1094,16 @@ note p = division_ofD[OF assms(1)] have div_cbox: "\k\p. \q. q division_of cbox a b \ k \ q" proof - case goal1 + fix k + assume kp: "k \ p" obtain c d where k: "k = cbox c d" - using p(4)[OF goal1] by blast + using p(4)[OF kp] by blast have *: "cbox c d \ cbox a b" "cbox c d \ {}" - using p(2,3)[OF goal1, unfolded k] using assms(2) + using p(2,3)[OF kp, unfolded k] using assms(2) by (blast intro: order.trans)+ obtain q where "q division_of cbox a b" "cbox c d \ q" by (rule partial_division_extend_1[OF *]) - then show ?case + then show "\q. q division_of cbox a b \ k \ q" unfolding k by auto qed obtain q where q: "\x. x \ p \ q x division_of cbox a b" "\x. x \ p \ x \ q x" @@ -1275,9 +1273,10 @@ assume as: "p \ {}" "interior (cbox a b) \ {}" "cbox a b \ {}" have "\k\p. \q. (insert (cbox a b) q) division_of (cbox a b \ k)" proof - case goal1 - from assm(4)[OF this] obtain c d where "k = cbox c d" by blast - then show ?case + fix k + assume kp: "k \ p" + from assm(4)[OF kp] obtain c d where "k = cbox c d" by blast + then show "\q. (insert (cbox a b) q) division_of (cbox a b \ k)" by (meson as(3) division_union_intervals_exists) qed from bchoice[OF this] obtain q where "\x\p. insert (cbox a b) (q x) division_of (cbox a b) \ x" .. @@ -1910,7 +1909,8 @@ (\i\Basis. (if i \ s then (a\i + b\i) / 2 else b\i) *\<^sub>R i)) ` {s. s \ Basis}" have "?A \ ?B" proof - case goal1 + fix x + assume "x \ ?A" then obtain c d where x: "x = cbox c d" "\i. i \ Basis \ @@ -2034,15 +2034,14 @@ proof - have "\x. \y. \ P (cbox (fst x) (snd x)) \ (\ P (cbox (fst y) (snd y)) \ (\i\Basis. fst x\i \ fst y\i \ fst y\i \ snd y\i \ snd y\i \ snd x\i \ - 2 * (snd y\i - fst y\i) \ snd x\i - fst x\i))" + 2 * (snd y\i - fst y\i) \ snd x\i - fst x\i))" (is "\x. ?P x") proof - case goal1 - show ?case - proof - - presume "\ P (cbox (fst x) (snd x)) \ ?thesis" - then show ?thesis by (cases "P (cbox (fst x) (snd x))") auto + show "?P x" for x + proof (cases "P (cbox (fst x) (snd x))") + case True + then show ?thesis by auto next - assume as: "\ P (cbox (fst x) (snd x))" + case as: False obtain c d where "\ P (cbox c d)" "\i\Basis. fst x \ i \ c \ i \ @@ -2080,9 +2079,8 @@ proof - show "A 0 = a" "B 0 = b" unfolding ab_def by auto - case goal3 note S = ab_def funpow.simps o_def id_apply - show ?case + show "?P n" for n proof (induct n) case 0 then show ?case @@ -2103,12 +2101,12 @@ qed note AB = this(1-2) conjunctD2[OF this(3),rule_format] - have interv: "\e. 0 < e \ \n. \x\cbox (A n) (B n). \y\cbox (A n) (B n). dist x y < e" + have interv: "\n. \x\cbox (A n) (B n). \y\cbox (A n) (B n). dist x y < e" + if e: "0 < e" for e proof - - case goal1 obtain n where n: "(\i\Basis. b \ i - a \ i) / e < 2 ^ n" using real_arch_pow2[of "(setsum (\i. b\i - a\i) Basis) / e"] .. - show ?case + show ?thesis proof (rule exI [where x=n], clarify) fix x y assume xy: "x\cbox (A n) (B n)" "y\cbox (A n) (B n)" @@ -2125,8 +2123,7 @@ also have "\ \ setsum (\i. b\i - a\i) Basis / 2^n" unfolding setsum_divide_distrib proof (rule setsum_mono) - case goal1 - then show ?case + show "B n \ i - A n \ i \ (b \ i - a \ i) / 2 ^ n" if i: "i \ Basis" for i proof (induct n) case 0 then show ?case @@ -2134,14 +2131,14 @@ next case (Suc n) have "B (Suc n) \ i - A (Suc n) \ i \ (B n \ i - A n \ i) / 2" - using AB(4)[of i n] using goal1 by auto + using AB(4)[of i n] using i by auto also have "\ \ (b \ i - a \ i) / 2 ^ Suc n" - using Suc by (auto simp add:field_simps) + using Suc by (auto simp add: field_simps) finally show ?case . qed qed also have "\ < e" - using n using goal1 by (auto simp add:field_simps) + using n using e by (auto simp add: field_simps) finally show "dist x y < e" . qed qed @@ -2240,25 +2237,27 @@ shows "k1 = k2" proof (rule ccontr) let ?e = "norm (k1 - k2) / 2" - assume as:"k1 \ k2" + assume as: "k1 \ k2" then have e: "?e > 0" by auto - have lem: "\f::'n \ 'a. \a b k1 k2. - (f has_integral k1) (cbox a b) \ (f has_integral k2) (cbox a b) \ k1 \ k2 \ False" + have lem: False + if f_k1: "(f has_integral k1) (cbox a b)" + and f_k2: "(f has_integral k2) (cbox a b)" + and "k1 \ k2" + for f :: "'n \ 'a" and a b k1 k2 proof - - case goal1 let ?e = "norm (k1 - k2) / 2" - from goal1(3) have e: "?e > 0" by auto + from \k1 \ k2\ have e: "?e > 0" by auto obtain d1 where d1: "gauge d1" "\p. p tagged_division_of cbox a b \ d1 fine p \ norm ((\(x, k)\p. content k *\<^sub>R f x) - k1) < norm (k1 - k2) / 2" - by (rule has_integralD[OF goal1(1) e]) blast + by (rule has_integralD[OF f_k1 e]) blast obtain d2 where d2: "gauge d2" "\p. p tagged_division_of cbox a b \ d2 fine p \ norm ((\(x, k)\p. content k *\<^sub>R f x) - k2) < norm (k1 - k2) / 2" - by (rule has_integralD[OF goal1(2) e]) blast + by (rule has_integralD[OF f_k2 e]) blast obtain p where p: "p tagged_division_of cbox a b" "(\x. d1 x \ d2 x) fine p" @@ -2336,26 +2335,26 @@ fix a b e fix f :: "'n \ 'a" assume as: "\x\cbox a b. f x = 0" "0 < (e::real)" - have "\p. p tagged_division_of cbox a b \ (\x. ball x 1) fine p \ norm ((\(x, k)\p. content k *\<^sub>R f x) - 0) < e" + have "norm ((\(x, k)\p. content k *\<^sub>R f x) - 0) < e" + if p: "p tagged_division_of cbox a b" for p proof - - case goal1 have "(\(x, k)\p. content k *\<^sub>R f x) = 0" proof (rule setsum.neutral, rule) fix x assume x: "x \ p" have "f (fst x) = 0" - using tagged_division_ofD(2-3)[OF goal1(1), of "fst x" "snd x"] using as x by auto + using tagged_division_ofD(2-3)[OF p, of "fst x" "snd x"] using as x by auto then show "(\(x, k). content k *\<^sub>R f x) x = 0" apply (subst surjective_pairing[of x]) unfolding split_conv apply auto done qed - then show ?case + then show ?thesis using as by auto qed then show "\d. gauge d \ - (\p. p tagged_division_of (cbox a b) \ d fine p \ norm ((\(x, k)\p. content k *\<^sub>R f x) - 0) < e)" + (\p. p tagged_division_of (cbox a b) \ d fine p \ norm ((\(x, k)\p. content k *\<^sub>R f x) - 0) < e)" by auto qed { @@ -2392,19 +2391,20 @@ by blast have lem: "\(f :: 'n \ 'a) y a b. (f has_integral y) (cbox a b) \ ((h o f) has_integral h y) (cbox a b)" - unfolding has_integral - proof clarify - case goal1 + unfolding has_integral + proof (clarify, goal_cases) + case prems: (1 f y a b e) from pos_bounded obtain B where B: "0 < B" "\x. norm (h x) \ norm x * B" by blast - have "e / B > 0" using goal1(2) B by simp + have "e / B > 0" using prems(2) B by simp then obtain g where g: "gauge g" "\p. p tagged_division_of (cbox a b) \ g fine p \ norm ((\(x, k)\p. content k *\<^sub>R f x) - y) < e / B" - using goal1(1) by auto - { fix p + using prems(1) by auto + { + fix p assume as: "p tagged_division_of (cbox a b)" "g fine p" have hc: "\x k. h ((\(x, k). content k *\<^sub>R f x) x) = (\(x, k). h (content k *\<^sub>R f x)) x" by auto @@ -2441,18 +2441,19 @@ using has_integral_altD[OF assms(1) as *] by blast show "\B>0. \a b. ball 0 B \ cbox a b \ (\z. ((\x. if x \ s then (h \ f) x else 0) has_integral z) (cbox a b) \ norm (z - h y) < e)" - proof (rule_tac x=M in exI, clarsimp simp add: M) - case goal1 + proof (rule_tac x=M in exI, clarsimp simp add: M, goal_cases) + case prems: (1 a b) obtain z where z: "((\x. if x \ s then f x else 0) has_integral z) (cbox a b)" "norm (z - y) < e / B" - using M(2)[OF goal1(1)] by blast + using M(2)[OF prems(1)] by blast have *: "(\x. if x \ s then (h \ f) x else 0) = h \ (\x. if x \ s then f x else 0)" using zero by auto show ?case apply (rule_tac x="h z" in exI) - apply (simp add: "*" lem z(1)) - by (metis B diff le_less_trans pos_less_divide_eq z(2)) + apply (simp add: * lem z(1)) + apply (metis B diff le_less_trans pos_less_divide_eq z(2)) + done qed qed qed @@ -2475,7 +2476,7 @@ fixes c :: "'a :: real_normed_algebra" shows "(f has_integral y) i \ ((\x. c * f x) has_integral (c * y)) i" using has_integral_linear[OF _ bounded_linear_mult_right] by (simp add: comp_def) - + lemma has_integral_cmul: "(f has_integral k) s \ ((\x. c *\<^sub>R f x) has_integral (c *\<^sub>R k)) s" unfolding o_def[symmetric] by (metis has_integral_linear bounded_linear_scaleR_right) @@ -2502,51 +2503,47 @@ and "(g has_integral l) s" shows "((\x. f x + g x) has_integral (k + l)) s" proof - - have lem:"\(f:: 'n \ 'a) g a b k l. - (f has_integral k) (cbox a b) \ - (g has_integral l) (cbox a b) \ - ((\x. f x + g x) has_integral (k + l)) (cbox a b)" - proof - - case goal1 - show ?case - unfolding has_integral - proof clarify - fix e :: real - assume e: "e > 0" - then have *: "e/2 > 0" + have lem: "((\x. f x + g x) has_integral (k + l)) (cbox a b)" + if f_k: "(f has_integral k) (cbox a b)" + and g_l: "(g has_integral l) (cbox a b)" + for f :: "'n \ 'a" and g a b k l + unfolding has_integral + proof clarify + fix e :: real + assume e: "e > 0" + then have *: "e / 2 > 0" + by auto + obtain d1 where d1: + "gauge d1" + "\p. p tagged_division_of (cbox a b) \ d1 fine p \ + norm ((\(x, k)\p. content k *\<^sub>R f x) - k) < e / 2" + using has_integralD[OF f_k *] by blast + obtain d2 where d2: + "gauge d2" + "\p. p tagged_division_of (cbox a b) \ d2 fine p \ + norm ((\(x, k)\p. content k *\<^sub>R g x) - l) < e / 2" + using has_integralD[OF g_l *] by blast + show "\d. gauge d \ (\p. p tagged_division_of (cbox a b) \ d fine p \ + norm ((\(x, k)\p. content k *\<^sub>R (f x + g x)) - (k + l)) < e)" + proof (rule exI [where x="\x. (d1 x) \ (d2 x)"], clarsimp simp add: gauge_inter[OF d1(1) d2(1)]) + fix p + assume as: "p tagged_division_of (cbox a b)" "(\x. d1 x \ d2 x) fine p" + have *: "(\(x, k)\p. content k *\<^sub>R (f x + g x)) = + (\(x, k)\p. content k *\<^sub>R f x) + (\(x, k)\p. content k *\<^sub>R g x)" + unfolding scaleR_right_distrib setsum.distrib[of "\(x,k). content k *\<^sub>R f x" "\(x,k). content k *\<^sub>R g x" p,symmetric] + by (rule setsum.cong) auto + from as have fine: "d1 fine p" "d2 fine p" + unfolding fine_inter by auto + have "norm ((\(x, k)\p. content k *\<^sub>R (f x + g x)) - (k + l)) = + norm (((\(x, k)\p. content k *\<^sub>R f x) - k) + ((\(x, k)\p. content k *\<^sub>R g x) - l))" + unfolding * by (auto simp add: algebra_simps) + also have "\ < e/2 + e/2" + apply (rule le_less_trans[OF norm_triangle_ineq]) + using as d1 d2 fine + apply (blast intro: add_strict_mono) + done + finally show "norm ((\(x, k)\p. content k *\<^sub>R (f x + g x)) - (k + l)) < e" by auto - obtain d1 where d1: - "gauge d1" - "\p. p tagged_division_of (cbox a b) \ d1 fine p \ - norm ((\(x, k)\p. content k *\<^sub>R f x) - k) < e / 2" - using has_integralD[OF goal1(1) *] by blast - obtain d2 where d2: - "gauge d2" - "\p. p tagged_division_of (cbox a b) \ d2 fine p \ - norm ((\(x, k)\p. content k *\<^sub>R g x) - l) < e / 2" - using has_integralD[OF goal1(2) *] by blast - show "\d. gauge d \ (\p. p tagged_division_of (cbox a b) \ d fine p \ - norm ((\(x, k)\p. content k *\<^sub>R (f x + g x)) - (k + l)) < e)" - proof (rule exI [where x="\x. (d1 x) \ (d2 x)"], clarsimp simp add: gauge_inter[OF d1(1) d2(1)]) - fix p - assume as: "p tagged_division_of (cbox a b)" "(\x. d1 x \ d2 x) fine p" - have *: "(\(x, k)\p. content k *\<^sub>R (f x + g x)) = - (\(x, k)\p. content k *\<^sub>R f x) + (\(x, k)\p. content k *\<^sub>R g x)" - unfolding scaleR_right_distrib setsum.distrib[of "\(x,k). content k *\<^sub>R f x" "\(x,k). content k *\<^sub>R g x" p,symmetric] - by (rule setsum.cong) auto - from as have fine: "d1 fine p" "d2 fine p" - unfolding fine_inter by auto - have "norm ((\(x, k)\p. content k *\<^sub>R (f x + g x)) - (k + l)) = - norm (((\(x, k)\p. content k *\<^sub>R f x) - k) + ((\(x, k)\p. content k *\<^sub>R g x) - l))" - unfolding * by (auto simp add: algebra_simps) - also have "\ < e/2 + e/2" - apply (rule le_less_trans[OF norm_triangle_ineq]) - using as d1 d2 fine - apply (blast intro: add_strict_mono) - done - finally show "norm ((\(x, k)\p. content k *\<^sub>R (f x + g x)) - (k + l)) < e" - by auto - qed qed qed { @@ -2556,9 +2553,9 @@ } assume as: "\ (\a b. s = cbox a b)" then show ?thesis - proof (subst has_integral_alt, clarsimp) - case goal1 - then have *: "e/2 > 0" + proof (subst has_integral_alt, clarsimp, goal_cases) + case (1 e) + then have *: "e / 2 > 0" by auto from has_integral_altD[OF assms(1) as *] obtain B1 where B1: @@ -2812,8 +2809,8 @@ assume ?l then guess y unfolding integrable_on_def has_integral .. note y=this show "\e>0. \d. ?P e d" - proof clarify - case goal1 + proof (clarify, goal_cases) + case (1 e) then have "e/2 > 0" by auto then guess d apply - @@ -2847,8 +2844,8 @@ have dp: "\i n. i\n \ d i fine p n" using p(2) unfolding fine_inters by auto have "Cauchy (\n. setsum (\(x,k). content k *\<^sub>R (f x)) (p n))" - proof (rule CauchyI) - case goal1 + proof (rule CauchyI, goal_cases) + case (1 e) then guess N unfolding real_arch_inv[of e] .. note N=this show ?case apply (rule_tac x=N in exI) @@ -3107,8 +3104,8 @@ and fj: "(f has_integral j) (cbox a b \ {x. x\k \ c})" and k: "k \ Basis" shows "(f has_integral (i + j)) (cbox a b)" -proof (unfold has_integral, rule, rule) - case goal1 +proof (unfold has_integral, rule, rule, goal_cases) + case (1 e) then have e: "e/2 > 0" by auto obtain d1 @@ -3176,12 +3173,11 @@ have lem1: "\f P Q. (\x k. (x, k) \ {(x, f k) | x k. P x k} \ Q x k) \ (\x k. P x k \ Q x (f k))" by auto - have fin_finite: "\f s P f. finite s \ finite {(x,f k) | x k. (x,k) \ s \ P x k}" + have fin_finite: "finite {(x,f k) | x k. (x,k) \ s \ P x k}" if "finite s" for f s P proof - - case goal1 - then have "finite ((\(x, k). (x, f k)) ` s)" + from that have "finite ((\(x, k). (x, f k)) ` s)" by auto - then show ?case + then show ?thesis by (rule rev_finite_subset) auto qed { fix g :: "'a set \ 'a set" @@ -3848,16 +3844,18 @@ lemma iterate_image: assumes "monoidal opp" - and "inj_on f s" - shows "iterate opp (f ` s) g = iterate opp s (g \ f)" -proof - - have *: "\s. finite s \ \x\s. \y\s. f x = f y \ x = y \ - iterate opp (f ` s) g = iterate opp s (g \ f)" - proof - - case goal1 - then show ?case - apply (induct s) - using assms(1) by auto + and "inj_on f s" + shows "iterate opp (f ` s) g = iterate opp s (g \ f)" +proof - + have *: "iterate opp (f ` s) g = iterate opp s (g \ f)" + if "finite s" "\x\s. \y\s. f x = f y \ x = y" for s + using that + proof (induct s) + case empty + then show ?case by simp + next + case insert + with assms(1) show ?case by auto qed show ?thesis apply (cases "finite (support opp g (f ` s))") @@ -4333,14 +4331,17 @@ and "\x\s. (f x)\k \ (g x)\k" shows "i\k \ j\k" proof - - have lem: "\a b i j::'b. \g f::'a \ 'b. (f has_integral i) (cbox a b) \ - (g has_integral j) (cbox a b) \ \x\cbox a b. (f x)\k \ (g x)\k \ i\k \ j\k" + have lem: "i\k \ j\k" + if f_i: "(f has_integral i) (cbox a b)" + and g_j: "(g has_integral j) (cbox a b)" + and le: "\x\cbox a b. (f x)\k \ (g x)\k" + for a b i and j :: 'b and f g :: "'a \ 'b" proof (rule ccontr) - case goal1 + assume "\ ?thesis" then have *: "0 < (i\k - j\k) / 3" by auto - guess d1 using goal1(1)[unfolded has_integral,rule_format,OF *] by (elim exE conjE) note d1=this[rule_format] - guess d2 using goal1(2)[unfolded has_integral,rule_format,OF *] by (elim exE conjE) note d2=this[rule_format] + guess d1 using f_i[unfolded has_integral,rule_format,OF *] by (elim exE conjE) note d1=this[rule_format] + guess d2 using g_j[unfolded has_integral,rule_format,OF *] by (elim exE conjE) note d2=this[rule_format] obtain p where p: "p tagged_division_of cbox a b" "d1 fine p" "d2 fine p" using fine_division_exists[OF gauge_inter[OF d1(1) d2(1)], of a b] unfolding fine_inter by metis @@ -4351,7 +4352,7 @@ by blast+ then show False unfolding inner_simps - using rsum_component_le[OF p(1) goal1(3)] + using rsum_component_le[OF p(1) le] by (simp add: abs_real_def split: split_if_asm) qed show ?thesis @@ -4747,9 +4748,10 @@ assumes k: "k \ Basis" shows "negligible {x. x\k = c}" unfolding negligible_def has_integral -proof clarify - case goal1 - from content_doublesplit[OF this k,of a b c] guess d . note d=this +proof (clarify, goal_cases) + case (1 a b e) + from this and k obtain d where d: "0 < d" "content (cbox a b \ {x. \x \ k - c\ \ d}) < e" + by (rule content_doublesplit) let ?i = "indicator {x::'a. x\k = c} :: 'a\real" show ?case apply (rule_tac x="\x. ball x d" in exI) @@ -4821,9 +4823,8 @@ apply (auto simp add:interval_doublesplit[OF k]) done also have "\ < e" - apply (subst setsum_over_tagged_division_lemma[OF p[THEN conjunct1]]) - proof - - case goal1 + proof (subst setsum_over_tagged_division_lemma[OF p[THEN conjunct1]], goal_cases) + case prems: (1 u v) have "content (cbox u v \ {x. \x \ k - c\ \ d}) \ content (cbox u v)" unfolding interval_doublesplit[OF k] apply (rule content_subset) @@ -4831,8 +4832,7 @@ apply auto done then show ?case - unfolding goal1 - unfolding interval_doublesplit[OF k] + unfolding prems interval_doublesplit[OF k] by (blast intro: antisym) next have *: "setsum content {l \ {x. \x \ k - c\ \ d} |l. l \ snd ` p \ l \ {x. \x \ k - c\ \ d} \ {}} \ 0" @@ -5111,8 +5111,8 @@ assume assm: "\x. x \ s \ f x = 0" show "(f has_integral 0) (cbox a b)" unfolding has_integral - proof safe - case goal1 + proof (safe, goal_cases) + case prems: (1 e) then have "\n. e / 2 / ((real n+1) * (2 ^ n)) > 0" apply - apply (rule divide_pos_pos) @@ -5135,7 +5135,7 @@ presume "p \ {} \ ?goal" then show ?goal apply (cases "p = {}") - using goal1 + using prems apply auto done } @@ -5159,21 +5159,16 @@ apply (drule tagged_division_ofD(4)[OF q(1)]) apply (auto intro: mult_nonneg_nonneg) done - have **: "\f g s t. finite s \ finite t \ (\(x,y) \ t. (0::real) \ g(x,y)) \ - (\y\s. \x. (x,y) \ t \ f(y) \ g(x,y)) \ setsum f s \ setsum g t" - proof - - case goal1 - then show ?case - apply - - apply (rule setsum_le_included[of s t g snd f]) - prefer 4 - apply safe - apply (erule_tac x=x in ballE) - apply (erule exE) - apply (rule_tac x="(xa,x)" in bexI) - apply auto - done - qed + have **: "finite s \ finite t \ (\(x,y) \ t. (0::real) \ g(x,y)) \ + (\y\s. \x. (x,y) \ t \ f(y) \ g(x,y)) \ setsum f s \ setsum g t" for f g s t + apply (rule setsum_le_included[of s t g snd f]) + prefer 4 + apply safe + apply (erule_tac x=x in ballE) + apply (erule exE) + apply (rule_tac x="(xa,x)" in bexI) + apply auto + done have "norm ((\(x, k)\p. content k *\<^sub>R f x) - 0) \ setsum (\i. (real i + 1) * norm (setsum (\(x,k). content k *\<^sub>R indicator s x :: real) (q i))) {..N+1}" unfolding real_norm_def setsum_right_distrib abs_of_nonneg[OF *] diff_0_right @@ -5244,12 +5239,11 @@ done qed (insert as, auto) also have "\ \ setsum (\i. e / 2 / 2 ^ i) {..N+1}" - apply (rule setsum_mono) - proof - - case goal1 + proof (rule setsum_mono, goal_cases) + case (1 i) then show ?case apply (subst mult.commute, subst pos_le_divide_eq[symmetric]) - using d(2)[rule_format,of "q i" i] + using d(2)[rule_format, of "q i" i] using q[rule_format] apply (auto simp add: field_simps) done @@ -5259,7 +5253,7 @@ apply (rule mult_strict_left_mono) unfolding power_inverse [symmetric] lessThan_Suc_atMost[symmetric] apply (subst geometric_sum) - using goal1 + using prems apply auto done finally show "?goal" by auto @@ -5352,8 +5346,8 @@ and "t \ s" shows "negligible t" unfolding negligible_def -proof safe - case goal1 +proof (safe, goal_cases) + case (1 a b) show ?case using assms(1)[unfolded negligible_def,rule_format,of a b] apply - @@ -5381,8 +5375,8 @@ and "negligible t" shows "negligible (s \ t)" unfolding negligible_def -proof safe - case goal1 +proof (safe, goal_cases) + case (1 a b) note assm = assms[unfolded negligible_def,rule_format,of a b] then show ?case apply (subst has_integral_spike_eq[OF assms(2)]) @@ -5557,20 +5551,18 @@ by auto lemma operative_approximable: - fixes f::"'b::euclidean_space \ 'a::banach" + fixes f :: "'b::euclidean_space \ 'a::banach" assumes "0 \ e" shows "operative op \ (\i. \g. (\x\i. norm (f x - g (x::'b)) \ e) \ g integrable_on i)" unfolding operative_def neutral_and proof safe fix a b :: 'b - { - assume "content (cbox a b) = 0" - then show "\g. (\x\cbox a b. norm (f x - g x) \ e) \ g integrable_on cbox a b" - apply (rule_tac x=f in exI) - using assms - apply (auto intro!:integrable_on_null) - done - } + show "\g. (\x\cbox a b. norm (f x - g x) \ e) \ g integrable_on cbox a b" + if "content (cbox a b) = 0" + apply (rule_tac x=f in exI) + using assms that + apply (auto intro!: integrable_on_null) + done { fix c g fix k :: 'b @@ -5590,8 +5582,9 @@ let ?g = "\x. if x\k = c then f x else if x\k \ c then g1 x else g2 x" show "\g. (\x\cbox a b. norm (f x - g x) \ e) \ g integrable_on cbox a b" apply (rule_tac x="?g" in exI) - proof safe - case goal1 + apply safe + proof goal_cases + case (1 x) then show ?case apply - apply (cases "x\k=c") @@ -5600,7 +5593,7 @@ apply auto done next - case goal2 + case 2 presume "?g integrable_on cbox a b \ {x. x \ k \ c}" and "?g integrable_on cbox a b \ {x. x \ k \ c}" then guess h1 h2 unfolding integrable_on_def by auto @@ -6080,7 +6073,7 @@ "f b = (\iR Df i a) + integral {a..b} i" and taylor_integrable: "i integrable_on {a .. b}" -proof goals +proof goal_cases case 1 interpret bounded_bilinear "scaleR::real\'a\'a" by (rule bounded_bilinear_scaleR) @@ -6437,8 +6430,8 @@ let ?I = "\a b. integral {a .. b} f" show "\d>0. \y\{a .. b}. norm (y - x) < d \ norm (?I a y - ?I a x - (y - x) *\<^sub>R f x) \ e * norm (y - x)" - proof (rule, rule, rule d, safe) - case goal1 + proof (rule, rule, rule d, safe, goal_cases) + case prems: (1 y) show ?case proof (cases "y < x") case False @@ -6446,7 +6439,7 @@ apply (rule integrable_subinterval_real,rule integrable_continuous_real) apply (rule assms) unfolding not_less - using assms(2) goal1 + using assms(2) prems apply auto done then have *: "?I a y - ?I a x = ?I x y" @@ -6455,7 +6448,7 @@ apply (rule integral_combine) using False unfolding not_less - using assms(2) goal1 + using assms(2) prems apply auto done have **: "norm (y - x) = content {x .. y}" @@ -6472,7 +6465,7 @@ apply (rule assms)+ proof - show "{x .. y} \ {a .. b}" - using goal1 assms(2) by auto + using prems assms(2) by auto have *: "y - x = norm (y - x)" using False by auto show "((\xa. f x) has_integral (y - x) *\<^sub>R f x) {x .. y}" @@ -6484,7 +6477,7 @@ apply (rule less_imp_le) apply (rule d(2)[unfolded dist_norm]) using assms(2) - using goal1 + using prems apply auto done qed (insert e, auto) @@ -6495,14 +6488,14 @@ unfolding box_real apply (rule assms)+ unfolding not_less - using assms(2) goal1 + using assms(2) prems apply auto done then have *: "?I a x - ?I a y = ?I y x" unfolding algebra_simps apply (subst eq_commute) apply (rule integral_combine) - using True using assms(2) goal1 + using True using assms(2) prems apply auto done have **: "norm (y - x) = content {y .. x}" @@ -6528,7 +6521,7 @@ apply (rule assms)+ proof - show "{y .. x} \ {a .. b}" - using goal1 assms(2) by auto + using prems assms(2) by auto have *: "x - y = norm (y - x)" using True by auto show "((\xa. f x) has_integral (x - y) *\<^sub>R f x) {y .. x}" @@ -6541,7 +6534,7 @@ apply (rule less_imp_le) apply (rule d(2)[unfolded dist_norm]) using assms(2) - using goal1 + using prems apply auto done qed (insert e, auto) @@ -6570,17 +6563,18 @@ from antiderivative_continuous[OF assms] guess g . note g=this show ?thesis apply (rule that[of g]) - proof safe - case goal1 + apply safe + proof goal_cases + case prems: (1 u v) have "\x\cbox u v. (g has_vector_derivative f x) (at x within cbox u v)" apply rule apply (rule has_vector_derivative_within_subset) apply (rule g[rule_format]) - using goal1(1-2) + using prems(1,2) apply auto done then show ?case - using fundamental_theorem_of_calculus[OF goal1(3),of "g" "f"] by auto + using fundamental_theorem_of_calculus[OF prems(3), of g f] by auto qed qed @@ -6598,18 +6592,16 @@ and "(f has_integral i) (cbox a b)" shows "((\x. f(g x)) has_integral (1 / r) *\<^sub>R i) (h ` cbox a b)" proof - - { - presume *: "cbox a b \ {} \ ?thesis" - show ?thesis - apply cases - defer - apply (rule *) - apply assumption - proof - - case goal1 - then show ?thesis - unfolding goal1 assms(8)[unfolded goal1 has_integral_empty_eq] by auto qed - } + show ?thesis when *: "cbox a b \ {} \ ?thesis" + apply cases + defer + apply (rule *) + apply assumption + proof goal_cases + case prems: 1 + then show ?thesis + unfolding prems assms(8)[unfolded prems has_integral_empty_eq] by auto + qed assume "cbox a b \ {}" from assms(6)[rule_format,of a b] guess w z by (elim exE) note wz=this have inj: "inj g" "inj h" @@ -6809,7 +6801,7 @@ using assms apply (safe intro!: interval_image_affinity_interval content_image_affinity_cbox) apply (rule zero_less_power) - unfolding scaleR_right_distrib + unfolding scaleR_right_distrib apply auto done @@ -7102,10 +7094,9 @@ by (rule norm_triangle_ineq4) also have "\ \ e * (b - a) / 8 + e * (b - a) / 8" proof (rule add_mono) - case goal1 have "\c - a\ \ \l\" using as' by auto - then show ?case + then show "norm ((c - a) *\<^sub>R f' a) \ e * (b - a) / 8" apply - apply (rule order_trans[OF _ l(2)]) unfolding norm_scaleR @@ -7113,8 +7104,7 @@ apply auto done next - case goal2 - show ?case + show "norm (f c - f a) \ e * (b - a) / 8" apply (rule less_imp_le) apply (cases "a = c") defer @@ -7165,10 +7155,9 @@ by (rule norm_triangle_ineq4) also have "\ \ e * (b - a) / 8 + e * (b - a) / 8" proof (rule add_mono) - case goal1 have "\c - b\ \ \l\" using as' by auto - then show ?case + then show "norm ((b - c) *\<^sub>R f' b) \ e * (b - a) / 8" apply - apply (rule order_trans[OF _ l(2)]) unfolding norm_scaleR @@ -7176,8 +7165,7 @@ apply auto done next - case goal2 - show ?case + show "norm (f b - f c) \ e * (b - a) / 8" apply (rule less_imp_le) apply (cases "b = c") defer @@ -7196,21 +7184,20 @@ let ?d = "(\x. ball x (if x=a then da else if x=b then db else d x))" show "?P e" apply (rule_tac x="?d" in exI) - proof safe - case goal1 + proof (safe, goal_cases) + case 1 show ?case apply (rule gauge_ball_dependent) using ab db(1) da(1) d(1) apply auto done next - case goal2 - note as=this + case as: (2 p) let ?A = "{t. fst t \ {a, b}}" - note p = tagged_division_ofD[OF goal2(1)] + note p = tagged_division_ofD[OF as(1)] have pA: "p = (p \ ?A) \ (p - ?A)" "finite (p \ ?A)" "finite (p - ?A)" "(p \ ?A) \ (p - ?A) = {}" - using goal2 by auto - note * = additive_tagged_division_1'[OF assms(1) goal2(1), symmetric] + using as by auto + note * = additive_tagged_division_1'[OF assms(1) as(1), symmetric] have **: "\n1 s1 n2 s2::real. n2 \ s2 / 2 \ n1 - s1 \ s2 / 2 \ n1 + n2 \ s1 + s2" by arith show ?case @@ -7219,8 +7206,8 @@ apply (subst(2) pA) apply (subst pA) unfolding setsum.union_disjoint[OF pA(2-)] - proof (rule norm_triangle_le, rule **) - case goal1 + proof (rule norm_triangle_le, rule **, goal_cases) + case 1 show ?case apply (rule order_trans) apply (rule setsum_norm_le) @@ -7231,17 +7218,17 @@ apply (unfold not_le o_def split_conv fst_conv) proof (rule ccontr) fix x k - assume as: "(x, k) \ p" + assume xk: "(x, k) \ p" "e * (Sup k - Inf k) / 2 < norm (content k *\<^sub>R f' x - (f (Sup k) - f (Inf k)))" from p(4)[OF this(1)] guess u v by (elim exE) note k=this then have "u \ v" and uv: "{u, v} \ cbox u v" - using p(2)[OF as(1)] by auto - note result = as(2)[unfolded k box_real interval_bounds_real[OF this(1)] content_real[OF this(1)]] + using p(2)[OF xk(1)] by auto + note result = xk(2)[unfolded k box_real interval_bounds_real[OF this(1)] content_real[OF this(1)]] assume as': "x \ a" "x \ b" then have "x \ box a b" - using p(2-3)[OF as(1)] by (auto simp: mem_box) + using p(2-3)[OF xk(1)] by (auto simp: mem_box) note * = d(2)[OF this] have "norm ((v - u) *\<^sub>R f' (x) - (f (v) - f (u))) = norm ((f (u) - f (x) - (u - x) *\<^sub>R f' (x)) - (f (v) - f (x) - (v - x) *\<^sub>R f' (x)))" @@ -7253,7 +7240,7 @@ apply (rule norm_triangle_le_sub) apply (rule add_mono) apply (rule_tac[!] *) - using fineD[OF goal2(2) as(1)] as' + using fineD[OF as(2) xk(1)] as' unfolding k subset_eq apply - apply (erule_tac x=u in ballE) @@ -7262,7 +7249,7 @@ apply (auto simp:dist_real_def) done also have "\ \ e / 2 * norm (v - u)" - using p(2)[OF as(1)] + using p(2)[OF xk(1)] unfolding k by (auto simp add: field_simps) finally have "e * (v - u) / 2 < e * (v - u) / 2" @@ -7276,7 +7263,7 @@ next have *: "\x s1 s2::real. 0 \ s1 \ x \ (s1 + s2) / 2 \ x - s1 \ s2 / 2" by auto - case goal2 + case 2 show ?case apply (rule *) apply (rule setsum_nonneg) @@ -7285,7 +7272,6 @@ defer unfolding setsum.union_disjoint[OF pA(2-),symmetric] pA(1)[symmetric] unfolding setsum_right_distrib[symmetric] - thm additive_tagged_division_1 apply (subst additive_tagged_division_1[OF _ as(1)]) apply (rule assms) proof - @@ -7307,7 +7293,7 @@ defer apply rule unfolding split_paired_all split_conv o_def - proof - + proof goal_cases fix x k assume "(x, k) \ p \ {t. fst t \ {a, b}} - p \ {t. fst t \ {a, b} \ content (snd t) \ 0}" then have xk: "(x, k) \ p" "content k = 0" @@ -7325,18 +7311,24 @@ have *: "p \ {t. fst t \ {a, b} \ content(snd t) \ 0} = {t. t\p \ fst t = a \ content(snd t) \ 0} \ {t. t\p \ fst t = b \ content(snd t) \ 0}" by blast - have **: "\s f. \e::real. (\x y. x \ s \ y \ s \ x = y) \ - (\x. x \ s \ norm (f x) \ e) \ e > 0 \ norm (setsum f s) \ e" - proof (case_tac "s = {}") - case goal2 + have **: "norm (setsum f s) \ e" + if "\x y. x \ s \ y \ s \ x = y" + and "\x. x \ s \ norm (f x) \ e" + and "e > 0" + for s f and e :: real + proof (cases "s = {}") + case True + with that show ?thesis by auto + next + case False then obtain x where "x \ s" by auto then have *: "s = {x}" - using goal2(1) by auto - then show ?case - using \x \ s\ goal2(2) by auto - qed auto - case goal2 + using that(1) by auto + then show ?thesis + using \x \ s\ that(2) by auto + qed + case 2 show ?case apply (subst *) apply (subst setsum.union_disjoint) @@ -7346,48 +7338,46 @@ apply (rule_tac[1-2] **) proof - let ?B = "\x. {t \ p. fst t = x \ content (snd t) \ 0}" - have pa: "\k. (a, k) \ p \ \v. k = cbox a v \ a \ v" + have pa: "\v. k = cbox a v \ a \ v" if "(a, k) \ p" for k proof - - case goal1 - guess u v using p(4)[OF goal1] by (elim exE) note uv=this + guess u v using p(4)[OF that] by (elim exE) note uv=this have *: "u \ v" - using p(2)[OF goal1] unfolding uv by auto + using p(2)[OF that] unfolding uv by auto have u: "u = a" proof (rule ccontr) have "u \ cbox u v" - using p(2-3)[OF goal1(1)] unfolding uv by auto + using p(2-3)[OF that(1)] unfolding uv by auto have "u \ a" - using p(2-3)[OF goal1(1)] unfolding uv subset_eq by auto + using p(2-3)[OF that(1)] unfolding uv subset_eq by auto moreover assume "\ ?thesis" ultimately have "u > a" by auto then show False - using p(2)[OF goal1(1)] unfolding uv by (auto simp add:) + using p(2)[OF that(1)] unfolding uv by (auto simp add:) qed - then show ?case + then show ?thesis apply (rule_tac x=v in exI) unfolding uv using * apply auto done qed - have pb: "\k. (b, k) \ p \ \v. k = cbox v b \ b \ v" + have pb: "\v. k = cbox v b \ b \ v" if "(b, k) \ p" for k proof - - case goal1 - guess u v using p(4)[OF goal1] by (elim exE) note uv=this + guess u v using p(4)[OF that] by (elim exE) note uv=this have *: "u \ v" - using p(2)[OF goal1] unfolding uv by auto - have u: "v = b" + using p(2)[OF that] unfolding uv by auto + have u: "v = b" proof (rule ccontr) have "u \ cbox u v" - using p(2-3)[OF goal1(1)] unfolding uv by auto + using p(2-3)[OF that(1)] unfolding uv by auto have "v \ b" - using p(2-3)[OF goal1(1)] unfolding uv subset_eq by auto + using p(2-3)[OF that(1)] unfolding uv subset_eq by auto moreover assume "\ ?thesis" ultimately have "v < b" by auto then show False - using p(2)[OF goal1(1)] unfolding uv by (auto simp add:) + using p(2)[OF that(1)] unfolding uv by (auto simp add:) qed - then show ?case + then show ?thesis apply (rule_tac x=u in exI) unfolding uv using * @@ -7458,15 +7448,15 @@ apply rule unfolding mem_Collect_eq unfolding split_paired_all fst_conv snd_conv - proof safe - case goal1 - guess v using pa[OF goal1(1)] .. note v = conjunctD2[OF this] + proof (safe, goal_cases) + case prems: 1 + guess v using pa[OF prems(1)] .. note v = conjunctD2[OF this] have "?a \ {?a..v}" using v(2) by auto then have "v \ ?b" - using p(3)[OF goal1(1)] unfolding subset_eq v by auto + using p(3)[OF prems(1)] unfolding subset_eq v by auto moreover have "{?a..v} \ ball ?a da" - using fineD[OF as(2) goal1(1)] + using fineD[OF as(2) prems(1)] apply - apply (subst(asm) if_P) apply (rule refl) @@ -7479,7 +7469,7 @@ unfolding v interval_bounds_real[OF v(2)] box_real apply - apply(rule da(2)[of "v"]) - using goal1 fineD[OF as(2) goal1(1)] + using prems fineD[OF as(2) prems(1)] unfolding v content_eq_0 apply auto done @@ -7490,14 +7480,15 @@ apply rule unfolding mem_Collect_eq unfolding split_paired_all fst_conv snd_conv - proof safe - case goal1 guess v using pb[OF goal1(1)] .. note v = conjunctD2[OF this] + proof (safe, goal_cases) + case prems: 1 + guess v using pb[OF prems(1)] .. note v = conjunctD2[OF this] have "?b \ {v.. ?b}" using v(2) by auto - then have "v \ ?a" using p(3)[OF goal1(1)] + then have "v \ ?a" using p(3)[OF prems(1)] unfolding subset_eq v by auto moreover have "{v..?b} \ ball ?b db" - using fineD[OF as(2) goal1(1)] + using fineD[OF as(2) prems(1)] apply - apply (subst(asm) if_P, rule refl) unfolding subset_eq @@ -7511,7 +7502,7 @@ unfolding interval_bounds_real[OF v(2)] box_real apply - apply(rule db(2)[of "v"]) - using goal1 fineD[OF as(2) goal1(1)] + using prems fineD[OF as(2) prems(1)] unfolding v content_eq_0 apply auto done @@ -7705,9 +7696,9 @@ from fine_division_exists_real[OF this, of a t] guess p . note p=this note p'=tagged_division_ofD[OF this(1)] have pt: "\(x,k)\p. x \ t" - proof safe - case goal1 - from p'(2,3)[OF this] show ?case + proof (safe, goal_cases) + case prems: 1 + from p'(2,3)[OF prems] show ?case by auto qed with p(2) have "d2 fine p" @@ -7760,9 +7751,9 @@ have **: "\x F. F \ {x} = insert x F" by auto have "(c, cbox t c) \ p" - proof safe - case goal1 - from p'(2-3)[OF this] have "c \ cbox a t" + proof (safe, goal_cases) + case prems: 1 + from p'(2-3)[OF prems] have "c \ cbox a t" by auto then show False using \t < c\ by auto @@ -7862,8 +7853,8 @@ apply cases apply (rule *) apply assumption - proof - - case goal1 + proof goal_cases + case 1 then have "cbox a b = {x}" using as(1) apply - @@ -8001,12 +7992,11 @@ using assms(4,7) apply auto done - have *: "\t xa. (1 - t) *\<^sub>R c + t *\<^sub>R x = (1 - xa) *\<^sub>R c + xa *\<^sub>R x \ t = xa" + have *: "t = xa" if "(1 - t) *\<^sub>R c + t *\<^sub>R x = (1 - xa) *\<^sub>R c + xa *\<^sub>R x" for t xa proof - - case goal1 - then have "(t - xa) *\<^sub>R x = (t - xa) *\<^sub>R c" + from that have "(t - xa) *\<^sub>R x = (t - xa) *\<^sub>R c" unfolding scaleR_simps by (auto simp add: algebra_simps) - then show ?case + then show ?thesis using \x \ c\ by auto qed have as2: "finite {t. ((1 - t) *\<^sub>R c + t *\<^sub>R x) \ k}" @@ -8151,14 +8141,14 @@ apply cases apply (rule *) apply assumption - proof - - case goal1 + proof goal_cases + case prems: 1 then have *: "box c d = {}" by (metis bot.extremum_uniqueI box_subset_cbox) show ?thesis using assms(1) unfolding * - using goal1 + using prems by auto qed } @@ -8187,13 +8177,14 @@ have iterate:"iterate (lifted op +) (p - {cbox c d}) (\i. if g integrable_on i then Some (integral i g) else None) = Some 0" proof (rule *) - case goal1 + fix x + assume x: "x \ p - {cbox c d}" then have "x \ p" by auto note div = division_ofD(2-5)[OF p(1) this] from div(3) guess u v by (elim exE) note uv=this have "interior x \ interior (cbox c d) = {}" - using div(4)[OF p(2)] goal1 by auto + using div(4)[OF p(2)] x by auto then have "(g has_integral 0) x" unfolding uv apply - @@ -8201,7 +8192,7 @@ unfolding g_def interior_cbox apply auto done - then show ?case + then show "(if g integrable_on x then Some (integral x g) else None) = Some 0" by auto qed @@ -8345,19 +8336,20 @@ apply (drule B(2)) unfolding mem_box proof - case goal1 - then show ?case - using Basis_le_norm[OF \i\Basis\, of x] + fix x i + show "c \ i \ x \ i \ x \ i \ d \ i" if "norm x \ B" and "i \ Basis" + using that and Basis_le_norm[OF \i\Basis\, of x] unfolding c_def d_def by (auto simp add: field_simps setsum_negf) qed have "ball 0 C \ cbox c d" - apply safe + apply (rule subsetI) unfolding mem_box mem_ball dist_norm proof - case goal1 - then show ?case - using Basis_le_norm[OF \i\Basis\, of x] + fix x i :: 'n + assume x: "norm (0 - x) < C" and i: "i \ Basis" + show "c \ i \ x \ i \ x \ i \ d \ i" + using Basis_le_norm[OF i, of x] and x i unfolding c_def d_def by (auto simp: setsum_negf) qed @@ -8380,18 +8372,20 @@ apply (drule B(2)) unfolding mem_box proof - case goal1 - then show ?case + fix x i :: 'n + assume "norm x \ B" and "i \ Basis" + then show "c \ i \ x \ i \ x \ i \ d \ i" using Basis_le_norm[of i x] unfolding c_def d_def by (auto simp add: field_simps setsum_negf) qed have "ball 0 C \ cbox c d" - apply safe + apply (rule subsetI) unfolding mem_box mem_ball dist_norm proof - case goal1 - then show ?case + fix x i :: 'n + assume "norm (0 - x) < C" and "i \ Basis" + then show "c \ i \ x \ i \ x \ i \ d \ i" using Basis_le_norm[of i x] unfolding c_def d_def by (auto simp: setsum_negf) @@ -8521,8 +8515,8 @@ show ?l unfolding negligible_def proof safe - case goal1 - show ?case + fix a b + show "(indicator s has_integral 0) (cbox a b)" apply (rule has_integral_negligible[OF \?r\[rule_format,of a b]]) unfolding indicator_def apply auto @@ -8662,8 +8656,8 @@ show ?l apply (subst has_integral') apply safe - proof - - case goal1 + proof goal_cases + case (1 e) from \?r\[THEN conjunct2,rule_format,OF this] guess B .. note B=conjunctD2[OF this] show ?case apply rule @@ -8688,10 +8682,10 @@ show "?f integrable_on cbox a b" proof (rule integrable_subinterval[of _ ?a ?b]) have "ball 0 B \ cbox ?a ?b" - apply safe + apply (rule subsetI) unfolding mem_ball mem_box dist_norm - proof - case goal1 + proof (rule, goal_cases) + case (1 x i) then show ?case using Basis_le_norm[of i x] by (auto simp add:field_simps) qed @@ -8716,8 +8710,8 @@ apply rule apply (rule B) apply safe - proof - - case goal1 + proof goal_cases + case 1 from B(2)[OF this] guess z .. note z=conjunctD2[OF this] from integral_unique[OF this(1)] show ?case using z(2) by auto @@ -8743,8 +8737,8 @@ show ?r apply safe apply (rule y) - proof - - case goal1 + proof goal_cases + case (1 e) then have "e/2 > 0" by auto from y(2)[OF this] guess B .. note B=conjunctD2[OF this,rule_format] @@ -8753,11 +8747,11 @@ apply rule apply (rule B) apply safe - proof - - case goal1 + proof goal_cases + case prems: (1 a b c d) show ?case apply (rule norm_triangle_half_l) - using B(2)[OF goal1(1)] B(2)[OF goal1(2)] + using B(2)[OF prems(1)] B(2)[OF prems(2)] apply auto done qed @@ -8767,18 +8761,18 @@ note as = conjunctD2[OF this,rule_format] let ?cube = "\n. cbox (\i\Basis. - real n *\<^sub>R i::'n) (\i\Basis. real n *\<^sub>R i)" have "Cauchy (\n. integral (?cube n) (\x. if x \ s then f x else 0))" - proof (unfold Cauchy_def, safe) - case goal1 + proof (unfold Cauchy_def, safe, goal_cases) + case (1 e) from as(2)[OF this] guess B .. note B = conjunctD2[OF this,rule_format] from real_arch_simple[of B] guess N .. note N = this { fix n assume n: "n \ N" have "ball 0 B \ ?cube n" - apply safe + apply (rule subsetI) unfolding mem_ball mem_box dist_norm - proof - case goal1 + proof (rule, goal_cases) + case (1 x i) then show ?case using Basis_le_norm[of i x] \i\Basis\ using n N @@ -8801,8 +8795,8 @@ apply (rule_tac x=i in exI) apply safe apply (rule as(1)[unfolded integrable_on_def]) - proof - - case goal1 + proof goal_cases + case (1 e) then have *: "e/2 > 0" by auto from i[OF this] guess N .. note N =this[rule_format] from as(2)[OF *] guess B .. note B=conjunctD2[OF this,rule_format] @@ -8834,8 +8828,8 @@ using x unfolding mem_box mem_ball dist_norm apply - - proof - case goal1 + proof (rule, goal_cases) + case (1 i) then show ?case using Basis_le_norm[of i x] \i \ Basis\ using n @@ -8874,8 +8868,8 @@ assumes "\e>0. \g h i j. (g has_integral i) (cbox a b) \ (h has_integral j) (cbox a b) \ norm (i - j) < e \ (\x\cbox a b. (g x) \ f x \ f x \ h x)" shows "f integrable_on cbox a b" -proof (subst integrable_cauchy, safe) - case goal1 +proof (subst integrable_cauchy, safe, goal_cases) + case (1 e) then have e: "e/3 > 0" by auto note assms[rule_format,OF this] @@ -8886,13 +8880,13 @@ apply (rule_tac x="\x. d1 x \ d2 x" in exI) apply (rule conjI gauge_inter d1 d2)+ unfolding fine_inter - proof safe + proof (safe, goal_cases) have **: "\i j g1 g2 h1 h2 f1 f2. g1 - h2 \ f1 - f2 \ f1 - f2 \ h1 - g2 \ abs (i - j) < e / 3 \ abs (g2 - i) < e / 3 \ abs (g1 - i) < e / 3 \ abs (h2 - j) < e / 3 \ abs (h1 - j) < e / 3 \ abs (f1 - f2) < e" using \e > 0\ by arith - case goal1 - note tagged_division_ofD(2-4) note * = this[OF goal1(1)] this[OF goal1(4)] + case prems: (1 p1 p2) + note tagged_division_ofD(2-4) note * = this[OF prems(1)] this[OF prems(4)] have "(\(x, k)\p1. content k *\<^sub>R f x) - (\(x, k)\p1. content k *\<^sub>R g x) \ 0" and "0 \ (\(x, k)\p2. content k *\<^sub>R h x) - (\(x, k)\p2. content k *\<^sub>R f x)" @@ -8937,10 +8931,10 @@ defer unfolding real_norm_def[symmetric] apply (rule obt(3)) - apply (rule d1(2)[OF conjI[OF goal1(4,5)]]) - apply (rule d1(2)[OF conjI[OF goal1(1,2)]]) - apply (rule d2(2)[OF conjI[OF goal1(4,6)]]) - apply (rule d2(2)[OF conjI[OF goal1(1,3)]]) + apply (rule d1(2)[OF conjI[OF prems(4,5)]]) + apply (rule d1(2)[OF conjI[OF prems(1,2)]]) + apply (rule d2(2)[OF conjI[OF prems(4,6)]]) + apply (rule d2(2)[OF conjI[OF prems(1,3)]]) apply auto done qed @@ -8953,8 +8947,8 @@ shows "f integrable_on s" proof - have "\a b. (\x. if x \ s then f x else 0) integrable_on cbox a b" - proof (rule integrable_straddle_interval, safe) - case goal1 + proof (rule integrable_straddle_interval, safe, goal_cases) + case (1 a b e) then have *: "e/4 > 0" by auto from assms[rule_format,OF this] guess g h i j by (elim exE conjE) note obt=this @@ -8972,16 +8966,16 @@ apply safe unfolding mem_ball mem_box dist_norm apply (rule_tac[!] ballI) - proof - - case goal1 + proof goal_cases + case (1 x i) then show ?case using Basis_le_norm[of i x] unfolding c_def d_def by auto next - case goal2 + case (2 x i) then show ?case using Basis_le_norm[of i x] unfolding c_def d_def by auto qed - have **:" \ch cg ag ah::real. norm (ah - ag) \ norm (ch - cg) \ norm (cg - i) < e / 4 \ + have **: "\ch cg ag ah::real. norm (ah - ag) \ norm (ch - cg) \ norm (cg - i) < e / 4 \ norm (ch - j) < e / 4 \ norm (ag - ah) < e" using obt(3) unfolding real_norm_def @@ -9031,8 +9025,8 @@ unfolding integrable_alt[of f] apply safe apply (rule interv) - proof - - case goal1 + proof goal_cases + case (1 e) then have *: "e/3 > 0" by auto from assms[rule_format,OF this] guess g h i j by (elim exE conjE) note obt=this @@ -9129,15 +9123,21 @@ done note assms(2)[unfolded *] note has_integral_setsum[OF assms(1) this] - then show ?thesis unfolding * apply-apply(rule has_integral_spike[OF **]) defer apply assumption - proof safe - case goal1 + then show ?thesis + unfolding * + apply - + apply (rule has_integral_spike[OF **]) + defer + apply assumption + apply safe + proof goal_cases + case prems: (1 x) then show ?case proof (cases "x \ \t") case True then guess s unfolding Union_iff .. note s=this then have *: "\b\t. x \ b \ b = s" - using goal1(3) by blast + using prems(3) by blast show ?thesis unfolding if_P[OF True] apply (rule trans) @@ -9172,10 +9172,10 @@ apply rule apply rule apply rule - proof - - case goal1 + proof goal_cases + case prems: (1 s s') from d(4)[OF this(1)] d(4)[OF this(2)] guess a c b d by (elim exE) note obt=this - from d(5)[OF goal1] show ?case + from d(5)[OF prems] show ?case unfolding obt interior_cbox apply - apply (rule negligible_subset[of "(cbox a b-box a b) \ (cbox c d-box c d)"]) @@ -9206,8 +9206,8 @@ apply (rule has_integral_combine_division[OF assms(2)]) apply safe unfolding has_integral_integral[symmetric] -proof - - case goal1 +proof goal_cases + case (1 k) from division_ofD(2,4)[OF assms(2) this] show ?case apply safe @@ -9245,8 +9245,9 @@ and "i \ s" shows "f integrable_on i" apply (rule integrable_combine_division assms)+ -proof safe - case goal1 + apply safe +proof goal_cases + case 1 note division_ofD(2,4)[OF assms(1) this] then show ?case apply safe @@ -9306,8 +9307,9 @@ and "p tagged_division_of (cbox a b)" shows "(f has_integral (setsum (\(x,k). integral k f) p)) (cbox a b)" apply (rule has_integral_combine_tagged_division[OF assms(2)]) -proof safe - case goal1 + apply safe +proof goal_cases + case 1 note tagged_division_ofD(3-4)[OF assms(2) this] then show ?case using integrable_subinterval[OF assms(1)] by blast @@ -9354,8 +9356,9 @@ have "\i\r. \p. p tagged_division_of i \ d fine p \ norm (setsum (\(x,j). content j *\<^sub>R f x) p - integral i f) < k / (real (card r) + 1)" - proof safe - case goal1 + apply safe + proof goal_cases + case (1 i) then have i: "i \ q" unfolding r_def by auto from q'(4)[OF this] guess u v by (elim exE) note uv=this @@ -9392,14 +9395,13 @@ done note * = tagged_partial_division_of_union_self[OF p(1)] have "p \ \(qq ` r) tagged_division_of \(snd ` p) \ \r" - proof (rule tagged_division_union[OF * tagged_division_unions]) - show "finite r" - by fact - case goal2 + using r + proof (rule tagged_division_union[OF * tagged_division_unions], goal_cases) + case 1 then show ?case using qq by auto next - case goal3 + case 2 then show ?case apply rule apply rule @@ -9409,7 +9411,7 @@ apply auto done next - case goal4 + case 3 then show ?case apply (rule inter_interior_unions_intervals) apply fact @@ -9514,22 +9516,40 @@ using as(3) unfolding as by auto qed - have *: "\ir ip i cr cp. norm ((cp + cr) - i) < e \ norm(cr - ir) < k \ - ip + ir = i \ norm (cp - ip) \ e + k" + have *: "norm (cp - ip) \ e + k" + if "norm ((cp + cr) - i) < e" + and "norm (cr - ir) < k" + and "ip + ir = i" + for ir ip i cr cp proof - - case goal1 - then show ?case + from that show ?thesis using norm_triangle_le[of "cp + cr - i" "- (cr - ir)"] - unfolding goal1(3)[symmetric] norm_minus_cancel + unfolding that(3)[symmetric] norm_minus_cancel by (auto simp add: algebra_simps) qed have "?x = norm ((\(x, k)\p. content k *\<^sub>R f x) - (\(x, k)\p. integral k f))" unfolding split_def setsum_subtractf .. also have "\ \ e + k" - apply (rule *[OF **, where ir="setsum (\k. integral k f) r"]) - proof - - case goal2 + apply (rule *[OF **, where ir2="setsum (\k. integral k f) r"]) + proof goal_cases + case 1 + have *: "k * real (card r) / (1 + real (card r)) < k" + using k by (auto simp add: field_simps) + show ?case + apply (rule le_less_trans[of _ "setsum (\x. k / (real (card r) + 1)) r"]) + unfolding setsum_subtractf[symmetric] + apply (rule setsum_norm_le) + apply rule + apply (drule qq) + defer + unfolding divide_inverse setsum_left_distrib[symmetric] + unfolding divide_inverse[symmetric] + using * + apply (auto simp add: field_simps real_eq_of_nat) + done + next + case 2 have *: "(\(x, k)\p. integral k f) = (\k\snd ` p. integral k f)" apply (subst setsum.reindex_nontrivial) apply fact @@ -9553,22 +9573,6 @@ unfolding integral_combine_division_topdown[OF assms(1) q(2)] * r_def using ** q'(1) p'(1) setsum.union_disjoint [of "snd ` p" "q - snd ` p" "\k. integral k f", symmetric] by simp - next - case goal1 - have *: "k * real (card r) / (1 + real (card r)) < k" - using k by (auto simp add: field_simps) - show ?case - apply (rule le_less_trans[of _ "setsum (\x. k / (real (card r) + 1)) r"]) - unfolding setsum_subtractf[symmetric] - apply (rule setsum_norm_le) - apply rule - apply (drule qq) - defer - unfolding divide_inverse setsum_left_distrib[symmetric] - unfolding divide_inverse[symmetric] - using * - apply (auto simp add: field_simps real_eq_of_nat) - done qed finally show "?x \ e + k" . qed @@ -9614,8 +9618,8 @@ show thesis apply (rule that) apply (rule d) - proof safe - case goal1 + proof (safe, goal_cases) + case (1 p) note * = henstock_lemma_part2[OF assms(1) * d this] show ?case apply (rule le_less_trans[OF *]) @@ -9727,18 +9731,18 @@ by auto next case False - have fg: "\x\cbox a b. \ k. (f k x) \ 1 \ (g x) \ 1" + have fg: "\x\cbox a b. \k. (f k x) \ 1 \ (g x) \ 1" proof safe - case goal1 - note assms(3)[rule_format,OF this] - note * = Lim_component_ge[OF this trivial_limit_sequentially] - show ?case + fix x k + assume x: "x \ cbox a b" + note * = Lim_component_ge[OF assms(3)[rule_format, OF x] trivial_limit_sequentially] + show "f k x \ 1 \ g x \ 1" apply (rule *) unfolding eventually_sequentially apply (rule_tac x=k in exI) apply - apply (rule transitive_stepwise_le) - using assms(2)[rule_format,OF goal1] + using assms(2)[rule_format, OF x] apply auto done qed @@ -9770,9 +9774,8 @@ have "(g has_integral i) (cbox a b)" unfolding has_integral - proof safe - case goal1 - note e=this + proof (safe, goal_cases) + case e: (1 e) then have "\k. (\d. gauge d \ (\p. p tagged_division_of (cbox a b) \ d fine p \ norm ((\(x, ka)\p. content ka *\<^sub>R f k x) - integral (cbox a b) (f k)) < e / 2 ^ (k + 2)))" apply - @@ -9784,36 +9787,32 @@ have "\r. \k\r. 0 \ i\1 - (integral (cbox a b) (f k)) \ i\1 - (integral (cbox a b) (f k)) < e / 4" proof - - case goal1 have "e/4 > 0" using e by auto from LIMSEQ_D [OF i this] guess r .. - then show ?case + then show ?thesis apply (rule_tac x=r in exI) apply rule apply (erule_tac x=k in allE) - proof - - case goal1 - then show ?case - using i'[of k] by auto - qed + subgoal for k using i'[of k] by auto + done qed then guess r .. note r=conjunctD2[OF this[rule_format]] have "\x\cbox a b. \n\r. \k\n. 0 \ (g x)\1 - (f k x)\1 \ (g x)\1 - (f k x)\1 < e / (4 * content(cbox a b))" - proof - case goal1 + proof (rule, goal_cases) + case prems: (1 x) have "e / (4 * content (cbox a b)) > 0" using \e>0\ False content_pos_le[of a b] by auto - from assms(3)[rule_format, OF goal1, THEN LIMSEQ_D, OF this] + from assms(3)[rule_format, OF prems, THEN LIMSEQ_D, OF this] guess n .. note n=this then show ?case apply (rule_tac x="n + r" in exI) apply safe apply (erule_tac[2-3] x=k in allE) unfolding dist_real_def - using fg[rule_format,OF goal1] + using fg[rule_format, OF prems] apply (auto simp add: field_simps) done qed @@ -9834,8 +9833,8 @@ then guess s .. note s=this have *: "\a b c d. norm(a - b) \ e / 4 \ norm(b - c) < e / 2 \ norm (c - d) < e / 4 \ norm (a - d) < e" - proof safe - case goal1 + proof (safe, goal_cases) + case (1 a b c d) then show ?case using norm_triangle_lt[of "a - b" "b - c" "3* e/4"] norm_triangle_lt[of "a - b + (b - c)" "c - d" e] @@ -9845,8 +9844,8 @@ show "norm ((\(x, k)\p. content k *\<^sub>R g x) - i) < e" apply (rule *[rule_format,where b="\(x, k)\p. content k *\<^sub>R f (m x) x" and c="\(x, k)\p. integral k (f (m x))"]) - proof safe - case goal1 + proof (safe, goal_cases) + case 1 show ?case apply (rule order_trans[of _ "\(x, k)\p. content k * (e / (4 * content (cbox a b)))"]) unfolding setsum_subtractf[symmetric] @@ -9872,7 +9871,7 @@ qed (insert False, auto) next - case goal2 + case 2 show ?case apply (rule le_less_trans[of _ "norm (\j = 0..s. \(x, k)\{xk\p. m (fst xk) = j}. content k *\<^sub>R f (m x) x - integral k (f (m x)))"]) @@ -9927,7 +9926,7 @@ qed qed (insert s, auto) next - case goal3 + case 3 note comb = integral_combine_tagged_division_topdown[OF assms(1)[rule_format] p(1)] have *: "\sr sx ss ks kr::real. kr = sr \ ks = ss \ ks \ i \ sr \ sx \ sx \ ss \ 0 \ i\1 - kr\1 \ i\1 - kr\1 < e/4 \ abs (sx - i) < e/4" @@ -9994,42 +9993,43 @@ and "bounded {integral s (f k)| k. True}" shows "g integrable_on s \ ((\k. integral s (f k)) ---> integral s g) sequentially" proof - - have lem: "\f::nat \ 'n::euclidean_space \ real. - \g s. \k.\x\s. 0 \ f k x \ \k. (f k) integrable_on s \ - \k. \x\s. f k x \ f (Suc k) x \ \x\s. ((\k. f k x) ---> g x) sequentially \ - bounded {integral s (f k)| k. True} \ - g integrable_on s \ ((\k. integral s (f k)) ---> integral s g) sequentially" + have lem: "g integrable_on s \ ((\k. integral s (f k)) ---> integral s g) sequentially" + if "\k. \x\s. 0 \ f k x" + and "\k. (f k) integrable_on s" + and "\k. \x\s. f k x \ f (Suc k) x" + and "\x\s. ((\k. f k x) ---> g x) sequentially" + and "bounded {integral s (f k)| k. True}" + for f :: "nat \ 'n::euclidean_space \ real" and g s proof - - case goal1 - note assms=this[rule_format] + note assms=that[rule_format] have "\x\s. \k. (f k x)\1 \ (g x)\1" apply safe apply (rule Lim_component_ge) - apply (rule goal1(4)[rule_format]) + apply (rule that(4)[rule_format]) apply assumption apply (rule trivial_limit_sequentially) unfolding eventually_sequentially apply (rule_tac x=k in exI) apply (rule transitive_stepwise_le) - using goal1(3) + using that(3) apply auto done note fg=this[rule_format] have "\i. ((\k. integral s (f k)) ---> i) sequentially" apply (rule bounded_increasing_convergent) - apply (rule goal1(5)) + apply (rule that(5)) apply rule apply (rule integral_le) - apply (rule goal1(2)[rule_format])+ - using goal1(3) + apply (rule that(2)[rule_format])+ + using that(3) apply auto done then guess i .. note i=this have "\k. \x\s. \n\k. f k x \ f n x" apply rule apply (rule transitive_stepwise_le) - using goal1(3) + using that(3) apply auto done then have i': "\k. (integral s (f k))\1 \ i\1" @@ -10043,7 +10043,7 @@ apply safe apply (rule integral_component_le) apply simp - apply (rule goal1(2)[rule_format])+ + apply (rule that(2)[rule_format])+ apply auto done @@ -10060,25 +10060,25 @@ have "\a b. (\x. if x \ s then g x else 0) integrable_on cbox a b \ ((\k. integral (cbox a b) (\x. if x \ s then f k x else 0)) ---> integral (cbox a b) (\x. if x \ s then g x else 0)) sequentially" - proof (rule monotone_convergence_interval, safe) - case goal1 + proof (rule monotone_convergence_interval, safe, goal_cases) + case 1 show ?case by (rule int) next - case goal2 + case (2 _ _ _ x) then show ?case apply (cases "x \ s") using assms(3) apply auto done next - case goal3 + case (3 _ _ x) then show ?case apply (cases "x \ s") using assms(4) apply auto done next - case goal4 + case (4 a b) note * = integral_nonneg have "\k. norm (integral (cbox a b) (\x. if x \ s then f k x else 0)) \ norm (integral s (f k))" unfolding real_norm_def @@ -10089,7 +10089,7 @@ apply (drule assms(1)) prefer 3 apply (subst abs_of_nonneg) - apply (rule *[OF assms(2) goal1(1)[THEN spec]]) + apply (rule *[OF assms(2) that(1)[THEN spec]]) apply (subst integral_restrict_univ[symmetric,OF int]) unfolding ifif unfolding integral_restrict_univ[OF int'] @@ -10115,8 +10115,8 @@ unfolding has_integral_alt' apply safe apply (rule g(1)) - proof - - case goal1 + proof goal_cases + case (1 e) then have "e/4>0" by auto from LIMSEQ_D [OF i this] guess N .. note N=this @@ -10153,8 +10153,8 @@ apply (rule integral_le[OF int int]) defer apply (rule order_trans[OF _ i'[rule_format,of "M + N",unfolded real_inner_1_right]]) - proof safe - case goal2 + proof (safe, goal_cases) + case (2 x) have "\m. x \ s \ \n\m. (f m x)\1 \ (f n x)\1" apply (rule transitive_stepwise_le) using assms(3) @@ -10163,7 +10163,7 @@ then show ?case by auto next - case goal1 + case 1 show ?case apply (subst integral_restrict_univ[symmetric,OF int]) unfolding ifif integral_restrict_univ[OF int'] @@ -10174,7 +10174,7 @@ qed qed qed - then show ?case + then show ?thesis apply safe defer apply (drule integral_unique) @@ -10198,23 +10198,23 @@ integral s (\x. g x - f 0 x)) sequentially" apply (rule lem) apply safe - proof - - case goal1 + proof goal_cases + case (1 k x) then show ?case using *[of x 0 "Suc k"] by auto next - case goal2 + case (2 k) then show ?case apply (rule integrable_sub) using assms(1) apply auto done next - case goal3 + case (3 k x) then show ?case using *[of x "Suc k" "Suc (Suc k)"] by auto next - case goal4 + case (4 x) then show ?case apply - apply (rule tendsto_diff) @@ -10222,7 +10222,7 @@ apply auto done next - case goal5 + case 5 then show ?case using assms(4) unfolding bounded_iff @@ -10352,43 +10352,44 @@ and "\x\s. norm (f x) \ g x" shows "norm (integral s f) \ integral s g" proof - - have *: "\x y. (\e::real. 0 < e \ x < y + e) \ x \ y" - apply safe + have *: "\x y. (\e::real. 0 < e \ x < y + e) \ x \ y" apply (rule ccontr) apply (erule_tac x="x - y" in allE) apply auto done - have "\e sg dsa dia ig. - norm sg \ dsa \ abs (dsa - dia) < e / 2 \ norm (sg - ig) < e / 2 \ norm ig < dia + e" - proof safe - case goal1 - show ?case - apply (rule le_less_trans[OF norm_triangle_sub[of ig sg]]) - apply (subst real_sum_of_halves[of e,symmetric]) - unfolding add.assoc[symmetric] - apply (rule add_le_less_mono) - defer - apply (subst norm_minus_commute) - apply (rule goal1) - apply (rule order_trans[OF goal1(1)]) - using goal1(2) - apply arith - done - qed - note norm=this[rule_format] - have lem: "\f::'n \ 'a. \g a b. f integrable_on cbox a b \ g integrable_on cbox a b \ - \x\cbox a b. norm (f x) \ g x \ norm (integral(cbox a b) f) \ integral (cbox a b) g" + have norm: "norm ig < dia + e" + if "norm sg \ dsa" + and "abs (dsa - dia) < e / 2" + and "norm (sg - ig) < e / 2" + for e dsa dia and sg ig :: 'a + apply (rule le_less_trans[OF norm_triangle_sub[of ig sg]]) + apply (subst real_sum_of_halves[of e,symmetric]) + unfolding add.assoc[symmetric] + apply (rule add_le_less_mono) + defer + apply (subst norm_minus_commute) + apply (rule that(3)) + apply (rule order_trans[OF that(1)]) + using that(2) + apply arith + done + have lem: "norm (integral(cbox a b) f) \ integral (cbox a b) g" + if "f integrable_on cbox a b" + and "g integrable_on cbox a b" + and "\x\cbox a b. norm (f x) \ g x" + for f :: "'n \ 'a" and g a b proof (rule *[rule_format]) - case goal1 + fix e :: real + assume "e > 0" then have *: "e/2 > 0" by auto - from integrable_integral[OF goal1(1),unfolded has_integral[of f],rule_format,OF *] + from integrable_integral[OF that(1),unfolded has_integral[of f],rule_format,OF *] guess d1 .. note d1 = conjunctD2[OF this,rule_format] - from integrable_integral[OF goal1(2),unfolded has_integral[of g],rule_format,OF *] + from integrable_integral[OF that(2),unfolded has_integral[of g],rule_format,OF *] guess d2 .. note d2 = conjunctD2[OF this,rule_format] note gauge_inter[OF d1(1) d2(1)] from fine_division_exists[OF this, of a b] guess p . note p=this - show ?case + show "norm (integral (cbox a b) f) < integral (cbox a b) g + e" apply (rule norm) defer apply (rule d2(2)[OF conjI[OF p(1)],unfolded real_norm_def]) @@ -10405,7 +10406,7 @@ unfolding uv norm_scaleR unfolding abs_of_nonneg[OF content_pos_le] real_scaleR_def apply (rule mult_left_mono) - using goal1(3) as + using that(3) as apply auto done qed (insert p[unfolded fine_inter], auto) @@ -10534,9 +10535,10 @@ assumes "f absolutely_integrable_on UNIV" obtains B where "\d. d division_of (\d) \ setsum (\k. norm(integral k f)) d \ B" apply (rule that[of "integral UNIV (\x. norm (f x))"]) -proof safe - case goal1 - note d = division_ofD[OF this(2)] + apply safe +proof goal_cases + case prems: (1 d) + note d = division_ofD[OF prems(2)] have "(\k\d. norm (integral k f)) \ (\i\d. integral i (\x. norm (f x)))" apply (rule setsum_mono,rule absolutely_integrable_le) apply (drule d(4)) @@ -10545,14 +10547,14 @@ apply auto done also have "\ \ integral (\d) (\x. norm (f x))" - apply (subst integral_combine_division_topdown[OF _ goal1(2)]) - using integrable_on_subdivision[OF goal1(2)] + apply (subst integral_combine_division_topdown[OF _ prems(2)]) + using integrable_on_subdivision[OF prems(2)] using assms apply auto done also have "\ \ integral UNIV (\x. norm (f x))" apply (rule integral_subset_le) - using integrable_on_subdivision[OF goal1(2)] + using integrable_on_subdivision[OF prems(2)] using assms apply auto done @@ -10586,8 +10588,9 @@ show ?thesis apply (rule absolutely_integrable_onI [OF f has_integral_integrable]) apply (subst has_integral[of _ ?S]) - proof safe - case goal1 + apply safe + proof goal_cases + case e: (1 e) then have "?S - e / 2 < ?S" by simp then obtain d where d: "d division_of (cbox a b)" "?S - e / 2 < (\k\d. norm (integral k f))" unfolding less_cSUP_iff[OF D] by auto @@ -10595,7 +10598,7 @@ have "\x. \e>0. \i\d. x \ i \ ball x e \ i = {}" proof - case goal1 + fix x have "\da>0. \xa\\{i \ d. x \ i}. da \ dist x xa" apply (rule separate_point_closed) apply (rule closed_Union) @@ -10603,13 +10606,13 @@ using d'(4) apply auto done - then show ?case + then show "\e>0. \i\d. x \ i \ ball x e \ i = {}" by force qed from choice[OF this] guess k .. note k=conjunctD2[OF this[rule_format],rule_format] have "e/2 > 0" - using goal1 by auto + using e by auto from henstock_lemma[OF assms(1) this] guess g . note g=this[rule_format] let ?g = "\x. g x \ ball x (k x)" show ?case @@ -10720,23 +10723,23 @@ by (force intro!: helplemma) have p'alt: "p' = {(x,(i \ l)) | x i l. (x,l) \ p \ i \ d \ i \ l \ {}}" - proof safe - case goal2 + proof (safe, goal_cases) + case prems: (2 _ _ x i l) have "x \ i" - using fineD[OF p(3) goal2(1)] k(2)[OF goal2(2), of x] goal2(4-) + using fineD[OF p(3) prems(1)] k(2)[OF prems(2), of x] prems(4-) by auto then have "(x, i \ l) \ p'" unfolding p'_def - using goal2 + using prems apply safe apply (rule_tac x=x in exI) apply (rule_tac x="i \ l" in exI) apply safe - using goal2 + using prems apply auto done then show ?case - using goal2(3) by auto + using prems(3) by auto next fix x k assume "(x, k) \ p'" @@ -10768,18 +10771,18 @@ apply (rule *[rule_format,OF **]) apply safe apply(rule d(2)) - proof - - case goal1 show ?case + proof goal_cases + case 1 + show ?case by (auto simp: sum_p' division_of_tagged_division[OF p''] D intro!: cSUP_upper) next - case goal2 + case 2 have *: "{k \ l | k l. k \ d \ l \ snd ` p} = (\(k,l). k \ l) ` {(k,l)|k l. k \ d \ l \ snd ` p}" by auto have "(\k\d. norm (integral k f)) \ (\i\d. \l\snd ` p. norm (integral (i \ l) f))" - proof (rule setsum_mono) - case goal1 - note k=this + proof (rule setsum_mono, goal_cases) + case k: (1 k) from d'(4)[OF this] guess u v by (elim exE) note uv=this def d' \ "{cbox u v \ l |l. l \ snd ` p \ cbox u v \ l \ {}}" note uvab = d'(2)[OF k[unfolded uv]] @@ -10804,13 +10807,13 @@ apply fact unfolding d'_def uv apply blast - proof - case goal1 + proof (rule, goal_cases) + case prems: (1 i) then have "i \ {cbox u v \ l |l. l \ snd ` p}" by auto from this[unfolded mem_Collect_eq] guess l .. note l=this then have "cbox u v \ l = {}" - using goal1 by auto + using prems by auto then show ?case using l by auto qed @@ -10819,18 +10822,18 @@ apply (rule setsum.reindex_nontrivial [unfolded o_def]) apply (rule finite_imageI) apply (rule p') - proof - - case goal1 + proof goal_cases + case prems: (1 l y) have "interior (k \ l) \ interior (l \ y)" apply (subst(2) interior_inter) apply (rule Int_greatest) defer - apply (subst goal1(4)) + apply (subst prems(4)) apply auto done then have *: "interior (k \ l) = {}" - using snd_p(5)[OF goal1(1-3)] by auto - from d'(4)[OF k] snd_p(4)[OF goal1(1)] guess u1 v1 u2 v2 by (elim exE) note uv=this + using snd_p(5)[OF prems(1-3)] by auto + from d'(4)[OF k] snd_p(4)[OF prems(1)] guess u1 v1 u2 v2 by (elim exE) note uv=this show ?case using * unfolding uv inter_interval content_eq_0_interior[symmetric] @@ -10895,10 +10898,9 @@ apply fact apply (rule finite_imageI[OF p'(1)]) apply safe - proof - - case goal2 - have "ia \ b = {}" - using goal2 + proof goal_cases + case (2 i ia l a b) + then have "ia \ b = {}" unfolding p'alt image_iff Bex_def not_ex apply (erule_tac x="(a, ia \ b)" in allE) apply auto @@ -10906,7 +10908,7 @@ then show ?case by auto next - case goal1 + case (1 x a b) then show ?case unfolding p'_def apply safe @@ -10920,7 +10922,7 @@ qed finally show ?case . next - case goal3 + case 3 let ?S = "{(x, i \ l) |x i l. (x, l) \ p \ i \ d}" have Sigma_alt: "\s t. s \ t = {(i, j) |i j. i \ s \ j \ t}" by auto @@ -11007,19 +11009,19 @@ unfolding simple_image apply (rule setsum.reindex_nontrivial [unfolded o_def, symmetric]) apply (rule d') - proof - - case goal1 + proof goal_cases + case prems: (1 k y) from d'(4)[OF this(1)] d'(4)[OF this(2)] guess u1 v1 u2 v2 by (elim exE) note uv=this have "{} = interior ((k \ y) \ cbox u v)" apply (subst interior_inter) - using d'(5)[OF goal1(1-3)] + using d'(5)[OF prems(1-3)] apply auto done also have "\ = interior (y \ (k \ cbox u v))" by auto also have "\ = interior (k \ cbox u v)" - unfolding goal1(4) by auto + unfolding prems(4) by auto finally show ?case unfolding uv inter_interval content_eq_0_interior .. qed @@ -11031,15 +11033,15 @@ apply blast apply safe apply (rule_tac x=k in exI) - proof - - case goal1 + proof goal_cases + case prems: (1 i k) from d'(4)[OF this(1)] guess a b by (elim exE) note ab=this have "interior (k \ cbox u v) \ {}" - using goal1(2) + using prems(2) unfolding ab inter_interval content_eq_0_interior by auto then show ?case - using goal1(1) + using prems(1) using interior_subset[of "k \ cbox u v"] by auto qed @@ -11081,19 +11083,19 @@ show "((\x. norm (f x)) has_integral ?S) UNIV" apply (subst has_integral_alt') apply safe - proof - - case goal1 + proof goal_cases + case (1 a b) show ?case using f_int[of a b] by auto next - case goal2 + case prems: (2 e) have "\y\setsum (\k. norm (integral k f)) ` {d. d division_of \d}. \ y \ ?S - e" proof (rule ccontr) assume "\ ?thesis" then have "?S \ ?S - e" by (intro cSUP_least[OF D(1)]) auto then show False - using goal2 by auto + using prems by auto qed then obtain K where *: "\x\{d. d division_of \d}. K = (\k\x. norm (integral k f))" "SUPREMUM {d. d division_of \d} (setsum (\k. norm (integral k f))) - e < K" @@ -11120,8 +11122,8 @@ apply (rule *[rule_format]) apply safe apply (rule d(2)) - proof - - case goal1 + proof goal_cases + case 1 have "(\k\d. norm (integral k f)) \ setsum (\k. integral k (\x. norm (f x))) d" apply (rule setsum_mono) apply (rule absolutely_integrable_le) @@ -11138,14 +11140,13 @@ done also have "\ \ integral (cbox a b) (\x. if x \ UNIV then norm (f x) else 0)" proof - - case goal1 have "\d \ cbox a b" apply rule apply (drule K(2)[rule_format]) apply (rule ab[unfolded subset_eq,rule_format]) apply (auto simp add: dist_norm) done - then show ?case + then show ?thesis apply - apply (subst if_P) apply rule @@ -11247,10 +11248,11 @@ apply (rule bounded_variation_absolutely_integrable[of _ "B1+B2"]) apply (rule integrable_add) prefer 3 - proof safe - case goal1 + apply safe + proof goal_cases + case prems: (1 d) have "\k. k \ d \ f integrable_on k \ g integrable_on k" - apply (drule division_ofD(4)[OF goal1]) + apply (drule division_ofD(4)[OF prems]) apply safe apply (rule_tac[!] integrable_on_subcbox[of _ UNIV]) using assms @@ -11267,7 +11269,7 @@ apply auto done also have "\ \ B1 + B2" - using B(1)[OF goal1] B(2)[OF goal1] by auto + using B(1)[OF prems] B(2)[OF prems] by auto finally show ?case . qed (insert assms, auto) qed @@ -11305,14 +11307,15 @@ show "(h \ f) absolutely_integrable_on UNIV" apply (rule bounded_variation_absolutely_integrable[of _ "B * b"]) apply (rule integrable_linear[OF _ assms(2)]) - proof safe - case goal2 + apply safe + proof goal_cases + case prems: (2 d) have "(\k\d. norm (integral k (h \ f))) \ setsum (\k. norm(integral k f)) d * b" unfolding setsum_left_distrib apply (rule setsum_mono) - proof - - case goal1 - from division_ofD(4)[OF goal2 this] + proof goal_cases + case (1 k) + from division_ofD(4)[OF prems this] guess u v by (elim exE) note uv=this have *: "f integrable_on k" unfolding uv @@ -11328,7 +11331,7 @@ qed also have "\ \ B * b" apply (rule mult_right_mono) - using B goal2 b + using B prems b apply auto done finally show ?case . @@ -11450,9 +11453,9 @@ show "f absolutely_integrable_on UNIV" apply (rule bounded_variation_absolutely_integrable[OF assms(1), where B="?B"]) apply safe - proof - - case goal1 - note d=this and d'=division_ofD[OF this] + proof goal_cases + case d: (1 d) + note d'=division_ofD[OF d] have "(\k\d. norm (integral k f)) \ (\k\d. setsum (op \ (integral k (\x. (\i\Basis. \f x\i\ *\<^sub>R i)::'m))) Basis)" apply (rule setsum_mono) @@ -11481,8 +11484,8 @@ also have "\ \ setsum (op \ (integral UNIV (\x. (\i\Basis. \f x\i\ *\<^sub>R i)::'m))) Basis" apply (subst setsum.commute) apply (rule setsum_mono) - proof - - case goal1 + proof goal_cases + case (1 j) have *: "(\x. \i\Basis. \f x\i\ *\<^sub>R i::'m) integrable_on \d" using integrable_on_subdivision[OF d assms(2)] by auto have "(\i\d. integral i (\x. \i\Basis. \f x\i\ *\<^sub>R i::'m) \ j) = @@ -11535,9 +11538,10 @@ assume assms: "\x. norm (f x) \ g x" "f integrable_on UNIV" "g integrable_on UNIV" show "f absolutely_integrable_on UNIV" apply (rule bounded_variation_absolutely_integrable[OF assms(2),where B="integral UNIV g"]) - proof safe - case goal1 - note d=this and d'=division_ofD[OF this] + apply safe + proof goal_cases + case d: (1 d) + note d'=division_ofD[OF d] have "(\k\d. norm (integral k f)) \ (\k\d. integral k g)" apply (rule setsum_mono) apply (rule integral_norm_bound_integral) @@ -11725,9 +11729,8 @@ by (rule cInf_superset_mono) auto let ?S = "{f j x| j. m \ j}" show "((\k. Inf {f j x |j. j \ {m..m + k}}) ---> Inf ?S) sequentially" - proof (rule LIMSEQ_I) - case goal1 - note r = this + proof (rule LIMSEQ_I, goal_cases) + case r: (1 r) have "\y\?S. y < Inf ?S + r" by (subst cInf_less_iff[symmetric]) (auto simp: \x\s\ r) @@ -11736,8 +11739,9 @@ show ?case apply (rule_tac x=N in exI) - proof safe - case goal1 + apply safe + proof goal_cases + case prems: (1 n) have *: "\y ix. y < Inf ?S + r \ Inf ?S \ ix \ ix \ y \ abs(ix - Inf ?S) < r" by arith show ?case @@ -11745,7 +11749,7 @@ apply (rule *[rule_format, OF N(1)]) apply (rule cInf_superset_mono, auto simp: \x\s\) [] apply (rule cInf_lower) - using N goal1 + using N prems apply auto [] apply simp done @@ -11796,8 +11800,8 @@ by (rule cSup_subset_mono) auto let ?S = "{f j x| j. m \ j}" show "((\k. Sup {f j x |j. j \ {m..m + k}}) ---> Sup ?S) sequentially" - proof (rule LIMSEQ_I) - case goal1 note r=this + proof (rule LIMSEQ_I, goal_cases) + case r: (1 r) have "\y\?S. Sup ?S - r < y" by (subst less_cSup_iff[symmetric]) (auto simp: r \x\s\) then obtain N where N: "Sup ?S - r < f N x" "m \ N" @@ -11805,8 +11809,9 @@ show ?case apply (rule_tac x=N in exI) - proof safe - case goal1 + apply safe + proof goal_cases + case prems: (1 n) have *: "\y ix. Sup ?S - r < y \ ix \ Sup ?S \ y \ ix \ abs(ix - Sup ?S) < r" by arith show ?case @@ -11814,7 +11819,7 @@ apply (rule *[rule_format, OF N(1)]) apply (rule cSup_subset_mono, auto simp: \x\s\) [] apply (subst cSup_upper) - using N goal1 + using N prems apply auto done qed @@ -11849,20 +11854,21 @@ by (intro cInf_superset_mono) (auto simp: \x\s\) show "(\k::nat. Inf {f j x |j. k \ j}) ----> g x" - proof (rule LIMSEQ_I) - case goal1 + proof (rule LIMSEQ_I, goal_cases) + case r: (1 r) then have "0 j} \ Sup {f j x |j. Suc k \ j}" by (rule cSup_subset_mono) (auto simp: \x\s\) show "((\k. Sup {f j x |j. k \ j}) ---> g x) sequentially" - proof (rule LIMSEQ_I) - case goal1 + proof (rule LIMSEQ_I, goal_cases) + case r: (1 r) then have "0k. integral s (f k)) ---> integral s g) sequentially" - proof (rule LIMSEQ_I) - case goal1 - from LIMSEQ_D [OF inc2(2) goal1] guess N1 .. note N1=this[unfolded real_norm_def] - from LIMSEQ_D [OF dec2(2) goal1] guess N2 .. note N2=this[unfolded real_norm_def] + proof (rule LIMSEQ_I, goal_cases) + case r: (1 r) + from LIMSEQ_D [OF inc2(2) r] guess N1 .. note N1=this[unfolded real_norm_def] + from LIMSEQ_D [OF dec2(2) r] guess N2 .. note N2=this[unfolded real_norm_def] show ?case proof (rule_tac x="N1+N2" in exI, safe) fix n diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Multivariate_Analysis/Ordered_Euclidean_Space.thy --- a/src/HOL/Multivariate_Analysis/Ordered_Euclidean_Space.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Multivariate_Analysis/Ordered_Euclidean_Space.thy Fri Sep 18 16:42:19 2015 +0100 @@ -17,20 +17,20 @@ begin subclass order - by default + by standard (auto simp: eucl_le eucl_less_le_not_le intro!: euclidean_eqI antisym intro: order.trans) subclass ordered_ab_group_add_abs - by default (auto simp: eucl_le inner_add_left eucl_abs abs_leI) + by standard (auto simp: eucl_le inner_add_left eucl_abs abs_leI) subclass ordered_real_vector - by default (auto simp: eucl_le intro!: mult_left_mono mult_right_mono) + by standard (auto simp: eucl_le intro!: mult_left_mono mult_right_mono) subclass lattice - by default (auto simp: eucl_inf eucl_sup eucl_le) + by standard (auto simp: eucl_inf eucl_sup eucl_le) subclass distrib_lattice - by default (auto simp: eucl_inf eucl_sup sup_inf_distrib1 intro!: euclidean_eqI) + by standard (auto simp: eucl_inf eucl_sup sup_inf_distrib1 intro!: euclidean_eqI) subclass conditionally_complete_lattice proof @@ -152,7 +152,7 @@ by (auto) instance real :: ordered_euclidean_space - by default (auto simp: INF_def SUP_def) + by standard (auto simp: INF_def SUP_def) lemma in_Basis_prod_iff: fixes i::"'a::euclidean_space*'b::euclidean_space" @@ -168,7 +168,7 @@ end instance prod :: (ordered_euclidean_space, ordered_euclidean_space) ordered_euclidean_space - by default + by standard (auto intro!: add_mono simp add: euclidean_representation_setsum' Ball_def inner_prod_def in_Basis_prod_iff inner_Basis_inf_left inner_Basis_sup_left inner_Basis_INF_left Inf_prod_def inner_Basis_SUP_left Sup_prod_def less_prod_def less_eq_prod_def eucl_le[where 'a='a] @@ -281,7 +281,7 @@ definition "abs x = (\ i. abs (x $ i))" instance - apply default + apply standard unfolding euclidean_representation_setsum' apply (auto simp: less_eq_vec_def inf_vec_def sup_vec_def Inf_vec_def Sup_vec_def inner_axis Basis_vec_def inner_Basis_inf_left inner_Basis_sup_left inner_Basis_INF_left diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/NSA/HyperDef.thy --- a/src/HOL/NSA/HyperDef.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/NSA/HyperDef.thy Fri Sep 18 16:42:19 2015 +0100 @@ -337,7 +337,7 @@ *} simproc_setup fast_arith_hypreal ("(m::hypreal) < n" | "(m::hypreal) <= n" | "(m::hypreal) = n") = - {* fn _ => fn ss => fn ct => Lin_Arith.simproc ss (Thm.term_of ct) *} + {* K Lin_Arith.simproc *} subsection {* Exponentials on the Hyperreals *} diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Nat.thy --- a/src/HOL/Nat.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Nat.thy Fri Sep 18 16:42:19 2015 +0100 @@ -529,7 +529,7 @@ end instance nat :: no_top - by default (auto intro: less_Suc_eq_le [THEN iffD2]) + by standard (auto intro: less_Suc_eq_le [THEN iffD2]) subsubsection \Introduction properties\ @@ -1664,8 +1664,8 @@ setup \Lin_Arith.global_setup\ declaration \K Lin_Arith.setup\ -simproc_setup fast_arith_nat ("(m::nat) < n" | "(m::nat) <= n" | "(m::nat) = n") = - \fn _ => fn ss => fn ct => Lin_Arith.simproc ss (Thm.term_of ct)\ +simproc_setup fast_arith_nat ("(m::nat) < n" | "(m::nat) \ n" | "(m::nat) = n") = + \K Lin_Arith.simproc\ (* Because of this simproc, the arithmetic solver is really only useful to detect inconsistencies among the premises for subgoals which are *not* themselves (in)equalities, because the latter activate diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Nitpick.thy --- a/src/HOL/Nitpick.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Nitpick.thy Fri Sep 18 16:42:19 2015 +0100 @@ -239,8 +239,8 @@ hide_fact (open) Ex1_unfold rtrancl_unfold rtranclp_unfold tranclp_unfold prod_def refl'_def wf'_def card'_def setsum'_def fold_graph'_def The_psimp Eps_psimp case_unit_unfold case_nat_unfold - size_list_simp nat_gcd_def nat_lcm_def int_gcd_def int_lcm_def Frac_def zero_frac_def one_frac_def - num_def denom_def norm_frac_def frac_def plus_frac_def times_frac_def uminus_frac_def + size_list_simp nat_lcm_def int_gcd_def int_lcm_def Frac_def zero_frac_def one_frac_def + num_def denom_def frac_def plus_frac_def times_frac_def uminus_frac_def number_of_frac_def inverse_frac_def less_frac_def less_eq_frac_def of_frac_def wf_wfrec'_def wfrec'_def diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Nominal/Examples/Pattern.thy --- a/src/HOL/Nominal/Examples/Pattern.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Nominal/Examples/Pattern.thy Fri Sep 18 16:42:19 2015 +0100 @@ -62,7 +62,7 @@ by (simp add: supp_def Collect_disj_eq del: disj_not1) instance pat :: pt_name -proof (default, goals) +proof (standard, goal_cases) case (1 x) show ?case by (induct x) simp_all next @@ -74,7 +74,7 @@ qed instance pat :: fs_name -proof (default, goals) +proof (standard, goal_cases) case (1 x) show ?case by (induct x) (simp_all add: fin_supp) qed diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Nominal/nominal_datatype.ML --- a/src/HOL/Nominal/nominal_datatype.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Nominal/nominal_datatype.ML Fri Sep 18 16:42:19 2015 +0100 @@ -98,12 +98,15 @@ fun permTs_of (Const (@{const_name Nominal.perm}, T) $ t $ u) = fst (dest_permT T) :: permTs_of u | permTs_of _ = []; -fun perm_simproc' ctxt (Const (@{const_name Nominal.perm}, T) $ t $ (u as Const (@{const_name Nominal.perm}, U) $ r $ s)) = +fun perm_simproc' ctxt ct = + (case Thm.term_of ct of + Const (@{const_name Nominal.perm}, T) $ t $ (u as Const (@{const_name Nominal.perm}, U) $ r $ s) => let val thy = Proof_Context.theory_of ctxt; val (aT as Type (a, []), S) = dest_permT T; val (bT as Type (b, []), _) = dest_permT U; - in if member (op =) (permTs_of u) aT andalso aT <> bT then + in + if member (op =) (permTs_of u) aT andalso aT <> bT then let val cp = cp_inst_of thy a b; val dj = dj_thm_of thy b a; @@ -115,10 +118,11 @@ end else NONE end - | perm_simproc' _ _ = NONE; + | _ => NONE); val perm_simproc = - Simplifier.simproc_global @{theory} "perm_simp" ["pi1 \ (pi2 \ x)"] perm_simproc'; + Simplifier.make_simproc @{context} "perm_simp" + {lhss = [@{term "pi1 \ (pi2 \ x)"}], proc = K perm_simproc', identifier = []}; fun projections ctxt rule = Project_Rule.projections ctxt rule @@ -582,7 +586,7 @@ val (typedefs, thy6) = thy4 |> fold_map (fn (((name, mx), tvs), (cname, U)) => fn thy => - Typedef.add_typedef_global false + Typedef.add_typedef_global (name, map (fn (v, _) => (v, dummyS)) tvs, mx) (* FIXME keep constraints!? *) (Const (@{const_name Collect}, (U --> HOLogic.boolT) --> HOLogic.mk_setT U) $ Const (cname, U --> HOLogic.boolT)) NONE diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Nominal/nominal_inductive.ML --- a/src/HOL/Nominal/nominal_inductive.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Nominal/nominal_inductive.ML Fri Sep 18 16:42:19 2015 +0100 @@ -40,11 +40,15 @@ th RS infer_instantiate ctxt [(#1 (dest_Var (Thm.term_of perm_boolI_pi)), pi)] perm_boolI; fun mk_perm_bool_simproc names = - Simplifier.simproc_global_i @{theory} "perm_bool" [@{term "perm pi x"}] (fn ctxt => - fn Const (@{const_name Nominal.perm}, _) $ _ $ t => - if member (op =) names (the_default "" (try (head_of #> dest_Const #> fst) t)) - then SOME perm_bool else NONE - | _ => NONE); + Simplifier.make_simproc @{context} "perm_bool" + {lhss = [@{term "perm pi x"}], + proc = fn _ => fn _ => fn ct => + (case Thm.term_of ct of + Const (@{const_name Nominal.perm}, _) $ _ $ t => + if member (op =) names (the_default "" (try (head_of #> dest_Const #> fst) t)) + then SOME perm_bool else NONE + | _ => NONE), + identifier = []}; fun transp ([] :: _) = [] | transp xs = map hd xs :: transp (map tl xs); diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Nominal/nominal_inductive2.ML --- a/src/HOL/Nominal/nominal_inductive2.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Nominal/nominal_inductive2.ML Fri Sep 18 16:42:19 2015 +0100 @@ -44,11 +44,15 @@ th RS infer_instantiate ctxt [(#1 (dest_Var (Thm.term_of perm_boolI_pi)), pi)] perm_boolI; fun mk_perm_bool_simproc names = - Simplifier.simproc_global_i @{theory} "perm_bool" [@{term "perm pi x"}] (fn ctxt => - fn Const (@{const_name Nominal.perm}, _) $ _ $ t => - if member (op =) names (the_default "" (try (head_of #> dest_Const #> fst) t)) - then SOME perm_bool else NONE - | _ => NONE); + Simplifier.make_simproc @{context} "perm_bool" + {lhss = [@{term "perm pi x"}], + proc = fn _ => fn _ => fn ct => + (case Thm.term_of ct of + Const (@{const_name Nominal.perm}, _) $ _ $ t => + if member (op =) names (the_default "" (try (head_of #> dest_Const #> fst) t)) + then SOME perm_bool else NONE + | _ => NONE), + identifier = []}; fun transp ([] :: _) = [] | transp xs = map hd xs :: transp (map tl xs); diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Nominal/nominal_permeq.ML --- a/src/HOL/Nominal/nominal_permeq.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Nominal/nominal_permeq.ML Fri Sep 18 16:42:19 2015 +0100 @@ -3,7 +3,7 @@ Author: Julien Narboux, TU Muenchen Methods for simplifying permutations and for analysing equations -involving permutations. +involving permutations. *) (* @@ -18,8 +18,8 @@ [(a,b)] o pi1 o pi2 = .... - rather it tries to permute pi1 over pi2, which - results in a failure when used with the + rather it tries to permute pi1 over pi2, which + results in a failure when used with the perm_(full)_simp tactics *) @@ -67,7 +67,7 @@ val supp_unit = @{thm "supp_unit"}; val pt_perm_compose_aux = @{thm "pt_perm_compose_aux"}; val cp1_aux = @{thm "cp1_aux"}; -val perm_aux_fold = @{thm "perm_aux_fold"}; +val perm_aux_fold = @{thm "perm_aux_fold"}; val supports_fresh_rule = @{thm "supports_fresh"}; (* needed in the process of fully simplifying permutations *) @@ -76,31 +76,32 @@ val weak_congs = [@{thm "if_weak_cong"}] (* debugging *) -fun DEBUG ctxt (msg,tac) = - CHANGED (EVERY [print_tac ctxt ("before "^msg), tac, print_tac ctxt ("after "^msg)]); -fun NO_DEBUG _ (_,tac) = CHANGED tac; +fun DEBUG ctxt (msg,tac) = + CHANGED (EVERY [print_tac ctxt ("before "^msg), tac, print_tac ctxt ("after "^msg)]); +fun NO_DEBUG _ (_,tac) = CHANGED tac; (* simproc that deals with instances of permutations in front *) (* of applications; just adding this rule to the simplifier *) (* would loop; it also needs careful tuning with the simproc *) (* for functions to avoid further possibilities for looping *) -fun perm_simproc_app' ctxt redex = - let - val thy = Proof_Context.theory_of ctxt; +fun perm_simproc_app' ctxt ct = + let + val thy = Proof_Context.theory_of ctxt + val redex = Thm.term_of ct (* the "application" case is only applicable when the head of f is not a *) (* constant or when (f x) is a permuation with two or more arguments *) - fun applicable_app t = + fun applicable_app t = (case (strip_comb t) of (Const (@{const_name Nominal.perm},_),ts) => (length ts) >= 2 | (Const _,_) => false | _ => true) in - case redex of + case redex of (* case pi o (f x) == (pi o f) (pi o x) *) (Const(@{const_name Nominal.perm}, Type(@{type_name fun}, - [Type(@{type_name list}, [Type(@{type_name prod},[Type(n,_),_])]),_])) $ pi $ (f $ x)) => + [Type(@{type_name list}, [Type(@{type_name prod},[Type(n,_),_])]),_])) $ pi $ (f $ x)) => (if (applicable_app f) then let val name = Long_Name.base_name n @@ -111,12 +112,14 @@ | _ => NONE end -val perm_simproc_app = Simplifier.simproc_global @{theory} "perm_simproc_app" - ["Nominal.perm pi x"] perm_simproc_app'; +val perm_simproc_app = + Simplifier.make_simproc @{context} "perm_simproc_app" + {lhss = [@{term "Nominal.perm pi x"}], proc = K perm_simproc_app', identifier = []} (* a simproc that deals with permutation instances in front of functions *) -fun perm_simproc_fun' ctxt redex = - let +fun perm_simproc_fun' ctxt ct = + let + val redex = Thm.term_of ct fun applicable_fun t = (case (strip_comb t) of (Abs _ ,[]) => true @@ -124,20 +127,21 @@ | (Const _, _) => true | _ => false) in - case redex of - (* case pi o f == (%x. pi o (f ((rev pi)o x))) *) - (Const(@{const_name Nominal.perm},_) $ pi $ f) => + case redex of + (* case pi o f == (%x. pi o (f ((rev pi)o x))) *) + (Const(@{const_name Nominal.perm},_) $ pi $ f) => (if applicable_fun f then SOME perm_fun_def else NONE) | _ => NONE end -val perm_simproc_fun = Simplifier.simproc_global @{theory} "perm_simproc_fun" - ["Nominal.perm pi x"] perm_simproc_fun'; +val perm_simproc_fun = + Simplifier.make_simproc @{context} "perm_simproc_fun" + {lhss = [@{term "Nominal.perm pi x"}], proc = K perm_simproc_fun', identifier = []} (* function for simplyfying permutations *) (* stac contains the simplifiation tactic that is *) (* applied (see (no_asm) options below *) -fun perm_simp_gen stac dyn_thms eqvt_thms ctxt i = +fun perm_simp_gen stac dyn_thms eqvt_thms ctxt i = ("general simplification of permutations", fn st => SUBGOAL (fn _ => let val ctxt' = ctxt @@ -150,23 +154,23 @@ end) i st); (* general simplification of permutations and permutation that arose from eqvt-problems *) -fun perm_simp stac ctxt = +fun perm_simp stac ctxt = let val simps = ["perm_swap","perm_fresh_fresh","perm_bij","perm_pi_simp","swap_simps"] - in + in perm_simp_gen stac simps [] ctxt end; -fun eqvt_simp stac ctxt = +fun eqvt_simp stac ctxt = let val simps = ["perm_swap","perm_fresh_fresh","perm_pi_simp"] val eqvts_thms = NominalThmDecls.get_eqvt_thms ctxt; - in + in perm_simp_gen stac simps eqvts_thms ctxt end; (* main simplification tactics for permutations *) fun perm_simp_tac_gen_i stac tactical ctxt i = DETERM (tactical ctxt (perm_simp stac ctxt i)); -fun eqvt_simp_tac_gen_i stac tactical ctxt i = DETERM (tactical ctxt (eqvt_simp stac ctxt i)); +fun eqvt_simp_tac_gen_i stac tactical ctxt i = DETERM (tactical ctxt (eqvt_simp stac ctxt i)); val perm_simp_tac_i = perm_simp_tac_gen_i simp_tac val perm_asm_simp_tac_i = perm_simp_tac_gen_i asm_simp_tac @@ -177,18 +181,18 @@ (* applies the perm_compose rule such that *) (* pi o (pi' o lhs) = rhs *) -(* is transformed to *) +(* is transformed to *) (* (pi o pi') o (pi' o lhs) = rhs *) (* *) (* this rule would loop in the simplifier, so some trick is used with *) (* generating perm_aux'es for the outermost permutation and then un- *) (* folding the definition *) -fun perm_compose_simproc' ctxt redex = - (case redex of +fun perm_compose_simproc' ctxt ct = + (case Thm.term_of ct of (Const (@{const_name Nominal.perm}, Type (@{type_name fun}, [Type (@{type_name list}, - [Type (@{type_name Product_Type.prod}, [T as Type (tname,_),_])]),_])) $ pi1 $ (Const (@{const_name Nominal.perm}, - Type (@{type_name fun}, [Type (@{type_name list}, [Type (@{type_name Product_Type.prod}, [U as Type (uname,_),_])]),_])) $ + [Type (@{type_name Product_Type.prod}, [T as Type (tname,_),_])]),_])) $ pi1 $ (Const (@{const_name Nominal.perm}, + Type (@{type_name fun}, [Type (@{type_name list}, [Type (@{type_name Product_Type.prod}, [U as Type (uname,_),_])]),_])) $ pi2 $ t)) => let val thy = Proof_Context.theory_of ctxt @@ -196,7 +200,7 @@ val uname' = Long_Name.base_name uname in if pi1 <> pi2 then (* only apply the composition rule in this case *) - if T = U then + if T = U then SOME (Thm.instantiate' [SOME (Thm.global_ctyp_of thy (fastype_of t))] [SOME (Thm.global_cterm_of thy pi1), SOME (Thm.global_cterm_of thy pi2), SOME (Thm.global_cterm_of thy t)] @@ -206,16 +210,18 @@ SOME (Thm.instantiate' [SOME (Thm.global_ctyp_of thy (fastype_of t))] [SOME (Thm.global_cterm_of thy pi1), SOME (Thm.global_cterm_of thy pi2), SOME (Thm.global_cterm_of thy t)] - (mk_meta_eq (Global_Theory.get_thm thy ("cp_"^tname'^"_"^uname'^"_inst") RS + (mk_meta_eq (Global_Theory.get_thm thy ("cp_"^tname'^"_"^uname'^"_inst") RS cp1_aux))) else NONE end | _ => NONE); -val perm_compose_simproc = Simplifier.simproc_global @{theory} "perm_compose" - ["Nominal.perm pi1 (Nominal.perm pi2 t)"] perm_compose_simproc'; +val perm_compose_simproc = + Simplifier.make_simproc @{context} "perm_compose" + {lhss = [@{term "Nominal.perm pi1 (Nominal.perm pi2 t)"}], + proc = K perm_compose_simproc', identifier = []} -fun perm_compose_tac ctxt i = +fun perm_compose_tac ctxt i = ("analysing permutation compositions on the lhs", fn st => EVERY [resolve_tac ctxt [trans] i, @@ -227,11 +233,11 @@ (* unfolds the definition of permutations *) (* applied to functions such that *) -(* pi o f = rhs *) +(* pi o f = rhs *) (* is transformed to *) (* %x. pi o (f ((rev pi) o x)) = rhs *) fun unfold_perm_fun_def_tac ctxt i = - ("unfolding of permutations on functions", + ("unfolding of permutations on functions", resolve_tac ctxt [perm_fun_def RS meta_eq_to_obj_eq RS trans] i) (* applies the ext-rule such that *) @@ -246,14 +252,14 @@ (* since it contains looping rules the "recursion" - depth is set *) (* to 10 - this seems to be sufficient in most cases *) fun perm_extend_simp_tac_i tactical ctxt = - let fun perm_extend_simp_tac_aux tactical ctxt n = + let fun perm_extend_simp_tac_aux tactical ctxt n = if n=0 then K all_tac - else DETERM o + else DETERM o (FIRST' [fn i => tactical ctxt ("splitting conjunctions on the rhs", resolve_tac ctxt [conjI] i), fn i => tactical ctxt (perm_simp asm_full_simp_tac ctxt i), fn i => tactical ctxt (perm_compose_tac ctxt i), - fn i => tactical ctxt (apply_cong_tac ctxt i), + fn i => tactical ctxt (apply_cong_tac ctxt i), fn i => tactical ctxt (unfold_perm_fun_def_tac ctxt i), fn i => tactical ctxt (ext_fun_tac ctxt i)] THEN_ALL_NEW (TRY o (perm_extend_simp_tac_aux tactical ctxt (n-1)))) @@ -264,7 +270,7 @@ (* unfolds the support definition and strips off the *) (* intros, then applies eqvt_simp_tac *) fun supports_tac_i tactical ctxt i = - let + let val simps = [supports_def, Thm.symmetric fresh_def, fresh_prod] in EVERY [tactical ctxt ("unfolding of supports ", simp_tac (put_simpset HOL_basic_ss ctxt addsimps simps) i), @@ -323,11 +329,11 @@ (* tactic that guesses whether an atom is fresh for an expression *) -(* it first collects all free variables and tries to show that the *) +(* it first collects all free variables and tries to show that the *) (* support of these free variables (op supports) the goal *) (* FIXME proper SUBGOAL/CSUBGOAL instead of cprems_of etc. *) fun fresh_guess_tac_i tactical ctxt i st = - let + let val goal = nth (cprems_of st) (i - 1) val fin_supp = Proof_Context.get_thms ctxt "fin_supp" val fresh_atm = Proof_Context.get_thms ctxt "fresh_atm" @@ -335,7 +341,7 @@ val ctxt2 = ctxt addsimps [supp_prod,supp_unit,finite_Un,finite_emptyI,conj_absorb]@fin_supp in case Logic.strip_assums_concl (Thm.term_of goal) of - _ $ (Const (@{const_name Nominal.fresh}, Type ("fun", [T, _])) $ _ $ t) => + _ $ (Const (@{const_name Nominal.fresh}, Type ("fun", [T, _])) $ _ $ t) => let val ps = Logic.strip_params (Thm.term_of goal); val Ts = rev (map snd ps); @@ -353,15 +359,15 @@ infer_instantiate ctxt [(#1 (dest_Var (head_of S)), Thm.cterm_of ctxt s')] supports_fresh_rule'; in - (tactical ctxt ("guessing of the right set that supports the goal", + (tactical ctxt ("guessing of the right set that supports the goal", (EVERY [compose_tac ctxt (false, supports_fresh_rule'', 3) i, asm_full_simp_tac ctxt1 (i+2), - asm_full_simp_tac ctxt2 (i+1), + asm_full_simp_tac ctxt2 (i+1), supports_tac_i tactical ctxt i]))) st end - (* when a term-constructor contains more than one binder, it is useful *) + (* when a term-constructor contains more than one binder, it is useful *) (* in nominal_primrecs to try whether the goal can be solved by an hammer *) - | _ => (tactical ctxt ("if it is not of the form _\_, then try the simplifier", + | _ => (tactical ctxt ("if it is not of the form _\_, then try the simplifier", (asm_full_simp_tac (put_simpset HOL_ss ctxt addsimps [fresh_prod]@fresh_atm) i))) st end handle General.Subscript => Seq.empty; @@ -383,7 +389,7 @@ (* Code opied from the Simplifer for setting up the perm_simp method *) (* behaves nearly identical to the simp-method, for example can handle *) -(* options like (no_asm) etc. *) +(* options like (no_asm) etc. *) val no_asmN = "no_asm"; val no_asm_useN = "no_asm_use"; val no_asm_simpN = "no_asm_simp"; diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Num.thy --- a/src/HOL/Num.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Num.thy Fri Sep 18 16:42:19 2015 +0100 @@ -106,7 +106,7 @@ "m < n \ nat_of_num m < nat_of_num n" instance - by (default, auto simp add: less_num_def less_eq_num_def num_eq_iff) + by standard (auto simp add: less_num_def less_eq_num_def num_eq_iff) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Number_Theory/Eratosthenes.thy --- a/src/HOL/Number_Theory/Eratosthenes.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Number_Theory/Eratosthenes.thy Fri Sep 18 16:42:19 2015 +0100 @@ -122,7 +122,7 @@ "mark_out_aux n m [] = []" "mark_out_aux n 0 (b # bs) = False # mark_out_aux n n bs" "mark_out_aux n (Suc m) (b # bs) = b # mark_out_aux n m bs" -proof goals +proof goal_cases case 1 show ?case by (simp add: mark_out_aux_def) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Orderings.thy --- a/src/HOL/Orderings.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Orderings.thy Fri Sep 18 16:42:19 2015 +0100 @@ -196,7 +196,7 @@ by (auto simp add: less_le_not_le intro: antisym) sublocale order!: ordering less_eq less + dual_order!: ordering greater_eq greater - by default (auto intro: antisym order_trans simp add: less_le) + by standard (auto intro: antisym order_trans simp add: less_le) text \Reflexivity.\ @@ -1197,7 +1197,7 @@ begin sublocale bot!: ordering_top greater_eq greater bot - by default (fact bot_least) + by standard (fact bot_least) lemma le_bot: "a \ \ \ a = \" @@ -1225,7 +1225,7 @@ begin sublocale top!: ordering_top less_eq less top - by default (fact top_greatest) + by standard (fact top_greatest) lemma top_le: "\ \ a \ a = \" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Predicate_Compile_Examples/Predicate_Compile_Quickcheck_Examples.thy --- a/src/HOL/Predicate_Compile_Examples/Predicate_Compile_Quickcheck_Examples.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Predicate_Compile_Examples/Predicate_Compile_Quickcheck_Examples.thy Fri Sep 18 16:42:19 2015 +0100 @@ -2,6 +2,7 @@ imports "~~/src/HOL/Library/Predicate_Compile_Quickcheck" begin +(* section {* Sets *} lemma "x \ {(1::nat)} ==> False" @@ -35,6 +36,7 @@ "x \ {1, 2} \ {3, 4} ==> x = (1::nat) \ x = (2::nat)" quickcheck[generator=predicate_compile_wo_ff] oops +*) section {* Equivalences *} @@ -48,7 +50,7 @@ lemma "is_ten x = is_eleven x" -quickcheck[tester = predicate_compile_wo_ff, iterations = 1, size = 1, expect = counterexample] +quickcheck[tester = smart_exhaustive, iterations = 1, size = 1, expect = counterexample] oops section {* Context Free Grammar *} @@ -64,13 +66,13 @@ | "\v \ B\<^sub>1; v \ B\<^sub>1\ \ a # v @ w \ B\<^sub>1" lemma - "w \ S\<^sub>1 \ w = []" -quickcheck[tester = predicate_compile_ff_nofs, iterations=1] + "S\<^sub>1p w \ w = []" +quickcheck[tester = smart_exhaustive, iterations=1] oops theorem S\<^sub>1_sound: -"w \ S\<^sub>1 \ length [x \ w. x = a] = length [x \ w. x = b]" -quickcheck[generator=predicate_compile_ff_nofs, size=15] +"S\<^sub>1p w \ length [x \ w. x = a] = length [x \ w. x = b]" +quickcheck[tester=smart_exhaustive, size=15] oops @@ -111,8 +113,8 @@ oops *) theorem S\<^sub>2_sound: -"w \ S\<^sub>2 \ length [x \ w. x = a] = length [x \ w. x = b]" -quickcheck[generator=predicate_compile_ff_nofs, size=5, iterations=10] +"S\<^sub>2p w \ length [x \ w. x = a] = length [x \ w. x = b]" +quickcheck[tester=smart_exhaustive, size=5, iterations=10] oops inductive_set S\<^sub>3 and A\<^sub>3 and B\<^sub>3 where @@ -123,26 +125,26 @@ | "w \ S\<^sub>3 \ b # w \ B\<^sub>3" | "\v \ B\<^sub>3; w \ B\<^sub>3\ \ a # v @ w \ B\<^sub>3" -code_pred [inductify, skip_proof] S\<^sub>3 . -thm S\<^sub>3.equation +code_pred [inductify, skip_proof] S\<^sub>3p . +thm S\<^sub>3p.equation (* values 10 "{x. S\<^sub>3 x}" *) lemma S\<^sub>3_sound: -"w \ S\<^sub>3 \ length [x \ w. x = a] = length [x \ w. x = b]" -quickcheck[generator=predicate_compile_ff_fs, size=10, iterations=10] +"S\<^sub>3p w \ length [x \ w. x = a] = length [x \ w. x = b]" +quickcheck[tester=smart_exhaustive, size=10, iterations=10] oops lemma "\ (length w > 2) \ \ (length [x \ w. x = a] = length [x \ w. x = b])" -quickcheck[size=10, tester = predicate_compile_ff_fs] +quickcheck[size=10, tester = smart_exhaustive] oops theorem S\<^sub>3_complete: -"length [x \ w. x = a] = length [x \ w. b = x] \ w \ S\<^sub>3" +"length [x \ w. x = a] = length [x \ w. b = x] \ S\<^sub>3p w" (*quickcheck[generator=SML]*) -quickcheck[generator=predicate_compile_ff_fs, size=10, iterations=100] +quickcheck[tester=smart_exhaustive, size=10, iterations=100] oops @@ -156,13 +158,13 @@ | "\v \ B\<^sub>4; w \ B\<^sub>4\ \ a # v @ w \ B\<^sub>4" theorem S\<^sub>4_sound: -"w \ S\<^sub>4 \ length [x \ w. x = a] = length [x \ w. x = b]" -quickcheck[tester = predicate_compile_ff_nofs, size=5, iterations=1] +"S\<^sub>4p w \ length [x \ w. x = a] = length [x \ w. x = b]" +quickcheck[tester = smart_exhaustive, size=5, iterations=1] oops theorem S\<^sub>4_complete: -"length [x \ w. x = a] = length [x \ w. x = b] \ w \ S\<^sub>4" -quickcheck[tester = predicate_compile_ff_nofs, size=5, iterations=1] +"length [x \ w. x = a] = length [x \ w. x = b] \ S\<^sub>4p w" +quickcheck[tester = smart_exhaustive, size=5, iterations=1] oops hide_const a b @@ -201,7 +203,7 @@ lemma "exec c s s' ==> exec (Seq c c) s s'" - quickcheck[tester = predicate_compile_wo_ff, size=2, iterations=20, expect = counterexample] + quickcheck[tester = smart_exhaustive, size=2, iterations=20, expect = counterexample] oops subsection {* Lambda *} @@ -256,7 +258,7 @@ lemma "\ \ t : U \ t \\<^sub>\ t' \ \ \ t' : U" -quickcheck[tester = predicate_compile_ff_fs, size = 7, iterations = 10] +quickcheck[tester = smart_exhaustive, size = 7, iterations = 10] oops subsection {* JAD *} @@ -281,17 +283,16 @@ unfolding matrix_def by auto qed -code_pred [random_dseq inductify] matrix +code_pred [random_dseq] matrix apply (cases x) unfolding matrix_def apply fastforce apply fastforce done - values [random_dseq 2, 2, 15] 6 "{(M::int list list, n, m). matrix M n m}" definition "scalar_product v w = (\ (x, y)\zip v w. x * y)" -definition mv :: "('a \ semiring_0) list list \ 'a list \ 'a list" +definition mv :: "('a :: semiring_0) list list \ 'a list \ 'a list" where [simp]: "mv M v = map (scalar_product v) M" text {* This defines the matrix vector multiplication. To work properly @{term @@ -306,7 +307,7 @@ by (auto simp: sparsify_def set_zip) lemma listsum_sparsify[simp]: - fixes v :: "('a \ semiring_0) list" + fixes v :: "('a :: semiring_0) list" assumes "length w = length v" shows "(\x\sparsify w. (\(i, x). v ! i) x * snd x) = scalar_product v w" (is "(\x\_. ?f x) = _") @@ -316,11 +317,11 @@ *) definition [simp]: "unzip w = (map fst w, map snd w)" -primrec insert :: "('a \ 'b \ linorder) => 'a \ 'a list => 'a list" where +primrec insert :: "('a \ 'b :: linorder) => 'a \ 'a list => 'a list" where "insert f x [] = [x]" | "insert f x (y # ys) = (if f y < f x then y # insert f x ys else x # y # ys)" -primrec sort :: "('a \ 'b \ linorder) \ 'a list => 'a list" where +primrec sort :: "('a \ 'b :: linorder) \ 'a list => 'a list" where "sort f [] = []" | "sort f (x # xs) = insert f x (sort f xs)" @@ -340,12 +341,12 @@ "jad_mv v = inflate o split zip o apsnd (map listsum o transpose o map (map (\ (i, x). v ! i * x)))" lemma "matrix (M::int list list) rs cs \ False" -quickcheck[tester = predicate_compile_ff_nofs, size = 6] +quickcheck[tester = smart_exhaustive, size = 6] oops lemma "\ matrix M rs cs ; length v = cs \ \ jad_mv v (jad M) = mv M v" -quickcheck[tester = predicate_compile_wo_ff] +quickcheck[tester = smart_exhaustive] oops end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Binary_Product_Measure.thy --- a/src/HOL/Probability/Binary_Product_Measure.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Binary_Product_Measure.thy Fri Sep 18 16:42:19 2015 +0100 @@ -702,7 +702,7 @@ proof (rule measure_eqI) interpret A: finite_measure "count_space A" by (rule finite_measure_count_space) fact interpret B: finite_measure "count_space B" by (rule finite_measure_count_space) fact - interpret P: pair_sigma_finite "count_space A" "count_space B" by default + interpret P: pair_sigma_finite "count_space A" "count_space B" .. show eq: "sets ?P = sets ?C" by (simp add: sets_pair_measure sigma_sets_pair_measure_generator_finite A B) fix X assume X: "X \ sets ?P" @@ -890,7 +890,7 @@ proof - interpret M1: sigma_finite_measure M1 by fact interpret M2: sigma_finite_measure M2 by fact - interpret pair_sigma_finite M1 M2 by default + interpret pair_sigma_finite M1 M2 .. from sigma_finite_up_in_pair_measure_generator guess F :: "nat \ ('a \ 'b) set" .. note F = this let ?E = "{a \ b |a b. a \ sets M1 \ b \ sets M2}" let ?P = "M1 \\<^sub>M M2" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Bochner_Integration.thy --- a/src/HOL/Probability/Bochner_Integration.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Bochner_Integration.thy Fri Sep 18 16:42:19 2015 +0100 @@ -2549,7 +2549,7 @@ assumes "integrable (M1 \\<^sub>M M2) f" shows "integrable (M2 \\<^sub>M M1) (\(x,y). f (y,x))" proof - - interpret Q: pair_sigma_finite M2 M1 by default + interpret Q: pair_sigma_finite M2 M1 .. have *: "(\(x,y). f (y,x)) = (\x. f (case x of (x,y)\(y,x)))" by (auto simp: fun_eq_iff) show ?thesis unfolding * by (rule integrable_distr[OF measurable_pair_swap']) @@ -2560,7 +2560,7 @@ fixes f :: "_ \ _::{banach, second_countable_topology}" shows "integrable (M2 \\<^sub>M M1) (\(x,y). f (y,x)) \ integrable (M1 \\<^sub>M M2) f" proof - - interpret Q: pair_sigma_finite M2 M1 by default + interpret Q: pair_sigma_finite M2 M1 .. from Q.integrable_product_swap[of "\(x,y). f (y,x)"] integrable_product_swap[of f] show ?thesis by auto qed @@ -2751,7 +2751,7 @@ and integrable_snd: "integrable M2 (\y. \x. f x y \M1)" (is "?INT") and integral_snd: "(\y. (\x. f x y \M1) \M2) = integral\<^sup>L (M1 \\<^sub>M M2) (split f)" (is "?EQ") proof - - interpret Q: pair_sigma_finite M2 M1 by default + interpret Q: pair_sigma_finite M2 M1 .. have Q_int: "integrable (M2 \\<^sub>M M1) (\(x, y). f y x)" using f unfolding integrable_product_swap_iff[symmetric] by simp show ?AE using Q.AE_integrable_fst'[OF Q_int] by simp @@ -2780,11 +2780,11 @@ and f: "integrable (Pi\<^sub>M (I \ J) M) f" shows "integral\<^sup>L (Pi\<^sub>M (I \ J) M) f = (\x. (\y. f (merge I J (x, y)) \Pi\<^sub>M J M) \Pi\<^sub>M I M)" proof - - interpret I: finite_product_sigma_finite M I by default fact - interpret J: finite_product_sigma_finite M J by default fact + interpret I: finite_product_sigma_finite M I by standard fact + interpret J: finite_product_sigma_finite M J by standard fact have "finite (I \ J)" using fin by auto - interpret IJ: finite_product_sigma_finite M "I \ J" by default fact - interpret P: pair_sigma_finite "Pi\<^sub>M I M" "Pi\<^sub>M J M" by default + interpret IJ: finite_product_sigma_finite M "I \ J" by standard fact + interpret P: pair_sigma_finite "Pi\<^sub>M I M" "Pi\<^sub>M J M" .. let ?M = "merge I J" let ?f = "\x. f (?M x)" from f have f_borel: "f \ borel_measurable (Pi\<^sub>M (I \ J) M)" @@ -2830,7 +2830,7 @@ assumes [simp]: "finite I" and integrable: "\i. i \ I \ integrable (M i) (f i)" shows "integrable (Pi\<^sub>M I M) (\x. (\i\I. f i (x i)))" (is "integrable _ ?f") proof (unfold integrable_iff_bounded, intro conjI) - interpret finite_product_sigma_finite M I by default fact + interpret finite_product_sigma_finite M I by standard fact show "?f \ borel_measurable (Pi\<^sub>M I M)" using assms by simp @@ -2859,7 +2859,7 @@ then have prod: "\J. J \ insert i I \ integrable (Pi\<^sub>M J M) (\x. (\i\J. f i (x i)))" by (intro product_integrable_setprod insert(4)) (auto intro: finite_subset) - interpret I: finite_product_sigma_finite M I by default fact + interpret I: finite_product_sigma_finite M I by standard fact have *: "\x y. (\j\I. f j (if j = i then y else x j)) = (\j\I. f j (x j))" using `i \ I` by (auto intro!: setprod.cong) show ?case diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Embed_Measure.thy --- a/src/HOL/Probability/Embed_Measure.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Embed_Measure.thy Fri Sep 18 16:42:19 2015 +0100 @@ -169,7 +169,7 @@ from A_props and inj have "\a\op ` f ` A. emeasure (embed_measure M f) a \ \" by (intro ballI, subst emeasure_embed_measure) (auto simp: inj_vimage_image_eq intro: in_sets_embed_measure) - ultimately show ?thesis by - (default, blast) + ultimately show ?thesis by - (standard, blast) qed lemma embed_measure_count_space': diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Finite_Product_Measure.thy --- a/src/HOL/Probability/Finite_Product_Measure.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Finite_Product_Measure.thy Fri Sep 18 16:42:19 2015 +0100 @@ -193,7 +193,7 @@ assumes "I = J" "\x. x \ I \ M x = N x" shows "PiM I M = PiM J N" unfolding PiM_def -proof (rule extend_measure_cong, goals) +proof (rule extend_measure_cong, goal_cases) case 1 show ?case using assms by (subst assms(1), intro PiE_cong[of J "\i. space (M i)" "\i. space (N i)"]) simp_all @@ -764,9 +764,9 @@ "finite I \ (\i. i\I \ A i \ sets (M i)) \ emeasure (PiM I M) (Pi\<^sub>E I A) = (\i\I. emeasure (M i) (A i))" proof (induct I arbitrary: A rule: finite_induct) case (insert i I) - interpret finite_product_sigma_finite M I by default fact + interpret finite_product_sigma_finite M I by standard fact have "finite (insert i I)" using `finite I` by auto - interpret I': finite_product_sigma_finite M "insert i I" by default fact + interpret I': finite_product_sigma_finite M "insert i I" by standard fact let ?h = "(\(f, y). f(i := y))" let ?P = "distr (Pi\<^sub>M I M \\<^sub>M M i) (Pi\<^sub>M (insert i I) M) ?h" @@ -821,7 +821,7 @@ assumes "finite I" shows "sigma_finite_measure (PiM I M)" proof - interpret finite_product_sigma_finite M I by default fact + interpret finite_product_sigma_finite M I by standard fact obtain F where F: "\j. countable (F j)" "\j f. f \ F j \ f \ sets (M j)" "\j f. f \ F j \ emeasure (M j) f \ \" and @@ -846,7 +846,7 @@ assumes pos: "0 \ f (\k. undefined)" shows "integral\<^sup>N (Pi\<^sub>M {} M) f = f (\k. undefined)" proof - - interpret finite_product_sigma_finite M "{}" by default (fact finite.emptyI) + interpret finite_product_sigma_finite M "{}" by standard (fact finite.emptyI) have "\A. emeasure (Pi\<^sub>M {} M) (Pi\<^sub>E {} A) = 1" using assms by (subst measure_times) auto then show ?thesis @@ -864,11 +864,11 @@ shows "distr (Pi\<^sub>M I M \\<^sub>M Pi\<^sub>M J M) (Pi\<^sub>M (I \ J) M) (merge I J) = Pi\<^sub>M (I \ J) M" (is "?D = ?P") proof - - interpret I: finite_product_sigma_finite M I by default fact - interpret J: finite_product_sigma_finite M J by default fact + interpret I: finite_product_sigma_finite M I by standard fact + interpret J: finite_product_sigma_finite M J by standard fact have "finite (I \ J)" using fin by auto - interpret IJ: finite_product_sigma_finite M "I \ J" by default fact - interpret P: pair_sigma_finite "Pi\<^sub>M I M" "Pi\<^sub>M J M" by default + interpret IJ: finite_product_sigma_finite M "I \ J" by standard fact + interpret P: pair_sigma_finite "Pi\<^sub>M I M" "Pi\<^sub>M J M" by standard let ?g = "merge I J" from IJ.sigma_finite_pairs obtain F where @@ -928,9 +928,9 @@ shows "integral\<^sup>N (Pi\<^sub>M (I \ J) M) f = (\\<^sup>+ x. (\\<^sup>+ y. f (merge I J (x, y)) \(Pi\<^sub>M J M)) \(Pi\<^sub>M I M))" proof - - interpret I: finite_product_sigma_finite M I by default fact - interpret J: finite_product_sigma_finite M J by default fact - interpret P: pair_sigma_finite "Pi\<^sub>M I M" "Pi\<^sub>M J M" by default + interpret I: finite_product_sigma_finite M I by standard fact + interpret J: finite_product_sigma_finite M J by standard fact + interpret P: pair_sigma_finite "Pi\<^sub>M I M" "Pi\<^sub>M J M" by standard have P_borel: "(\x. f (merge I J x)) \ borel_measurable (Pi\<^sub>M I M \\<^sub>M Pi\<^sub>M J M)" using measurable_comp[OF measurable_merge f] by (simp add: comp_def) show ?thesis @@ -944,7 +944,7 @@ lemma (in product_sigma_finite) distr_singleton: "distr (Pi\<^sub>M {i} M) (M i) (\x. x i) = M i" (is "?D = _") proof (intro measure_eqI[symmetric]) - interpret I: finite_product_sigma_finite M "{i}" by default simp + interpret I: finite_product_sigma_finite M "{i}" by standard simp fix A assume A: "A \ sets (M i)" then have "(\x. x i) -` A \ space (Pi\<^sub>M {i} M) = (\\<^sub>E i\{i}. A)" using sets.sets_into_space by (auto simp: space_PiM) @@ -957,7 +957,7 @@ assumes f: "f \ borel_measurable (M i)" shows "integral\<^sup>N (Pi\<^sub>M {i} M) (\x. f (x i)) = integral\<^sup>N (M i) f" proof - - interpret I: finite_product_sigma_finite M "{i}" by default simp + interpret I: finite_product_sigma_finite M "{i}" by standard simp from f show ?thesis apply (subst distr_singleton[symmetric]) apply (subst nn_integral_distr[OF measurable_component_singleton]) @@ -970,8 +970,8 @@ and f: "f \ borel_measurable (Pi\<^sub>M (insert i I) M)" shows "integral\<^sup>N (Pi\<^sub>M (insert i I) M) f = (\\<^sup>+ x. (\\<^sup>+ y. f (x(i := y)) \(M i)) \(Pi\<^sub>M I M))" proof - - interpret I: finite_product_sigma_finite M I by default auto - interpret i: finite_product_sigma_finite M "{i}" by default auto + interpret I: finite_product_sigma_finite M I by standard auto + interpret i: finite_product_sigma_finite M "{i}" by standard auto have IJ: "I \ {i} = {}" and insert: "I \ {i} = insert i I" using f by auto show ?thesis @@ -1008,7 +1008,7 @@ using assms proof induct case (insert i I) note `finite I`[intro, simp] - interpret I: finite_product_sigma_finite M I by default auto + interpret I: finite_product_sigma_finite M I by standard auto have *: "\x y. (\j\I. f j (if j = i then y else x j)) = (\j\I. f j (x j))" using insert by (auto intro!: setprod.cong) have prod: "\J. J \ insert i I \ (\x. (\i\J. f i (x i))) \ borel_measurable (Pi\<^sub>M J M)" @@ -1044,7 +1044,7 @@ lemma (in product_sigma_finite) distr_component: "distr (M i) (Pi\<^sub>M {i} M) (\x. \i\{i}. x) = Pi\<^sub>M {i} M" (is "?D = ?P") proof (intro measure_eqI[symmetric]) - interpret I: finite_product_sigma_finite M "{i}" by default simp + interpret I: finite_product_sigma_finite M "{i}" by standard simp have eq: "\x. x \ extensional {i} \ (\j\{i}. x i) = x" by (auto simp: extensional_def restrict_def) @@ -1068,8 +1068,8 @@ and emeasure_fold_measurable: "(\x. emeasure (Pi\<^sub>M J M) ((\y. merge I J (x, y)) -` A \ space (Pi\<^sub>M J M))) \ borel_measurable (Pi\<^sub>M I M)" (is ?B) proof - - interpret I: finite_product_sigma_finite M I by default fact - interpret J: finite_product_sigma_finite M J by default fact + interpret I: finite_product_sigma_finite M I by standard fact + interpret J: finite_product_sigma_finite M J by standard fact interpret IJ: pair_sigma_finite "Pi\<^sub>M I M" "Pi\<^sub>M J M" .. have merge: "merge I J -` A \ space (Pi\<^sub>M I M \\<^sub>M Pi\<^sub>M J M) \ sets (Pi\<^sub>M I M \\<^sub>M Pi\<^sub>M J M)" by (intro measurable_sets[OF _ A] measurable_merge assms) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Giry_Monad.thy --- a/src/HOL/Probability/Giry_Monad.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Giry_Monad.thy Fri Sep 18 16:42:19 2015 +0100 @@ -25,7 +25,7 @@ proof show "emeasure M (space M) \ \" using * by auto qed - show "subprob_space M" by default fact+ + show "subprob_space M" by standard fact+ qed lemma prob_space_imp_subprob_space: diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Infinite_Product_Measure.thy --- a/src/HOL/Probability/Infinite_Product_Measure.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Infinite_Product_Measure.thy Fri Sep 18 16:42:19 2015 +0100 @@ -50,8 +50,8 @@ have "finite (K - J)" using K by auto - interpret J: finite_product_prob_space M J by default fact+ - interpret KmJ: finite_product_prob_space M "K - J" by default fact+ + interpret J: finite_product_prob_space M J by standard fact+ + interpret KmJ: finite_product_prob_space M "K - J" by standard fact+ have "\G Z = emeasure (Pi\<^sub>M (J \ (K - J)) M) (emb (J \ (K - J)) K X)" using K J by simp @@ -84,7 +84,7 @@ proof (rule G.caratheodory_empty_continuous[OF positive_mu_G additive_mu_G]) fix A assume "A \ ?G" with generatorE guess J X . note JX = this - interpret JK: finite_product_prob_space M J by default fact+ + interpret JK: finite_product_prob_space M J by standard fact+ from JX show "\G A \ \" by simp next fix A assume A: "range A \ ?G" "decseq A" "(\i. A i) = {}" @@ -113,7 +113,7 @@ have J_mono: "\n m. n \ m \ J n \ J m" unfolding J_def by force - interpret J: finite_product_prob_space M "J i" for i by default fact+ + interpret J: finite_product_prob_space M "J i" for i by standard fact+ have a_le_1: "?a \ 1" using mu_G_spec[of "J 0" "A 0" "X 0"] J A_eq @@ -124,7 +124,7 @@ { fix Z k assume Z: "range Z \ ?G" "decseq Z" "\n. ?a / 2^k \ \G (Z n)" then have Z_sets: "\n. Z n \ ?G" by auto fix J' assume J': "J' \ {}" "finite J'" "J' \ I" - interpret J': finite_product_prob_space M J' by default fact+ + interpret J': finite_product_prob_space M J' by standard fact+ let ?q = "\n y. \G (?M J' (Z n) y)" let ?Q = "\n. ?q n -` {?a / 2^(k+1) ..} \ space (Pi\<^sub>M J' M)" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Information.thy --- a/src/HOL/Probability/Information.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Information.thy Fri Sep 18 16:42:19 2015 +0100 @@ -311,7 +311,7 @@ shows "0 \ KL_divergence b (density M f) (density M g)" proof - interpret Mf: prob_space "density M f" by fact - interpret Mf: information_space "density M f" b by default fact + interpret Mf: information_space "density M f" b by standard fact have eq: "density (density M f) (\x. g x / f x) = density M g" (is "?DD = _") using f g ac by (subst density_density_divide) simp_all @@ -443,8 +443,8 @@ by (rule prob_space_distr) fact interpret Y: prob_space "distr M T Y" by (rule prob_space_distr) fact - interpret XY: pair_prob_space "distr M S X" "distr M T Y" by default - interpret P: information_space P b unfolding P_def by default (rule b_gt_1) + interpret XY: pair_prob_space "distr M S X" "distr M T Y" by standard + interpret P: information_space P b unfolding P_def by standard (rule b_gt_1) interpret Q: prob_space Q unfolding Q_def by (rule prob_space_distr) simp @@ -770,7 +770,7 @@ interpret X: prob_space "distr M S X" using D(1) by (rule prob_space_distr) - have sf: "sigma_finite_measure (distr M S X)" by default + have sf: "sigma_finite_measure (distr M S X)" by standard show ?thesis using D apply (subst eq_commute) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Measure_Space.thy --- a/src/HOL/Probability/Measure_Space.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Measure_Space.thy Fri Sep 18 16:42:19 2015 +0100 @@ -2078,7 +2078,7 @@ "less_measure M N \ (M \ N \ \ N \ M)" instance -proof (standard, goals) +proof (standard, goal_cases) case 1 then show ?case unfolding less_measure_def .. next diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Nonnegative_Lebesgue_Integration.thy --- a/src/HOL/Probability/Nonnegative_Lebesgue_Integration.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Nonnegative_Lebesgue_Integration.thy Fri Sep 18 16:42:19 2015 +0100 @@ -2454,7 +2454,7 @@ lemma (in finite_measure) finite_measure_restricted: "S \ sets M \ finite_measure (density M (indicator S))" - by default (simp add: emeasure_restricted) + by standard (simp add: emeasure_restricted) lemma emeasure_density_const: "A \ sets M \ 0 \ c \ emeasure (density M (\_. c)) A = c * emeasure M A" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Probability_Mass_Function.thy --- a/src/HOL/Probability/Probability_Mass_Function.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Probability_Mass_Function.thy Fri Sep 18 16:42:19 2015 +0100 @@ -653,7 +653,7 @@ measure (density (count_space UNIV) (ereal \ f)) {x} \ 0" by (simp add: AE_density nonneg measure_def emeasure_density max_def) show "prob_space (density (count_space UNIV) (ereal \ f))" - by default (simp add: emeasure_density prob) + by standard (simp add: emeasure_density prob) qed simp lemma pmf_embed_pmf: "pmf embed_pmf x = f x" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Probability_Measure.thy --- a/src/HOL/Probability/Probability_Measure.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Probability_Measure.thy Fri Sep 18 16:42:19 2015 +0100 @@ -20,7 +20,7 @@ proof show "emeasure M (space M) \ \" using * by simp qed - show "prob_space M" by default fact + show "prob_space M" by standard fact qed lemma prob_space_imp_sigma_finite: "prob_space M \ sigma_finite_measure M" @@ -278,7 +278,7 @@ in go ((x, 0) :: pattern) (bound_dummyT $ tx :: elem) t end - | go pattern elem (Const (@{const_syntax case_prod}, _) $ t) = + | go pattern elem (Const (@{const_syntax uncurry}, _) $ t) = go ((Syntax.const @{syntax_const "_pattern"}, 2) :: pattern) (Syntax.const @{const_syntax Pair} :: elem) @@ -626,7 +626,7 @@ proof safe interpret S: sigma_finite_measure S by fact interpret T: sigma_finite_measure T by fact - interpret ST: pair_sigma_finite S T by default + interpret ST: pair_sigma_finite S T .. from ST.sigma_finite_up_in_pair_measure_generator guess F :: "nat \ ('b \ 'c) set" .. note F = this let ?E = "{a \ b |a b. a \ sets S \ b \ sets T}" @@ -666,8 +666,8 @@ proof - interpret S: sigma_finite_measure S by fact interpret T: sigma_finite_measure T by fact - interpret ST: pair_sigma_finite S T by default - interpret TS: pair_sigma_finite T S by default + interpret ST: pair_sigma_finite S T .. + interpret TS: pair_sigma_finite T S .. note Pxy[measurable] show ?thesis @@ -715,7 +715,7 @@ proof safe interpret S: sigma_finite_measure S by fact interpret T: sigma_finite_measure T by fact - interpret ST: pair_sigma_finite S T by default + interpret ST: pair_sigma_finite S T .. note Pxy[measurable] show X: "X \ measurable M S" by simp @@ -792,7 +792,7 @@ proof safe interpret S: sigma_finite_measure S by fact interpret T: sigma_finite_measure T by fact - interpret ST: pair_sigma_finite S T by default + interpret ST: pair_sigma_finite S T .. interpret X: prob_space "density S Px" unfolding distributed_distr_eq_density[OF X, symmetric] @@ -1133,7 +1133,7 @@ qed lemma prob_space_uniform_count_measure: "finite A \ A \ {} \ prob_space (uniform_count_measure A)" - by default (auto simp: emeasure_uniform_count_measure space_uniform_count_measure one_ereal_def) + by standard (auto simp: emeasure_uniform_count_measure space_uniform_count_measure one_ereal_def) lemma (in prob_space) measure_uniform_measure_eq_cond_prob: assumes [measurable]: "Measurable.pred M P" "Measurable.pred M Q" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Radon_Nikodym.thy --- a/src/HOL/Probability/Radon_Nikodym.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Radon_Nikodym.thy Fri Sep 18 16:42:19 2015 +0100 @@ -993,7 +993,7 @@ note A_in_sets = this show "sigma_finite_measure ?N" - proof (default, intro exI conjI ballI) + proof (standard, intro exI conjI ballI) show "countable (range (\(i, j). A i \ Q j))" by auto show "range (\(i, j). A i \ Q j) \ sets (density M f)" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Sigma_Algebra.thy --- a/src/HOL/Probability/Sigma_Algebra.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Sigma_Algebra.thy Fri Sep 18 16:42:19 2015 +0100 @@ -1333,7 +1333,7 @@ assumes "N \ M" shows "dynkin \ N \ M" proof - - have "dynkin_system \ M" by default + have "dynkin_system \ M" .. then have "dynkin_system \ M" using assms unfolding dynkin_system_def dynkin_system_axioms_def subset_class_def by simp with `N \ M` show ?thesis by (auto simp add: dynkin_def) @@ -1432,7 +1432,7 @@ using closed by (rule sigma_algebra_sigma_sets) from compl[OF _ empty] closed have space: "P \" by simp interpret dynkin_system \ ?D - by default (auto dest: sets_into_space intro!: space compl union) + by standard (auto dest: sets_into_space intro!: space compl union) have "sigma_sets \ G = ?D" by (rule dynkin_lemma) (auto simp: basic `Int_stable G`) with A show ?thesis by auto @@ -1967,7 +1967,7 @@ assume "\ (\i\I. \ i = 0)" moreover have "measure_space (space M) (sets M) \'" - using ms unfolding measure_space_def by auto default + using ms unfolding measure_space_def by auto standard with ms eq have "\\'. P \'" unfolding P_def by (intro exI[of _ \']) (auto simp add: M space_extend_measure sets_extend_measure) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/Stream_Space.thy --- a/src/HOL/Probability/Stream_Space.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/Stream_Space.thy Fri Sep 18 16:42:19 2015 +0100 @@ -160,7 +160,7 @@ lemma (in prob_space) prob_space_stream_space: "prob_space (stream_space M)" proof - - interpret product_prob_space "\_. M" UNIV by default + interpret product_prob_space "\_. M" UNIV .. show ?thesis by (subst stream_space_eq_distr) (auto intro!: P.prob_space_distr) qed @@ -169,10 +169,8 @@ assumes [measurable]: "f \ borel_measurable (stream_space M)" shows "(\\<^sup>+X. f X \stream_space M) = (\\<^sup>+x. (\\<^sup>+X. f (x ## X) \stream_space M) \M)" proof - - interpret S: sequence_space M - by default - interpret P: pair_sigma_finite M "\\<^sub>M i::nat\UNIV. M" - by default + interpret S: sequence_space M .. + interpret P: pair_sigma_finite M "\\<^sub>M i::nat\UNIV. M" .. have "(\\<^sup>+X. f X \stream_space M) = (\\<^sup>+X. f (to_stream X) \S.S)" by (subst stream_space_eq_distr) (simp add: nn_integral_distr) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/ex/Dining_Cryptographers.thy --- a/src/HOL/Probability/ex/Dining_Cryptographers.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/ex/Dining_Cryptographers.thy Fri Sep 18 16:42:19 2015 +0100 @@ -399,7 +399,7 @@ (insert n_gt_3, auto simp: dc_crypto intro: exI[of _ "replicate n True"]) sublocale dining_cryptographers_space \ information_space "uniform_count_measure dc_crypto" 2 - by default auto + by standard auto notation (in dining_cryptographers_space) mutual_information_Pow ("\'( _ ; _ ')") diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Probability/ex/Koepf_Duermuth_Countermeasure.thy --- a/src/HOL/Probability/ex/Koepf_Duermuth_Countermeasure.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Probability/ex/Koepf_Duermuth_Countermeasure.thy Fri Sep 18 16:42:19 2015 +0100 @@ -125,10 +125,10 @@ by (auto intro!: setsum_nonneg) sublocale finite_information \ prob_space "point_measure \ p" - by default (simp add: one_ereal_def emeasure_point_measure_finite) + by standard (simp add: one_ereal_def emeasure_point_measure_finite) sublocale finite_information \ information_space "point_measure \ p" b - by default simp + by standard simp lemma (in finite_information) \'_eq: "A \ \ \ prob A = setsum p A" by (auto simp: measure_point_measure) @@ -150,7 +150,7 @@ end sublocale koepf_duermuth \ finite_information msgs P b -proof default +proof show "finite msgs" unfolding msgs_def using finite_lists_length_eq[OF M.finite_space, of n] by auto diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Product_Type.thy --- a/src/HOL/Product_Type.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Product_Type.thy Fri Sep 18 16:42:19 2015 +0100 @@ -240,7 +240,7 @@ lemma prod_cases: "(\a b. P (Pair a b)) \ P p" by (cases p) (auto simp add: prod_def Pair_def Pair_Rep_def) -free_constructors case_prod for Pair fst snd +free_constructors uncurry for Pair fst snd proof - fix P :: bool and p :: "'a \ 'b" show "(\x1 x2. p = Pair x1 x2 \ P) \ P" @@ -300,90 +300,16 @@ "_patterns" :: "[pttrn, patterns] => patterns" ("_,/ _") translations - "(x, y)" == "CONST Pair x y" - "_pattern x y" => "CONST Pair x y" - "_patterns x y" => "CONST Pair x y" - "_tuple x (_tuple_args y z)" == "_tuple x (_tuple_arg (_tuple y z))" - "%(x, y, zs). b" == "CONST case_prod (%x (y, zs). b)" - "%(x, y). b" == "CONST case_prod (%x y. b)" - "_abs (CONST Pair x y) t" => "%(x, y). t" - - - - - - -- \The last rule accommodates tuples in `case C ... (x,y) ... => ...' - The (x,y) is parsed as `Pair x y' because it is logic, not pttrn\ - -(*reconstruct pattern from (nested) splits, avoiding eta-contraction of body; - works best with enclosing "let", if "let" does not avoid eta-contraction*) -print_translation \ - let - fun split_tr' [Abs (x, T, t as (Abs abs))] = - (* split (%x y. t) => %(x,y) t *) - let - val (y, t') = Syntax_Trans.atomic_abs_tr' abs; - val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, T, t'); - in - Syntax.const @{syntax_const "_abs"} $ - (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t'' - end - | split_tr' [Abs (x, T, (s as Const (@{const_syntax case_prod}, _) $ t))] = - (* split (%x. (split (%y z. t))) => %(x,y,z). t *) - let - val Const (@{syntax_const "_abs"}, _) $ - (Const (@{syntax_const "_pattern"}, _) $ y $ z) $ t' = split_tr' [t]; - val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, T, t'); - in - Syntax.const @{syntax_const "_abs"} $ - (Syntax.const @{syntax_const "_pattern"} $ x' $ - (Syntax.const @{syntax_const "_patterns"} $ y $ z)) $ t'' - end - | split_tr' [Const (@{const_syntax case_prod}, _) $ t] = - (* split (split (%x y z. t)) => %((x, y), z). t *) - split_tr' [(split_tr' [t])] (* inner split_tr' creates next pattern *) - | split_tr' [Const (@{syntax_const "_abs"}, _) $ x_y $ Abs abs] = - (* split (%pttrn z. t) => %(pttrn,z). t *) - let val (z, t) = Syntax_Trans.atomic_abs_tr' abs in - Syntax.const @{syntax_const "_abs"} $ - (Syntax.const @{syntax_const "_pattern"} $ x_y $ z) $ t - end - | split_tr' _ = raise Match; - in [(@{const_syntax case_prod}, K split_tr')] end -\ - -(* print "split f" as "\(x,y). f x y" and "split (\x. f x)" as "\(x,y). f x y" *) -typed_print_translation \ - let - fun split_guess_names_tr' T [Abs (x, _, Abs _)] = raise Match - | split_guess_names_tr' T [Abs (x, xT, t)] = - (case (head_of t) of - Const (@{const_syntax case_prod}, _) => raise Match - | _ => - let - val (_ :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match; - val (y, t') = Syntax_Trans.atomic_abs_tr' ("y", yT, incr_boundvars 1 t $ Bound 0); - val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, xT, t'); - in - Syntax.const @{syntax_const "_abs"} $ - (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t'' - end) - | split_guess_names_tr' T [t] = - (case head_of t of - Const (@{const_syntax case_prod}, _) => raise Match - | _ => - let - val (xT :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match; - val (y, t') = - Syntax_Trans.atomic_abs_tr' ("y", yT, incr_boundvars 2 t $ Bound 1 $ Bound 0); - val (x', t'') = Syntax_Trans.atomic_abs_tr' ("x", xT, t'); - in - Syntax.const @{syntax_const "_abs"} $ - (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t'' - end) - | split_guess_names_tr' _ _ = raise Match; - in [(@{const_syntax case_prod}, K split_guess_names_tr')] end -\ + "(x, y)" \ "CONST Pair x y" + "_pattern x y" \ "CONST Pair x y" + "_patterns x y" \ "CONST Pair x y" + "_tuple x (_tuple_args y z)" \ "_tuple x (_tuple_arg (_tuple y z))" + "\(x, y, zs). b" \ "CONST uncurry (\x (y, zs). b)" + "\(x, y). b" \ "CONST uncurry (\x y. b)" + "_abs (CONST Pair x y) t" \ "\(x, y). t" + -- \This rule accommodates tuples in @{text "case C \ (x, y) \ \ \"}: + The @{text "(x, y)"} is parsed as @{text "Pair x y"} because it is @{text logic}, + not @{text pttrn}.\ subsubsection \Code generator setup\ @@ -420,7 +346,7 @@ constant fst \ (Haskell) "fst" | constant snd \ (Haskell) "snd" -lemma case_prod_unfold [nitpick_unfold]: "case_prod = (%c p. c (fst p) (snd p))" +lemma case_prod_unfold [nitpick_unfold]: "uncurry = (%c p. c (fst p) (snd p))" by (simp add: fun_eq_iff split: prod.split) lemma fst_eqD: "fst (x, y) = a ==> x = a" @@ -437,29 +363,29 @@ lemma prod_eqI [intro?]: "fst p = fst q \ snd p = snd q \ p = q" by (simp add: prod_eq_iff) -lemma split_conv [simp, code]: "case_prod f (a, b) = f a b" +lemma split_conv [simp, code]: "(case (a, b) of (c, d) \ f c d) = f a b" by (fact prod.case) -lemma splitI: "f a b \ case_prod f (a, b)" +lemma splitI: "f a b \ case (a, b) of (c, d) \ f c d" by (rule split_conv [THEN iffD2]) -lemma splitD: "case_prod f (a, b) \ f a b" +lemma splitD: "(case (a, b) of (c, d) \ f c d) \ f a b" by (rule split_conv [THEN iffD1]) -lemma split_Pair [simp]: "(\(x, y). (x, y)) = id" +lemma split_Pair [simp]: "uncurry Pair = id" by (simp add: fun_eq_iff split: prod.split) lemma split_eta: "(\(x, y). f (x, y)) = f" -- \Subsumes the old @{text split_Pair} when @{term f} is the identity function.\ by (simp add: fun_eq_iff split: prod.split) -lemma split_comp: "case_prod (f \ g) x = f (g (fst x)) (snd x)" +lemma split_comp: "(case x of (a, b) \ (f \ g) a b) = f (g (fst x)) (snd x)" by (cases x) simp -lemma split_twice: "case_prod f (case_prod g p) = case_prod (\x y. case_prod f (g x y)) p" +lemma split_twice: "uncurry f (uncurry g p) = uncurry (\x y. uncurry f (g x y)) p" by (fact prod.case_distrib) -lemma The_split: "The (case_prod P) = (THE xy. P (fst xy) (snd xy))" +lemma The_split: "The (uncurry P) = (THE xy. P (fst xy) (snd xy))" by (simp add: case_prod_unfold) lemmas split_weak_cong = prod.case_cong_weak @@ -479,7 +405,7 @@ from \PROP P (fst x, snd x)\ show "PROP P x" by simp qed -lemma case_prod_distrib: "f (case x of (x, y) \ g x y) = (case x of (x, y) \ f (g x y))" +lemma uncurry_distrib: "f (case x of (x, y) \ g x y) = (case x of (x, y) \ f (g x y))" by (cases x) simp text \ @@ -551,7 +477,7 @@ | no_args k i (Bound m) = m < k orelse m > k + i | no_args _ _ _ = true; fun split_pat tp i (Abs (_, _, t)) = if tp 0 i t then SOME (i, t) else NONE - | split_pat tp i (Const (@{const_name case_prod}, _) $ Abs (_, _, t)) = split_pat tp (i + 1) t + | split_pat tp i (Const (@{const_name uncurry}, _) $ Abs (_, _, t)) = split_pat tp (i + 1) t | split_pat tp i _ = NONE; fun metaeq ctxt lhs rhs = mk_meta_eq (Goal.prove ctxt [] [] (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs))) @@ -569,12 +495,12 @@ else (subst arg k i t $ subst arg k i u) | subst arg k i t = t; in - fun beta_proc ctxt (s as Const (@{const_name case_prod}, _) $ Abs (_, _, t) $ arg) = + fun beta_proc ctxt (s as Const (@{const_name uncurry}, _) $ Abs (_, _, t) $ arg) = (case split_pat beta_term_pat 1 t of SOME (i, f) => SOME (metaeq ctxt s (subst arg 0 i f)) | NONE => NONE) | beta_proc _ _ = NONE; - fun eta_proc ctxt (s as Const (@{const_name case_prod}, _) $ Abs (_, _, t)) = + fun eta_proc ctxt (s as Const (@{const_name uncurry}, _) $ Abs (_, _, t)) = (case split_pat eta_term_pat 1 t of SOME (_, ft) => SOME (metaeq ctxt s (let val f $ _ = ft in f end)) | NONE => NONE) @@ -604,31 +530,31 @@ lemmas split_split_asm [no_atp] = prod.split_asm text \ - \medskip @{const case_prod} used as a logical connective or set former. + \medskip @{const uncurry} used as a logical connective or set former. \medskip These rules are for use with @{text blast}; could instead call @{text simp} using @{thm [source] prod.split} as rewrite.\ -lemma splitI2: "!!p. [| !!a b. p = (a, b) ==> c a b |] ==> case_prod c p" +lemma splitI2: "!!p. [| !!a b. p = (a, b) ==> c a b |] ==> case p of (a, b) \ c a b" apply (simp only: split_tupled_all) apply (simp (no_asm_simp)) done -lemma splitI2': "!!p. [| !!a b. (a, b) = p ==> c a b x |] ==> case_prod c p x" +lemma splitI2': "!!p. [| !!a b. (a, b) = p ==> c a b x |] ==> (case p of (a, b) \ c a b) x" apply (simp only: split_tupled_all) apply (simp (no_asm_simp)) done -lemma splitE: "case_prod c p ==> (!!x y. p = (x, y) ==> c x y ==> Q) ==> Q" +lemma splitE: "(case p of (a, b) \ c a b) ==> (!!x y. p = (x, y) ==> c x y ==> Q) ==> Q" by (induct p) auto -lemma splitE': "case_prod c p z ==> (!!x y. p = (x, y) ==> c x y z ==> Q) ==> Q" +lemma splitE': "(case p of (a, b) \ c a b) z ==> (!!x y. p = (x, y) ==> c x y z ==> Q) ==> Q" by (induct p) auto lemma splitE2: - "[| Q (case_prod P z); !!x y. [|z = (x, y); Q (P x y)|] ==> R |] ==> R" + "[| Q (case z of (a, b) \ P a b); !!x y. [|z = (x, y); Q (P x y)|] ==> R |] ==> R" proof - - assume q: "Q (case_prod P z)" + assume q: "Q (uncurry P z)" assume r: "!!x y. [|z = (x, y); Q (P x y)|] ==> R" show R apply (rule r surjective_pairing)+ @@ -636,17 +562,20 @@ done qed -lemma splitD': "case_prod R (a,b) c ==> R a b c" - by simp - -lemma mem_splitI: "z: c a b ==> z: case_prod c (a, b)" +lemma splitD': + "(case (a, b) of (c, d) \ R c d) c \ R a b c" by simp -lemma mem_splitI2: "!!p. [| !!a b. p = (a, b) ==> z: c a b |] ==> z: case_prod c p" -by (simp only: split_tupled_all, simp) +lemma mem_splitI: + "z \ c a b \ z \ (case (a, b) of (d, e) \ c d e)" + by simp + +lemma mem_splitI2: + "\p. (\a b. p = (a, b) \ z \ c a b) \ z \ (case p of (a, b) \ c a b)" + by (simp only: split_tupled_all) simp lemma mem_splitE: - assumes "z \ case_prod c p" + assumes "z \ uncurry c p" obtains x y where "p = (x, y)" and "z \ c x y" using assms by (rule splitE2) @@ -655,7 +584,7 @@ ML \ local (* filtering with exists_p_split is an essential optimization *) - fun exists_p_split (Const (@{const_name case_prod},_) $ _ $ (Const (@{const_name Pair},_)$_$_)) = true + fun exists_p_split (Const (@{const_name uncurry},_) $ _ $ (Const (@{const_name Pair},_)$_$_)) = true | exists_p_split (t $ u) = exists_p_split t orelse exists_p_split u | exists_p_split (Abs (_, _, t)) = exists_p_split t | exists_p_split _ = false; @@ -674,10 +603,10 @@ lemma split_eta_SetCompr [simp, no_atp]: "(%u. EX x y. u = (x, y) & P (x, y)) = P" by (rule ext) fast -lemma split_eta_SetCompr2 [simp, no_atp]: "(%u. EX x y. u = (x, y) & P x y) = case_prod P" +lemma split_eta_SetCompr2 [simp, no_atp]: "(%u. EX x y. u = (x, y) & P x y) = uncurry P" by (rule ext) fast -lemma split_part [simp]: "(%(a,b). P & Q a b) = (%ab. P & case_prod Q ab)" +lemma split_part [simp]: "(%(a,b). P & Q a b) = (%ab. P & uncurry Q ab)" -- \Allows simplifications of nested splits in case of independent predicates.\ by (rule ext) blast @@ -687,7 +616,7 @@ *) lemma split_comp_eq: fixes f :: "'a => 'b => 'c" and g :: "'d => 'a" - shows "(%u. f (g (fst u)) (snd u)) = (case_prod (%x. f (g x)))" + shows "(%u. f (g (fst u)) (snd u)) = (uncurry (%x. f (g x)))" by (rule ext) auto lemma pair_imageI [intro]: "(a, b) : A ==> f a b : (%(a, b). f a b) ` A" @@ -717,22 +646,22 @@ lemmas case_prodI = prod.case [THEN iffD2] -lemma case_prodI2: "!!p. [| !!a b. p = (a, b) ==> c a b |] ==> case_prod c p" +lemma case_prodI2: "!!p. [| !!a b. p = (a, b) ==> c a b |] ==> uncurry c p" by (fact splitI2) -lemma case_prodI2': "!!p. [| !!a b. (a, b) = p ==> c a b x |] ==> case_prod c p x" +lemma case_prodI2': "!!p. [| !!a b. (a, b) = p ==> c a b x |] ==> uncurry c p x" by (fact splitI2') -lemma case_prodE: "case_prod c p ==> (!!x y. p = (x, y) ==> c x y ==> Q) ==> Q" +lemma case_prodE: "uncurry c p ==> (!!x y. p = (x, y) ==> c x y ==> Q) ==> Q" by (fact splitE) -lemma case_prodE': "case_prod c p z ==> (!!x y. p = (x, y) ==> c x y z ==> Q) ==> Q" +lemma case_prodE': "uncurry c p z ==> (!!x y. p = (x, y) ==> c x y z ==> Q) ==> Q" by (fact splitE') declare case_prodI [intro!] lemma case_prod_beta: - "case_prod f p = f (fst p) (snd p)" + "uncurry f p = f (fst p) (snd p)" by (fact split_beta) lemma prod_cases3 [cases type]: @@ -776,7 +705,7 @@ by (cases x) blast definition internal_split :: "('a \ 'b \ 'c) \ 'a \ 'b \ 'c" where - "internal_split == case_prod" + "internal_split == uncurry" lemma internal_split_conv: "internal_split c (a, b) = c a b" by (simp only: internal_split_def split_conv) @@ -803,10 +732,10 @@ lemma curryE: "curry f a b \ (f (a, b) \ Q) \ Q" by (simp add: curry_def) -lemma curry_split [simp]: "curry (case_prod f) = f" +lemma curry_split [simp]: "curry (uncurry f) = f" by (simp add: curry_def case_prod_unfold) -lemma split_curry [simp]: "case_prod (curry f) = f" +lemma split_curry [simp]: "uncurry (curry f) = f" by (simp add: curry_def case_prod_unfold) lemma curry_K: "curry (\x. c) = (\x y. c)" @@ -819,12 +748,12 @@ notation fcomp (infixl "\>" 60) definition scomp :: "('a \ 'b \ 'c) \ ('b \ 'c \ 'd) \ 'a \ 'd" (infixl "\\" 60) where - "f \\ g = (\x. case_prod g (f x))" + "f \\ g = (\x. uncurry g (f x))" lemma scomp_unfold: "scomp = (\f g x. g (fst (f x)) (snd (f x)))" by (simp add: fun_eq_iff scomp_def case_prod_unfold) -lemma scomp_apply [simp]: "(f \\ g) x = case_prod g (f x)" +lemma scomp_apply [simp]: "(f \\ g) x = uncurry g (f x)" by (simp add: scomp_unfold case_prod_unfold) lemma Pair_scomp: "Pair x \\ f = f x" @@ -1118,44 +1047,52 @@ by (blast elim: equalityE) lemma SetCompr_Sigma_eq: - "Collect (case_prod (%x y. P x & Q x y)) = (SIGMA x:Collect P. Collect (Q x))" + "{(x, y). P x \ Q x y} = (SIGMA x:Collect P. Collect (Q x))" by blast -lemma Collect_split [simp]: "{(a,b). P a & Q b} = Collect P <*> Collect Q" +lemma Collect_split [simp]: + "{(a, b). P a \ Q b} = Collect P \ Collect Q " by (fact SetCompr_Sigma_eq) lemma UN_Times_distrib: - "(UN (a,b):(A <*> B). E a <*> F b) = (UNION A E) <*> (UNION B F)" + "(\(a, b)\A \ B. E a \ F b) = UNION A E \ UNION B F" -- \Suggested by Pierre Chartier\ by blast lemma split_paired_Ball_Sigma [simp, no_atp]: - "(ALL z: Sigma A B. P z) = (ALL x:A. ALL y: B x. P(x,y))" + "(\z\Sigma A B. P z) \ (\x\A. \y\B x. P (x, y))" by blast lemma split_paired_Bex_Sigma [simp, no_atp]: - "(EX z: Sigma A B. P z) = (EX x:A. EX y: B x. P(x,y))" + "(\z\Sigma A B. P z) \ (\x\A. \y\B x. P (x, y))" + by blast + +lemma Sigma_Un_distrib1: + "Sigma (I \ J) C = Sigma I C \ Sigma J C" by blast -lemma Sigma_Un_distrib1: "(SIGMA i:I Un J. C(i)) = (SIGMA i:I. C(i)) Un (SIGMA j:J. C(j))" +lemma Sigma_Un_distrib2: + "(SIGMA i:I. A i \ B i) = Sigma I A \ Sigma I B" by blast -lemma Sigma_Un_distrib2: "(SIGMA i:I. A(i) Un B(i)) = (SIGMA i:I. A(i)) Un (SIGMA i:I. B(i))" +lemma Sigma_Int_distrib1: + "Sigma (I \ J) C = Sigma I C \ Sigma J C" by blast -lemma Sigma_Int_distrib1: "(SIGMA i:I Int J. C(i)) = (SIGMA i:I. C(i)) Int (SIGMA j:J. C(j))" - by blast - -lemma Sigma_Int_distrib2: "(SIGMA i:I. A(i) Int B(i)) = (SIGMA i:I. A(i)) Int (SIGMA i:I. B(i))" +lemma Sigma_Int_distrib2: + "(SIGMA i:I. A i \ B i) = Sigma I A \ Sigma I B" by blast -lemma Sigma_Diff_distrib1: "(SIGMA i:I - J. C(i)) = (SIGMA i:I. C(i)) - (SIGMA j:J. C(j))" +lemma Sigma_Diff_distrib1: + "Sigma (I - J) C = Sigma I C - Sigma J C" by blast -lemma Sigma_Diff_distrib2: "(SIGMA i:I. A(i) - B(i)) = (SIGMA i:I. A(i)) - (SIGMA i:I. B(i))" +lemma Sigma_Diff_distrib2: + "(SIGMA i:I. A i - B i) = Sigma I A - Sigma I B" by blast -lemma Sigma_Union: "Sigma (Union X) B = (UN A:X. Sigma A B)" +lemma Sigma_Union: + "Sigma (\X) B = (\A\X. Sigma A B)" by blast text \ @@ -1163,25 +1100,32 @@ matching, especially when the rules are re-oriented. \ -lemma Times_Un_distrib1: "(A Un B) <*> C = (A <*> C) Un (B <*> C)" +lemma Times_Un_distrib1: + "(A \ B) \ C = A \ C \ B \ C " by (fact Sigma_Un_distrib1) -lemma Times_Int_distrib1: "(A Int B) <*> C = (A <*> C) Int (B <*> C)" +lemma Times_Int_distrib1: + "(A \ B) \ C = A \ C \ B \ C " by (fact Sigma_Int_distrib1) -lemma Times_Diff_distrib1: "(A - B) <*> C = (A <*> C) - (B <*> C)" +lemma Times_Diff_distrib1: + "(A - B) \ C = A \ C - B \ C " by (fact Sigma_Diff_distrib1) -lemma Times_empty[simp]: "A \ B = {} \ A = {} \ B = {}" +lemma Times_empty [simp]: + "A \ B = {} \ A = {} \ B = {}" by auto -lemma times_eq_iff: "A \ B = C \ D \ A = C \ B = D \ ((A = {} \ B = {}) \ (C = {} \ D = {}))" +lemma times_eq_iff: + "A \ B = C \ D \ A = C \ B = D \ (A = {} \ B = {}) \ (C = {} \ D = {})" by auto -lemma fst_image_times[simp]: "fst ` (A \ B) = (if B = {} then {} else A)" +lemma fst_image_times [simp]: + "fst ` (A \ B) = (if B = {} then {} else A)" by force -lemma snd_image_times[simp]: "snd ` (A \ B) = (if A = {} then {} else B)" +lemma snd_image_times [simp]: + "snd ` (A \ B) = (if A = {} then {} else B)" by force lemma vimage_fst: @@ -1195,15 +1139,18 @@ lemma insert_times_insert[simp]: "insert a A \ insert b B = insert (a,b) (A \ insert b B \ insert a A \ B)" -by blast + by blast -lemma vimage_Times: "f -` (A \ B) = ((fst \ f) -` A) \ ((snd \ f) -` B)" - apply auto - apply (case_tac "f x") - apply auto - done +lemma vimage_Times: + "f -` (A \ B) = (fst \ f) -` A \ (snd \ f) -` B" +proof (rule set_eqI) + fix x + show "x \ f -` (A \ B) \ x \ (fst \ f) -` A \ (snd \ f) -` B" + by (cases "f x") (auto split: prod.split) +qed -lemma times_Int_times: "A \ B \ C \ D = (A \ C) \ (B \ D)" +lemma times_Int_times: + "A \ B \ C \ D = (A \ C) \ (B \ D)" by auto lemma product_swap: @@ -1234,15 +1181,18 @@ lemma inj_apsnd [simp]: "inj (apsnd f) \ inj f" using inj_on_apsnd[of f UNIV] by simp -definition product :: "'a set \ 'b set \ ('a \ 'b) set" where +context +begin + +qualified definition product :: "'a set \ 'b set \ ('a \ 'b) set" where [code_abbrev]: "product A B = A \ B" -hide_const (open) product - lemma member_product: "x \ Product_Type.product A B \ x \ A \ B" - by (simp add: product_def) + by (simp add: Product_Type.product_def) +end + text \The following @{const map_prod} lemmas are due to Joachim Breitner:\ lemma map_prod_inj_on: @@ -1311,8 +1261,10 @@ setup \ Code_Preproc.map_pre (fn ctxt => ctxt addsimprocs - [Raw_Simplifier.make_simproc {name = "set comprehension", lhss = [@{cpat "Collect ?P"}], - proc = K Set_Comprehension_Pointfree.code_simproc, identifier = []}]) + [Simplifier.make_simproc @{context} "set comprehension" + {lhss = [@{term "Collect P"}], + proc = K Set_Comprehension_Pointfree.code_simproc, + identifier = []}]) \ @@ -1355,8 +1307,11 @@ subsection \Legacy theorem bindings and duplicates\ +abbreviation (input) case_prod :: "('a \ 'b \ 'c) \ 'a \ 'b \ 'c" where + "case_prod \ uncurry" + abbreviation (input) split :: "('a \ 'b \ 'c) \ 'a \ 'b \ 'c" where - "split \ case_prod" + "split \ uncurry" lemmas PairE = prod.exhaust lemmas Pair_eq = prod.inject diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Quickcheck_Examples/Quickcheck_Examples.thy --- a/src/HOL/Quickcheck_Examples/Quickcheck_Examples.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Quickcheck_Examples/Quickcheck_Examples.thy Fri Sep 18 16:42:19 2015 +0100 @@ -478,8 +478,8 @@ fixes R assumes "R x y --> R y x --> x = y" -interpretation equal : antisym "op =" by default simp -interpretation order_nat : antisym "op <= :: nat => _ => _" by default simp +interpretation equal : antisym "op =" by standard simp +interpretation order_nat : antisym "op <= :: nat => _ => _" by standard simp lemma (in antisym) "R x y --> R y z --> R x z" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Quickcheck_Exhaustive.thy --- a/src/HOL/Quickcheck_Exhaustive.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Quickcheck_Exhaustive.thy Fri Sep 18 16:42:19 2015 +0100 @@ -646,11 +646,6 @@ hide_fact (open) orelse_def no_notation orelse (infixr "orelse" 55) -hide_fact - exhaustive_int'_def - exhaustive_integer'_def - exhaustive_natural'_def - hide_const valtermify_absdummy valtermify_fun_upd valterm_emptyset valtermify_insert valtermify_pair valtermify_Inl valtermify_Inr termify_fun_upd term_emptyset termify_insert termify_pair setify diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Quotient_Examples/Lifting_Code_Dt_Test.thy --- a/src/HOL/Quotient_Examples/Lifting_Code_Dt_Test.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Quotient_Examples/Lifting_Code_Dt_Test.thy Fri Sep 18 16:42:19 2015 +0100 @@ -91,7 +91,7 @@ datatype ('a::finite, 'b::finite) F = F 'a | F2 'b -instance T :: (finite) finite by (default, transfer, auto) +instance T :: (finite) finite by standard (transfer, auto) lift_definition(code_dt) f17 :: "bool \ (bool T, 'b::finite) F" is "\b. F b" by auto diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Quotient_Examples/Quotient_Int.thy --- a/src/HOL/Quotient_Examples/Quotient_Int.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Quotient_Examples/Quotient_Int.thy Fri Sep 18 16:42:19 2015 +0100 @@ -188,8 +188,7 @@ "(sup :: int \ int \ int) = max" instance - by default - (auto simp add: inf_int_def sup_int_def max_min_distrib2) + by standard (auto simp add: inf_int_def sup_int_def max_min_distrib2) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/ROOT --- a/src/HOL/ROOT Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/ROOT Fri Sep 18 16:42:19 2015 +0100 @@ -14,7 +14,7 @@ "root.bib" "root.tex" -session "HOL-Proofs" = Pure + +session "HOL-Proofs" (slow) = Pure + description {* HOL-Main with explicit proof terms. *} @@ -975,15 +975,14 @@ theories Examples Predicate_Compile_Tests - (* FIXME - Predicate_Compile_Quickcheck_Examples -- should be added again soon (since 21-Oct-2010) *) + Predicate_Compile_Quickcheck_Examples Specialisation_Examples IMP_1 IMP_2 (* FIXME since 21-Jul-2011 - Hotel_Example_Small_Generator + Hotel_Example_Small_Generator *) IMP_3 - IMP_4 *) + IMP_4 theories [condition = "ISABELLE_SWIPL"] Code_Prolog_Examples Context_Free_Grammar_Example diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Rat.thy --- a/src/HOL/Rat.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Rat.thy Fri Sep 18 16:42:19 2015 +0100 @@ -629,7 +629,7 @@ @{thm minus_divide_left} RS sym, @{thm minus_divide_right} RS sym, @{thm of_int_minus}, @{thm of_int_diff}, @{thm of_int_of_nat_eq}] - #> Lin_Arith.add_simprocs Numeral_Simprocs.field_divide_cancel_numeral_factor + #> Lin_Arith.add_simprocs [Numeral_Simprocs.field_divide_cancel_numeral_factor] #> Lin_Arith.add_inj_const (@{const_name of_nat}, @{typ "nat => rat"}) #> Lin_Arith.add_inj_const (@{const_name of_int}, @{typ "int => rat"})) \ diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Real_Vector_Spaces.thy --- a/src/HOL/Real_Vector_Spaces.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Real_Vector_Spaces.thy Fri Sep 18 16:42:19 2015 +0100 @@ -1294,7 +1294,7 @@ assumes "\x y. f (x + y) = f x + f y" assumes "\c x. f (c *\<^sub>R x) = c *\<^sub>R f x" shows "linear f" - by default (rule assms)+ + by standard (rule assms)+ locale bounded_linear = linear f for f :: "'a::real_normed_vector \ 'b::real_normed_vector" + assumes bounded: "\K. \x. norm (f x) \ norm x * K" @@ -1334,7 +1334,7 @@ assumes "\r x. f (scaleR r x) = scaleR r (f x)" assumes "\x. norm (f x) \ norm x * K" shows "bounded_linear f" - by default (fast intro: assms)+ + by standard (fast intro: assms)+ locale bounded_bilinear = fixes prod :: "['a::real_normed_vector, 'b::real_normed_vector] @@ -1415,10 +1415,10 @@ end lemma bounded_linear_ident[simp]: "bounded_linear (\x. x)" - by default (auto intro!: exI[of _ 1]) + by standard (auto intro!: exI[of _ 1]) lemma bounded_linear_zero[simp]: "bounded_linear (\x. 0)" - by default (auto intro!: exI[of _ 1]) + by standard (auto intro!: exI[of _ 1]) lemma bounded_linear_add: assumes "bounded_linear f" @@ -1859,7 +1859,7 @@ class banach = real_normed_vector + complete_space -instance real :: banach by default +instance real :: banach .. lemma tendsto_at_topI_sequentially: fixes f :: "real \ 'b::first_countable_topology" diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Relation.thy --- a/src/HOL/Relation.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Relation.thy Fri Sep 18 16:42:19 2015 +0100 @@ -1116,7 +1116,7 @@ assumes "finite A" shows "Id_on A = Finite_Set.fold (\x. Set.insert (Pair x x)) {} A" proof - - interpret comp_fun_commute "\x. Set.insert (Pair x x)" by default auto + interpret comp_fun_commute "\x. Set.insert (Pair x x)" by standard auto show ?thesis using assms unfolding Id_on_def by (induct A) simp_all qed @@ -1126,7 +1126,7 @@ interpret comp_fun_idem Set.insert by (fact comp_fun_idem_insert) show ?thesis - by default (auto simp add: fun_eq_iff comp_fun_commute split:prod.split) + by standard (auto simp add: fun_eq_iff comp_fun_commute split:prod.split) qed lemma Image_fold: @@ -1148,7 +1148,7 @@ proof - interpret comp_fun_idem Set.insert by (fact comp_fun_idem_insert) show "comp_fun_commute (\(w,z) A'. if snd x = w then Set.insert (fst x,z) A' else A')" - by default (auto simp add: fun_eq_iff split:prod.split) + by standard (auto simp add: fun_eq_iff split:prod.split) qed have *: "{x} O S = {(x', z). x' = fst x \ (snd x,z) \ S}" by (auto simp: relcomp_unfold intro!: exI) show ?thesis unfolding * @@ -1172,7 +1172,7 @@ have *: "\a b A. Finite_Set.fold (\(w, z) A'. if b = w then Set.insert (a, z) A' else A') A S = {(a,b)} O S \ A" by (auto simp: insert_relcomp_union_fold[OF assms] cong: if_cong) - show ?thesis by default (auto simp: *) + show ?thesis by standard (auto simp: *) qed lemma relcomp_fold: diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/SPARK/Manual/Reference.thy --- a/src/HOL/SPARK/Manual/Reference.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/SPARK/Manual/Reference.thy Fri Sep 18 16:42:19 2015 +0100 @@ -4,7 +4,7 @@ begin syntax (my_constrain output) - "_constrain" :: "logic => type => logic" ("_ \ _" [4, 0] 3) + "_constrain" :: "logic => type => logic" ("_ :: _" [4, 0] 3) (*>*) chapter {* HOL-\SPARK{} Reference *} diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Semiring_Normalization.thy --- a/src/HOL/Semiring_Normalization.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Semiring_Normalization.thy Fri Sep 18 16:42:19 2015 +0100 @@ -72,101 +72,120 @@ context comm_semiring_1 begin -declaration \ -let - val rules = @{lemma - "(a * m) + (b * m) = (a + b) * m" - "(a * m) + m = (a + 1) * m" - "m + (a * m) = (a + 1) * m" - "m + m = (1 + 1) * m" - "0 + a = a" - "a + 0 = a" - "a * b = b * a" - "(a + b) * c = (a * c) + (b * c)" - "0 * a = 0" - "a * 0 = 0" - "1 * a = a" - "a * 1 = a" - "(lx * ly) * (rx * ry) = (lx * rx) * (ly * ry)" - "(lx * ly) * (rx * ry) = lx * (ly * (rx * ry))" - "(lx * ly) * (rx * ry) = rx * ((lx * ly) * ry)" - "(lx * ly) * rx = (lx * rx) * ly" - "(lx * ly) * rx = lx * (ly * rx)" - "lx * (rx * ry) = (lx * rx) * ry" - "lx * (rx * ry) = rx * (lx * ry)" - "(a + b) + (c + d) = (a + c) + (b + d)" - "(a + b) + c = a + (b + c)" - "a + (c + d) = c + (a + d)" - "(a + b) + c = (a + c) + b" - "a + c = c + a" - "a + (c + d) = (a + c) + d" - "(x ^ p) * (x ^ q) = x ^ (p + q)" - "x * (x ^ q) = x ^ (Suc q)" - "(x ^ q) * x = x ^ (Suc q)" - "x * x = x\<^sup>2" - "(x * y) ^ q = (x ^ q) * (y ^ q)" - "(x ^ p) ^ q = x ^ (p * q)" - "x ^ 0 = 1" - "x ^ 1 = x" - "x * (y + z) = (x * y) + (x * z)" - "x ^ (Suc q) = x * (x ^ q)" - "x ^ (2*n) = (x ^ n) * (x ^ n)" - by (simp_all add: algebra_simps power_add power2_eq_square - power_mult_distrib power_mult del: one_add_one)} -in +lemma semiring_normalization_rules: + "(a * m) + (b * m) = (a + b) * m" + "(a * m) + m = (a + 1) * m" + "m + (a * m) = (a + 1) * m" + "m + m = (1 + 1) * m" + "0 + a = a" + "a + 0 = a" + "a * b = b * a" + "(a + b) * c = (a * c) + (b * c)" + "0 * a = 0" + "a * 0 = 0" + "1 * a = a" + "a * 1 = a" + "(lx * ly) * (rx * ry) = (lx * rx) * (ly * ry)" + "(lx * ly) * (rx * ry) = lx * (ly * (rx * ry))" + "(lx * ly) * (rx * ry) = rx * ((lx * ly) * ry)" + "(lx * ly) * rx = (lx * rx) * ly" + "(lx * ly) * rx = lx * (ly * rx)" + "lx * (rx * ry) = (lx * rx) * ry" + "lx * (rx * ry) = rx * (lx * ry)" + "(a + b) + (c + d) = (a + c) + (b + d)" + "(a + b) + c = a + (b + c)" + "a + (c + d) = c + (a + d)" + "(a + b) + c = (a + c) + b" + "a + c = c + a" + "a + (c + d) = (a + c) + d" + "(x ^ p) * (x ^ q) = x ^ (p + q)" + "x * (x ^ q) = x ^ (Suc q)" + "(x ^ q) * x = x ^ (Suc q)" + "x * x = x\<^sup>2" + "(x * y) ^ q = (x ^ q) * (y ^ q)" + "(x ^ p) ^ q = x ^ (p * q)" + "x ^ 0 = 1" + "x ^ 1 = x" + "x * (y + z) = (x * y) + (x * z)" + "x ^ (Suc q) = x * (x ^ q)" + "x ^ (2*n) = (x ^ n) * (x ^ n)" + by (simp_all add: algebra_simps power_add power2_eq_square + power_mult_distrib power_mult del: one_add_one) + +local_setup \ Semiring_Normalizer.declare @{thm comm_semiring_1_axioms} - {semiring = ([@{cpat "?x + ?y"}, @{cpat "?x * ?y"}, @{cpat "?x ^ ?n"}, @{cpat 0}, @{cpat 1}], - rules), ring = ([], []), field = ([], []), idom = [], ideal = []} -end\ + {semiring = ([@{term "x + y"}, @{term "x * y"}, @{term "x ^ n"}, @{term 0}, @{term 1}], + @{thms semiring_normalization_rules}), + ring = ([], []), + field = ([], []), + idom = [], + ideal = []} +\ end context comm_ring_1 begin -declaration \ -let - val rules = @{lemma - "- x = (- 1) * x" - "x - y = x + (- y)" - by simp_all} -in +lemma ring_normalization_rules: + "- x = (- 1) * x" + "x - y = x + (- y)" + by simp_all + +local_setup \ Semiring_Normalizer.declare @{thm comm_ring_1_axioms} - {semiring = Semiring_Normalizer.the_semiring @{context} @{thm comm_semiring_1_axioms}, - ring = ([@{cpat "?x - ?y"}, @{cpat "- ?x"}], rules), field = ([], []), idom = [], ideal = []} -end\ + {semiring = ([@{term "x + y"}, @{term "x * y"}, @{term "x ^ n"}, @{term 0}, @{term 1}], + @{thms semiring_normalization_rules}), + ring = ([@{term "x - y"}, @{term "- x"}], @{thms ring_normalization_rules}), + field = ([], []), + idom = [], + ideal = []} +\ end context comm_semiring_1_cancel_crossproduct begin -declaration \Semiring_Normalizer.declare @{thm comm_semiring_1_cancel_crossproduct_axioms} - {semiring = Semiring_Normalizer.the_semiring @{context} @{thm comm_semiring_1_axioms}, - ring = ([], []), field = ([], []), idom = @{thms crossproduct_noteq add_scale_eq_noteq}, ideal = []}\ +local_setup \ + Semiring_Normalizer.declare @{thm comm_semiring_1_cancel_crossproduct_axioms} + {semiring = ([@{term "x + y"}, @{term "x * y"}, @{term "x ^ n"}, @{term 0}, @{term 1}], + @{thms semiring_normalization_rules}), + ring = ([], []), + field = ([], []), + idom = @{thms crossproduct_noteq add_scale_eq_noteq}, + ideal = []} +\ end context idom begin -declaration \Semiring_Normalizer.declare @{thm idom_axioms} - {semiring = Semiring_Normalizer.the_semiring @{context} @{thm comm_ring_1_axioms}, - ring = Semiring_Normalizer.the_ring @{context} @{thm comm_ring_1_axioms}, - field = ([], []), idom = @{thms crossproduct_noteq add_scale_eq_noteq}, - ideal = @{thms right_minus_eq add_0_iff}}\ +local_setup \ + Semiring_Normalizer.declare @{thm idom_axioms} + {semiring = ([@{term "x + y"}, @{term "x * y"}, @{term "x ^ n"}, @{term 0}, @{term 1}], + @{thms semiring_normalization_rules}), + ring = ([@{term "x - y"}, @{term "- x"}], @{thms ring_normalization_rules}), + field = ([], []), + idom = @{thms crossproduct_noteq add_scale_eq_noteq}, + ideal = @{thms right_minus_eq add_0_iff}} +\ end context field begin -declaration \Semiring_Normalizer.declare @{thm field_axioms} - {semiring = Semiring_Normalizer.the_semiring @{context} @{thm idom_axioms}, - ring = Semiring_Normalizer.the_ring @{context} @{thm idom_axioms}, - field = ([@{cpat "?x / ?y"}, @{cpat "inverse ?x"}], @{thms divide_inverse inverse_eq_divide}), - idom = Semiring_Normalizer.the_idom @{context} @{thm idom_axioms}, - ideal = Semiring_Normalizer.the_ideal @{context} @{thm idom_axioms}}\ +local_setup \ + Semiring_Normalizer.declare @{thm field_axioms} + {semiring = ([@{term "x + y"}, @{term "x * y"}, @{term "x ^ n"}, @{term 0}, @{term 1}], + @{thms semiring_normalization_rules}), + ring = ([@{term "x - y"}, @{term "- x"}], @{thms ring_normalization_rules}), + field = ([@{term "x / y"}, @{term "inverse x"}], @{thms divide_inverse inverse_eq_divide}), + idom = @{thms crossproduct_noteq add_scale_eq_noteq}, + ideal = @{thms right_minus_eq add_0_iff}} +\ end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Statespace/distinct_tree_prover.ML --- a/src/HOL/Statespace/distinct_tree_prover.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Statespace/distinct_tree_prover.ML Fri Sep 18 16:42:19 2015 +0100 @@ -353,12 +353,15 @@ mk_solver "distinctFieldSolver" (distinctTree_tac names); fun distinct_simproc names = - Simplifier.simproc_global @{theory HOL} "DistinctTreeProver.distinct_simproc" ["x = y"] - (fn ctxt => - (fn Const (@{const_name HOL.eq}, _) $ x $ y => + Simplifier.make_simproc @{context} "DistinctTreeProver.distinct_simproc" + {lhss = [@{term "x = y"}], + proc = fn _ => fn ctxt => fn ct => + (case Thm.term_of ct of + Const (@{const_name HOL.eq}, _) $ x $ y => Option.map (fn neq => @{thm neq_to_eq_False} OF [neq]) (get_fst_success (neq_x_y ctxt x y) names) - | _ => NONE)); + | _ => NONE), + identifier = []}; end; diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Statespace/state_fun.ML --- a/src/HOL/Statespace/state_fun.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Statespace/state_fun.ML Fri Sep 18 16:42:19 2015 +0100 @@ -51,26 +51,29 @@ in val lazy_conj_simproc = - Simplifier.simproc_global @{theory HOL} "lazy_conj_simp" ["P & Q"] - (fn ctxt => fn t => - (case t of (Const (@{const_name HOL.conj},_) $ P $ Q) => - let - val P_P' = Simplifier.rewrite ctxt (Thm.cterm_of ctxt P); - val P' = P_P' |> Thm.prop_of |> Logic.dest_equals |> #2; - in - if isFalse P' then SOME (conj1_False OF [P_P']) - else - let - val Q_Q' = Simplifier.rewrite ctxt (Thm.cterm_of ctxt Q); - val Q' = Q_Q' |> Thm.prop_of |> Logic.dest_equals |> #2; - in - if isFalse Q' then SOME (conj2_False OF [Q_Q']) - else if isTrue P' andalso isTrue Q' then SOME (conj_True OF [P_P', Q_Q']) - else if P aconv P' andalso Q aconv Q' then NONE - else SOME (conj_cong OF [P_P', Q_Q']) - end - end - | _ => NONE)); + Simplifier.make_simproc @{context} "lazy_conj_simp" + {lhss = [@{term "P & Q"}], + proc = fn _ => fn ctxt => fn ct => + (case Thm.term_of ct of + Const (@{const_name HOL.conj},_) $ P $ Q => + let + val P_P' = Simplifier.rewrite ctxt (Thm.cterm_of ctxt P); + val P' = P_P' |> Thm.prop_of |> Logic.dest_equals |> #2; + in + if isFalse P' then SOME (conj1_False OF [P_P']) + else + let + val Q_Q' = Simplifier.rewrite ctxt (Thm.cterm_of ctxt Q); + val Q' = Q_Q' |> Thm.prop_of |> Logic.dest_equals |> #2; + in + if isFalse Q' then SOME (conj2_False OF [Q_Q']) + else if isTrue P' andalso isTrue Q' then SOME (conj_True OF [P_P', Q_Q']) + else if P aconv P' andalso Q aconv Q' then NONE + else SOME (conj_cong OF [P_P', Q_Q']) + end + end + | _ => NONE), + identifier = []}; fun string_eq_simp_tac ctxt = simp_tac (put_simpset HOL_basic_ss ctxt @@ -106,13 +109,14 @@ val _ = Theory.setup (Context.theory_map (Data.put (lookup_ss, ex_lookup_ss, false))); val lookup_simproc = - Simplifier.simproc_global @{theory} "lookup_simp" ["lookup d n (update d' c m v s)"] - (fn ctxt => fn t => - (case t of (Const (@{const_name StateFun.lookup}, lT) $ destr $ n $ + Simplifier.make_simproc @{context} "lookup_simp" + {lhss = [@{term "lookup d n (update d' c m v s)"}], + proc = fn _ => fn ctxt => fn ct => + (case Thm.term_of ct of (Const (@{const_name StateFun.lookup}, lT) $ destr $ n $ (s as Const (@{const_name StateFun.update}, uT) $ _ $ _ $ _ $ _ $ _)) => (let val (_::_::_::_::sT::_) = binder_types uT; - val mi = maxidx_of_term t; + val mi = Term.maxidx_of_term (Thm.term_of ct); fun mk_upds (Const (@{const_name StateFun.update}, uT) $ d' $ c $ m $ v $ s) = let val (_ :: _ :: _ :: fT :: _ :: _) = binder_types uT; @@ -149,7 +153,8 @@ else SOME thm end handle Option.Option => NONE) - | _ => NONE )); + | _ => NONE), + identifier = []}; local @@ -165,9 +170,10 @@ in val update_simproc = - Simplifier.simproc_global @{theory} "update_simp" ["update d c n v s"] - (fn ctxt => fn t => - (case t of + Simplifier.make_simproc @{context} "update_simp" + {lhss = [@{term "update d c n v s"}], + proc = fn _ => fn ctxt => fn ct => + (case Thm.term_of ct of Const (@{const_name StateFun.update}, uT) $ _ $ _ $ _ $ _ $ _ => let val (_ :: _ :: _ :: _ :: sT :: _) = binder_types uT; @@ -242,7 +248,7 @@ val ctxt1 = put_simpset ss' ctxt0; val ctxt2 = put_simpset (#1 (Data.get (Context.Proof ctxt0))) ctxt0; in - (case mk_updterm [] t of + (case mk_updterm [] (Thm.term_of ct) of (trm, trm', vars, _, true) => let val eq1 = @@ -253,7 +259,8 @@ in SOME (Thm.transitive eq1 eq2) end | _ => NONE) end - | _ => NONE)); + | _ => NONE), + identifier = []}; end; @@ -269,10 +276,12 @@ in val ex_lookup_eq_simproc = - Simplifier.simproc_global @{theory HOL} "ex_lookup_eq_simproc" ["Ex t"] - (fn ctxt => fn t => + Simplifier.make_simproc @{context} "ex_lookup_eq_simproc" + {lhss = [@{term "Ex t"}], + proc = fn _ => fn ctxt => fn ct => let val thy = Proof_Context.theory_of ctxt; + val t = Thm.term_of ct; val ex_lookup_ss = #2 (Data.get (Context.Proof ctxt)); val ctxt' = ctxt |> Config.put simp_depth_limit 100 |> put_simpset ex_lookup_ss; @@ -316,7 +325,8 @@ val thm' = if swap then swap_ex_eq OF [thm] else thm in SOME thm' end handle TERM _ => NONE) | _ => NONE) - end handle Option.Option => NONE); + end handle Option.Option => NONE, + identifier = []}; end; diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Statespace/state_space.ML --- a/src/HOL/Statespace/state_space.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Statespace/state_space.ML Fri Sep 18 16:42:19 2015 +0100 @@ -211,10 +211,15 @@ val distinctNameSolver = mk_solver "distinctNameSolver" distinctTree_tac; val distinct_simproc = - Simplifier.simproc_global @{theory HOL} "StateSpace.distinct_simproc" ["x = y"] - (fn ctxt => (fn (Const (@{const_name HOL.eq},_)$(x as Free _)$(y as Free _)) => - Option.map (fn neq => DistinctTreeProver.neq_to_eq_False OF [neq]) (neq_x_y ctxt x y) - | _ => NONE)); + Simplifier.make_simproc @{context} "StateSpace.distinct_simproc" + {lhss = [@{term "x = y"}], + proc = fn _ => fn ctxt => fn ct => + (case Thm.term_of ct of + Const (@{const_name HOL.eq},_) $ (x as Free _) $ (y as Free _) => + Option.map (fn neq => DistinctTreeProver.neq_to_eq_False OF [neq]) + (neq_x_y ctxt x y) + | _ => NONE), + identifier = []}; fun interprete_parent name dist_thm_name parent_expr thy = let diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/BNF/bnf_def.ML --- a/src/HOL/Tools/BNF/bnf_def.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/BNF/bnf_def.ML Fri Sep 18 16:42:19 2015 +0100 @@ -1484,9 +1484,9 @@ Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) (fn {context = ctxt, prems = _} => mk_set_transfer_tac ctxt (Lazy.force in_rel) (map Lazy.force set_map)) + |> Thm.close_derivation |> Conjunction.elim_balanced (length goals) |> Proof_Context.export names_lthy lthy - |> map Thm.close_derivation end; val set_transfer = Lazy.lazy mk_set_transfer; @@ -1566,9 +1566,10 @@ fun mk_wit_thms set_maps = Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) (fn {context = ctxt, prems = _} => mk_wits_tac ctxt set_maps) + |> Thm.close_derivation |> Conjunction.elim_balanced (length wit_goals) |> map2 (Conjunction.elim_balanced o length) wit_goalss - |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0)); + |> (map o map) (Thm.forall_elim_vars 0); in map2 (Thm.close_derivation oo Goal.prove_sorry lthy [] []) goals (map (fn tac => fn {context = ctxt, prems = _} => @@ -1585,9 +1586,10 @@ fun mk_triv_wit_thms tac set_maps = Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) (fn {context = ctxt, prems = _} => TRYALL Goal.conjunction_tac THEN tac ctxt set_maps) + |> Thm.close_derivation |> Conjunction.elim_balanced (length wit_goals) |> map2 (Conjunction.elim_balanced o length) wit_goalss - |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0)); + |> (map o map) (Thm.forall_elim_vars 0); val (mk_wit_thms, nontriv_wit_goals) = (case triv_tac_opt of NONE => (fn _ => [], map (map (rpair [])) wit_goalss) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/BNF/bnf_fp_def_sugar.ML --- a/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML Fri Sep 18 16:42:19 2015 +0100 @@ -680,9 +680,9 @@ Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) (fn {context = ctxt, prems = _} => mk_ctr_transfer_tac ctxt rel_intro_thms live_nesting_rel_eqs) + |> Thm.close_derivation |> Conjunction.elim_balanced (length goals) |> Proof_Context.export names_lthy lthy - |> map Thm.close_derivation end; val (set_cases_thms, set_cases_attrss) = @@ -785,9 +785,9 @@ else Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) (fn {context = ctxt, prems = _} => mk_set_intros_tac ctxt set0_thms) + |> Thm.close_derivation |> Conjunction.elim_balanced (length goals) - |> Proof_Context.export names_lthy lthy - |> map Thm.close_derivation) + |> Proof_Context.export names_lthy lthy) end; val rel_sel_thms = @@ -884,9 +884,9 @@ Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) (fn {context = ctxt, prems = _} => mk_sel_transfer_tac ctxt n sel_defs case_transfer_thm) + |> Thm.close_derivation |> Conjunction.elim_balanced (length goals) |> Proof_Context.export names_lthy lthy - |> map Thm.close_derivation end; val disc_transfer_thms = @@ -897,9 +897,9 @@ Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) (fn {context = ctxt, prems = _} => mk_disc_transfer_tac ctxt (the_single rel_sel_thms) (the_single exhaust_discs) (flat (flat distinct_discsss))) + |> Thm.close_derivation |> Conjunction.elim_balanced (length goals) |> Proof_Context.export names_lthy lthy - |> map Thm.close_derivation end; val map_disc_iff_thms = @@ -921,9 +921,9 @@ Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) (fn {context = ctxt, prems = _} => mk_map_disc_iff_tac ctxt (Thm.cterm_of ctxt ta) exhaust (flat disc_thmss) map_thms) + |> Thm.close_derivation |> Conjunction.elim_balanced (length goals) |> Proof_Context.export names_lthy lthy - |> map Thm.close_derivation end; val (map_sel_thmss, map_sel_thms) = @@ -956,9 +956,9 @@ (fn {context = ctxt, prems = _} => mk_map_sel_tac ctxt (Thm.cterm_of ctxt ta) exhaust (flat disc_thmss) map_thms (flat sel_thmss) live_nesting_map_id0s) + |> Thm.close_derivation |> Conjunction.elim_balanced (length goals) - |> Proof_Context.export names_lthy lthy - |> map Thm.close_derivation) + |> Proof_Context.export names_lthy lthy) end; val (set_sel_thmssss, set_sel_thms) = @@ -1015,9 +1015,9 @@ (fn {context = ctxt, prems = _} => mk_set_sel_tac ctxt (Thm.cterm_of ctxt ta) exhaust (flat disc_thmss) (flat sel_thmss) set0_thms) + |> Thm.close_derivation |> Conjunction.elim_balanced (length goals) - |> Proof_Context.export names_lthy lthy - |> map Thm.close_derivation) + |> Proof_Context.export names_lthy lthy) end; val code_attrs = if plugins code_plugin then [Code.add_default_eqn_attrib] else []; @@ -2256,9 +2256,9 @@ (fn {context = ctxt, prems = _} => mk_rec_transfer_tac ctxt nn ns (map (Thm.cterm_of ctxt) Ss) (map (Thm.cterm_of ctxt) Rs) xsssss rec_defs xtor_co_rec_transfers pre_rel_defs live_nesting_rel_eqs) + |> Thm.close_derivation |> Conjunction.elim_balanced nn |> Proof_Context.export names_lthy lthy - |> map Thm.close_derivation end; fun derive_rec_o_map_thmss lthy recs rec_defs = @@ -2408,9 +2408,9 @@ mk_corec_transfer_tac ctxt (map (Thm.cterm_of ctxt) Ss) (map (Thm.cterm_of ctxt) Rs) type_definitions corec_defs xtor_co_rec_transfers pre_rel_defs live_nesting_rel_eqs (flat pgss) pss qssss gssss) + |> Thm.close_derivation |> Conjunction.elim_balanced (length goals) |> Proof_Context.export names_lthy lthy - |> map Thm.close_derivation end; fun derive_map_o_corec_thmss lthy0 lthy2 corecs corec_defs = diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/BNF/bnf_fp_n2m_sugar.ML --- a/src/HOL/Tools/BNF/bnf_fp_n2m_sugar.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/BNF/bnf_fp_n2m_sugar.ML Fri Sep 18 16:42:19 2015 +0100 @@ -66,7 +66,7 @@ | unfold_lets_splits (t $ u) = betapply (unfold_lets_splits t, unfold_lets_splits u) | unfold_lets_splits (Abs (s, T, t)) = Abs (s, T, unfold_lets_splits t) | unfold_lets_splits t = t -and unfold_splits_lets ((t as Const (@{const_name case_prod}, _)) $ u) = +and unfold_splits_lets ((t as Const (@{const_name uncurry}, _)) $ u) = (case unfold_splits_lets u of u' as Abs (s1, T1, Abs (s2, T2, _)) => let val v = Var ((s1 ^ s2, Term.maxidx_of_term u' + 1), HOLogic.mk_prodT (T1, T2)) in diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML --- a/src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML Fri Sep 18 16:42:19 2015 +0100 @@ -294,7 +294,7 @@ | (_, branches') => Term.list_comb (If_const (typof (hd branches')) $ tap (check_no_call bound_Ts) obj, branches')) - | (c as Const (@{const_name case_prod}, _), arg :: args) => + | (c as Const (@{const_name uncurry}, _), arg :: args) => massage_rec bound_Ts (unfold_splits_lets (Term.list_comb (c $ Envir.eta_long bound_Ts arg, args))) | (Const (c, _), args as _ :: _ :: _) => @@ -398,12 +398,12 @@ end | NONE => (case t of - Const (@{const_name case_prod}, _) $ t' => + Const (@{const_name uncurry}, _) $ t' => let val U' = curried_type U; val T' = curried_type T; in - Const (@{const_name case_prod}, U' --> U) $ massage_any_call bound_Ts U' T' t' + Const (@{const_name uncurry}, U' --> U) $ massage_any_call bound_Ts U' T' t' end | t1 $ t2 => (if has_call t2 then @@ -927,7 +927,7 @@ let val (u, vs) = strip_comb t in if is_Free u andalso has_call u then Inr_const T U2 $ mk_tuple1_balanced bound_Ts vs - else if try (fst o dest_Const) u = SOME @{const_name case_prod} then + else if try (fst o dest_Const) u = SOME @{const_name uncurry} then map (rewrite bound_Ts) vs |> chop 1 |>> HOLogic.mk_split o the_single |> Term.list_comb diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/BNF/bnf_lfp_basic_sugar.ML --- a/src/HOL/Tools/BNF/bnf_lfp_basic_sugar.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/BNF/bnf_lfp_basic_sugar.ML Fri Sep 18 16:42:19 2015 +0100 @@ -164,7 +164,7 @@ set_cases = @{thms fsts.cases[unfolded eq_fst_iff ex_neg_all_pos] snds.cases[unfolded eq_snd_iff ex_neg_all_pos]}}, fp_co_induct_sugar = - {co_rec = Const (@{const_name case_prod}, (ctr_Ts ---> C) --> fpT --> C), + {co_rec = Const (@{const_name uncurry}, (ctr_Ts ---> C) --> fpT --> C), common_co_inducts = @{thms prod.induct}, co_inducts = @{thms prod.induct}, co_rec_def = @{thm ctor_rec_def_alt[of "case_prod f" for f]}, diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/BNF/bnf_util.ML --- a/src/HOL/Tools/BNF/bnf_util.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/BNF/bnf_util.ML Fri Sep 18 16:42:19 2015 +0100 @@ -143,10 +143,20 @@ let (*Work around loss of qualification in "typedef" axioms by replicating it in the name*) val b' = fold_rev Binding.prefix_name (map (suffix "_" o fst) (Binding.path_of b)) b; + + val default_bindings = Typedef.default_bindings (Binding.concealed b'); + val bindings = + (case opt_morphs of + NONE => default_bindings + | SOME (Rep_name, Abs_name) => + {Rep_name = Binding.concealed Rep_name, + Abs_name = Binding.concealed Abs_name, + type_definition_name = #type_definition_name default_bindings}); + val ((name, info), (lthy, lthy_old)) = lthy |> Local_Theory.open_target |> snd - |> Typedef.add_typedef true (b', Ts, mx) set opt_morphs tac + |> Typedef.add_typedef (b', Ts, mx) set (SOME bindings) tac ||> `Local_Theory.close_target; val phi = Proof_Context.export_morphism lthy_old lthy; in diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML --- a/src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML Fri Sep 18 16:42:19 2015 +0100 @@ -1017,9 +1017,9 @@ Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced goals) (fn {context = ctxt, ...} => mk_disc_eq_case_tac ctxt (Thm.cterm_of ctxt u) exhaust_thm (flat nontriv_disc_thmss) distinct_thms case_thms) + |> Thm.close_derivation |> Conjunction.elim_balanced (length goals) |> Proof_Context.export names_lthy lthy - |> map Thm.close_derivation end; in (sel_defs, all_sel_thms, sel_thmss, disc_defs, disc_thmss, nontriv_disc_thmss, diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Ctr_Sugar/ctr_sugar_code.ML --- a/src/HOL/Tools/Ctr_Sugar/ctr_sugar_code.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Ctr_Sugar/ctr_sugar_code.ML Fri Sep 18 16:42:19 2015 +0100 @@ -76,6 +76,7 @@ fun proves goals = goals |> Logic.mk_conjunction_balanced |> prove + |> Thm.close_derivation |> Conjunction.elim_balanced (length goals) |> map Simpdata.mk_eq; in diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Function/function.ML --- a/src/HOL/Tools/Function/function.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Function/function.ML Fri Sep 18 16:42:19 2015 +0100 @@ -273,8 +273,7 @@ val cong = #case_cong (Old_Datatype_Data.the_info thy n) |> safe_mk_meta_eq in - Context.theory_map - (Function_Context_Tree.map_function_congs (Thm.add_thm cong)) thy + Context.theory_map (Function_Context_Tree.add_function_cong cong) thy end val _ = Theory.setup (Old_Datatype_Data.interpretation (K (fold add_case_cong))) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Function/function_common.ML --- a/src/HOL/Tools/Function/function_common.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Function/function_common.ML Fri Sep 18 16:42:19 2015 +0100 @@ -282,7 +282,7 @@ fun termination_rule_tac ctxt = resolve_tac ctxt (#1 (Data.get (Context.Proof ctxt))) -val store_termination_rule = Data.map o @{apply 4(1)} o cons +val store_termination_rule = Data.map o @{apply 4(1)} o cons o Thm.trim_context val get_functions = #2 o Data.get o Context.Proof fun add_function_data (info : info as {fs, termination, ...}) = diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Function/function_context_tree.ML --- a/src/HOL/Tools/Function/function_context_tree.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Function/function_context_tree.ML Fri Sep 18 16:42:19 2015 +0100 @@ -10,10 +10,8 @@ type ctxt = (string * typ) list * thm list type ctx_tree - (* FIXME: This interface is a mess and needs to be cleaned up! *) val get_function_congs : Proof.context -> thm list val add_function_cong : thm -> Context.generic -> Context.generic - val map_function_congs : (thm list -> thm list) -> Context.generic -> Context.generic val cong_add: attribute val cong_del: attribute @@ -53,14 +51,17 @@ val merge = Thm.merge_thms ); -val get_function_congs = FunctionCongs.get o Context.Proof -val map_function_congs = FunctionCongs.map -val add_function_cong = FunctionCongs.map o Thm.add_thm +fun get_function_congs ctxt = + FunctionCongs.get (Context.Proof ctxt) + |> map (Thm.transfer (Proof_Context.theory_of ctxt)); + +val add_function_cong = FunctionCongs.map o Thm.add_thm o Thm.trim_context; + (* congruence rules *) -val cong_add = Thm.declaration_attribute (map_function_congs o Thm.add_thm o safe_mk_meta_eq); -val cong_del = Thm.declaration_attribute (map_function_congs o Thm.del_thm o safe_mk_meta_eq); +val cong_add = Thm.declaration_attribute (add_function_cong o safe_mk_meta_eq); +val cong_del = Thm.declaration_attribute (FunctionCongs.map o Thm.del_thm o safe_mk_meta_eq); type depgraph = int Int_Graph.T diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Function/function_core.ML --- a/src/HOL/Tools/Function/function_core.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Function/function_core.ML Fri Sep 18 16:42:19 2015 +0100 @@ -7,7 +7,6 @@ signature FUNCTION_CORE = sig val trace: bool Unsynchronized.ref - val prepare_function : Function_Common.function_config -> string (* defname *) -> ((bstring * typ) * mixfix) list (* defined symbol *) @@ -504,10 +503,12 @@ Abs ("x", domT, Const (@{const_name Fun_Def.THE_default}, ranT --> (ranT --> boolT) --> ranT) $ (default $ Bound 0) $ Abs ("y", ranT, G $ Bound 1 $ Bound 0)) |> Syntax.check_term lthy + val def_binding = + if Config.get lthy function_defs then (Binding.name fdefname, []) + else Attrib.empty_binding in Local_Theory.define - ((Binding.name (function_name fname), mixfix), - ((Binding.concealed (Binding.name fdefname), []), f_def)) lthy + ((Binding.name (function_name fname), mixfix), (def_binding, f_def)) lthy end fun define_recursion_relation Rname domT qglrs clauses RCss lthy = diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Function/function_lib.ML --- a/src/HOL/Tools/Function/function_lib.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Function/function_lib.ML Fri Sep 18 16:42:19 2015 +0100 @@ -7,6 +7,8 @@ signature FUNCTION_LIB = sig + val function_defs: bool Config.T + val plural: string -> string -> 'a list -> string val dest_all_all: term -> term list * term @@ -30,6 +32,9 @@ structure Function_Lib: FUNCTION_LIB = struct +val function_defs = Attrib.setup_config_bool @{binding function_defs} (K false) + + (* "The variable" ^ plural " is" "s are" vs *) fun plural sg pl [x] = sg | plural sg pl _ = pl diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Function/mutual.ML --- a/src/HOL/Tools/Function/mutual.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Function/mutual.ML Fri Sep 18 16:42:19 2015 +0100 @@ -128,11 +128,13 @@ let fun def ((MutualPart {i=i, i'=i', fvar=(fname, fT), cargTs, f_def, ...}), (_, mixfix)) lthy = let + val def_binding = + if Config.get lthy function_defs then (Binding.name (Thm.def_name fname), []) + else Attrib.empty_binding val ((f, (_, f_defthm)), lthy') = Local_Theory.define ((Binding.name fname, mixfix), - ((Binding.concealed (Binding.name (Thm.def_name fname)), []), - Term.subst_bound (fsum, f_def))) lthy + (def_binding, Term.subst_bound (fsum, f_def))) lthy in (MutualPart {i=i, i'=i', fvar=(fname, fT), cargTs=cargTs, f_def=f_def, f=SOME f, f_defthm=SOME f_defthm }, diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Function/partial_function.ML --- a/src/HOL/Tools/Function/partial_function.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Function/partial_function.ML Fri Sep 18 16:42:19 2015 +0100 @@ -7,29 +7,35 @@ signature PARTIAL_FUNCTION = sig val init: string -> term -> term -> thm -> thm -> thm option -> declaration - val mono_tac: Proof.context -> int -> tactic - val add_partial_function: string -> (binding * typ option * mixfix) list -> Attrib.binding * term -> local_theory -> local_theory - val add_partial_function_cmd: string -> (binding * string option * mixfix) list -> Attrib.binding * string -> local_theory -> local_theory end; - structure Partial_Function: PARTIAL_FUNCTION = struct (*** Context Data ***) -datatype setup_data = Setup_Data of +datatype setup_data = Setup_Data of {fixp: term, mono: term, fixp_eq: thm, fixp_induct: thm, fixp_induct_user: thm option}; +fun transform_setup_data phi (Setup_Data {fixp, mono, fixp_eq, fixp_induct, fixp_induct_user}) = + let + val term = Morphism.term phi; + val thm = Morphism.thm phi; + in + Setup_Data + {fixp = term fixp, mono = term mono, fixp_eq = thm fixp_eq, + fixp_induct = thm fixp_induct, fixp_induct_user = Option.map thm fixp_induct_user} + end; + structure Modes = Generic_Data ( type T = setup_data Symtab.table; @@ -40,17 +46,18 @@ fun init mode fixp mono fixp_eq fixp_induct fixp_induct_user phi = let - val term = Morphism.term phi; - val thm = Morphism.thm phi; - val data' = Setup_Data - {fixp=term fixp, mono=term mono, fixp_eq=thm fixp_eq, - fixp_induct=thm fixp_induct, fixp_induct_user=Option.map thm fixp_induct_user}; - in - Modes.map (Symtab.update (mode, data')) - end + val data' = + Setup_Data + {fixp = fixp, mono = mono, fixp_eq = fixp_eq, + fixp_induct = fixp_induct, fixp_induct_user = fixp_induct_user} + |> transform_setup_data (phi $> Morphism.trim_context_morphism); + in Modes.map (Symtab.update (mode, data')) end; val known_modes = Symtab.keys o Modes.get o Context.Proof; -val lookup_mode = Symtab.lookup o Modes.get o Context.Proof; + +fun lookup_mode ctxt = + Symtab.lookup (Modes.get (Context.Proof ctxt)) + #> Option.map (transform_setup_data (Morphism.transfer_morphism (Proof_Context.theory_of ctxt))); (*** Automated monotonicity proofs ***) @@ -159,7 +166,7 @@ let val ([P], ctxt') = Variable.variant_fixes ["P"] ctxt val P_inst = Abs ("f", fT_uc, Free (P, fT --> HOLogic.boolT) $ (curry $ Bound 0)) - in + in (* FIXME ctxt vs. ctxt' (!?) *) rule |> infer_instantiate' ctxt @@ -182,7 +189,7 @@ val split_paired_all_conv = Conv.every_conv (replicate (length args - 1) (Conv.rewr_conv @{thm split_paired_all})) - val split_params_conv = + val split_params_conv = Conv.params_conv ~1 (fn ctxt' => Conv.implies_conv split_paired_all_conv Conv.all_conv) @@ -207,7 +214,7 @@ in inst_rule' end; - + (*** partial_function definition ***) @@ -251,9 +258,11 @@ val inst_mono_thm = Thm.forall_elim (Thm.cterm_of lthy x_uc) mono_thm val f_def_rhs = curry_n arity (apply_inst lthy fixp F_uc); - val f_def_binding = Binding.concealed (Binding.name (Thm.def_name fname)); + val f_def_binding = + if Config.get lthy Function_Lib.function_defs then (Binding.name (Thm.def_name fname), []) + else Attrib.empty_binding; val ((f, (_, f_def)), lthy') = Local_Theory.define - ((f_binding, mixfix), ((f_def_binding, []), f_def_rhs)) lthy; + ((f_binding, mixfix), (f_def_binding, f_def_rhs)) lthy; val eqn = HOLogic.mk_eq (list_comb (f, args), Term.betapplys (F, f :: args)) @@ -264,7 +273,7 @@ OF [inst_mono_thm, f_def]) |> Tactic.rule_by_tactic lthy' (Simplifier.simp_tac (put_simpset curry_uncurry_ss lthy') 1); - val specialized_fixp_induct = + val specialized_fixp_induct = specialize_fixp_induct lthy' args fT fT_uc F curry uncurry inst_mono_thm f_def fixp_induct |> Drule.rename_bvars' (map SOME (fname :: fname :: argnames)); @@ -288,10 +297,10 @@ |-> (fn (_, rec') => Spec_Rules.add Spec_Rules.Equational ([f], rec') #> Local_Theory.note ((Binding.qualify true fname (Binding.name "simps"), []), rec') #> snd) - |> (Local_Theory.note ((Binding.qualify true fname (Binding.name "mono"), []), [mono_thm]) #> snd) + |> (Local_Theory.note ((Binding.qualify true fname (Binding.name "mono"), []), [mono_thm]) #> snd) |> (case raw_induct of NONE => I | SOME thm => Local_Theory.note ((Binding.qualify true fname (Binding.name "raw_induct"), []), [thm]) #> snd) - |> (Local_Theory.note ((Binding.qualify true fname (Binding.name "fixp_induct"), []), [specialized_fixp_induct]) #> snd) + |> (Local_Theory.note ((Binding.qualify true fname (Binding.name "fixp_induct"), []), [specialized_fixp_induct]) #> snd) end; val add_partial_function = gen_add_partial_function Specification.check_spec; @@ -304,4 +313,4 @@ ((mode -- (Parse.fixes -- (Parse.where_ |-- Parse_Spec.spec))) >> (fn (mode, (fixes, spec)) => add_partial_function_cmd mode fixes spec)); -end +end; diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Nitpick/nitpick_hol.ML --- a/src/HOL/Tools/Nitpick/nitpick_hol.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML Fri Sep 18 16:42:19 2015 +0100 @@ -2287,7 +2287,7 @@ HOLogic.Collect_const tuple_T $ list_comb (Const base_x, outer_bounds) val step_set = HOLogic.Collect_const prod_T - $ (Const (@{const_name case_prod}, curried_T --> uncurried_T) + $ (Const (@{const_name uncurry}, curried_T --> uncurried_T) $ list_comb (Const step_x, outer_bounds)) val image_set = image_const $ (rtrancl_const $ step_set) $ base_set diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Old_Datatype/old_datatype.ML --- a/src/HOL/Tools/Old_Datatype/old_datatype.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Old_Datatype/old_datatype.ML Fri Sep 18 16:42:19 2015 +0100 @@ -186,7 +186,7 @@ |> Sign.parent_path |> fold_map (fn (((name, mx), tvs), c) => - Typedef.add_typedef_global false (name, tvs, mx) + Typedef.add_typedef_global (name, tvs, mx) (Collect $ Const (c, UnivT')) NONE (fn ctxt => resolve_tac ctxt [exI] 1 THEN diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Predicate_Compile/mode_inference.ML --- a/src/HOL/Tools/Predicate_Compile/mode_inference.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Predicate_Compile/mode_inference.ML Fri Sep 18 16:42:19 2015 +0100 @@ -53,7 +53,7 @@ struct open Predicate_Compile_Aux; -open Core_Data; + (* derivation trees for modes of premises *) @@ -317,7 +317,7 @@ fun is_functional t mode = case try (fst o dest_Const o fst o strip_comb) t of NONE => false - | SOME c => is_some (alternative_compilation_of ctxt c mode) + | SOME c => is_some (Core_Data.alternative_compilation_of ctxt c mode) in case (is_functional t1 (head_mode_of deriv1), is_functional t2 (head_mode_of deriv2)) of (true, true) => EQUAL diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML Fri Sep 18 16:42:19 2015 +0100 @@ -72,7 +72,6 @@ type random_seed = Random_Engine.seed open Predicate_Compile_Aux; -open Core_Data; open Mode_Inference; open Predicate_Compile_Proof; @@ -126,18 +125,19 @@ fun print_stored_rules ctxt = let - val preds = Graph.keys (PredData.get (Proof_Context.theory_of ctxt)) - fun print pred () = let - val _ = writeln ("predicate: " ^ pred) - val _ = writeln ("introrules: ") - val _ = fold (fn thm => fn _ => writeln (Display.string_of_thm ctxt thm)) - (rev (intros_of ctxt pred)) () - in - if (has_elim ctxt pred) then - writeln ("elimrule: " ^ Display.string_of_thm ctxt (the_elim_of ctxt pred)) - else - writeln ("no elimrule defined") - end + val preds = Graph.keys (Core_Data.PredData.get (Proof_Context.theory_of ctxt)) + fun print pred () = + let + val _ = writeln ("predicate: " ^ pred) + val _ = writeln ("introrules: ") + val _ = fold (fn thm => fn _ => writeln (Display.string_of_thm ctxt thm)) + (rev (Core_Data.intros_of ctxt pred)) () + in + if Core_Data.has_elim ctxt pred then + writeln ("elimrule: " ^ Display.string_of_thm ctxt (Core_Data.the_elim_of ctxt pred)) + else + writeln ("no elimrule defined") + end in fold print preds () end; @@ -151,7 +151,7 @@ val _ = writeln ("modes: " ^ (commas (map string_of_mode modes))) in u end in - fold print (all_modes_of compilation ctxt) () + fold print (Core_Data.all_modes_of compilation ctxt) () end (* validity checks *) @@ -670,10 +670,10 @@ SOME (compile_arg compilation_modifiers additional_arguments ctxt param_modes t) | (_, Term Output) => NONE | (Const (name, T), Context mode) => - (case alternative_compilation_of ctxt name mode of + (case Core_Data.alternative_compilation_of ctxt name mode of SOME alt_comp => SOME (alt_comp compfuns T) | NONE => - SOME (Const (function_name_of (Comp_Mod.compilation compilation_modifiers) + SOME (Const (Core_Data.function_name_of (Comp_Mod.compilation compilation_modifiers) ctxt name mode, Comp_Mod.funT_of compilation_modifiers mode T))) | (Free (s, T), Context m) => @@ -1014,7 +1014,7 @@ foldr1 (mk_plus compfuns) cl_ts) end val fun_const = - Const (function_name_of (Comp_Mod.compilation compilation_modifiers) ctxt s mode, funT) + Const (Core_Data.function_name_of (Comp_Mod.compilation compilation_modifiers) ctxt s mode, funT) in HOLogic.mk_Trueprop (HOLogic.mk_eq (list_comb (fun_const, in_ts @ additional_arguments), compilation)) @@ -1023,7 +1023,7 @@ (* Definition of executable functions and their intro and elim rules *) -fun strip_split_abs (Const (@{const_name case_prod}, _) $ t) = strip_split_abs t +fun strip_split_abs (Const (@{const_name uncurry}, _) $ t) = strip_split_abs t | strip_split_abs (Abs (_, _, t)) = strip_split_abs t | strip_split_abs t = t @@ -1132,7 +1132,7 @@ val mode_cname = create_constname_of_mode options thy "" name T mode val mode_cbasename = Long_Name.base_name mode_cname val funT = funT_of compfuns mode T - val (args, _) = fold_map (mk_args true) ((strip_fun_mode mode) ~~ (binder_types T)) [] + val (args, _) = fold_map (mk_args true) (strip_fun_mode mode ~~ binder_types T) [] fun strip_eval _ t = let val t' = strip_split_abs t @@ -1152,13 +1152,13 @@ create_intro_elim_rule ctxt' mode definition mode_cname funT (Const (name, T)) in thy' - |> set_function_name Pred name mode mode_cname - |> add_predfun_data name mode (definition, rules) + |> Core_Data.set_function_name Pred name mode mode_cname + |> Core_Data.add_predfun_data name mode (definition, rules) |> Global_Theory.store_thm (Binding.name (mode_cbasename ^ "I"), intro) |> snd |> Global_Theory.store_thm (Binding.name (mode_cbasename ^ "E"), elim) |> snd end; in - thy |> defined_function_of Pred name |> fold create_definition modes + thy |> Core_Data.defined_function_of Pred name |> fold create_definition modes end; fun define_functions comp_modifiers _ options preds (name, modes) thy = @@ -1171,11 +1171,11 @@ val funT = Comp_Mod.funT_of comp_modifiers mode T in thy |> Sign.add_consts [(Binding.name (Long_Name.base_name mode_cname), funT, NoSyn)] - |> set_function_name (Comp_Mod.compilation comp_modifiers) name mode mode_cname + |> Core_Data.set_function_name (Comp_Mod.compilation comp_modifiers) name mode mode_cname end; in thy - |> defined_function_of (Comp_Mod.compilation comp_modifiers) name + |> Core_Data.defined_function_of (Comp_Mod.compilation comp_modifiers) name |> fold create_definition modes end; @@ -1220,7 +1220,7 @@ Syntax.string_of_term ctxt (c $ t)) | Sidecond t => Sidecond (c $ t)) | (Const (s, _), _) => - if is_registered ctxt s then Prem t else Sidecond t + if Core_Data.is_registered ctxt s then Prem t else Sidecond t | _ => Sidecond t) fun prepare_intrs options ctxt prednames intros = @@ -1334,18 +1334,18 @@ let val full_mode = fold_rev (curry Fun) (map (K Input) (binder_types T)) Bool in - if member eq_mode (modes_of Pred ctxt predname) full_mode then + if member eq_mode (Core_Data.modes_of Pred ctxt predname) full_mode then let val Ts = binder_types T val arg_names = Name.variant_list [] (map (fn i => "x" ^ string_of_int i) (1 upto length Ts)) val args = map2 (curry Free) arg_names Ts - val predfun = Const (function_name_of Pred ctxt predname full_mode, + val predfun = Const (Core_Data.function_name_of Pred ctxt predname full_mode, Ts ---> Predicate_Comp_Funs.mk_monadT @{typ unit}) val rhs = @{term Predicate.holds} $ (list_comb (predfun, args)) val eq_term = HOLogic.mk_Trueprop (HOLogic.mk_eq (list_comb (Const (predname, T), args), rhs)) - val def = predfun_definition_of ctxt predname full_mode + val def = Core_Data.predfun_definition_of ctxt predname full_mode val tac = fn _ => Simplifier.simp_tac (put_simpset HOL_basic_ss ctxt addsimps [def, @{thm holds_eq}, @{thm eval_pred}]) 1 val eq = Goal.prove ctxt arg_names [] eq_term tac @@ -1387,18 +1387,18 @@ (*val _ = map (check_format_of_intro_rule thy) (maps (intros_of thy) prednames)*) val _ = if show_intermediate_results options then - tracing (commas (map (Display.string_of_thm ctxt) (maps (intros_of ctxt) prednames))) + tracing (commas (map (Display.string_of_thm ctxt) (maps (Core_Data.intros_of ctxt) prednames))) else () val (preds, all_vs, param_vs, all_modes, clauses) = - prepare_intrs options ctxt prednames (maps (intros_of ctxt) prednames) + prepare_intrs options ctxt prednames (maps (Core_Data.intros_of ctxt) prednames) val _ = print_step options "Infering modes..." - val (lookup_mode, lookup_neg_mode, needs_random) = (modes_of compilation ctxt, - modes_of (negative_compilation_of compilation) ctxt, needs_random ctxt) + val (lookup_mode, lookup_neg_mode, needs_random) = (Core_Data.modes_of compilation ctxt, + Core_Data.modes_of (negative_compilation_of compilation) ctxt, Core_Data.needs_random ctxt) val ((moded_clauses, needs_random), errors) = cond_timeit (Config.get ctxt Quickcheck.timing) "Infering modes" (fn _ => infer_modes mode_analysis_options options (lookup_mode, lookup_neg_mode, needs_random) ctxt preds all_modes param_vs clauses) - val thy' = fold (fn (s, ms) => set_needs_random s ms) needs_random thy + val thy' = fold (fn (s, ms) => Core_Data.set_needs_random s ms) needs_random thy val modes = map (fn (p, mps) => (p, map fst mps)) moded_clauses val _ = check_expected_modes options preds modes val _ = check_proposed_modes options preds modes errors @@ -1435,12 +1435,12 @@ fun gen_add_equations steps options names thy = let fun dest_steps (Steps s) = s - val defined = defined_functions (Comp_Mod.compilation (#comp_modifiers (dest_steps steps))) - val thy' = extend_intro_graph names thy; + val defined = Core_Data.defined_functions (Comp_Mod.compilation (#comp_modifiers (dest_steps steps))) + val thy' = Core_Data.extend_intro_graph names thy; fun strong_conn_of gr keys = Graph.strong_conn (Graph.restrict (member (op =) (Graph.all_succs gr keys)) gr) - val scc = strong_conn_of (PredData.get thy') names - val thy'' = fold preprocess_intros (flat scc) thy' + val scc = strong_conn_of (Core_Data.PredData.get thy') names + val thy'' = fold Core_Data.preprocess_intros (flat scc) thy' val thy''' = fold_rev (fn preds => fn thy => if not (forall (defined (Proof_Context.init_global thy)) preds) then @@ -1601,7 +1601,7 @@ fun attrib' f opt_case_name = Thm.declaration_attribute (fn thm => Context.mapping (f (opt_case_name, thm)) I); -val code_pred_intro_attrib = attrib' add_intro NONE; +val code_pred_intro_attrib = attrib' Core_Data.add_intro NONE; (*FIXME - Naming of auxiliary rules necessary? @@ -1616,8 +1616,9 @@ val _ = Theory.setup - (PredData.put (Graph.empty) #> - Attrib.setup @{binding code_pred_intro} (Scan.lift (Scan.option Args.name) >> attrib' add_intro) + (Core_Data.PredData.put (Graph.empty) #> + Attrib.setup @{binding code_pred_intro} + (Scan.lift (Scan.option Args.name) >> attrib' Core_Data.add_intro) "adding alternative introduction rules for code generation of inductive predicates") (* TODO: make Theory_Data to Generic_Data & remove duplication of local theory and theory *) @@ -1626,15 +1627,16 @@ let val thy = Proof_Context.theory_of lthy val const = prep_const thy raw_const - val lthy' = Local_Theory.background_theory (extend_intro_graph [const]) lthy + val lthy' = Local_Theory.background_theory (Core_Data.extend_intro_graph [const]) lthy val thy' = Proof_Context.theory_of lthy' val ctxt' = Proof_Context.init_global thy' - val preds = Graph.all_succs (PredData.get thy') [const] |> filter_out (has_elim ctxt') + val preds = + Graph.all_succs (Core_Data.PredData.get thy') [const] |> filter_out (Core_Data.has_elim ctxt') fun mk_cases const = let val T = Sign.the_const_type thy' const val pred = Const (const, T) - val intros = intros_of ctxt' const + val intros = Core_Data.intros_of ctxt' const in mk_casesrule lthy' pred intros end val cases_rules = map mk_cases preds val cases = @@ -1644,7 +1646,7 @@ assumes = ("that", tl (Logic.strip_imp_prems case_rule)) :: map_filter (fn (fact_name, fact) => Option.map (fn a => (a, [fact])) fact_name) - ((SOME "prems" :: names_of ctxt' pred_name) ~~ Logic.strip_imp_prems case_rule), + ((SOME "prems" :: Core_Data.names_of ctxt' pred_name) ~~ Logic.strip_imp_prems case_rule), binds = [], cases = []}) preds cases_rules val case_env = map2 (fn p => fn c => (Long_Name.base_name p, SOME c)) preds cases val lthy'' = lthy' @@ -1655,7 +1657,7 @@ val global_thms = Proof_Context.export goal_ctxt (Proof_Context.init_global (Proof_Context.theory_of goal_ctxt)) (map the_single thms) in - goal_ctxt |> Local_Theory.background_theory (fold set_elim global_thms #> + goal_ctxt |> Local_Theory.background_theory (fold Core_Data.set_elim global_thms #> ((case compilation options of Pred => add_equations | DSeq => add_dseq_equations @@ -1762,7 +1764,7 @@ (compilation, _) t_compr = let val compfuns = Comp_Mod.compfuns comp_modifiers - val all_modes_of = all_modes_of compilation + val all_modes_of = Core_Data.all_modes_of compilation val (((body, output), T_compr), output_names) = (case try dest_special_compr t_compr of SOME r => r @@ -1772,7 +1774,7 @@ (Const (name, T), all_args) => (Const (name, T), all_args) | (head, _) => error ("Not a constant: " ^ Syntax.string_of_term ctxt head)) in - if defined_functions compilation ctxt name then + if Core_Data.defined_functions compilation ctxt name then let fun extract_mode (Const (@{const_name Pair}, _) $ t1 $ t2) = Pair (extract_mode t1, extract_mode t2) @@ -1878,7 +1880,6 @@ @{term natural_of_nat} $ (HOLogic.size_const T $ Bound 0)))) t else mk_map compfuns T HOLogic.termT (HOLogic.term_of_const T) t - val thy = Proof_Context.theory_of ctxt val time_limit = seconds (Config.get ctxt values_timeout) val (ts, statistics) = (case compilation of diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Predicate_Compile/predicate_compile_proof.ML --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_proof.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_proof.ML Fri Sep 18 16:42:19 2015 +0100 @@ -12,14 +12,13 @@ -> (string * (term list * indprem list) list) list -> (string * typ) list -> string -> bool * mode -> (term list * (indprem * Mode_Inference.mode_derivation) list) list * term - -> Thm.thm + -> thm end; structure Predicate_Compile_Proof : PREDICATE_COMPILE_PROOF = struct open Predicate_Compile_Aux; -open Core_Data; open Mode_Inference; @@ -62,7 +61,7 @@ val f_tac = (case f of Const (name, _) => simp_tac (put_simpset HOL_basic_ss ctxt addsimps - [@{thm eval_pred}, predfun_definition_of ctxt name mode, + [@{thm eval_pred}, Core_Data.predfun_definition_of ctxt name mode, @{thm split_eta}, @{thm split_beta}, @{thm fst_conv}, @{thm snd_conv}, @{thm pair_collapse}, @{thm Product_Type.split_conv}]) 1 | Free _ => @@ -88,7 +87,7 @@ (Const (name, _), args) => let val mode = head_mode_of deriv - val introrule = predfun_intro_of ctxt name mode + val introrule = Core_Data.predfun_intro_of ctxt name mode val param_derivations = param_derivations_of deriv val ho_args = ho_args_of mode args in @@ -170,12 +169,12 @@ fun preds_of t nameTs = (case strip_comb t of (Const (name, T), args) => - if is_registered ctxt name then (name, T) :: nameTs - else fold preds_of args nameTs + if Core_Data.is_registered ctxt name then (name, T) :: nameTs + else fold preds_of args nameTs | _ => nameTs) val preds = preds_of t [] val defs = map - (fn (pred, T) => predfun_definition_of ctxt pred + (fn (pred, T) => Core_Data.predfun_definition_of ctxt pred (all_input_of T)) preds in @@ -227,7 +226,7 @@ val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE) val neg_intro_rule = Option.map (fn name => - the (predfun_neg_intro_of ctxt name mode)) name + the (Core_Data.predfun_neg_intro_of ctxt name mode)) name val param_derivations = param_derivations_of deriv val params = ho_args_of mode args in @@ -278,11 +277,11 @@ let val T = the (AList.lookup (op =) preds pred) val nargs = length (binder_types T) - val pred_case_rule = the_elim_of ctxt pred + val pred_case_rule = Core_Data.the_elim_of ctxt pred in REPEAT_DETERM (CHANGED (rewrite_goals_tac ctxt @{thms split_paired_all})) THEN trace_tac ctxt options "before applying elim rule" - THEN eresolve_tac ctxt [predfun_elim_of ctxt pred mode] 1 + THEN eresolve_tac ctxt [Core_Data.predfun_elim_of ctxt pred mode] 1 THEN eresolve_tac ctxt [pred_case_rule] 1 THEN trace_tac ctxt options "after applying elim rule" THEN (EVERY (map @@ -338,8 +337,8 @@ val f_tac = (case f of Const (name, _) => full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps - (@{thm eval_pred}::(predfun_definition_of ctxt name mode) - :: @{thm "Product_Type.split_conv"}::[])) 1 + [@{thm eval_pred}, Core_Data.predfun_definition_of ctxt name mode, + @{thm Product_Type.split_conv}]) 1 | Free _ => all_tac | _ => error "prove_param2: illegal parameter term") in @@ -360,7 +359,7 @@ eresolve_tac ctxt @{thms bindE} 1 THEN (REPEAT_DETERM (CHANGED (rewrite_goals_tac ctxt @{thms split_paired_all}))) THEN trace_tac ctxt options "prove_expr2-before" - THEN eresolve_tac ctxt [predfun_elim_of ctxt name mode] 1 + THEN eresolve_tac ctxt [Core_Data.predfun_elim_of ctxt name mode] 1 THEN trace_tac ctxt options "prove_expr2" THEN (EVERY (map2 (prove_param2 options ctxt) ho_args param_derivations)) THEN trace_tac ctxt options "finished prove_expr2" @@ -372,12 +371,12 @@ fun preds_of t nameTs = (case strip_comb t of (Const (name, T), args) => - if is_registered ctxt name then (name, T) :: nameTs - else fold preds_of args nameTs + if Core_Data.is_registered ctxt name then (name, T) :: nameTs + else fold preds_of args nameTs | _ => nameTs) val preds = preds_of t [] val defs = map - (fn (pred, T) => predfun_definition_of ctxt pred + (fn (pred, T) => Core_Data.predfun_definition_of ctxt pred (all_input_of T)) preds in @@ -389,7 +388,7 @@ fun prove_clause2 options ctxt pred mode (ts, ps) i = let - val pred_intro_rule = nth (intros_of ctxt pred) (i - 1) + val pred_intro_rule = nth (Core_Data.intros_of ctxt pred) (i - 1) val (in_ts, _) = split_mode mode ts; val split_simpset = put_simpset HOL_basic_ss' ctxt @@ -441,9 +440,9 @@ THEN eresolve_tac ctxt @{thms bindE} 1 THEN (if is_some name then full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps - [predfun_definition_of ctxt (the name) mode]) 1 + [Core_Data.predfun_definition_of ctxt (the name) mode]) 1 THEN eresolve_tac ctxt @{thms not_predE} 1 - THEN simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm not_False_eq_True}]) 1 + THEN simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms not_False_eq_True}) 1 THEN (EVERY (map2 (prove_param2 options ctxt) ho_args param_derivations)) else eresolve_tac ctxt @{thms not_predE'} 1) @@ -478,7 +477,7 @@ in (DETERM (TRY (resolve_tac ctxt @{thms unit.induct} 1))) THEN (REPEAT_DETERM (CHANGED (rewrite_goals_tac ctxt @{thms split_paired_all}))) - THEN (resolve_tac ctxt [predfun_intro_of ctxt pred mode] 1) + THEN (resolve_tac ctxt [Core_Data.predfun_intro_of ctxt pred mode] 1) THEN (REPEAT_DETERM (resolve_tac ctxt @{thms refl} 2)) THEN ( if null moded_clauses then eresolve_tac ctxt @{thms botE} 1 diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML Fri Sep 18 16:42:19 2015 +0100 @@ -26,7 +26,7 @@ val put_cps_result : (unit -> Code_Numeral.natural -> (bool * term list) option) -> Proof.context -> Proof.context val test_goals : (Predicate_Compile_Aux.compilation * bool) -> - Proof.context -> bool * bool -> (string * typ) list -> (term * term list) list -> + Proof.context -> bool -> (string * typ) list -> (term * term list) list -> Quickcheck.result list val nrandom : int Unsynchronized.ref val debug : bool Unsynchronized.ref diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Qelim/cooper.ML --- a/src/HOL/Tools/Qelim/cooper.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Qelim/cooper.ML Fri Sep 18 16:42:19 2015 +0100 @@ -635,7 +635,7 @@ | fm_of_term ps vs (@{term "op = :: bool => _ "} $ t1 $ t2) = Proc.Iff (fm_of_term ps vs t1, fm_of_term ps vs t2) | fm_of_term ps vs (Const (@{const_name Not}, _) $ t') = - Proc.Not (fm_of_term ps vs t') + Proc.NOT (fm_of_term ps vs t') | fm_of_term ps vs (Const (@{const_name Ex}, _) $ Abs abs) = Proc.E (uncurry (fm_of_term ps) (descend vs abs)) | fm_of_term ps vs (Const (@{const_name All}, _) $ Abs abs) = @@ -663,7 +663,7 @@ @{term "op - :: int => _"} $ term_of_num vs t1 $ term_of_num vs t2 | term_of_num vs (Proc.Mul (i, t2)) = @{term "op * :: int => _"} $ HOLogic.mk_number HOLogic.intT (Proc.integer_of_int i) $ term_of_num vs t2 - | term_of_num vs (Proc.Cn (n, i, t')) = + | term_of_num vs (Proc.CN (n, i, t')) = term_of_num vs (Proc.Add (Proc.Mul (i, Proc.Bound n), t')); fun term_of_fm ps vs Proc.T = @{term True} @@ -672,18 +672,18 @@ | term_of_fm ps vs (Proc.Or (t1, t2)) = HOLogic.disj $ term_of_fm ps vs t1 $ term_of_fm ps vs t2 | term_of_fm ps vs (Proc.Imp (t1, t2)) = HOLogic.imp $ term_of_fm ps vs t1 $ term_of_fm ps vs t2 | term_of_fm ps vs (Proc.Iff (t1, t2)) = @{term "op = :: bool => _"} $ term_of_fm ps vs t1 $ term_of_fm ps vs t2 - | term_of_fm ps vs (Proc.Not t') = HOLogic.Not $ term_of_fm ps vs t' + | term_of_fm ps vs (Proc.NOT t') = HOLogic.Not $ term_of_fm ps vs t' | term_of_fm ps vs (Proc.Eq t') = @{term "op = :: int => _ "} $ term_of_num vs t'$ @{term "0::int"} - | term_of_fm ps vs (Proc.NEq t') = term_of_fm ps vs (Proc.Not (Proc.Eq t')) + | term_of_fm ps vs (Proc.NEq t') = term_of_fm ps vs (Proc.NOT (Proc.Eq t')) | term_of_fm ps vs (Proc.Lt t') = @{term "op < :: int => _ "} $ term_of_num vs t' $ @{term "0::int"} | term_of_fm ps vs (Proc.Le t') = @{term "op <= :: int => _ "} $ term_of_num vs t' $ @{term "0::int"} | term_of_fm ps vs (Proc.Gt t') = @{term "op < :: int => _ "} $ @{term "0::int"} $ term_of_num vs t' | term_of_fm ps vs (Proc.Ge t') = @{term "op <= :: int => _ "} $ @{term "0::int"} $ term_of_num vs t' | term_of_fm ps vs (Proc.Dvd (i, t')) = @{term "op dvd :: int => _ "} $ HOLogic.mk_number HOLogic.intT (Proc.integer_of_int i) $ term_of_num vs t' - | term_of_fm ps vs (Proc.NDvd (i, t')) = term_of_fm ps vs (Proc.Not (Proc.Dvd (i, t'))) + | term_of_fm ps vs (Proc.NDvd (i, t')) = term_of_fm ps vs (Proc.NOT (Proc.Dvd (i, t'))) | term_of_fm ps vs (Proc.Closed n) = nth ps (Proc.integer_of_nat n) - | term_of_fm ps vs (Proc.NClosed n) = term_of_fm ps vs (Proc.Not (Proc.Closed n)); + | term_of_fm ps vs (Proc.NClosed n) = term_of_fm ps vs (Proc.NOT (Proc.Closed n)); fun procedure t = let diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Qelim/cooper_procedure.ML --- a/src/HOL/Tools/Qelim/cooper_procedure.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Qelim/cooper_procedure.ML Fri Sep 18 16:42:19 2015 +0100 @@ -5,11 +5,11 @@ val integer_of_int : inta -> int type nat val integer_of_nat : nat -> int - datatype numa = C of inta | Bound of nat | Cn of nat * inta * numa | + datatype numa = C of inta | Bound of nat | CN of nat * inta * numa | Neg of numa | Add of numa * numa | Sub of numa * numa | Mul of inta * numa datatype fm = T | F | Lt of numa | Le of numa | Gt of numa | Ge of numa | Eq of numa | NEq of numa | Dvd of inta * numa | NDvd of inta * numa | - Not of fm | And of fm * fm | Or of fm * fm | Imp of fm * fm | Iff of fm * fm + NOT of fm | And of fm * fm | Or of fm * fm | Imp of fm * fm | Iff of fm * fm | E of fm | A of fm | Closed of nat | NClosed of nat val pa : fm -> fm val nat_of_integer : int -> nat @@ -48,26 +48,34 @@ val one_int = {one = one_inta} : inta one; fun sgn_integer k = - (if k = 0 then 0 - else (if k < 0 then (~1 : IntInf.int) else (1 : IntInf.int))); + (if k = (0 : IntInf.int) then (0 : IntInf.int) + else (if k < (0 : IntInf.int) then (~1 : IntInf.int) + else (1 : IntInf.int))); -fun abs_integer k = (if k < 0 then ~ k else k); +fun abs_integer k = (if k < (0 : IntInf.int) then ~ k else k); fun apsnd f (x, y) = (x, f y); fun divmod_integer k l = - (if k = 0 then (0, 0) - else (if l = 0 then (0, k) + (if k = (0 : IntInf.int) then ((0 : IntInf.int), (0 : IntInf.int)) + else (if l = (0 : IntInf.int) then ((0 : IntInf.int), k) else (apsnd o (fn a => fn b => a * b) o sgn_integer) l (if sgn_integer k = sgn_integer l then Integer.div_mod (abs k) (abs l) else let val (r, s) = Integer.div_mod (abs k) (abs l); in - (if s = 0 then (~ r, 0) + (if s = (0 : IntInf.int) then (~ r, (0 : IntInf.int)) else (~ r - (1 : IntInf.int), abs_integer l - s)) end))); +fun fst (x1, x2) = x1; + +fun divide_integer k l = fst (divmod_integer k l); + +fun divide_inta k l = + Int_of_integer (divide_integer (integer_of_int k) (integer_of_int l)); + fun snd (x1, x2) = x2; fun mod_integer k l = snd (divmod_integer k l); @@ -75,19 +83,19 @@ fun mod_int k l = Int_of_integer (mod_integer (integer_of_int k) (integer_of_int l)); -fun fst (x1, x2) = x1; - -fun div_integer k l = fst (divmod_integer k l); +type 'a divide = {divide : 'a -> 'a -> 'a}; +val divide = #divide : 'a divide -> 'a -> 'a -> 'a; -fun div_inta k l = - Int_of_integer (div_integer (integer_of_int k) (integer_of_int l)); - -type 'a diva = {dvd_div : 'a dvd, diva : 'a -> 'a -> 'a, moda : 'a -> 'a -> 'a}; +type 'a diva = + {divide_div : 'a divide, dvd_div : 'a dvd, moda : 'a -> 'a -> 'a}; +val divide_div = #divide_div : 'a diva -> 'a divide; val dvd_div = #dvd_div : 'a diva -> 'a dvd; -val diva = #diva : 'a diva -> 'a -> 'a -> 'a; val moda = #moda : 'a diva -> 'a -> 'a -> 'a; -val div_int = {dvd_div = dvd_int, diva = div_inta, moda = mod_int} : inta diva; +val divide_int = {divide = divide_inta} : inta divide; + +val div_int = {divide_div = divide_int, dvd_div = dvd_int, moda = mod_int} : + inta diva; fun plus_inta k l = Int_of_integer (integer_of_int k + integer_of_int l); @@ -96,7 +104,7 @@ val plus_int = {plus = plus_inta} : inta plus; -val zero_inta : inta = Int_of_integer 0; +val zero_inta : inta = Int_of_integer (0 : IntInf.int); type 'a zero = {zero : 'a}; val zero = #zero : 'a zero -> 'a; @@ -124,40 +132,17 @@ val power_int = {one_power = one_int, times_power = times_int} : inta power; +fun minus_inta k l = Int_of_integer (integer_of_int k - integer_of_int l); + +type 'a minus = {minus : 'a -> 'a -> 'a}; +val minus = #minus : 'a minus -> 'a -> 'a -> 'a; + +val minus_int = {minus = minus_inta} : inta minus; + type 'a ab_semigroup_add = {semigroup_add_ab_semigroup_add : 'a semigroup_add}; val semigroup_add_ab_semigroup_add = #semigroup_add_ab_semigroup_add : 'a ab_semigroup_add -> 'a semigroup_add; -type 'a semigroup_mult = {times_semigroup_mult : 'a times}; -val times_semigroup_mult = #times_semigroup_mult : - 'a semigroup_mult -> 'a times; - -type 'a semiring = - {ab_semigroup_add_semiring : 'a ab_semigroup_add, - semigroup_mult_semiring : 'a semigroup_mult}; -val ab_semigroup_add_semiring = #ab_semigroup_add_semiring : - 'a semiring -> 'a ab_semigroup_add; -val semigroup_mult_semiring = #semigroup_mult_semiring : - 'a semiring -> 'a semigroup_mult; - -val ab_semigroup_add_int = {semigroup_add_ab_semigroup_add = semigroup_add_int} - : inta ab_semigroup_add; - -val semigroup_mult_int = {times_semigroup_mult = times_int} : - inta semigroup_mult; - -val semiring_int = - {ab_semigroup_add_semiring = ab_semigroup_add_int, - semigroup_mult_semiring = semigroup_mult_int} - : inta semiring; - -type 'a mult_zero = {times_mult_zero : 'a times, zero_mult_zero : 'a zero}; -val times_mult_zero = #times_mult_zero : 'a mult_zero -> 'a times; -val zero_mult_zero = #zero_mult_zero : 'a mult_zero -> 'a zero; - -val mult_zero_int = {times_mult_zero = times_int, zero_mult_zero = zero_int} : - inta mult_zero; - type 'a monoid_add = {semigroup_add_monoid_add : 'a semigroup_add, zero_monoid_add : 'a zero}; val semigroup_add_monoid_add = #semigroup_add_monoid_add : @@ -172,6 +157,22 @@ val monoid_add_comm_monoid_add = #monoid_add_comm_monoid_add : 'a comm_monoid_add -> 'a monoid_add; +type 'a mult_zero = {times_mult_zero : 'a times, zero_mult_zero : 'a zero}; +val times_mult_zero = #times_mult_zero : 'a mult_zero -> 'a times; +val zero_mult_zero = #zero_mult_zero : 'a mult_zero -> 'a zero; + +type 'a semigroup_mult = {times_semigroup_mult : 'a times}; +val times_semigroup_mult = #times_semigroup_mult : + 'a semigroup_mult -> 'a times; + +type 'a semiring = + {ab_semigroup_add_semiring : 'a ab_semigroup_add, + semigroup_mult_semiring : 'a semigroup_mult}; +val ab_semigroup_add_semiring = #ab_semigroup_add_semiring : + 'a semiring -> 'a ab_semigroup_add; +val semigroup_mult_semiring = #semigroup_mult_semiring : + 'a semiring -> 'a semigroup_mult; + type 'a semiring_0 = {comm_monoid_add_semiring_0 : 'a comm_monoid_add, mult_zero_semiring_0 : 'a mult_zero, semiring_semiring_0 : 'a semiring}; @@ -181,19 +182,10 @@ 'a semiring_0 -> 'a mult_zero; val semiring_semiring_0 = #semiring_semiring_0 : 'a semiring_0 -> 'a semiring; -val monoid_add_int = - {semigroup_add_monoid_add = semigroup_add_int, zero_monoid_add = zero_int} : - inta monoid_add; - -val comm_monoid_add_int = - {ab_semigroup_add_comm_monoid_add = ab_semigroup_add_int, - monoid_add_comm_monoid_add = monoid_add_int} - : inta comm_monoid_add; - -val semiring_0_int = - {comm_monoid_add_semiring_0 = comm_monoid_add_int, - mult_zero_semiring_0 = mult_zero_int, semiring_semiring_0 = semiring_int} - : inta semiring_0; +type 'a semiring_no_zero_divisors = + {semiring_0_semiring_no_zero_divisors : 'a semiring_0}; +val semiring_0_semiring_no_zero_divisors = #semiring_0_semiring_no_zero_divisors + : 'a semiring_no_zero_divisors -> 'a semiring_0; type 'a monoid_mult = {semigroup_mult_monoid_mult : 'a semigroup_mult, @@ -228,48 +220,16 @@ val zero_neq_one_semiring_1 = #zero_neq_one_semiring_1 : 'a semiring_1 -> 'a zero_neq_one; -val monoid_mult_int = - {semigroup_mult_monoid_mult = semigroup_mult_int, - power_monoid_mult = power_int} - : inta monoid_mult; - -val semiring_numeral_int = - {monoid_mult_semiring_numeral = monoid_mult_int, - numeral_semiring_numeral = numeral_int, - semiring_semiring_numeral = semiring_int} - : inta semiring_numeral; - -val zero_neq_one_int = - {one_zero_neq_one = one_int, zero_zero_neq_one = zero_int} : - inta zero_neq_one; - -val semiring_1_int = - {semiring_numeral_semiring_1 = semiring_numeral_int, - semiring_0_semiring_1 = semiring_0_int, - zero_neq_one_semiring_1 = zero_neq_one_int} - : inta semiring_1; - -type 'a ab_semigroup_mult = - {semigroup_mult_ab_semigroup_mult : 'a semigroup_mult}; -val semigroup_mult_ab_semigroup_mult = #semigroup_mult_ab_semigroup_mult : - 'a ab_semigroup_mult -> 'a semigroup_mult; - -type 'a comm_semiring = - {ab_semigroup_mult_comm_semiring : 'a ab_semigroup_mult, - semiring_comm_semiring : 'a semiring}; -val ab_semigroup_mult_comm_semiring = #ab_semigroup_mult_comm_semiring : - 'a comm_semiring -> 'a ab_semigroup_mult; -val semiring_comm_semiring = #semiring_comm_semiring : - 'a comm_semiring -> 'a semiring; - -val ab_semigroup_mult_int = - {semigroup_mult_ab_semigroup_mult = semigroup_mult_int} : - inta ab_semigroup_mult; - -val comm_semiring_int = - {ab_semigroup_mult_comm_semiring = ab_semigroup_mult_int, - semiring_comm_semiring = semiring_int} - : inta comm_semiring; +type 'a semiring_1_no_zero_divisors = + {semiring_1_semiring_1_no_zero_divisors : 'a semiring_1, + semiring_no_zero_divisors_semiring_1_no_zero_divisors : + 'a semiring_no_zero_divisors}; +val semiring_1_semiring_1_no_zero_divisors = + #semiring_1_semiring_1_no_zero_divisors : + 'a semiring_1_no_zero_divisors -> 'a semiring_1; +val semiring_no_zero_divisors_semiring_1_no_zero_divisors = + #semiring_no_zero_divisors_semiring_1_no_zero_divisors : + 'a semiring_1_no_zero_divisors -> 'a semiring_no_zero_divisors; type 'a cancel_semigroup_add = {semigroup_add_cancel_semigroup_add : 'a semigroup_add}; @@ -278,13 +238,16 @@ type 'a cancel_ab_semigroup_add = {ab_semigroup_add_cancel_ab_semigroup_add : 'a ab_semigroup_add, - cancel_semigroup_add_cancel_ab_semigroup_add : 'a cancel_semigroup_add}; + cancel_semigroup_add_cancel_ab_semigroup_add : 'a cancel_semigroup_add, + minus_cancel_ab_semigroup_add : 'a minus}; val ab_semigroup_add_cancel_ab_semigroup_add = #ab_semigroup_add_cancel_ab_semigroup_add : 'a cancel_ab_semigroup_add -> 'a ab_semigroup_add; val cancel_semigroup_add_cancel_ab_semigroup_add = #cancel_semigroup_add_cancel_ab_semigroup_add : 'a cancel_ab_semigroup_add -> 'a cancel_semigroup_add; +val minus_cancel_ab_semigroup_add = #minus_cancel_ab_semigroup_add : + 'a cancel_ab_semigroup_add -> 'a minus; type 'a cancel_comm_monoid_add = {cancel_ab_semigroup_add_cancel_comm_monoid_add : 'a cancel_ab_semigroup_add, @@ -305,6 +268,19 @@ val semiring_0_semiring_0_cancel = #semiring_0_semiring_0_cancel : 'a semiring_0_cancel -> 'a semiring_0; +type 'a ab_semigroup_mult = + {semigroup_mult_ab_semigroup_mult : 'a semigroup_mult}; +val semigroup_mult_ab_semigroup_mult = #semigroup_mult_ab_semigroup_mult : + 'a ab_semigroup_mult -> 'a semigroup_mult; + +type 'a comm_semiring = + {ab_semigroup_mult_comm_semiring : 'a ab_semigroup_mult, + semiring_comm_semiring : 'a semiring}; +val ab_semigroup_mult_comm_semiring = #ab_semigroup_mult_comm_semiring : + 'a comm_semiring -> 'a ab_semigroup_mult; +val semiring_comm_semiring = #semiring_comm_semiring : + 'a comm_semiring -> 'a semiring; + type 'a comm_semiring_0 = {comm_semiring_comm_semiring_0 : 'a comm_semiring, semiring_0_comm_semiring_0 : 'a semiring_0}; @@ -333,21 +309,23 @@ type 'a comm_monoid_mult = {ab_semigroup_mult_comm_monoid_mult : 'a ab_semigroup_mult, - monoid_mult_comm_monoid_mult : 'a monoid_mult}; + monoid_mult_comm_monoid_mult : 'a monoid_mult, + dvd_comm_monoid_mult : 'a dvd}; val ab_semigroup_mult_comm_monoid_mult = #ab_semigroup_mult_comm_monoid_mult : 'a comm_monoid_mult -> 'a ab_semigroup_mult; val monoid_mult_comm_monoid_mult = #monoid_mult_comm_monoid_mult : 'a comm_monoid_mult -> 'a monoid_mult; +val dvd_comm_monoid_mult = #dvd_comm_monoid_mult : + 'a comm_monoid_mult -> 'a dvd; type 'a comm_semiring_1 = {comm_monoid_mult_comm_semiring_1 : 'a comm_monoid_mult, comm_semiring_0_comm_semiring_1 : 'a comm_semiring_0, - dvd_comm_semiring_1 : 'a dvd, semiring_1_comm_semiring_1 : 'a semiring_1}; + semiring_1_comm_semiring_1 : 'a semiring_1}; val comm_monoid_mult_comm_semiring_1 = #comm_monoid_mult_comm_semiring_1 : 'a comm_semiring_1 -> 'a comm_monoid_mult; val comm_semiring_0_comm_semiring_1 = #comm_semiring_0_comm_semiring_1 : 'a comm_semiring_1 -> 'a comm_semiring_0; -val dvd_comm_semiring_1 = #dvd_comm_semiring_1 : 'a comm_semiring_1 -> 'a dvd; val semiring_1_comm_semiring_1 = #semiring_1_comm_semiring_1 : 'a comm_semiring_1 -> 'a semiring_1; @@ -365,22 +343,72 @@ #semiring_1_cancel_comm_semiring_1_cancel : 'a comm_semiring_1_cancel -> 'a semiring_1_cancel; -type 'a no_zero_divisors = - {times_no_zero_divisors : 'a times, zero_no_zero_divisors : 'a zero}; -val times_no_zero_divisors = #times_no_zero_divisors : - 'a no_zero_divisors -> 'a times; -val zero_no_zero_divisors = #zero_no_zero_divisors : - 'a no_zero_divisors -> 'a zero; +type 'a semidom = + {semiring_1_no_zero_divisors_semidom : 'a semiring_1_no_zero_divisors, + comm_semiring_1_cancel_semidom : 'a comm_semiring_1_cancel}; +val semiring_1_no_zero_divisors_semidom = #semiring_1_no_zero_divisors_semidom : + 'a semidom -> 'a semiring_1_no_zero_divisors; +val comm_semiring_1_cancel_semidom = #comm_semiring_1_cancel_semidom : + 'a semidom -> 'a comm_semiring_1_cancel; + +val ab_semigroup_add_int = {semigroup_add_ab_semigroup_add = semigroup_add_int} + : inta ab_semigroup_add; + +val monoid_add_int = + {semigroup_add_monoid_add = semigroup_add_int, zero_monoid_add = zero_int} : + inta monoid_add; + +val comm_monoid_add_int = + {ab_semigroup_add_comm_monoid_add = ab_semigroup_add_int, + monoid_add_comm_monoid_add = monoid_add_int} + : inta comm_monoid_add; + +val mult_zero_int = {times_mult_zero = times_int, zero_mult_zero = zero_int} : + inta mult_zero; + +val semigroup_mult_int = {times_semigroup_mult = times_int} : + inta semigroup_mult; + +val semiring_int = + {ab_semigroup_add_semiring = ab_semigroup_add_int, + semigroup_mult_semiring = semigroup_mult_int} + : inta semiring; -type 'a semiring_div = - {div_semiring_div : 'a diva, - comm_semiring_1_cancel_semiring_div : 'a comm_semiring_1_cancel, - no_zero_divisors_semiring_div : 'a no_zero_divisors}; -val div_semiring_div = #div_semiring_div : 'a semiring_div -> 'a diva; -val comm_semiring_1_cancel_semiring_div = #comm_semiring_1_cancel_semiring_div : - 'a semiring_div -> 'a comm_semiring_1_cancel; -val no_zero_divisors_semiring_div = #no_zero_divisors_semiring_div : - 'a semiring_div -> 'a no_zero_divisors; +val semiring_0_int = + {comm_monoid_add_semiring_0 = comm_monoid_add_int, + mult_zero_semiring_0 = mult_zero_int, semiring_semiring_0 = semiring_int} + : inta semiring_0; + +val semiring_no_zero_divisors_int = + {semiring_0_semiring_no_zero_divisors = semiring_0_int} : + inta semiring_no_zero_divisors; + +val monoid_mult_int = + {semigroup_mult_monoid_mult = semigroup_mult_int, + power_monoid_mult = power_int} + : inta monoid_mult; + +val semiring_numeral_int = + {monoid_mult_semiring_numeral = monoid_mult_int, + numeral_semiring_numeral = numeral_int, + semiring_semiring_numeral = semiring_int} + : inta semiring_numeral; + +val zero_neq_one_int = + {one_zero_neq_one = one_int, zero_zero_neq_one = zero_int} : + inta zero_neq_one; + +val semiring_1_int = + {semiring_numeral_semiring_1 = semiring_numeral_int, + semiring_0_semiring_1 = semiring_0_int, + zero_neq_one_semiring_1 = zero_neq_one_int} + : inta semiring_1; + +val semiring_1_no_zero_divisors_int = + {semiring_1_semiring_1_no_zero_divisors = semiring_1_int, + semiring_no_zero_divisors_semiring_1_no_zero_divisors = + semiring_no_zero_divisors_int} + : inta semiring_1_no_zero_divisors; val cancel_semigroup_add_int = {semigroup_add_cancel_semigroup_add = semigroup_add_int} : @@ -388,7 +416,8 @@ val cancel_ab_semigroup_add_int = {ab_semigroup_add_cancel_ab_semigroup_add = ab_semigroup_add_int, - cancel_semigroup_add_cancel_ab_semigroup_add = cancel_semigroup_add_int} + cancel_semigroup_add_cancel_ab_semigroup_add = cancel_semigroup_add_int, + minus_cancel_ab_semigroup_add = minus_int} : inta cancel_ab_semigroup_add; val cancel_comm_monoid_add_int = @@ -401,6 +430,15 @@ semiring_0_semiring_0_cancel = semiring_0_int} : inta semiring_0_cancel; +val ab_semigroup_mult_int = + {semigroup_mult_ab_semigroup_mult = semigroup_mult_int} : + inta ab_semigroup_mult; + +val comm_semiring_int = + {ab_semigroup_mult_comm_semiring = ab_semigroup_mult_int, + semiring_comm_semiring = semiring_int} + : inta comm_semiring; + val comm_semiring_0_int = {comm_semiring_comm_semiring_0 = comm_semiring_int, semiring_0_comm_semiring_0 = semiring_0_int} @@ -418,13 +456,14 @@ val comm_monoid_mult_int = {ab_semigroup_mult_comm_monoid_mult = ab_semigroup_mult_int, - monoid_mult_comm_monoid_mult = monoid_mult_int} + monoid_mult_comm_monoid_mult = monoid_mult_int, + dvd_comm_monoid_mult = dvd_int} : inta comm_monoid_mult; val comm_semiring_1_int = {comm_monoid_mult_comm_semiring_1 = comm_monoid_mult_int, comm_semiring_0_comm_semiring_1 = comm_semiring_0_int, - dvd_comm_semiring_1 = dvd_int, semiring_1_comm_semiring_1 = semiring_1_int} + semiring_1_comm_semiring_1 = semiring_1_int} : inta comm_semiring_1; val comm_semiring_1_cancel_int = @@ -433,14 +472,60 @@ semiring_1_cancel_comm_semiring_1_cancel = semiring_1_cancel_int} : inta comm_semiring_1_cancel; -val no_zero_divisors_int = - {times_no_zero_divisors = times_int, zero_no_zero_divisors = zero_int} : - inta no_zero_divisors; +val semidom_int = + {semiring_1_no_zero_divisors_semidom = semiring_1_no_zero_divisors_int, + comm_semiring_1_cancel_semidom = comm_semiring_1_cancel_int} + : inta semidom; + +type 'a semiring_no_zero_divisors_cancel = + {semiring_no_zero_divisors_semiring_no_zero_divisors_cancel : + 'a semiring_no_zero_divisors}; +val semiring_no_zero_divisors_semiring_no_zero_divisors_cancel = + #semiring_no_zero_divisors_semiring_no_zero_divisors_cancel : + 'a semiring_no_zero_divisors_cancel -> 'a semiring_no_zero_divisors; + +type 'a semidom_divide = + {divide_semidom_divide : 'a divide, semidom_semidom_divide : 'a semidom, + semiring_no_zero_divisors_cancel_semidom_divide : + 'a semiring_no_zero_divisors_cancel}; +val divide_semidom_divide = #divide_semidom_divide : + 'a semidom_divide -> 'a divide; +val semidom_semidom_divide = #semidom_semidom_divide : + 'a semidom_divide -> 'a semidom; +val semiring_no_zero_divisors_cancel_semidom_divide = + #semiring_no_zero_divisors_cancel_semidom_divide : + 'a semidom_divide -> 'a semiring_no_zero_divisors_cancel; + +type 'a algebraic_semidom = + {semidom_divide_algebraic_semidom : 'a semidom_divide}; +val semidom_divide_algebraic_semidom = #semidom_divide_algebraic_semidom : + 'a algebraic_semidom -> 'a semidom_divide; + +type 'a semiring_div = + {div_semiring_div : 'a diva, + algebraic_semidom_semiring_div : 'a algebraic_semidom}; +val div_semiring_div = #div_semiring_div : 'a semiring_div -> 'a diva; +val algebraic_semidom_semiring_div = #algebraic_semidom_semiring_div : + 'a semiring_div -> 'a algebraic_semidom; + +val semiring_no_zero_divisors_cancel_int = + {semiring_no_zero_divisors_semiring_no_zero_divisors_cancel = + semiring_no_zero_divisors_int} + : inta semiring_no_zero_divisors_cancel; + +val semidom_divide_int = + {divide_semidom_divide = divide_int, semidom_semidom_divide = semidom_int, + semiring_no_zero_divisors_cancel_semidom_divide = + semiring_no_zero_divisors_cancel_int} + : inta semidom_divide; + +val algebraic_semidom_int = + {semidom_divide_algebraic_semidom = semidom_divide_int} : + inta algebraic_semidom; val semiring_div_int = {div_semiring_div = div_int, - comm_semiring_1_cancel_semiring_div = comm_semiring_1_cancel_int, - no_zero_divisors_semiring_div = no_zero_divisors_int} + algebraic_semidom_semiring_div = algebraic_semidom_int} : inta semiring_div; datatype nat = Nat of int; @@ -449,63 +534,62 @@ fun equal_nat m n = integer_of_nat m = integer_of_nat n; -datatype numa = C of inta | Bound of nat | Cn of nat * inta * numa | Neg of numa +datatype numa = C of inta | Bound of nat | CN of nat * inta * numa | Neg of numa | Add of numa * numa | Sub of numa * numa | Mul of inta * numa; -fun equal_numa (Sub (num1, num2)) (Mul (inta, num)) = false - | equal_numa (Mul (inta, num)) (Sub (num1, num2)) = false - | equal_numa (Add (num1, num2)) (Mul (inta, num)) = false - | equal_numa (Mul (inta, num)) (Add (num1, num2)) = false - | equal_numa (Add (num1a, num2a)) (Sub (num1, num2)) = false - | equal_numa (Sub (num1a, num2a)) (Add (num1, num2)) = false - | equal_numa (Neg numa) (Mul (inta, num)) = false - | equal_numa (Mul (inta, numa)) (Neg num) = false - | equal_numa (Neg num) (Sub (num1, num2)) = false - | equal_numa (Sub (num1, num2)) (Neg num) = false - | equal_numa (Neg num) (Add (num1, num2)) = false - | equal_numa (Add (num1, num2)) (Neg num) = false - | equal_numa (Cn (nat, intaa, numa)) (Mul (inta, num)) = false - | equal_numa (Mul (intaa, numa)) (Cn (nat, inta, num)) = false - | equal_numa (Cn (nat, inta, num)) (Sub (num1, num2)) = false - | equal_numa (Sub (num1, num2)) (Cn (nat, inta, num)) = false - | equal_numa (Cn (nat, inta, num)) (Add (num1, num2)) = false - | equal_numa (Add (num1, num2)) (Cn (nat, inta, num)) = false - | equal_numa (Cn (nat, inta, numa)) (Neg num) = false - | equal_numa (Neg numa) (Cn (nat, inta, num)) = false - | equal_numa (Bound nat) (Mul (inta, num)) = false - | equal_numa (Mul (inta, num)) (Bound nat) = false - | equal_numa (Bound nat) (Sub (num1, num2)) = false - | equal_numa (Sub (num1, num2)) (Bound nat) = false - | equal_numa (Bound nat) (Add (num1, num2)) = false - | equal_numa (Add (num1, num2)) (Bound nat) = false - | equal_numa (Bound nat) (Neg num) = false - | equal_numa (Neg num) (Bound nat) = false - | equal_numa (Bound nata) (Cn (nat, inta, num)) = false - | equal_numa (Cn (nata, inta, num)) (Bound nat) = false - | equal_numa (C intaa) (Mul (inta, num)) = false - | equal_numa (Mul (intaa, num)) (C inta) = false - | equal_numa (C inta) (Sub (num1, num2)) = false - | equal_numa (Sub (num1, num2)) (C inta) = false - | equal_numa (C inta) (Add (num1, num2)) = false - | equal_numa (Add (num1, num2)) (C inta) = false - | equal_numa (C inta) (Neg num) = false - | equal_numa (Neg num) (C inta) = false - | equal_numa (C intaa) (Cn (nat, inta, num)) = false - | equal_numa (Cn (nat, intaa, num)) (C inta) = false - | equal_numa (C inta) (Bound nat) = false - | equal_numa (Bound nat) (C inta) = false - | equal_numa (Mul (intaa, numa)) (Mul (inta, num)) = - equal_inta intaa inta andalso equal_numa numa num - | equal_numa (Sub (num1a, num2a)) (Sub (num1, num2)) = - equal_numa num1a num1 andalso equal_numa num2a num2 - | equal_numa (Add (num1a, num2a)) (Add (num1, num2)) = - equal_numa num1a num1 andalso equal_numa num2a num2 - | equal_numa (Neg numa) (Neg num) = equal_numa numa num - | equal_numa (Cn (nata, intaa, numa)) (Cn (nat, inta, num)) = - equal_nat nata nat andalso - (equal_inta intaa inta andalso equal_numa numa num) - | equal_numa (Bound nata) (Bound nat) = equal_nat nata nat - | equal_numa (C intaa) (C inta) = equal_inta intaa inta; +fun equal_numa (Sub (x61, x62)) (Mul (x71, x72)) = false + | equal_numa (Mul (x71, x72)) (Sub (x61, x62)) = false + | equal_numa (Add (x51, x52)) (Mul (x71, x72)) = false + | equal_numa (Mul (x71, x72)) (Add (x51, x52)) = false + | equal_numa (Add (x51, x52)) (Sub (x61, x62)) = false + | equal_numa (Sub (x61, x62)) (Add (x51, x52)) = false + | equal_numa (Neg x4) (Mul (x71, x72)) = false + | equal_numa (Mul (x71, x72)) (Neg x4) = false + | equal_numa (Neg x4) (Sub (x61, x62)) = false + | equal_numa (Sub (x61, x62)) (Neg x4) = false + | equal_numa (Neg x4) (Add (x51, x52)) = false + | equal_numa (Add (x51, x52)) (Neg x4) = false + | equal_numa (CN (x31, x32, x33)) (Mul (x71, x72)) = false + | equal_numa (Mul (x71, x72)) (CN (x31, x32, x33)) = false + | equal_numa (CN (x31, x32, x33)) (Sub (x61, x62)) = false + | equal_numa (Sub (x61, x62)) (CN (x31, x32, x33)) = false + | equal_numa (CN (x31, x32, x33)) (Add (x51, x52)) = false + | equal_numa (Add (x51, x52)) (CN (x31, x32, x33)) = false + | equal_numa (CN (x31, x32, x33)) (Neg x4) = false + | equal_numa (Neg x4) (CN (x31, x32, x33)) = false + | equal_numa (Bound x2) (Mul (x71, x72)) = false + | equal_numa (Mul (x71, x72)) (Bound x2) = false + | equal_numa (Bound x2) (Sub (x61, x62)) = false + | equal_numa (Sub (x61, x62)) (Bound x2) = false + | equal_numa (Bound x2) (Add (x51, x52)) = false + | equal_numa (Add (x51, x52)) (Bound x2) = false + | equal_numa (Bound x2) (Neg x4) = false + | equal_numa (Neg x4) (Bound x2) = false + | equal_numa (Bound x2) (CN (x31, x32, x33)) = false + | equal_numa (CN (x31, x32, x33)) (Bound x2) = false + | equal_numa (C x1) (Mul (x71, x72)) = false + | equal_numa (Mul (x71, x72)) (C x1) = false + | equal_numa (C x1) (Sub (x61, x62)) = false + | equal_numa (Sub (x61, x62)) (C x1) = false + | equal_numa (C x1) (Add (x51, x52)) = false + | equal_numa (Add (x51, x52)) (C x1) = false + | equal_numa (C x1) (Neg x4) = false + | equal_numa (Neg x4) (C x1) = false + | equal_numa (C x1) (CN (x31, x32, x33)) = false + | equal_numa (CN (x31, x32, x33)) (C x1) = false + | equal_numa (C x1) (Bound x2) = false + | equal_numa (Bound x2) (C x1) = false + | equal_numa (Mul (x71, x72)) (Mul (y71, y72)) = + equal_inta x71 y71 andalso equal_numa x72 y72 + | equal_numa (Sub (x61, x62)) (Sub (y61, y62)) = + equal_numa x61 y61 andalso equal_numa x62 y62 + | equal_numa (Add (x51, x52)) (Add (y51, y52)) = + equal_numa x51 y51 andalso equal_numa x52 y52 + | equal_numa (Neg x4) (Neg y4) = equal_numa x4 y4 + | equal_numa (CN (x31, x32, x33)) (CN (y31, y32, y33)) = + equal_nat x31 y31 andalso (equal_inta x32 y32 andalso equal_numa x33 y33) + | equal_numa (Bound x2) (Bound y2) = equal_nat x2 y2 + | equal_numa (C x1) (C y1) = equal_inta x1 y1; val equal_num = {equal = equal_numa} : numa equal; @@ -519,7 +603,7 @@ datatype fm = T | F | Lt of numa | Le of numa | Gt of numa | Ge of numa | Eq of numa | NEq of numa | Dvd of inta * numa | NDvd of inta * numa | - Not of fm | And of fm * fm | Or of fm * fm | Imp of fm * fm | Iff of fm * fm | + NOT of fm | And of fm * fm | Or of fm * fm | Imp of fm * fm | Iff of fm * fm | E of fm | A of fm | Closed of nat | NClosed of nat; fun id x = (fn xa => xa) x; @@ -543,7 +627,7 @@ | disjuncts (NEq v) = [NEq v] | disjuncts (Dvd (v, va)) = [Dvd (v, va)] | disjuncts (NDvd (v, va)) = [NDvd (v, va)] - | disjuncts (Not v) = [Not v] + | disjuncts (NOT v) = [NOT v] | disjuncts (And (v, va)) = [And (v, va)] | disjuncts (Imp (v, va)) = [Imp (v, va)] | disjuncts (Iff (v, va)) = [Iff (v, va)] @@ -555,371 +639,371 @@ fun foldr f [] = id | foldr f (x :: xs) = f x o foldr f xs; -fun equal_fm (Closed nata) (NClosed nat) = false - | equal_fm (NClosed nata) (Closed nat) = false - | equal_fm (A fm) (NClosed nat) = false - | equal_fm (NClosed nat) (A fm) = false - | equal_fm (A fm) (Closed nat) = false - | equal_fm (Closed nat) (A fm) = false - | equal_fm (E fm) (NClosed nat) = false - | equal_fm (NClosed nat) (E fm) = false - | equal_fm (E fm) (Closed nat) = false - | equal_fm (Closed nat) (E fm) = false - | equal_fm (E fma) (A fm) = false - | equal_fm (A fma) (E fm) = false - | equal_fm (Iff (fm1, fm2)) (NClosed nat) = false - | equal_fm (NClosed nat) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) (Closed nat) = false - | equal_fm (Closed nat) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) (A fm) = false - | equal_fm (A fm) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) (E fm) = false - | equal_fm (E fm) (Iff (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) (NClosed nat) = false - | equal_fm (NClosed nat) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) (Closed nat) = false - | equal_fm (Closed nat) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) (A fm) = false - | equal_fm (A fm) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) (E fm) = false - | equal_fm (E fm) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1a, fm2a)) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1a, fm2a)) (Imp (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) (NClosed nat) = false - | equal_fm (NClosed nat) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) (Closed nat) = false - | equal_fm (Closed nat) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) (A fm) = false - | equal_fm (A fm) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) (E fm) = false - | equal_fm (E fm) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1a, fm2a)) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1a, fm2a)) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1a, fm2a)) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1a, fm2a)) (Or (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) (NClosed nat) = false - | equal_fm (NClosed nat) (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) (Closed nat) = false - | equal_fm (Closed nat) (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) (A fm) = false - | equal_fm (A fm) (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) (E fm) = false - | equal_fm (E fm) (And (fm1, fm2)) = false - | equal_fm (And (fm1a, fm2a)) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1a, fm2a)) (And (fm1, fm2)) = false - | equal_fm (And (fm1a, fm2a)) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1a, fm2a)) (And (fm1, fm2)) = false - | equal_fm (And (fm1a, fm2a)) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1a, fm2a)) (And (fm1, fm2)) = false - | equal_fm (Not fm) (NClosed nat) = false - | equal_fm (NClosed nat) (Not fm) = false - | equal_fm (Not fm) (Closed nat) = false - | equal_fm (Closed nat) (Not fm) = false - | equal_fm (Not fma) (A fm) = false - | equal_fm (A fma) (Not fm) = false - | equal_fm (Not fma) (E fm) = false - | equal_fm (E fma) (Not fm) = false - | equal_fm (Not fm) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) (Not fm) = false - | equal_fm (Not fm) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) (Not fm) = false - | equal_fm (Not fm) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) (Not fm) = false - | equal_fm (Not fm) (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) (Not fm) = false - | equal_fm (NDvd (inta, num)) (NClosed nat) = false - | equal_fm (NClosed nat) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, num)) (Closed nat) = false - | equal_fm (Closed nat) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, num)) (A fm) = false - | equal_fm (A fm) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, num)) (E fm) = false - | equal_fm (E fm) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, num)) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, num)) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, num)) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, num)) (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, num)) (Not fm) = false - | equal_fm (Not fm) (NDvd (inta, num)) = false - | equal_fm (Dvd (inta, num)) (NClosed nat) = false - | equal_fm (NClosed nat) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, num)) (Closed nat) = false - | equal_fm (Closed nat) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, num)) (A fm) = false - | equal_fm (A fm) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, num)) (E fm) = false - | equal_fm (E fm) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, num)) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, num)) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, num)) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, num)) (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, num)) (Not fm) = false - | equal_fm (Not fm) (Dvd (inta, num)) = false - | equal_fm (Dvd (intaa, numa)) (NDvd (inta, num)) = false - | equal_fm (NDvd (intaa, numa)) (Dvd (inta, num)) = false - | equal_fm (NEq num) (NClosed nat) = false - | equal_fm (NClosed nat) (NEq num) = false - | equal_fm (NEq num) (Closed nat) = false - | equal_fm (Closed nat) (NEq num) = false - | equal_fm (NEq num) (A fm) = false - | equal_fm (A fm) (NEq num) = false - | equal_fm (NEq num) (E fm) = false - | equal_fm (E fm) (NEq num) = false - | equal_fm (NEq num) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) (NEq num) = false - | equal_fm (NEq num) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) (NEq num) = false - | equal_fm (NEq num) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) (NEq num) = false - | equal_fm (NEq num) (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) (NEq num) = false - | equal_fm (NEq num) (Not fm) = false - | equal_fm (Not fm) (NEq num) = false - | equal_fm (NEq numa) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, numa)) (NEq num) = false - | equal_fm (NEq numa) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, numa)) (NEq num) = false - | equal_fm (Eq num) (NClosed nat) = false - | equal_fm (NClosed nat) (Eq num) = false - | equal_fm (Eq num) (Closed nat) = false - | equal_fm (Closed nat) (Eq num) = false - | equal_fm (Eq num) (A fm) = false - | equal_fm (A fm) (Eq num) = false - | equal_fm (Eq num) (E fm) = false - | equal_fm (E fm) (Eq num) = false - | equal_fm (Eq num) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) (Eq num) = false - | equal_fm (Eq num) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) (Eq num) = false - | equal_fm (Eq num) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) (Eq num) = false - | equal_fm (Eq num) (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) (Eq num) = false - | equal_fm (Eq num) (Not fm) = false - | equal_fm (Not fm) (Eq num) = false - | equal_fm (Eq numa) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, numa)) (Eq num) = false - | equal_fm (Eq numa) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, numa)) (Eq num) = false - | equal_fm (Eq numa) (NEq num) = false - | equal_fm (NEq numa) (Eq num) = false - | equal_fm (Ge num) (NClosed nat) = false - | equal_fm (NClosed nat) (Ge num) = false - | equal_fm (Ge num) (Closed nat) = false - | equal_fm (Closed nat) (Ge num) = false - | equal_fm (Ge num) (A fm) = false - | equal_fm (A fm) (Ge num) = false - | equal_fm (Ge num) (E fm) = false - | equal_fm (E fm) (Ge num) = false - | equal_fm (Ge num) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) (Ge num) = false - | equal_fm (Ge num) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) (Ge num) = false - | equal_fm (Ge num) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) (Ge num) = false - | equal_fm (Ge num) (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) (Ge num) = false - | equal_fm (Ge num) (Not fm) = false - | equal_fm (Not fm) (Ge num) = false - | equal_fm (Ge numa) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, numa)) (Ge num) = false - | equal_fm (Ge numa) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, numa)) (Ge num) = false - | equal_fm (Ge numa) (NEq num) = false - | equal_fm (NEq numa) (Ge num) = false - | equal_fm (Ge numa) (Eq num) = false - | equal_fm (Eq numa) (Ge num) = false - | equal_fm (Gt num) (NClosed nat) = false - | equal_fm (NClosed nat) (Gt num) = false - | equal_fm (Gt num) (Closed nat) = false - | equal_fm (Closed nat) (Gt num) = false - | equal_fm (Gt num) (A fm) = false - | equal_fm (A fm) (Gt num) = false - | equal_fm (Gt num) (E fm) = false - | equal_fm (E fm) (Gt num) = false - | equal_fm (Gt num) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) (Gt num) = false - | equal_fm (Gt num) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) (Gt num) = false - | equal_fm (Gt num) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) (Gt num) = false - | equal_fm (Gt num) (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) (Gt num) = false - | equal_fm (Gt num) (Not fm) = false - | equal_fm (Not fm) (Gt num) = false - | equal_fm (Gt numa) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, numa)) (Gt num) = false - | equal_fm (Gt numa) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, numa)) (Gt num) = false - | equal_fm (Gt numa) (NEq num) = false - | equal_fm (NEq numa) (Gt num) = false - | equal_fm (Gt numa) (Eq num) = false - | equal_fm (Eq numa) (Gt num) = false - | equal_fm (Gt numa) (Ge num) = false - | equal_fm (Ge numa) (Gt num) = false - | equal_fm (Le num) (NClosed nat) = false - | equal_fm (NClosed nat) (Le num) = false - | equal_fm (Le num) (Closed nat) = false - | equal_fm (Closed nat) (Le num) = false - | equal_fm (Le num) (A fm) = false - | equal_fm (A fm) (Le num) = false - | equal_fm (Le num) (E fm) = false - | equal_fm (E fm) (Le num) = false - | equal_fm (Le num) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) (Le num) = false - | equal_fm (Le num) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) (Le num) = false - | equal_fm (Le num) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) (Le num) = false - | equal_fm (Le num) (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) (Le num) = false - | equal_fm (Le num) (Not fm) = false - | equal_fm (Not fm) (Le num) = false - | equal_fm (Le numa) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, numa)) (Le num) = false - | equal_fm (Le numa) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, numa)) (Le num) = false - | equal_fm (Le numa) (NEq num) = false - | equal_fm (NEq numa) (Le num) = false - | equal_fm (Le numa) (Eq num) = false - | equal_fm (Eq numa) (Le num) = false - | equal_fm (Le numa) (Ge num) = false - | equal_fm (Ge numa) (Le num) = false - | equal_fm (Le numa) (Gt num) = false - | equal_fm (Gt numa) (Le num) = false - | equal_fm (Lt num) (NClosed nat) = false - | equal_fm (NClosed nat) (Lt num) = false - | equal_fm (Lt num) (Closed nat) = false - | equal_fm (Closed nat) (Lt num) = false - | equal_fm (Lt num) (A fm) = false - | equal_fm (A fm) (Lt num) = false - | equal_fm (Lt num) (E fm) = false - | equal_fm (E fm) (Lt num) = false - | equal_fm (Lt num) (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) (Lt num) = false - | equal_fm (Lt num) (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) (Lt num) = false - | equal_fm (Lt num) (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) (Lt num) = false - | equal_fm (Lt num) (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) (Lt num) = false - | equal_fm (Lt num) (Not fm) = false - | equal_fm (Not fm) (Lt num) = false - | equal_fm (Lt numa) (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, numa)) (Lt num) = false - | equal_fm (Lt numa) (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, numa)) (Lt num) = false - | equal_fm (Lt numa) (NEq num) = false - | equal_fm (NEq numa) (Lt num) = false - | equal_fm (Lt numa) (Eq num) = false - | equal_fm (Eq numa) (Lt num) = false - | equal_fm (Lt numa) (Ge num) = false - | equal_fm (Ge numa) (Lt num) = false - | equal_fm (Lt numa) (Gt num) = false - | equal_fm (Gt numa) (Lt num) = false - | equal_fm (Lt numa) (Le num) = false - | equal_fm (Le numa) (Lt num) = false - | equal_fm F (NClosed nat) = false - | equal_fm (NClosed nat) F = false - | equal_fm F (Closed nat) = false - | equal_fm (Closed nat) F = false - | equal_fm F (A fm) = false - | equal_fm (A fm) F = false - | equal_fm F (E fm) = false - | equal_fm (E fm) F = false - | equal_fm F (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) F = false - | equal_fm F (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) F = false - | equal_fm F (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) F = false - | equal_fm F (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) F = false - | equal_fm F (Not fm) = false - | equal_fm (Not fm) F = false - | equal_fm F (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, num)) F = false - | equal_fm F (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, num)) F = false - | equal_fm F (NEq num) = false - | equal_fm (NEq num) F = false - | equal_fm F (Eq num) = false - | equal_fm (Eq num) F = false - | equal_fm F (Ge num) = false - | equal_fm (Ge num) F = false - | equal_fm F (Gt num) = false - | equal_fm (Gt num) F = false - | equal_fm F (Le num) = false - | equal_fm (Le num) F = false - | equal_fm F (Lt num) = false - | equal_fm (Lt num) F = false - | equal_fm T (NClosed nat) = false - | equal_fm (NClosed nat) T = false - | equal_fm T (Closed nat) = false - | equal_fm (Closed nat) T = false - | equal_fm T (A fm) = false - | equal_fm (A fm) T = false - | equal_fm T (E fm) = false - | equal_fm (E fm) T = false - | equal_fm T (Iff (fm1, fm2)) = false - | equal_fm (Iff (fm1, fm2)) T = false - | equal_fm T (Imp (fm1, fm2)) = false - | equal_fm (Imp (fm1, fm2)) T = false - | equal_fm T (Or (fm1, fm2)) = false - | equal_fm (Or (fm1, fm2)) T = false - | equal_fm T (And (fm1, fm2)) = false - | equal_fm (And (fm1, fm2)) T = false - | equal_fm T (Not fm) = false - | equal_fm (Not fm) T = false - | equal_fm T (NDvd (inta, num)) = false - | equal_fm (NDvd (inta, num)) T = false - | equal_fm T (Dvd (inta, num)) = false - | equal_fm (Dvd (inta, num)) T = false - | equal_fm T (NEq num) = false - | equal_fm (NEq num) T = false - | equal_fm T (Eq num) = false - | equal_fm (Eq num) T = false - | equal_fm T (Ge num) = false - | equal_fm (Ge num) T = false - | equal_fm T (Gt num) = false - | equal_fm (Gt num) T = false - | equal_fm T (Le num) = false - | equal_fm (Le num) T = false - | equal_fm T (Lt num) = false - | equal_fm (Lt num) T = false +fun equal_fm (Closed x18) (NClosed x19) = false + | equal_fm (NClosed x19) (Closed x18) = false + | equal_fm (A x17) (NClosed x19) = false + | equal_fm (NClosed x19) (A x17) = false + | equal_fm (A x17) (Closed x18) = false + | equal_fm (Closed x18) (A x17) = false + | equal_fm (E x16) (NClosed x19) = false + | equal_fm (NClosed x19) (E x16) = false + | equal_fm (E x16) (Closed x18) = false + | equal_fm (Closed x18) (E x16) = false + | equal_fm (E x16) (A x17) = false + | equal_fm (A x17) (E x16) = false + | equal_fm (Iff (x151, x152)) (NClosed x19) = false + | equal_fm (NClosed x19) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (Closed x18) = false + | equal_fm (Closed x18) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (A x17) = false + | equal_fm (A x17) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (E x16) = false + | equal_fm (E x16) (Iff (x151, x152)) = false + | equal_fm (Imp (x141, x142)) (NClosed x19) = false + | equal_fm (NClosed x19) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (Closed x18) = false + | equal_fm (Closed x18) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (A x17) = false + | equal_fm (A x17) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (E x16) = false + | equal_fm (E x16) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (Imp (x141, x142)) = false + | equal_fm (Or (x131, x132)) (NClosed x19) = false + | equal_fm (NClosed x19) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (Closed x18) = false + | equal_fm (Closed x18) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (A x17) = false + | equal_fm (A x17) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (E x16) = false + | equal_fm (E x16) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (Or (x131, x132)) = false + | equal_fm (And (x121, x122)) (NClosed x19) = false + | equal_fm (NClosed x19) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (Closed x18) = false + | equal_fm (Closed x18) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (A x17) = false + | equal_fm (A x17) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (E x16) = false + | equal_fm (E x16) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (And (x121, x122)) = false + | equal_fm (NOT x11) (NClosed x19) = false + | equal_fm (NClosed x19) (NOT x11) = false + | equal_fm (NOT x11) (Closed x18) = false + | equal_fm (Closed x18) (NOT x11) = false + | equal_fm (NOT x11) (A x17) = false + | equal_fm (A x17) (NOT x11) = false + | equal_fm (NOT x11) (E x16) = false + | equal_fm (E x16) (NOT x11) = false + | equal_fm (NOT x11) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (NOT x11) = false + | equal_fm (NOT x11) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (NOT x11) = false + | equal_fm (NOT x11) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (NOT x11) = false + | equal_fm (NOT x11) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (NOT x11) = false + | equal_fm (NDvd (x101, x102)) (NClosed x19) = false + | equal_fm (NClosed x19) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (Closed x18) = false + | equal_fm (Closed x18) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (A x17) = false + | equal_fm (A x17) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (E x16) = false + | equal_fm (E x16) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (NOT x11) = false + | equal_fm (NOT x11) (NDvd (x101, x102)) = false + | equal_fm (Dvd (x91, x92)) (NClosed x19) = false + | equal_fm (NClosed x19) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (Closed x18) = false + | equal_fm (Closed x18) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (A x17) = false + | equal_fm (A x17) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (E x16) = false + | equal_fm (E x16) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (NOT x11) = false + | equal_fm (NOT x11) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (Dvd (x91, x92)) = false + | equal_fm (NEq x8) (NClosed x19) = false + | equal_fm (NClosed x19) (NEq x8) = false + | equal_fm (NEq x8) (Closed x18) = false + | equal_fm (Closed x18) (NEq x8) = false + | equal_fm (NEq x8) (A x17) = false + | equal_fm (A x17) (NEq x8) = false + | equal_fm (NEq x8) (E x16) = false + | equal_fm (E x16) (NEq x8) = false + | equal_fm (NEq x8) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (NEq x8) = false + | equal_fm (NEq x8) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (NEq x8) = false + | equal_fm (NEq x8) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (NEq x8) = false + | equal_fm (NEq x8) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (NEq x8) = false + | equal_fm (NEq x8) (NOT x11) = false + | equal_fm (NOT x11) (NEq x8) = false + | equal_fm (NEq x8) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (NEq x8) = false + | equal_fm (NEq x8) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (NEq x8) = false + | equal_fm (Eq x7) (NClosed x19) = false + | equal_fm (NClosed x19) (Eq x7) = false + | equal_fm (Eq x7) (Closed x18) = false + | equal_fm (Closed x18) (Eq x7) = false + | equal_fm (Eq x7) (A x17) = false + | equal_fm (A x17) (Eq x7) = false + | equal_fm (Eq x7) (E x16) = false + | equal_fm (E x16) (Eq x7) = false + | equal_fm (Eq x7) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (Eq x7) = false + | equal_fm (Eq x7) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (Eq x7) = false + | equal_fm (Eq x7) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (Eq x7) = false + | equal_fm (Eq x7) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (Eq x7) = false + | equal_fm (Eq x7) (NOT x11) = false + | equal_fm (NOT x11) (Eq x7) = false + | equal_fm (Eq x7) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (Eq x7) = false + | equal_fm (Eq x7) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (Eq x7) = false + | equal_fm (Eq x7) (NEq x8) = false + | equal_fm (NEq x8) (Eq x7) = false + | equal_fm (Ge x6) (NClosed x19) = false + | equal_fm (NClosed x19) (Ge x6) = false + | equal_fm (Ge x6) (Closed x18) = false + | equal_fm (Closed x18) (Ge x6) = false + | equal_fm (Ge x6) (A x17) = false + | equal_fm (A x17) (Ge x6) = false + | equal_fm (Ge x6) (E x16) = false + | equal_fm (E x16) (Ge x6) = false + | equal_fm (Ge x6) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (Ge x6) = false + | equal_fm (Ge x6) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (Ge x6) = false + | equal_fm (Ge x6) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (Ge x6) = false + | equal_fm (Ge x6) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (Ge x6) = false + | equal_fm (Ge x6) (NOT x11) = false + | equal_fm (NOT x11) (Ge x6) = false + | equal_fm (Ge x6) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (Ge x6) = false + | equal_fm (Ge x6) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (Ge x6) = false + | equal_fm (Ge x6) (NEq x8) = false + | equal_fm (NEq x8) (Ge x6) = false + | equal_fm (Ge x6) (Eq x7) = false + | equal_fm (Eq x7) (Ge x6) = false + | equal_fm (Gt x5) (NClosed x19) = false + | equal_fm (NClosed x19) (Gt x5) = false + | equal_fm (Gt x5) (Closed x18) = false + | equal_fm (Closed x18) (Gt x5) = false + | equal_fm (Gt x5) (A x17) = false + | equal_fm (A x17) (Gt x5) = false + | equal_fm (Gt x5) (E x16) = false + | equal_fm (E x16) (Gt x5) = false + | equal_fm (Gt x5) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (Gt x5) = false + | equal_fm (Gt x5) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (Gt x5) = false + | equal_fm (Gt x5) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (Gt x5) = false + | equal_fm (Gt x5) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (Gt x5) = false + | equal_fm (Gt x5) (NOT x11) = false + | equal_fm (NOT x11) (Gt x5) = false + | equal_fm (Gt x5) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (Gt x5) = false + | equal_fm (Gt x5) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (Gt x5) = false + | equal_fm (Gt x5) (NEq x8) = false + | equal_fm (NEq x8) (Gt x5) = false + | equal_fm (Gt x5) (Eq x7) = false + | equal_fm (Eq x7) (Gt x5) = false + | equal_fm (Gt x5) (Ge x6) = false + | equal_fm (Ge x6) (Gt x5) = false + | equal_fm (Le x4) (NClosed x19) = false + | equal_fm (NClosed x19) (Le x4) = false + | equal_fm (Le x4) (Closed x18) = false + | equal_fm (Closed x18) (Le x4) = false + | equal_fm (Le x4) (A x17) = false + | equal_fm (A x17) (Le x4) = false + | equal_fm (Le x4) (E x16) = false + | equal_fm (E x16) (Le x4) = false + | equal_fm (Le x4) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (Le x4) = false + | equal_fm (Le x4) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (Le x4) = false + | equal_fm (Le x4) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (Le x4) = false + | equal_fm (Le x4) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (Le x4) = false + | equal_fm (Le x4) (NOT x11) = false + | equal_fm (NOT x11) (Le x4) = false + | equal_fm (Le x4) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (Le x4) = false + | equal_fm (Le x4) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (Le x4) = false + | equal_fm (Le x4) (NEq x8) = false + | equal_fm (NEq x8) (Le x4) = false + | equal_fm (Le x4) (Eq x7) = false + | equal_fm (Eq x7) (Le x4) = false + | equal_fm (Le x4) (Ge x6) = false + | equal_fm (Ge x6) (Le x4) = false + | equal_fm (Le x4) (Gt x5) = false + | equal_fm (Gt x5) (Le x4) = false + | equal_fm (Lt x3) (NClosed x19) = false + | equal_fm (NClosed x19) (Lt x3) = false + | equal_fm (Lt x3) (Closed x18) = false + | equal_fm (Closed x18) (Lt x3) = false + | equal_fm (Lt x3) (A x17) = false + | equal_fm (A x17) (Lt x3) = false + | equal_fm (Lt x3) (E x16) = false + | equal_fm (E x16) (Lt x3) = false + | equal_fm (Lt x3) (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) (Lt x3) = false + | equal_fm (Lt x3) (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) (Lt x3) = false + | equal_fm (Lt x3) (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) (Lt x3) = false + | equal_fm (Lt x3) (And (x121, x122)) = false + | equal_fm (And (x121, x122)) (Lt x3) = false + | equal_fm (Lt x3) (NOT x11) = false + | equal_fm (NOT x11) (Lt x3) = false + | equal_fm (Lt x3) (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) (Lt x3) = false + | equal_fm (Lt x3) (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) (Lt x3) = false + | equal_fm (Lt x3) (NEq x8) = false + | equal_fm (NEq x8) (Lt x3) = false + | equal_fm (Lt x3) (Eq x7) = false + | equal_fm (Eq x7) (Lt x3) = false + | equal_fm (Lt x3) (Ge x6) = false + | equal_fm (Ge x6) (Lt x3) = false + | equal_fm (Lt x3) (Gt x5) = false + | equal_fm (Gt x5) (Lt x3) = false + | equal_fm (Lt x3) (Le x4) = false + | equal_fm (Le x4) (Lt x3) = false + | equal_fm F (NClosed x19) = false + | equal_fm (NClosed x19) F = false + | equal_fm F (Closed x18) = false + | equal_fm (Closed x18) F = false + | equal_fm F (A x17) = false + | equal_fm (A x17) F = false + | equal_fm F (E x16) = false + | equal_fm (E x16) F = false + | equal_fm F (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) F = false + | equal_fm F (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) F = false + | equal_fm F (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) F = false + | equal_fm F (And (x121, x122)) = false + | equal_fm (And (x121, x122)) F = false + | equal_fm F (NOT x11) = false + | equal_fm (NOT x11) F = false + | equal_fm F (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) F = false + | equal_fm F (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) F = false + | equal_fm F (NEq x8) = false + | equal_fm (NEq x8) F = false + | equal_fm F (Eq x7) = false + | equal_fm (Eq x7) F = false + | equal_fm F (Ge x6) = false + | equal_fm (Ge x6) F = false + | equal_fm F (Gt x5) = false + | equal_fm (Gt x5) F = false + | equal_fm F (Le x4) = false + | equal_fm (Le x4) F = false + | equal_fm F (Lt x3) = false + | equal_fm (Lt x3) F = false + | equal_fm T (NClosed x19) = false + | equal_fm (NClosed x19) T = false + | equal_fm T (Closed x18) = false + | equal_fm (Closed x18) T = false + | equal_fm T (A x17) = false + | equal_fm (A x17) T = false + | equal_fm T (E x16) = false + | equal_fm (E x16) T = false + | equal_fm T (Iff (x151, x152)) = false + | equal_fm (Iff (x151, x152)) T = false + | equal_fm T (Imp (x141, x142)) = false + | equal_fm (Imp (x141, x142)) T = false + | equal_fm T (Or (x131, x132)) = false + | equal_fm (Or (x131, x132)) T = false + | equal_fm T (And (x121, x122)) = false + | equal_fm (And (x121, x122)) T = false + | equal_fm T (NOT x11) = false + | equal_fm (NOT x11) T = false + | equal_fm T (NDvd (x101, x102)) = false + | equal_fm (NDvd (x101, x102)) T = false + | equal_fm T (Dvd (x91, x92)) = false + | equal_fm (Dvd (x91, x92)) T = false + | equal_fm T (NEq x8) = false + | equal_fm (NEq x8) T = false + | equal_fm T (Eq x7) = false + | equal_fm (Eq x7) T = false + | equal_fm T (Ge x6) = false + | equal_fm (Ge x6) T = false + | equal_fm T (Gt x5) = false + | equal_fm (Gt x5) T = false + | equal_fm T (Le x4) = false + | equal_fm (Le x4) T = false + | equal_fm T (Lt x3) = false + | equal_fm (Lt x3) T = false | equal_fm T F = false | equal_fm F T = false - | equal_fm (NClosed nata) (NClosed nat) = equal_nat nata nat - | equal_fm (Closed nata) (Closed nat) = equal_nat nata nat - | equal_fm (A fma) (A fm) = equal_fm fma fm - | equal_fm (E fma) (E fm) = equal_fm fma fm - | equal_fm (Iff (fm1a, fm2a)) (Iff (fm1, fm2)) = - equal_fm fm1a fm1 andalso equal_fm fm2a fm2 - | equal_fm (Imp (fm1a, fm2a)) (Imp (fm1, fm2)) = - equal_fm fm1a fm1 andalso equal_fm fm2a fm2 - | equal_fm (Or (fm1a, fm2a)) (Or (fm1, fm2)) = - equal_fm fm1a fm1 andalso equal_fm fm2a fm2 - | equal_fm (And (fm1a, fm2a)) (And (fm1, fm2)) = - equal_fm fm1a fm1 andalso equal_fm fm2a fm2 - | equal_fm (Not fma) (Not fm) = equal_fm fma fm - | equal_fm (NDvd (intaa, numa)) (NDvd (inta, num)) = - equal_inta intaa inta andalso equal_numa numa num - | equal_fm (Dvd (intaa, numa)) (Dvd (inta, num)) = - equal_inta intaa inta andalso equal_numa numa num - | equal_fm (NEq numa) (NEq num) = equal_numa numa num - | equal_fm (Eq numa) (Eq num) = equal_numa numa num - | equal_fm (Ge numa) (Ge num) = equal_numa numa num - | equal_fm (Gt numa) (Gt num) = equal_numa numa num - | equal_fm (Le numa) (Le num) = equal_numa numa num - | equal_fm (Lt numa) (Lt num) = equal_numa numa num + | equal_fm (NClosed x19) (NClosed y19) = equal_nat x19 y19 + | equal_fm (Closed x18) (Closed y18) = equal_nat x18 y18 + | equal_fm (A x17) (A y17) = equal_fm x17 y17 + | equal_fm (E x16) (E y16) = equal_fm x16 y16 + | equal_fm (Iff (x151, x152)) (Iff (y151, y152)) = + equal_fm x151 y151 andalso equal_fm x152 y152 + | equal_fm (Imp (x141, x142)) (Imp (y141, y142)) = + equal_fm x141 y141 andalso equal_fm x142 y142 + | equal_fm (Or (x131, x132)) (Or (y131, y132)) = + equal_fm x131 y131 andalso equal_fm x132 y132 + | equal_fm (And (x121, x122)) (And (y121, y122)) = + equal_fm x121 y121 andalso equal_fm x122 y122 + | equal_fm (NOT x11) (NOT y11) = equal_fm x11 y11 + | equal_fm (NDvd (x101, x102)) (NDvd (y101, y102)) = + equal_inta x101 y101 andalso equal_numa x102 y102 + | equal_fm (Dvd (x91, x92)) (Dvd (y91, y92)) = + equal_inta x91 y91 andalso equal_numa x92 y92 + | equal_fm (NEq x8) (NEq y8) = equal_numa x8 y8 + | equal_fm (Eq x7) (Eq y7) = equal_numa x7 y7 + | equal_fm (Ge x6) (Ge y6) = equal_numa x6 y6 + | equal_fm (Gt x5) (Gt y5) = equal_numa x5 y5 + | equal_fm (Le x4) (Le y4) = equal_numa x4 y4 + | equal_fm (Lt x3) (Lt y3) = equal_numa x3 y3 | equal_fm F F = true | equal_fm T T = true; @@ -930,7 +1014,7 @@ | Le _ => Or (f p, q) | Gt _ => Or (f p, q) | Ge _ => Or (f p, q) | Eq _ => Or (f p, q) | NEq _ => Or (f p, q) | Dvd (_, _) => Or (f p, q) - | NDvd (_, _) => Or (f p, q) | Not _ => Or (f p, q) + | NDvd (_, _) => Or (f p, q) | NOT _ => Or (f p, q) | And (_, _) => Or (f p, q) | Or (_, _) => Or (f p, q) | Imp (_, _) => Or (f p, q) | Iff (_, _) => Or (f p, q) | E _ => Or (f p, q) | A _ => Or (f p, q) @@ -943,9 +1027,9 @@ fun max A_ a b = (if less_eq A_ a b then b else a); fun minus_nat m n = - Nat (max ord_integer 0 (integer_of_nat m - integer_of_nat n)); + Nat (max ord_integer (0 : IntInf.int) (integer_of_nat m - integer_of_nat n)); -val zero_nat : nat = Nat 0; +val zero_nat : nat = Nat (0 : IntInf.int); fun minusinf (And (p, q)) = And (minusinf p, minusinf q) | minusinf (Or (p, q)) = Or (minusinf p, minusinf q) @@ -989,34 +1073,34 @@ | minusinf (NEq (Mul (gy, gz))) = NEq (Mul (gy, gz)) | minusinf (Dvd (aa, ab)) = Dvd (aa, ab) | minusinf (NDvd (ac, ad)) = NDvd (ac, ad) - | minusinf (Not ae) = Not ae + | minusinf (NOT ae) = NOT ae | minusinf (Imp (aj, ak)) = Imp (aj, ak) | minusinf (Iff (al, am)) = Iff (al, am) | minusinf (E an) = E an | minusinf (A ao) = A ao | minusinf (Closed ap) = Closed ap | minusinf (NClosed aq) = NClosed aq - | minusinf (Lt (Cn (cm, c, e))) = + | minusinf (Lt (CN (cm, c, e))) = (if equal_nat cm zero_nat then T - else Lt (Cn (suc (minus_nat cm one_nat), c, e))) - | minusinf (Le (Cn (dm, c, e))) = + else Lt (CN (suc (minus_nat cm one_nat), c, e))) + | minusinf (Le (CN (dm, c, e))) = (if equal_nat dm zero_nat then T - else Le (Cn (suc (minus_nat dm one_nat), c, e))) - | minusinf (Gt (Cn (em, c, e))) = + else Le (CN (suc (minus_nat dm one_nat), c, e))) + | minusinf (Gt (CN (em, c, e))) = (if equal_nat em zero_nat then F - else Gt (Cn (suc (minus_nat em one_nat), c, e))) - | minusinf (Ge (Cn (fm, c, e))) = + else Gt (CN (suc (minus_nat em one_nat), c, e))) + | minusinf (Ge (CN (fm, c, e))) = (if equal_nat fm zero_nat then F - else Ge (Cn (suc (minus_nat fm one_nat), c, e))) - | minusinf (Eq (Cn (gm, c, e))) = + else Ge (CN (suc (minus_nat fm one_nat), c, e))) + | minusinf (Eq (CN (gm, c, e))) = (if equal_nat gm zero_nat then F - else Eq (Cn (suc (minus_nat gm one_nat), c, e))) - | minusinf (NEq (Cn (hm, c, e))) = + else Eq (CN (suc (minus_nat gm one_nat), c, e))) + | minusinf (NEq (CN (hm, c, e))) = (if equal_nat hm zero_nat then T - else NEq (Cn (suc (minus_nat hm one_nat), c, e))); + else NEq (CN (suc (minus_nat hm one_nat), c, e))); -fun map fi [] = [] - | map fi (x21a :: x22a) = fi x21a :: map fi x22a; +fun map f [] = [] + | map f (x21 :: x22) = f x21 :: map f x22; fun numsubst0 t (C c) = C c | numsubst0 t (Bound n) = (if equal_nat n zero_nat then t else Bound n) @@ -1024,9 +1108,9 @@ | numsubst0 t (Add (a, b)) = Add (numsubst0 t a, numsubst0 t b) | numsubst0 t (Sub (a, b)) = Sub (numsubst0 t a, numsubst0 t b) | numsubst0 t (Mul (i, a)) = Mul (i, numsubst0 t a) - | numsubst0 t (Cn (v, i, a)) = + | numsubst0 t (CN (v, i, a)) = (if equal_nat v zero_nat then Add (Mul (i, t), numsubst0 t a) - else Cn (suc (minus_nat v one_nat), i, numsubst0 t a)); + else CN (suc (minus_nat v one_nat), i, numsubst0 t a)); fun subst0 t T = T | subst0 t F = F @@ -1038,7 +1122,7 @@ | subst0 t (NEq a) = NEq (numsubst0 t a) | subst0 t (Dvd (i, a)) = Dvd (i, numsubst0 t a) | subst0 t (NDvd (i, a)) = NDvd (i, numsubst0 t a) - | subst0 t (Not p) = Not (subst0 t p) + | subst0 t (NOT p) = NOT (subst0 t p) | subst0 t (And (p, q)) = And (subst0 t p, subst0 t q) | subst0 t (Or (p, q)) = Or (subst0 t p, subst0 t q) | subst0 t (Imp (p, q)) = Imp (subst0 t p, subst0 t q) @@ -1059,11 +1143,12 @@ (zero ((zero_mult_zero o mult_zero_semiring_0 o semiring_0_semiring_1 o semiring_1_comm_semiring_1 o comm_semiring_1_comm_semiring_1_cancel o - comm_semiring_1_cancel_semiring_div) + comm_semiring_1_cancel_semidom o semidom_semidom_divide o + semidom_divide_algebraic_semidom o algebraic_semidom_semiring_div) A1_)); fun nummul i (C j) = C (times_inta i j) - | nummul i (Cn (n, c, t)) = Cn (n, times_inta c i, nummul i t) + | nummul i (CN (n, c, t)) = CN (n, times_inta c i, nummul i t) | nummul i (Bound v) = Mul (i, Bound v) | nummul i (Neg v) = Mul (i, Neg v) | nummul i (Add (v, va)) = Mul (i, Add (v, va)) @@ -1074,35 +1159,35 @@ fun less_eq_nat m n = integer_of_nat m <= integer_of_nat n; -fun numadd (Cn (n1, c1, r1), Cn (n2, c2, r2)) = +fun numadd (CN (n1, c1, r1), CN (n2, c2, r2)) = (if equal_nat n1 n2 then let val c = plus_inta c1 c2; in (if equal_inta c zero_inta then numadd (r1, r2) - else Cn (n1, c, numadd (r1, r2))) + else CN (n1, c, numadd (r1, r2))) end else (if less_eq_nat n1 n2 - then Cn (n1, c1, numadd (r1, Add (Mul (c2, Bound n2), r2))) - else Cn (n2, c2, numadd (Add (Mul (c1, Bound n1), r1), r2)))) - | numadd (Cn (n1, c1, r1), C dd) = Cn (n1, c1, numadd (r1, C dd)) - | numadd (Cn (n1, c1, r1), Bound de) = Cn (n1, c1, numadd (r1, Bound de)) - | numadd (Cn (n1, c1, r1), Neg di) = Cn (n1, c1, numadd (r1, Neg di)) - | numadd (Cn (n1, c1, r1), Add (dj, dk)) = - Cn (n1, c1, numadd (r1, Add (dj, dk))) - | numadd (Cn (n1, c1, r1), Sub (dl, dm)) = - Cn (n1, c1, numadd (r1, Sub (dl, dm))) - | numadd (Cn (n1, c1, r1), Mul (dn, doa)) = - Cn (n1, c1, numadd (r1, Mul (dn, doa))) - | numadd (C w, Cn (n2, c2, r2)) = Cn (n2, c2, numadd (C w, r2)) - | numadd (Bound x, Cn (n2, c2, r2)) = Cn (n2, c2, numadd (Bound x, r2)) - | numadd (Neg ac, Cn (n2, c2, r2)) = Cn (n2, c2, numadd (Neg ac, r2)) - | numadd (Add (ad, ae), Cn (n2, c2, r2)) = - Cn (n2, c2, numadd (Add (ad, ae), r2)) - | numadd (Sub (af, ag), Cn (n2, c2, r2)) = - Cn (n2, c2, numadd (Sub (af, ag), r2)) - | numadd (Mul (ah, ai), Cn (n2, c2, r2)) = - Cn (n2, c2, numadd (Mul (ah, ai), r2)) + then CN (n1, c1, numadd (r1, Add (Mul (c2, Bound n2), r2))) + else CN (n2, c2, numadd (Add (Mul (c1, Bound n1), r1), r2)))) + | numadd (CN (n1, c1, r1), C dd) = CN (n1, c1, numadd (r1, C dd)) + | numadd (CN (n1, c1, r1), Bound de) = CN (n1, c1, numadd (r1, Bound de)) + | numadd (CN (n1, c1, r1), Neg di) = CN (n1, c1, numadd (r1, Neg di)) + | numadd (CN (n1, c1, r1), Add (dj, dk)) = + CN (n1, c1, numadd (r1, Add (dj, dk))) + | numadd (CN (n1, c1, r1), Sub (dl, dm)) = + CN (n1, c1, numadd (r1, Sub (dl, dm))) + | numadd (CN (n1, c1, r1), Mul (dn, doa)) = + CN (n1, c1, numadd (r1, Mul (dn, doa))) + | numadd (C w, CN (n2, c2, r2)) = CN (n2, c2, numadd (C w, r2)) + | numadd (Bound x, CN (n2, c2, r2)) = CN (n2, c2, numadd (Bound x, r2)) + | numadd (Neg ac, CN (n2, c2, r2)) = CN (n2, c2, numadd (Neg ac, r2)) + | numadd (Add (ad, ae), CN (n2, c2, r2)) = + CN (n2, c2, numadd (Add (ad, ae), r2)) + | numadd (Sub (af, ag), CN (n2, c2, r2)) = + CN (n2, c2, numadd (Sub (af, ag), r2)) + | numadd (Mul (ah, ai), CN (n2, c2, r2)) = + CN (n2, c2, numadd (Mul (ah, ai), r2)) | numadd (C b1, C b2) = C (plus_inta b1 b2) | numadd (C aj, Bound bi) = Add (C aj, Bound bi) | numadd (C aj, Neg bm) = Add (C aj, Neg bm) @@ -1143,13 +1228,13 @@ fun numsub s t = (if equal_numa s t then C zero_inta else numadd (s, numneg t)); fun simpnum (C j) = C j - | simpnum (Bound n) = Cn (n, Int_of_integer (1 : IntInf.int), C zero_inta) + | simpnum (Bound n) = CN (n, Int_of_integer (1 : IntInf.int), C zero_inta) | simpnum (Neg t) = numneg (simpnum t) | simpnum (Add (t, s)) = numadd (simpnum t, simpnum s) | simpnum (Sub (t, s)) = numsub (simpnum t) (simpnum s) | simpnum (Mul (i, t)) = (if equal_inta i zero_inta then C zero_inta else nummul i (simpnum t)) - | simpnum (Cn (v, va, vb)) = Cn (v, va, vb); + | simpnum (CN (v, va, vb)) = CN (v, va, vb); fun disj p q = (if equal_fm p T orelse equal_fm q T then T @@ -1160,25 +1245,25 @@ else (if equal_fm p T then q else (if equal_fm q T then p else And (p, q)))); -fun nota (Not p) = p +fun nota (NOT p) = p | nota T = F | nota F = T - | nota (Lt v) = Not (Lt v) - | nota (Le v) = Not (Le v) - | nota (Gt v) = Not (Gt v) - | nota (Ge v) = Not (Ge v) - | nota (Eq v) = Not (Eq v) - | nota (NEq v) = Not (NEq v) - | nota (Dvd (v, va)) = Not (Dvd (v, va)) - | nota (NDvd (v, va)) = Not (NDvd (v, va)) - | nota (And (v, va)) = Not (And (v, va)) - | nota (Or (v, va)) = Not (Or (v, va)) - | nota (Imp (v, va)) = Not (Imp (v, va)) - | nota (Iff (v, va)) = Not (Iff (v, va)) - | nota (E v) = Not (E v) - | nota (A v) = Not (A v) - | nota (Closed v) = Not (Closed v) - | nota (NClosed v) = Not (NClosed v); + | nota (Lt v) = NOT (Lt v) + | nota (Le v) = NOT (Le v) + | nota (Gt v) = NOT (Gt v) + | nota (Ge v) = NOT (Ge v) + | nota (Eq v) = NOT (Eq v) + | nota (NEq v) = NOT (NEq v) + | nota (Dvd (v, va)) = NOT (Dvd (v, va)) + | nota (NDvd (v, va)) = NOT (NDvd (v, va)) + | nota (And (v, va)) = NOT (And (v, va)) + | nota (Or (v, va)) = NOT (Or (v, va)) + | nota (Imp (v, va)) = NOT (Imp (v, va)) + | nota (Iff (v, va)) = NOT (Iff (v, va)) + | nota (E v) = NOT (E v) + | nota (A v) = NOT (A v) + | nota (Closed v) = NOT (Closed v) + | nota (NClosed v) = NOT (NClosed v); fun imp p q = (if equal_fm p F orelse equal_fm q T then T @@ -1198,13 +1283,13 @@ | simpfm (Or (p, q)) = disj (simpfm p) (simpfm q) | simpfm (Imp (p, q)) = imp (simpfm p) (simpfm q) | simpfm (Iff (p, q)) = iff (simpfm p) (simpfm q) - | simpfm (Not p) = nota (simpfm p) + | simpfm (NOT p) = nota (simpfm p) | simpfm (Lt a) = let val aa = simpnum a; in (case aa of C v => (if less_int v zero_inta then T else F) - | Bound _ => Lt aa | Cn (_, _, _) => Lt aa | Neg _ => Lt aa + | Bound _ => Lt aa | CN (_, _, _) => Lt aa | Neg _ => Lt aa | Add (_, _) => Lt aa | Sub (_, _) => Lt aa | Mul (_, _) => Lt aa) end | simpfm (Le a) = @@ -1212,7 +1297,7 @@ val aa = simpnum a; in (case aa of C v => (if less_eq_int v zero_inta then T else F) - | Bound _ => Le aa | Cn (_, _, _) => Le aa | Neg _ => Le aa + | Bound _ => Le aa | CN (_, _, _) => Le aa | Neg _ => Le aa | Add (_, _) => Le aa | Sub (_, _) => Le aa | Mul (_, _) => Le aa) end | simpfm (Gt a) = @@ -1220,7 +1305,7 @@ val aa = simpnum a; in (case aa of C v => (if less_int zero_inta v then T else F) - | Bound _ => Gt aa | Cn (_, _, _) => Gt aa | Neg _ => Gt aa + | Bound _ => Gt aa | CN (_, _, _) => Gt aa | Neg _ => Gt aa | Add (_, _) => Gt aa | Sub (_, _) => Gt aa | Mul (_, _) => Gt aa) end | simpfm (Ge a) = @@ -1228,7 +1313,7 @@ val aa = simpnum a; in (case aa of C v => (if less_eq_int zero_inta v then T else F) - | Bound _ => Ge aa | Cn (_, _, _) => Ge aa | Neg _ => Ge aa + | Bound _ => Ge aa | CN (_, _, _) => Ge aa | Neg _ => Ge aa | Add (_, _) => Ge aa | Sub (_, _) => Ge aa | Mul (_, _) => Ge aa) end | simpfm (Eq a) = @@ -1236,7 +1321,7 @@ val aa = simpnum a; in (case aa of C v => (if equal_inta v zero_inta then T else F) - | Bound _ => Eq aa | Cn (_, _, _) => Eq aa | Neg _ => Eq aa + | Bound _ => Eq aa | CN (_, _, _) => Eq aa | Neg _ => Eq aa | Add (_, _) => Eq aa | Sub (_, _) => Eq aa | Mul (_, _) => Eq aa) end | simpfm (NEq a) = @@ -1244,7 +1329,7 @@ val aa = simpnum a; in (case aa of C v => (if not (equal_inta v zero_inta) then T else F) - | Bound _ => NEq aa | Cn (_, _, _) => NEq aa | Neg _ => NEq aa + | Bound _ => NEq aa | CN (_, _, _) => NEq aa | Neg _ => NEq aa | Add (_, _) => NEq aa | Sub (_, _) => NEq aa | Mul (_, _) => NEq aa) end | simpfm (Dvd (i, a)) = @@ -1256,7 +1341,7 @@ (case aa of C v => (if dvd (semiring_div_int, equal_int) i v then T else F) - | Bound _ => Dvd (i, aa) | Cn (_, _, _) => Dvd (i, aa) + | Bound _ => Dvd (i, aa) | CN (_, _, _) => Dvd (i, aa) | Neg _ => Dvd (i, aa) | Add (_, _) => Dvd (i, aa) | Sub (_, _) => Dvd (i, aa) | Mul (_, _) => Dvd (i, aa)) end)) @@ -1270,7 +1355,7 @@ of C v => (if not (dvd (semiring_div_int, equal_int) i v) then T else F) - | Bound _ => NDvd (i, aa) | Cn (_, _, _) => NDvd (i, aa) + | Bound _ => NDvd (i, aa) | CN (_, _, _) => NDvd (i, aa) | Neg _ => NDvd (i, aa) | Add (_, _) => NDvd (i, aa) | Sub (_, _) => NDvd (i, aa) | Mul (_, _) => NDvd (i, aa)) end)) @@ -1338,70 +1423,71 @@ | a_beta (NDvd (ac, Add (iu, iv))) = (fn _ => NDvd (ac, Add (iu, iv))) | a_beta (NDvd (ac, Sub (iw, ix))) = (fn _ => NDvd (ac, Sub (iw, ix))) | a_beta (NDvd (ac, Mul (iy, iz))) = (fn _ => NDvd (ac, Mul (iy, iz))) - | a_beta (Not ae) = (fn _ => Not ae) + | a_beta (NOT ae) = (fn _ => NOT ae) | a_beta (Imp (aj, ak)) = (fn _ => Imp (aj, ak)) | a_beta (Iff (al, am)) = (fn _ => Iff (al, am)) | a_beta (E an) = (fn _ => E an) | a_beta (A ao) = (fn _ => A ao) | a_beta (Closed ap) = (fn _ => Closed ap) | a_beta (NClosed aq) = (fn _ => NClosed aq) - | a_beta (Lt (Cn (cm, c, e))) = + | a_beta (Lt (CN (cm, c, e))) = (if equal_nat cm zero_nat then (fn k => - Lt (Cn (zero_nat, Int_of_integer (1 : IntInf.int), - Mul (div_inta k c, e)))) - else (fn _ => Lt (Cn (suc (minus_nat cm one_nat), c, e)))) - | a_beta (Le (Cn (dm, c, e))) = + Lt (CN (zero_nat, Int_of_integer (1 : IntInf.int), + Mul (divide_inta k c, e)))) + else (fn _ => Lt (CN (suc (minus_nat cm one_nat), c, e)))) + | a_beta (Le (CN (dm, c, e))) = (if equal_nat dm zero_nat then (fn k => - Le (Cn (zero_nat, Int_of_integer (1 : IntInf.int), - Mul (div_inta k c, e)))) - else (fn _ => Le (Cn (suc (minus_nat dm one_nat), c, e)))) - | a_beta (Gt (Cn (em, c, e))) = + Le (CN (zero_nat, Int_of_integer (1 : IntInf.int), + Mul (divide_inta k c, e)))) + else (fn _ => Le (CN (suc (minus_nat dm one_nat), c, e)))) + | a_beta (Gt (CN (em, c, e))) = (if equal_nat em zero_nat then (fn k => - Gt (Cn (zero_nat, Int_of_integer (1 : IntInf.int), - Mul (div_inta k c, e)))) - else (fn _ => Gt (Cn (suc (minus_nat em one_nat), c, e)))) - | a_beta (Ge (Cn (fm, c, e))) = + Gt (CN (zero_nat, Int_of_integer (1 : IntInf.int), + Mul (divide_inta k c, e)))) + else (fn _ => Gt (CN (suc (minus_nat em one_nat), c, e)))) + | a_beta (Ge (CN (fm, c, e))) = (if equal_nat fm zero_nat then (fn k => - Ge (Cn (zero_nat, Int_of_integer (1 : IntInf.int), - Mul (div_inta k c, e)))) - else (fn _ => Ge (Cn (suc (minus_nat fm one_nat), c, e)))) - | a_beta (Eq (Cn (gm, c, e))) = + Ge (CN (zero_nat, Int_of_integer (1 : IntInf.int), + Mul (divide_inta k c, e)))) + else (fn _ => Ge (CN (suc (minus_nat fm one_nat), c, e)))) + | a_beta (Eq (CN (gm, c, e))) = (if equal_nat gm zero_nat then (fn k => - Eq (Cn (zero_nat, Int_of_integer (1 : IntInf.int), - Mul (div_inta k c, e)))) - else (fn _ => Eq (Cn (suc (minus_nat gm one_nat), c, e)))) - | a_beta (NEq (Cn (hm, c, e))) = + Eq (CN (zero_nat, Int_of_integer (1 : IntInf.int), + Mul (divide_inta k c, e)))) + else (fn _ => Eq (CN (suc (minus_nat gm one_nat), c, e)))) + | a_beta (NEq (CN (hm, c, e))) = (if equal_nat hm zero_nat then (fn k => - NEq (Cn (zero_nat, Int_of_integer (1 : IntInf.int), - Mul (div_inta k c, e)))) - else (fn _ => NEq (Cn (suc (minus_nat hm one_nat), c, e)))) - | a_beta (Dvd (i, Cn (im, c, e))) = + NEq (CN (zero_nat, Int_of_integer (1 : IntInf.int), + Mul (divide_inta k c, e)))) + else (fn _ => NEq (CN (suc (minus_nat hm one_nat), c, e)))) + | a_beta (Dvd (i, CN (im, c, e))) = (if equal_nat im zero_nat then (fn k => - Dvd (times_inta (div_inta k c) i, - Cn (zero_nat, Int_of_integer (1 : IntInf.int), - Mul (div_inta k c, e)))) - else (fn _ => Dvd (i, Cn (suc (minus_nat im one_nat), c, e)))) - | a_beta (NDvd (i, Cn (jm, c, e))) = + Dvd (times_inta (divide_inta k c) i, + CN (zero_nat, Int_of_integer (1 : IntInf.int), + Mul (divide_inta k c, e)))) + else (fn _ => Dvd (i, CN (suc (minus_nat im one_nat), c, e)))) + | a_beta (NDvd (i, CN (jm, c, e))) = (if equal_nat jm zero_nat then (fn k => - NDvd (times_inta (div_inta k c) i, - Cn (zero_nat, Int_of_integer (1 : IntInf.int), - Mul (div_inta k c, e)))) - else (fn _ => NDvd (i, Cn (suc (minus_nat jm one_nat), c, e)))); + NDvd (times_inta (divide_inta k c) i, + CN (zero_nat, Int_of_integer (1 : IntInf.int), + Mul (divide_inta k c, e)))) + else (fn _ => NDvd (i, CN (suc (minus_nat jm one_nat), c, e)))); fun gcd_int k l = abs_int (if equal_inta l zero_inta then k else gcd_int l (mod_int (abs_int k) (abs_int l))); -fun lcm_int a b = div_inta (times_inta (abs_int a) (abs_int b)) (gcd_int a b); +fun lcm_int a b = + divide_inta (times_inta (abs_int a) (abs_int b)) (gcd_int a b); fun delta (And (p, q)) = lcm_int (delta p) (delta q) | delta (Or (p, q)) = lcm_int (delta p) (delta q) @@ -1425,16 +1511,16 @@ | delta (NDvd (ac, Add (cu, cv))) = Int_of_integer (1 : IntInf.int) | delta (NDvd (ac, Sub (cw, cx))) = Int_of_integer (1 : IntInf.int) | delta (NDvd (ac, Mul (cy, cz))) = Int_of_integer (1 : IntInf.int) - | delta (Not ae) = Int_of_integer (1 : IntInf.int) + | delta (NOT ae) = Int_of_integer (1 : IntInf.int) | delta (Imp (aj, ak)) = Int_of_integer (1 : IntInf.int) | delta (Iff (al, am)) = Int_of_integer (1 : IntInf.int) | delta (E an) = Int_of_integer (1 : IntInf.int) | delta (A ao) = Int_of_integer (1 : IntInf.int) | delta (Closed ap) = Int_of_integer (1 : IntInf.int) | delta (NClosed aq) = Int_of_integer (1 : IntInf.int) - | delta (Dvd (i, Cn (cm, c, e))) = + | delta (Dvd (i, CN (cm, c, e))) = (if equal_nat cm zero_nat then i else Int_of_integer (1 : IntInf.int)) - | delta (NDvd (i, Cn (dm, c, e))) = + | delta (NDvd (i, CN (dm, c, e))) = (if equal_nat dm zero_nat then i else Int_of_integer (1 : IntInf.int)); fun alpha (And (p, q)) = alpha p @ alpha q @@ -1479,23 +1565,23 @@ | alpha (NEq (Mul (gy, gz))) = [] | alpha (Dvd (aa, ab)) = [] | alpha (NDvd (ac, ad)) = [] - | alpha (Not ae) = [] + | alpha (NOT ae) = [] | alpha (Imp (aj, ak)) = [] | alpha (Iff (al, am)) = [] | alpha (E an) = [] | alpha (A ao) = [] | alpha (Closed ap) = [] | alpha (NClosed aq) = [] - | alpha (Lt (Cn (cm, c, e))) = (if equal_nat cm zero_nat then [e] else []) - | alpha (Le (Cn (dm, c, e))) = + | alpha (Lt (CN (cm, c, e))) = (if equal_nat cm zero_nat then [e] else []) + | alpha (Le (CN (dm, c, e))) = (if equal_nat dm zero_nat then [Add (C (uminus_int (Int_of_integer (1 : IntInf.int))), e)] else []) - | alpha (Gt (Cn (em, c, e))) = (if equal_nat em zero_nat then [] else []) - | alpha (Ge (Cn (fm, c, e))) = (if equal_nat fm zero_nat then [] else []) - | alpha (Eq (Cn (gm, c, e))) = + | alpha (Gt (CN (em, c, e))) = (if equal_nat em zero_nat then [] else []) + | alpha (Ge (CN (fm, c, e))) = (if equal_nat fm zero_nat then [] else []) + | alpha (Eq (CN (gm, c, e))) = (if equal_nat gm zero_nat then [Add (C (uminus_int (Int_of_integer (1 : IntInf.int))), e)] else []) - | alpha (NEq (Cn (hm, c, e))) = (if equal_nat hm zero_nat then [e] else []); + | alpha (NEq (CN (hm, c, e))) = (if equal_nat hm zero_nat then [e] else []); fun zeta (And (p, q)) = lcm_int (zeta p) (zeta q) | zeta (Or (p, q)) = lcm_int (zeta p) (zeta q) @@ -1549,28 +1635,28 @@ | zeta (NDvd (ac, Add (iu, iv))) = Int_of_integer (1 : IntInf.int) | zeta (NDvd (ac, Sub (iw, ix))) = Int_of_integer (1 : IntInf.int) | zeta (NDvd (ac, Mul (iy, iz))) = Int_of_integer (1 : IntInf.int) - | zeta (Not ae) = Int_of_integer (1 : IntInf.int) + | zeta (NOT ae) = Int_of_integer (1 : IntInf.int) | zeta (Imp (aj, ak)) = Int_of_integer (1 : IntInf.int) | zeta (Iff (al, am)) = Int_of_integer (1 : IntInf.int) | zeta (E an) = Int_of_integer (1 : IntInf.int) | zeta (A ao) = Int_of_integer (1 : IntInf.int) | zeta (Closed ap) = Int_of_integer (1 : IntInf.int) | zeta (NClosed aq) = Int_of_integer (1 : IntInf.int) - | zeta (Lt (Cn (cm, c, e))) = + | zeta (Lt (CN (cm, c, e))) = (if equal_nat cm zero_nat then c else Int_of_integer (1 : IntInf.int)) - | zeta (Le (Cn (dm, c, e))) = + | zeta (Le (CN (dm, c, e))) = (if equal_nat dm zero_nat then c else Int_of_integer (1 : IntInf.int)) - | zeta (Gt (Cn (em, c, e))) = + | zeta (Gt (CN (em, c, e))) = (if equal_nat em zero_nat then c else Int_of_integer (1 : IntInf.int)) - | zeta (Ge (Cn (fm, c, e))) = + | zeta (Ge (CN (fm, c, e))) = (if equal_nat fm zero_nat then c else Int_of_integer (1 : IntInf.int)) - | zeta (Eq (Cn (gm, c, e))) = + | zeta (Eq (CN (gm, c, e))) = (if equal_nat gm zero_nat then c else Int_of_integer (1 : IntInf.int)) - | zeta (NEq (Cn (hm, c, e))) = + | zeta (NEq (CN (hm, c, e))) = (if equal_nat hm zero_nat then c else Int_of_integer (1 : IntInf.int)) - | zeta (Dvd (i, Cn (im, c, e))) = + | zeta (Dvd (i, CN (im, c, e))) = (if equal_nat im zero_nat then c else Int_of_integer (1 : IntInf.int)) - | zeta (NDvd (i, Cn (jm, c, e))) = + | zeta (NDvd (i, CN (jm, c, e))) = (if equal_nat jm zero_nat then c else Int_of_integer (1 : IntInf.int)); fun beta (And (p, q)) = beta p @ beta q @@ -1615,23 +1701,23 @@ | beta (NEq (Mul (gy, gz))) = [] | beta (Dvd (aa, ab)) = [] | beta (NDvd (ac, ad)) = [] - | beta (Not ae) = [] + | beta (NOT ae) = [] | beta (Imp (aj, ak)) = [] | beta (Iff (al, am)) = [] | beta (E an) = [] | beta (A ao) = [] | beta (Closed ap) = [] | beta (NClosed aq) = [] - | beta (Lt (Cn (cm, c, e))) = (if equal_nat cm zero_nat then [] else []) - | beta (Le (Cn (dm, c, e))) = (if equal_nat dm zero_nat then [] else []) - | beta (Gt (Cn (em, c, e))) = (if equal_nat em zero_nat then [Neg e] else []) - | beta (Ge (Cn (fm, c, e))) = + | beta (Lt (CN (cm, c, e))) = (if equal_nat cm zero_nat then [] else []) + | beta (Le (CN (dm, c, e))) = (if equal_nat dm zero_nat then [] else []) + | beta (Gt (CN (em, c, e))) = (if equal_nat em zero_nat then [Neg e] else []) + | beta (Ge (CN (fm, c, e))) = (if equal_nat fm zero_nat then [Sub (C (uminus_int (Int_of_integer (1 : IntInf.int))), e)] else []) - | beta (Eq (Cn (gm, c, e))) = + | beta (Eq (CN (gm, c, e))) = (if equal_nat gm zero_nat then [Sub (C (uminus_int (Int_of_integer (1 : IntInf.int))), e)] else []) - | beta (NEq (Cn (hm, c, e))) = + | beta (NEq (CN (hm, c, e))) = (if equal_nat hm zero_nat then [Neg e] else []); fun mirror (And (p, q)) = And (mirror p, mirror q) @@ -1686,37 +1772,37 @@ | mirror (NDvd (ac, Add (iu, iv))) = NDvd (ac, Add (iu, iv)) | mirror (NDvd (ac, Sub (iw, ix))) = NDvd (ac, Sub (iw, ix)) | mirror (NDvd (ac, Mul (iy, iz))) = NDvd (ac, Mul (iy, iz)) - | mirror (Not ae) = Not ae + | mirror (NOT ae) = NOT ae | mirror (Imp (aj, ak)) = Imp (aj, ak) | mirror (Iff (al, am)) = Iff (al, am) | mirror (E an) = E an | mirror (A ao) = A ao | mirror (Closed ap) = Closed ap | mirror (NClosed aq) = NClosed aq - | mirror (Lt (Cn (cm, c, e))) = - (if equal_nat cm zero_nat then Gt (Cn (zero_nat, c, Neg e)) - else Lt (Cn (suc (minus_nat cm one_nat), c, e))) - | mirror (Le (Cn (dm, c, e))) = - (if equal_nat dm zero_nat then Ge (Cn (zero_nat, c, Neg e)) - else Le (Cn (suc (minus_nat dm one_nat), c, e))) - | mirror (Gt (Cn (em, c, e))) = - (if equal_nat em zero_nat then Lt (Cn (zero_nat, c, Neg e)) - else Gt (Cn (suc (minus_nat em one_nat), c, e))) - | mirror (Ge (Cn (fm, c, e))) = - (if equal_nat fm zero_nat then Le (Cn (zero_nat, c, Neg e)) - else Ge (Cn (suc (minus_nat fm one_nat), c, e))) - | mirror (Eq (Cn (gm, c, e))) = - (if equal_nat gm zero_nat then Eq (Cn (zero_nat, c, Neg e)) - else Eq (Cn (suc (minus_nat gm one_nat), c, e))) - | mirror (NEq (Cn (hm, c, e))) = - (if equal_nat hm zero_nat then NEq (Cn (zero_nat, c, Neg e)) - else NEq (Cn (suc (minus_nat hm one_nat), c, e))) - | mirror (Dvd (i, Cn (im, c, e))) = - (if equal_nat im zero_nat then Dvd (i, Cn (zero_nat, c, Neg e)) - else Dvd (i, Cn (suc (minus_nat im one_nat), c, e))) - | mirror (NDvd (i, Cn (jm, c, e))) = - (if equal_nat jm zero_nat then NDvd (i, Cn (zero_nat, c, Neg e)) - else NDvd (i, Cn (suc (minus_nat jm one_nat), c, e))); + | mirror (Lt (CN (cm, c, e))) = + (if equal_nat cm zero_nat then Gt (CN (zero_nat, c, Neg e)) + else Lt (CN (suc (minus_nat cm one_nat), c, e))) + | mirror (Le (CN (dm, c, e))) = + (if equal_nat dm zero_nat then Ge (CN (zero_nat, c, Neg e)) + else Le (CN (suc (minus_nat dm one_nat), c, e))) + | mirror (Gt (CN (em, c, e))) = + (if equal_nat em zero_nat then Lt (CN (zero_nat, c, Neg e)) + else Gt (CN (suc (minus_nat em one_nat), c, e))) + | mirror (Ge (CN (fm, c, e))) = + (if equal_nat fm zero_nat then Le (CN (zero_nat, c, Neg e)) + else Ge (CN (suc (minus_nat fm one_nat), c, e))) + | mirror (Eq (CN (gm, c, e))) = + (if equal_nat gm zero_nat then Eq (CN (zero_nat, c, Neg e)) + else Eq (CN (suc (minus_nat gm one_nat), c, e))) + | mirror (NEq (CN (hm, c, e))) = + (if equal_nat hm zero_nat then NEq (CN (zero_nat, c, Neg e)) + else NEq (CN (suc (minus_nat hm one_nat), c, e))) + | mirror (Dvd (i, CN (im, c, e))) = + (if equal_nat im zero_nat then Dvd (i, CN (zero_nat, c, Neg e)) + else Dvd (i, CN (suc (minus_nat im one_nat), c, e))) + | mirror (NDvd (i, CN (jm, c, e))) = + (if equal_nat jm zero_nat then NDvd (i, CN (zero_nat, c, Neg e)) + else NDvd (i, CN (suc (minus_nat jm one_nat), c, e))); fun member A_ [] y = false | member A_ (x :: xs) y = eq A_ x y orelse member A_ xs y; @@ -1725,97 +1811,103 @@ | remdups A_ (x :: xs) = (if member A_ xs x then remdups A_ xs else x :: remdups A_ xs); -fun minus_int k l = Int_of_integer (integer_of_int k - integer_of_int l); - fun zsplit0 (C c) = (zero_inta, C c) | zsplit0 (Bound n) = (if equal_nat n zero_nat then (Int_of_integer (1 : IntInf.int), C zero_inta) else (zero_inta, Bound n)) - | zsplit0 (Cn (n, i, a)) = + | zsplit0 (CN (n, i, a)) = let - val (ia, aa) = zsplit0 a; + val aa = zsplit0 a; + val (ia, ab) = aa; in - (if equal_nat n zero_nat then (plus_inta i ia, aa) - else (ia, Cn (n, i, aa))) + (if equal_nat n zero_nat then (plus_inta i ia, ab) + else (ia, CN (n, i, ab))) end - | zsplit0 (Neg a) = let - val (i, aa) = zsplit0 a; - in - (uminus_int i, Neg aa) - end + | zsplit0 (Neg a) = + let + val aa = zsplit0 a; + val (i, ab) = aa; + in + (uminus_int i, Neg ab) + end | zsplit0 (Add (a, b)) = let - val (ia, aa) = zsplit0 a; - val (ib, ba) = zsplit0 b; + val aa = zsplit0 a; + val (ia, ab) = aa; + val ba = zsplit0 b; + val (ib, bb) = ba; in - (plus_inta ia ib, Add (aa, ba)) + (plus_inta ia ib, Add (ab, bb)) end | zsplit0 (Sub (a, b)) = let - val (ia, aa) = zsplit0 a; - val (ib, ba) = zsplit0 b; + val aa = zsplit0 a; + val (ia, ab) = aa; + val ba = zsplit0 b; + val (ib, bb) = ba; in - (minus_int ia ib, Sub (aa, ba)) + (minus_inta ia ib, Sub (ab, bb)) end | zsplit0 (Mul (i, a)) = let - val (ia, aa) = zsplit0 a; + val aa = zsplit0 a; + val (ia, ab) = aa; in - (times_inta i ia, Mul (i, aa)) + (times_inta i ia, Mul (i, ab)) end; fun zlfm (And (p, q)) = And (zlfm p, zlfm q) | zlfm (Or (p, q)) = Or (zlfm p, zlfm q) - | zlfm (Imp (p, q)) = Or (zlfm (Not p), zlfm q) + | zlfm (Imp (p, q)) = Or (zlfm (NOT p), zlfm q) | zlfm (Iff (p, q)) = - Or (And (zlfm p, zlfm q), And (zlfm (Not p), zlfm (Not q))) + Or (And (zlfm p, zlfm q), And (zlfm (NOT p), zlfm (NOT q))) | zlfm (Lt a) = let val (c, r) = zsplit0 a; in (if equal_inta c zero_inta then Lt r - else (if less_int zero_inta c then Lt (Cn (zero_nat, c, r)) - else Gt (Cn (zero_nat, uminus_int c, Neg r)))) + else (if less_int zero_inta c then Lt (CN (zero_nat, c, r)) + else Gt (CN (zero_nat, uminus_int c, Neg r)))) end | zlfm (Le a) = let val (c, r) = zsplit0 a; in (if equal_inta c zero_inta then Le r - else (if less_int zero_inta c then Le (Cn (zero_nat, c, r)) - else Ge (Cn (zero_nat, uminus_int c, Neg r)))) + else (if less_int zero_inta c then Le (CN (zero_nat, c, r)) + else Ge (CN (zero_nat, uminus_int c, Neg r)))) end | zlfm (Gt a) = let val (c, r) = zsplit0 a; in (if equal_inta c zero_inta then Gt r - else (if less_int zero_inta c then Gt (Cn (zero_nat, c, r)) - else Lt (Cn (zero_nat, uminus_int c, Neg r)))) + else (if less_int zero_inta c then Gt (CN (zero_nat, c, r)) + else Lt (CN (zero_nat, uminus_int c, Neg r)))) end | zlfm (Ge a) = let val (c, r) = zsplit0 a; in (if equal_inta c zero_inta then Ge r - else (if less_int zero_inta c then Ge (Cn (zero_nat, c, r)) - else Le (Cn (zero_nat, uminus_int c, Neg r)))) + else (if less_int zero_inta c then Ge (CN (zero_nat, c, r)) + else Le (CN (zero_nat, uminus_int c, Neg r)))) end | zlfm (Eq a) = let val (c, r) = zsplit0 a; in (if equal_inta c zero_inta then Eq r - else (if less_int zero_inta c then Eq (Cn (zero_nat, c, r)) - else Eq (Cn (zero_nat, uminus_int c, Neg r)))) + else (if less_int zero_inta c then Eq (CN (zero_nat, c, r)) + else Eq (CN (zero_nat, uminus_int c, Neg r)))) end | zlfm (NEq a) = let val (c, r) = zsplit0 a; in (if equal_inta c zero_inta then NEq r - else (if less_int zero_inta c then NEq (Cn (zero_nat, c, r)) - else NEq (Cn (zero_nat, uminus_int c, Neg r)))) + else (if less_int zero_inta c then NEq (CN (zero_nat, c, r)) + else NEq (CN (zero_nat, uminus_int c, Neg r)))) end | zlfm (Dvd (i, a)) = (if equal_inta i zero_inta then zlfm (Eq a) @@ -1824,8 +1916,8 @@ in (if equal_inta c zero_inta then Dvd (abs_int i, r) else (if less_int zero_inta c - then Dvd (abs_int i, Cn (zero_nat, c, r)) - else Dvd (abs_int i, Cn (zero_nat, uminus_int c, Neg r)))) + then Dvd (abs_int i, CN (zero_nat, c, r)) + else Dvd (abs_int i, CN (zero_nat, uminus_int c, Neg r)))) end) | zlfm (NDvd (i, a)) = (if equal_inta i zero_inta then zlfm (NEq a) @@ -1834,32 +1926,32 @@ in (if equal_inta c zero_inta then NDvd (abs_int i, r) else (if less_int zero_inta c - then NDvd (abs_int i, Cn (zero_nat, c, r)) + then NDvd (abs_int i, CN (zero_nat, c, r)) else NDvd (abs_int i, - Cn (zero_nat, uminus_int c, Neg r)))) + CN (zero_nat, uminus_int c, Neg r)))) end) - | zlfm (Not (And (p, q))) = Or (zlfm (Not p), zlfm (Not q)) - | zlfm (Not (Or (p, q))) = And (zlfm (Not p), zlfm (Not q)) - | zlfm (Not (Imp (p, q))) = And (zlfm p, zlfm (Not q)) - | zlfm (Not (Iff (p, q))) = - Or (And (zlfm p, zlfm (Not q)), And (zlfm (Not p), zlfm q)) - | zlfm (Not (Not p)) = zlfm p - | zlfm (Not T) = F - | zlfm (Not F) = T - | zlfm (Not (Lt a)) = zlfm (Ge a) - | zlfm (Not (Le a)) = zlfm (Gt a) - | zlfm (Not (Gt a)) = zlfm (Le a) - | zlfm (Not (Ge a)) = zlfm (Lt a) - | zlfm (Not (Eq a)) = zlfm (NEq a) - | zlfm (Not (NEq a)) = zlfm (Eq a) - | zlfm (Not (Dvd (i, a))) = zlfm (NDvd (i, a)) - | zlfm (Not (NDvd (i, a))) = zlfm (Dvd (i, a)) - | zlfm (Not (Closed p)) = NClosed p - | zlfm (Not (NClosed p)) = Closed p + | zlfm (NOT (And (p, q))) = Or (zlfm (NOT p), zlfm (NOT q)) + | zlfm (NOT (Or (p, q))) = And (zlfm (NOT p), zlfm (NOT q)) + | zlfm (NOT (Imp (p, q))) = And (zlfm p, zlfm (NOT q)) + | zlfm (NOT (Iff (p, q))) = + Or (And (zlfm p, zlfm (NOT q)), And (zlfm (NOT p), zlfm q)) + | zlfm (NOT (NOT p)) = zlfm p + | zlfm (NOT T) = F + | zlfm (NOT F) = T + | zlfm (NOT (Lt a)) = zlfm (Ge a) + | zlfm (NOT (Le a)) = zlfm (Gt a) + | zlfm (NOT (Gt a)) = zlfm (Le a) + | zlfm (NOT (Ge a)) = zlfm (Lt a) + | zlfm (NOT (Eq a)) = zlfm (NEq a) + | zlfm (NOT (NEq a)) = zlfm (Eq a) + | zlfm (NOT (Dvd (i, a))) = zlfm (NDvd (i, a)) + | zlfm (NOT (NDvd (i, a))) = zlfm (Dvd (i, a)) + | zlfm (NOT (Closed p)) = NClosed p + | zlfm (NOT (NClosed p)) = Closed p | zlfm T = T | zlfm F = F - | zlfm (Not (E ci)) = Not (E ci) - | zlfm (Not (A cj)) = Not (A cj) + | zlfm (NOT (E ci)) = NOT (E ci) + | zlfm (NOT (A cj)) = NOT (A cj) | zlfm (E ao) = E ao | zlfm (A ap) = A ap | zlfm (Closed aq) = Closed aq @@ -1870,7 +1962,7 @@ val pa = zlfm p; val l = zeta pa; val q = - And (Dvd (l, Cn (zero_nat, Int_of_integer (1 : IntInf.int), C zero_inta)), + And (Dvd (l, CN (zero_nat, Int_of_integer (1 : IntInf.int), C zero_inta)), a_beta pa l); val d = delta q; val b = remdups equal_num (map simpnum (beta q)); @@ -1885,7 +1977,7 @@ | decrnum (Add (a, b)) = Add (decrnum a, decrnum b) | decrnum (Sub (a, b)) = Sub (decrnum a, decrnum b) | decrnum (Mul (c, a)) = Mul (c, decrnum a) - | decrnum (Cn (n, i, a)) = Cn (minus_nat n one_nat, i, decrnum a) + | decrnum (CN (n, i, a)) = CN (minus_nat n one_nat, i, decrnum a) | decrnum (C v) = C v; fun decr (Lt a) = Lt (decrnum a) @@ -1896,7 +1988,7 @@ | decr (NEq a) = NEq (decrnum a) | decr (Dvd (i, a)) = Dvd (i, decrnum a) | decr (NDvd (i, a)) = NDvd (i, decrnum a) - | decr (Not p) = Not (decr p) + | decr (NOT p) = NOT (decr p) | decr (And (p, q)) = And (decr p, decr q) | decr (Or (p, q)) = Or (decr p, decr q) | decr (Imp (p, q)) = Imp (decr p, decr q) @@ -1910,7 +2002,7 @@ fun upto_aux i j js = (if less_int j i then js - else upto_aux i (minus_int j (Int_of_integer (1 : IntInf.int))) (j :: js)); + else upto_aux i (minus_inta j (Int_of_integer (1 : IntInf.int))) (j :: js)); fun uptoa i j = upto_aux i j []; @@ -1935,8 +2027,8 @@ end; fun qelim (E p) = (fn qe => dj qe (qelim p qe)) - | qelim (A p) = (fn qe => nota (qe (qelim (Not p) qe))) - | qelim (Not p) = (fn qe => nota (qelim p qe)) + | qelim (A p) = (fn qe => nota (qe (qelim (NOT p) qe))) + | qelim (NOT p) = (fn qe => nota (qelim p qe)) | qelim (And (p, q)) = (fn qe => conj (qelim p qe) (qelim q qe)) | qelim (Or (p, q)) = (fn qe => disj (qelim p qe) (qelim q qe)) | qelim (Imp (p, q)) = (fn qe => imp (qelim p qe) (qelim q qe)) @@ -1957,13 +2049,13 @@ fun prep (E T) = T | prep (E F) = F | prep (E (Or (p, q))) = Or (prep (E p), prep (E q)) - | prep (E (Imp (p, q))) = Or (prep (E (Not p)), prep (E q)) + | prep (E (Imp (p, q))) = Or (prep (E (NOT p)), prep (E q)) | prep (E (Iff (p, q))) = - Or (prep (E (And (p, q))), prep (E (And (Not p, Not q)))) - | prep (E (Not (And (p, q)))) = Or (prep (E (Not p)), prep (E (Not q))) - | prep (E (Not (Imp (p, q)))) = prep (E (And (p, Not q))) - | prep (E (Not (Iff (p, q)))) = - Or (prep (E (And (p, Not q))), prep (E (And (Not p, q)))) + Or (prep (E (And (p, q))), prep (E (And (NOT p, NOT q)))) + | prep (E (NOT (And (p, q)))) = Or (prep (E (NOT p)), prep (E (NOT q))) + | prep (E (NOT (Imp (p, q)))) = prep (E (And (p, NOT q))) + | prep (E (NOT (Iff (p, q)))) = + Or (prep (E (And (p, NOT q))), prep (E (And (NOT p, q)))) | prep (E (Lt ef)) = E (prep (Lt ef)) | prep (E (Le eg)) = E (prep (Le eg)) | prep (E (Gt eh)) = E (prep (Gt eh)) @@ -1972,69 +2064,69 @@ | prep (E (NEq ek)) = E (prep (NEq ek)) | prep (E (Dvd (el, em))) = E (prep (Dvd (el, em))) | prep (E (NDvd (en, eo))) = E (prep (NDvd (en, eo))) - | prep (E (Not T)) = E (prep (Not T)) - | prep (E (Not F)) = E (prep (Not F)) - | prep (E (Not (Lt gw))) = E (prep (Not (Lt gw))) - | prep (E (Not (Le gx))) = E (prep (Not (Le gx))) - | prep (E (Not (Gt gy))) = E (prep (Not (Gt gy))) - | prep (E (Not (Ge gz))) = E (prep (Not (Ge gz))) - | prep (E (Not (Eq ha))) = E (prep (Not (Eq ha))) - | prep (E (Not (NEq hb))) = E (prep (Not (NEq hb))) - | prep (E (Not (Dvd (hc, hd)))) = E (prep (Not (Dvd (hc, hd)))) - | prep (E (Not (NDvd (he, hf)))) = E (prep (Not (NDvd (he, hf)))) - | prep (E (Not (Not hg))) = E (prep (Not (Not hg))) - | prep (E (Not (Or (hj, hk)))) = E (prep (Not (Or (hj, hk)))) - | prep (E (Not (E hp))) = E (prep (Not (E hp))) - | prep (E (Not (A hq))) = E (prep (Not (A hq))) - | prep (E (Not (Closed hr))) = E (prep (Not (Closed hr))) - | prep (E (Not (NClosed hs))) = E (prep (Not (NClosed hs))) + | prep (E (NOT T)) = E (prep (NOT T)) + | prep (E (NOT F)) = E (prep (NOT F)) + | prep (E (NOT (Lt gw))) = E (prep (NOT (Lt gw))) + | prep (E (NOT (Le gx))) = E (prep (NOT (Le gx))) + | prep (E (NOT (Gt gy))) = E (prep (NOT (Gt gy))) + | prep (E (NOT (Ge gz))) = E (prep (NOT (Ge gz))) + | prep (E (NOT (Eq ha))) = E (prep (NOT (Eq ha))) + | prep (E (NOT (NEq hb))) = E (prep (NOT (NEq hb))) + | prep (E (NOT (Dvd (hc, hd)))) = E (prep (NOT (Dvd (hc, hd)))) + | prep (E (NOT (NDvd (he, hf)))) = E (prep (NOT (NDvd (he, hf)))) + | prep (E (NOT (NOT hg))) = E (prep (NOT (NOT hg))) + | prep (E (NOT (Or (hj, hk)))) = E (prep (NOT (Or (hj, hk)))) + | prep (E (NOT (E hp))) = E (prep (NOT (E hp))) + | prep (E (NOT (A hq))) = E (prep (NOT (A hq))) + | prep (E (NOT (Closed hr))) = E (prep (NOT (Closed hr))) + | prep (E (NOT (NClosed hs))) = E (prep (NOT (NClosed hs))) | prep (E (And (eq, er))) = E (prep (And (eq, er))) | prep (E (E ey)) = E (prep (E ey)) | prep (E (A ez)) = E (prep (A ez)) | prep (E (Closed fa)) = E (prep (Closed fa)) | prep (E (NClosed fb)) = E (prep (NClosed fb)) | prep (A (And (p, q))) = And (prep (A p), prep (A q)) - | prep (A T) = prep (Not (E (Not T))) - | prep (A F) = prep (Not (E (Not F))) - | prep (A (Lt jn)) = prep (Not (E (Not (Lt jn)))) - | prep (A (Le jo)) = prep (Not (E (Not (Le jo)))) - | prep (A (Gt jp)) = prep (Not (E (Not (Gt jp)))) - | prep (A (Ge jq)) = prep (Not (E (Not (Ge jq)))) - | prep (A (Eq jr)) = prep (Not (E (Not (Eq jr)))) - | prep (A (NEq js)) = prep (Not (E (Not (NEq js)))) - | prep (A (Dvd (jt, ju))) = prep (Not (E (Not (Dvd (jt, ju))))) - | prep (A (NDvd (jv, jw))) = prep (Not (E (Not (NDvd (jv, jw))))) - | prep (A (Not jx)) = prep (Not (E (Not (Not jx)))) - | prep (A (Or (ka, kb))) = prep (Not (E (Not (Or (ka, kb))))) - | prep (A (Imp (kc, kd))) = prep (Not (E (Not (Imp (kc, kd))))) - | prep (A (Iff (ke, kf))) = prep (Not (E (Not (Iff (ke, kf))))) - | prep (A (E kg)) = prep (Not (E (Not (E kg)))) - | prep (A (A kh)) = prep (Not (E (Not (A kh)))) - | prep (A (Closed ki)) = prep (Not (E (Not (Closed ki)))) - | prep (A (NClosed kj)) = prep (Not (E (Not (NClosed kj)))) - | prep (Not (Not p)) = prep p - | prep (Not (And (p, q))) = Or (prep (Not p), prep (Not q)) - | prep (Not (A p)) = prep (E (Not p)) - | prep (Not (Or (p, q))) = And (prep (Not p), prep (Not q)) - | prep (Not (Imp (p, q))) = And (prep p, prep (Not q)) - | prep (Not (Iff (p, q))) = Or (prep (And (p, Not q)), prep (And (Not p, q))) - | prep (Not T) = Not (prep T) - | prep (Not F) = Not (prep F) - | prep (Not (Lt bo)) = Not (prep (Lt bo)) - | prep (Not (Le bp)) = Not (prep (Le bp)) - | prep (Not (Gt bq)) = Not (prep (Gt bq)) - | prep (Not (Ge br)) = Not (prep (Ge br)) - | prep (Not (Eq bs)) = Not (prep (Eq bs)) - | prep (Not (NEq bt)) = Not (prep (NEq bt)) - | prep (Not (Dvd (bu, bv))) = Not (prep (Dvd (bu, bv))) - | prep (Not (NDvd (bw, bx))) = Not (prep (NDvd (bw, bx))) - | prep (Not (E ch)) = Not (prep (E ch)) - | prep (Not (Closed cj)) = Not (prep (Closed cj)) - | prep (Not (NClosed ck)) = Not (prep (NClosed ck)) + | prep (A T) = prep (NOT (E (NOT T))) + | prep (A F) = prep (NOT (E (NOT F))) + | prep (A (Lt jn)) = prep (NOT (E (NOT (Lt jn)))) + | prep (A (Le jo)) = prep (NOT (E (NOT (Le jo)))) + | prep (A (Gt jp)) = prep (NOT (E (NOT (Gt jp)))) + | prep (A (Ge jq)) = prep (NOT (E (NOT (Ge jq)))) + | prep (A (Eq jr)) = prep (NOT (E (NOT (Eq jr)))) + | prep (A (NEq js)) = prep (NOT (E (NOT (NEq js)))) + | prep (A (Dvd (jt, ju))) = prep (NOT (E (NOT (Dvd (jt, ju))))) + | prep (A (NDvd (jv, jw))) = prep (NOT (E (NOT (NDvd (jv, jw))))) + | prep (A (NOT jx)) = prep (NOT (E (NOT (NOT jx)))) + | prep (A (Or (ka, kb))) = prep (NOT (E (NOT (Or (ka, kb))))) + | prep (A (Imp (kc, kd))) = prep (NOT (E (NOT (Imp (kc, kd))))) + | prep (A (Iff (ke, kf))) = prep (NOT (E (NOT (Iff (ke, kf))))) + | prep (A (E kg)) = prep (NOT (E (NOT (E kg)))) + | prep (A (A kh)) = prep (NOT (E (NOT (A kh)))) + | prep (A (Closed ki)) = prep (NOT (E (NOT (Closed ki)))) + | prep (A (NClosed kj)) = prep (NOT (E (NOT (NClosed kj)))) + | prep (NOT (NOT p)) = prep p + | prep (NOT (And (p, q))) = Or (prep (NOT p), prep (NOT q)) + | prep (NOT (A p)) = prep (E (NOT p)) + | prep (NOT (Or (p, q))) = And (prep (NOT p), prep (NOT q)) + | prep (NOT (Imp (p, q))) = And (prep p, prep (NOT q)) + | prep (NOT (Iff (p, q))) = Or (prep (And (p, NOT q)), prep (And (NOT p, q))) + | prep (NOT T) = NOT (prep T) + | prep (NOT F) = NOT (prep F) + | prep (NOT (Lt bo)) = NOT (prep (Lt bo)) + | prep (NOT (Le bp)) = NOT (prep (Le bp)) + | prep (NOT (Gt bq)) = NOT (prep (Gt bq)) + | prep (NOT (Ge br)) = NOT (prep (Ge br)) + | prep (NOT (Eq bs)) = NOT (prep (Eq bs)) + | prep (NOT (NEq bt)) = NOT (prep (NEq bt)) + | prep (NOT (Dvd (bu, bv))) = NOT (prep (Dvd (bu, bv))) + | prep (NOT (NDvd (bw, bx))) = NOT (prep (NDvd (bw, bx))) + | prep (NOT (E ch)) = NOT (prep (E ch)) + | prep (NOT (Closed cj)) = NOT (prep (Closed cj)) + | prep (NOT (NClosed ck)) = NOT (prep (NClosed ck)) | prep (Or (p, q)) = Or (prep p, prep q) | prep (And (p, q)) = And (prep p, prep q) - | prep (Imp (p, q)) = prep (Or (Not p, q)) - | prep (Iff (p, q)) = Or (prep (And (p, q)), prep (And (Not p, Not q))) + | prep (Imp (p, q)) = prep (Or (NOT p, q)) + | prep (Iff (p, q)) = Or (prep (And (p, q)), prep (And (NOT p, NOT q))) | prep T = T | prep F = F | prep (Lt u) = Lt u @@ -2050,6 +2142,6 @@ fun pa p = qelim (prep p) cooper; -fun nat_of_integer k = Nat (max ord_integer 0 k); +fun nat_of_integer k = Nat (max ord_integer (0 : IntInf.int) k); end; (*struct Cooper_Procedure*) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Quickcheck/random_generators.ML --- a/src/HOL/Tools/Quickcheck/random_generators.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Quickcheck/random_generators.ML Fri Sep 18 16:42:19 2015 +0100 @@ -316,7 +316,7 @@ fun mk_scomp T1 T2 sT f g = Const (@{const_name scomp}, liftT T1 sT --> (T1 --> liftT T2 sT) --> liftT T2 sT) $ f $ g; fun mk_split T = Sign.mk_const thy - (@{const_name case_prod}, [T, @{typ "unit => term"}, liftT resultT @{typ Random.seed}]); + (@{const_name uncurry}, [T, @{typ "unit => term"}, liftT resultT @{typ Random.seed}]); fun mk_scomp_split T t t' = mk_scomp (mk_termtyp T) resultT @{typ Random.seed} t (mk_split T $ Abs ("", T, Abs ("", @{typ "unit => term"}, t'))); @@ -362,7 +362,7 @@ fun mk_scomp T1 T2 sT f g = Const (@{const_name scomp}, liftT T1 sT --> (T1 --> liftT T2 sT) --> liftT T2 sT) $ f $ g; fun mk_split T = Sign.mk_const thy - (@{const_name case_prod}, [T, @{typ "unit => term"}, liftT resultT @{typ Random.seed}]); + (@{const_name uncurry}, [T, @{typ "unit => term"}, liftT resultT @{typ Random.seed}]); fun mk_scomp_split T t t' = mk_scomp (mk_termtyp T) resultT @{typ Random.seed} t (mk_split T $ Abs ("", T, Abs ("", @{typ "unit => term"}, t'))); diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Quotient/quotient_tacs.ML --- a/src/HOL/Tools/Quotient/quotient_tacs.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Quotient/quotient_tacs.ML Fri Sep 18 16:42:19 2015 +0100 @@ -102,13 +102,13 @@ (case try (Thm.instantiate' ty_inst trm_inst) ball_bex_thm of NONE => NONE | SOME thm' => - (case try (get_match_inst thy (get_lhs thm')) redex of + (case try (get_match_inst thy (get_lhs thm')) (Thm.term_of redex) of NONE => NONE | SOME inst2 => try (Drule.instantiate_normalize inst2) thm')) end fun ball_bex_range_simproc ctxt redex = - case redex of + (case Thm.term_of redex of (Const (@{const_name "Ball"}, _) $ (Const (@{const_name "Respects"}, _) $ (Const (@{const_name "rel_fun"}, _) $ R1 $ R2)) $ _) => calculate_inst ctxt @{thm ball_reg_eqv_range[THEN eq_reflection]} redex R1 R2 @@ -117,7 +117,7 @@ (Const (@{const_name "rel_fun"}, _) $ R1 $ R2)) $ _) => calculate_inst ctxt @{thm bex_reg_eqv_range[THEN eq_reflection]} redex R1 R2 - | _ => NONE + | _ => NONE) (* Regularize works as follows: @@ -147,17 +147,19 @@ fun eq_imp_rel_get ctxt = map (OF1 eq_imp_rel) (rev (Named_Theorems.get ctxt @{named_theorems quot_equiv})) +val regularize_simproc = + Simplifier.make_simproc @{context} "regularize" + {lhss = [@{term "Ball (Respects (R1 ===> R2)) P"}, @{term "Bex (Respects (R1 ===> R2)) P"}], + proc = K ball_bex_range_simproc, + identifier = []}; + fun regularize_tac ctxt = let val thy = Proof_Context.theory_of ctxt - val ball_pat = @{term "Ball (Respects (R1 ===> R2)) P"} - val bex_pat = @{term "Bex (Respects (R1 ===> R2)) P"} - val simproc = - Simplifier.simproc_global_i thy "" [ball_pat, bex_pat] ball_bex_range_simproc val simpset = mk_minimal_simpset ctxt addsimps @{thms ball_reg_eqv bex_reg_eqv babs_reg_eqv babs_simp} - addsimprocs [simproc] + addsimprocs [regularize_simproc] addSolver equiv_solver addSolver quotient_solver val eq_eqvs = eq_imp_rel_get ctxt in diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Quotient/quotient_term.ML --- a/src/HOL/Tools/Quotient/quotient_term.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Quotient/quotient_term.ML Fri Sep 18 16:42:19 2015 +0100 @@ -634,12 +634,12 @@ end end - | (((t1 as Const (@{const_name case_prod}, _)) $ Abs (v1, ty, Abs(v1', ty', s1))), - ((t2 as Const (@{const_name case_prod}, _)) $ Abs (v2, _ , Abs(v2', _ , s2)))) => + | (((t1 as Const (@{const_name uncurry}, _)) $ Abs (v1, ty, Abs(v1', ty', s1))), + ((t2 as Const (@{const_name uncurry}, _)) $ Abs (v2, _ , Abs(v2', _ , s2)))) => regularize_trm ctxt (t1, t2) $ Abs (v1, ty, Abs (v1', ty', regularize_trm ctxt (s1, s2))) - | (((t1 as Const (@{const_name case_prod}, _)) $ Abs (v1, ty, s1)), - ((t2 as Const (@{const_name case_prod}, _)) $ Abs (v2, _ , s2))) => + | (((t1 as Const (@{const_name uncurry}, _)) $ Abs (v1, ty, s1)), + ((t2 as Const (@{const_name uncurry}, _)) $ Abs (v2, _ , s2))) => regularize_trm ctxt (t1, t2) $ Abs (v1, ty, regularize_trm ctxt (s1, s2)) | (t1 $ t2, t1' $ t2') => diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/Quotient/quotient_type.ML --- a/src/HOL/Tools/Quotient/quotient_type.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/Quotient/quotient_type.ML Fri Sep 18 16:42:19 2015 +0100 @@ -45,7 +45,7 @@ fun typedef_tac ctxt = EVERY1 (map (resolve_tac ctxt o single) [@{thm part_equivp_typedef}, equiv_thm]) in - Typedef.add_typedef false (qty_name, map (rpair dummyS) vs, mx) + Typedef.add_typedef (qty_name, map (rpair dummyS) vs, mx) (typedef_term rel rty lthy) NONE typedef_tac lthy end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/SMT/smt_real.ML --- a/src/HOL/Tools/SMT/smt_real.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/SMT/smt_real.ML Fri Sep 18 16:42:19 2015 +0100 @@ -98,8 +98,10 @@ (* Z3 proof replay *) -val real_linarith_proc = Simplifier.simproc_global @{theory} "fast_real_arith" [ - "(m::real) < n", "(m::real) <= n", "(m::real) = n"] Lin_Arith.simproc +val real_linarith_proc = + Simplifier.make_simproc @{context} "fast_real_arith" + {lhss = [@{term "(m::real) < n"}, @{term "(m::real) \ n"}, @{term "(m::real) = n"}], + proc = K Lin_Arith.simproc, identifier = []} (* setup *) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/SMT/z3_replay_util.ML --- a/src/HOL/Tools/SMT/z3_replay_util.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/SMT/z3_replay_util.ML Fri Sep 18 16:42:19 2015 +0100 @@ -91,9 +91,9 @@ fun dest_binop ((c as Const _) $ t $ u) = (c, t, u) | dest_binop t = raise TERM ("dest_binop", [t]) - fun prove_antisym_le ctxt t = + fun prove_antisym_le ctxt ct = let - val (le, r, s) = dest_binop t + val (le, r, s) = dest_binop (Thm.term_of ct) val less = Const (@{const_name less}, Term.fastype_of le) val prems = Simplifier.prems_of ctxt in @@ -105,9 +105,9 @@ end handle THM _ => NONE - fun prove_antisym_less ctxt t = + fun prove_antisym_less ctxt ct = let - val (less, r, s) = dest_binop (HOLogic.dest_not t) + val (less, r, s) = dest_binop (HOLogic.dest_not (Thm.term_of ct)) val le = Const (@{const_name less_eq}, Term.fastype_of less) val prems = Simplifier.prems_of ctxt in @@ -124,11 +124,15 @@ addsimps @{thms field_simps times_divide_eq_right times_divide_eq_left arith_special arith_simps rel_simps array_rules z3div_def z3mod_def NO_MATCH_def} addsimprocs [@{simproc numeral_divmod}, - Simplifier.simproc_global @{theory} "fast_int_arith" [ - "(m::int) < n", "(m::int) <= n", "(m::int) = n"] Lin_Arith.simproc, - Simplifier.simproc_global @{theory} "antisym_le" ["(x::'a::order) <= y"] prove_antisym_le, - Simplifier.simproc_global @{theory} "antisym_less" ["~ (x::'a::linorder) < y"] - prove_antisym_less]) + Simplifier.make_simproc @{context} "fast_int_arith" + {lhss = [@{term "(m::int) < n"}, @{term "(m::int) \ n"}, @{term "(m::int) = n"}], + proc = K Lin_Arith.simproc, identifier = []}, + Simplifier.make_simproc @{context} "antisym_le" + {lhss = [@{term "(x::'a::order) \ y"}], + proc = K prove_antisym_le, identifier = []}, + Simplifier.make_simproc @{context} "antisym_less" + {lhss = [@{term "\ (x::'a::linorder) < y"}], + proc = K prove_antisym_less, identifier = []}]) structure Simpset = Generic_Data ( diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/groebner.ML --- a/src/HOL/Tools/groebner.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/groebner.ML Fri Sep 18 16:42:19 2015 +0100 @@ -778,17 +778,20 @@ in Conv.fconv_rule (Conv.arg_conv (Conv.arg1_conv ring_normalize_conv)) (Thm.instantiate' [] [SOME a, SOME b] idl_sub) end - val poly_eq_simproc = + +val poly_eq_simproc = let - fun proc phi ctxt t = - let val th = poly_eq_conv t - in if Thm.is_reflexive th then NONE else SOME th - end - in make_simproc {lhss = [Thm.lhs_of idl_sub], - name = "poly_eq_simproc", proc = proc, identifier = []} - end; - val poly_eq_ss = - simpset_of (put_simpset HOL_basic_ss @{context} + fun proc ct = + let val th = poly_eq_conv ct + in if Thm.is_reflexive th then NONE else SOME th end + in + Simplifier.cert_simproc (Thm.theory_of_thm idl_sub) "poly_eq_simproc" + {lhss = [Thm.term_of (Thm.lhs_of idl_sub)], + proc = fn _ => fn _ => proc, identifier = []} + end; + +val poly_eq_ss = + simpset_of (put_simpset HOL_basic_ss @{context} addsimps @{thms simp_thms} addsimprocs [poly_eq_simproc]) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/hologic.ML --- a/src/HOL/Tools/hologic.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/hologic.ML Fri Sep 18 16:42:19 2015 +0100 @@ -349,12 +349,12 @@ end; fun split_const (A, B, C) = - Const ("Product_Type.prod.case_prod", (A --> B --> C) --> mk_prodT (A, B) --> C); + Const ("Product_Type.prod.uncurry", (A --> B --> C) --> mk_prodT (A, B) --> C); fun mk_split t = (case Term.fastype_of t of T as (Type ("fun", [A, Type ("fun", [B, C])])) => - Const ("Product_Type.prod.case_prod", T --> mk_prodT (A, B) --> C) $ t + Const ("Product_Type.prod.uncurry", T --> mk_prodT (A, B) --> C) $ t | _ => raise TERM ("mk_split: bad body type", [t])); (*Maps the type T1 * ... * Tn to [T1, ..., Tn], however nested*) @@ -470,7 +470,7 @@ val strip_psplits = let fun strip [] qs Ts t = (t, rev Ts, qs) - | strip (p :: ps) qs Ts (Const ("Product_Type.prod.case_prod", _) $ t) = + | strip (p :: ps) qs Ts (Const ("Product_Type.prod.uncurry", _) $ t) = strip ((1 :: p) :: (2 :: p) :: ps) (p :: qs) Ts t | strip (p :: ps) qs Ts (Abs (s, T, t)) = strip ps qs (T :: Ts) t | strip (p :: ps) qs Ts t = strip ps qs diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/inductive_set.ML --- a/src/HOL/Tools/inductive_set.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/inductive_set.ML Fri Sep 18 16:42:19 2015 +0100 @@ -38,65 +38,68 @@ val anyt = Free ("t", TFree ("'t", [])); fun strong_ind_simproc tab = - Simplifier.simproc_global_i @{theory HOL} "strong_ind" [anyt] (fn ctxt => fn t => - let - fun close p t f = - let val vs = Term.add_vars t [] - in Thm.instantiate' [] (rev (map (SOME o Thm.cterm_of ctxt o Var) vs)) - (p (fold (Logic.all o Var) vs t) f) - end; - fun mkop @{const_name HOL.conj} T x = - SOME (Const (@{const_name Lattices.inf}, T --> T --> T), x) - | mkop @{const_name HOL.disj} T x = - SOME (Const (@{const_name Lattices.sup}, T --> T --> T), x) - | mkop _ _ _ = NONE; - fun mk_collect p T t = - let val U = HOLogic.dest_setT T - in HOLogic.Collect_const U $ - HOLogic.mk_psplits (HOLogic.flat_tuple_paths p) U HOLogic.boolT t - end; - fun decomp (Const (s, _) $ ((m as Const (@{const_name Set.member}, - Type (_, [_, Type (_, [T, _])]))) $ p $ S) $ u) = - mkop s T (m, p, S, mk_collect p T (head_of u)) - | decomp (Const (s, _) $ u $ ((m as Const (@{const_name Set.member}, - Type (_, [_, Type (_, [T, _])]))) $ p $ S)) = - mkop s T (m, p, mk_collect p T (head_of u), S) - | decomp _ = NONE; - val simp = - full_simp_tac - (put_simpset HOL_basic_ss ctxt addsimps [mem_Collect_eq, @{thm split_conv}]) 1; - fun mk_rew t = (case strip_abs_vars t of - [] => NONE - | xs => (case decomp (strip_abs_body t) of - NONE => NONE - | SOME (bop, (m, p, S, S')) => - SOME (close (Goal.prove ctxt [] []) - (Logic.mk_equals (t, fold_rev Term.abs xs (m $ p $ (bop $ S $ S')))) - (K (EVERY - [resolve_tac ctxt [eq_reflection] 1, - REPEAT (resolve_tac ctxt @{thms ext} 1), - resolve_tac ctxt [iffI] 1, - EVERY [eresolve_tac ctxt [conjE] 1, resolve_tac ctxt [IntI] 1, simp, simp, - eresolve_tac ctxt [IntE] 1, resolve_tac ctxt [conjI] 1, simp, simp] ORELSE - EVERY [eresolve_tac ctxt [disjE] 1, resolve_tac ctxt [UnI1] 1, simp, - resolve_tac ctxt [UnI2] 1, simp, - eresolve_tac ctxt [UnE] 1, resolve_tac ctxt [disjI1] 1, simp, - resolve_tac ctxt [disjI2] 1, simp]]))) - handle ERROR _ => NONE)) - in - case strip_comb t of - (h as Const (name, _), ts) => (case Symtab.lookup tab name of - SOME _ => - let val rews = map mk_rew ts - in - if forall is_none rews then NONE - else SOME (fold (fn th1 => fn th2 => Thm.combination th2 th1) - (map2 (fn SOME r => K r | NONE => Thm.reflexive o Thm.cterm_of ctxt) - rews ts) (Thm.reflexive (Thm.cterm_of ctxt h))) - end - | NONE => NONE) - | _ => NONE - end); + Simplifier.make_simproc @{context} "strong_ind" + {lhss = [@{term "x::'a::{}"}], + proc = fn _ => fn ctxt => fn ct => + let + fun close p t f = + let val vs = Term.add_vars t [] + in Thm.instantiate' [] (rev (map (SOME o Thm.cterm_of ctxt o Var) vs)) + (p (fold (Logic.all o Var) vs t) f) + end; + fun mkop @{const_name HOL.conj} T x = + SOME (Const (@{const_name Lattices.inf}, T --> T --> T), x) + | mkop @{const_name HOL.disj} T x = + SOME (Const (@{const_name Lattices.sup}, T --> T --> T), x) + | mkop _ _ _ = NONE; + fun mk_collect p T t = + let val U = HOLogic.dest_setT T + in HOLogic.Collect_const U $ + HOLogic.mk_psplits (HOLogic.flat_tuple_paths p) U HOLogic.boolT t + end; + fun decomp (Const (s, _) $ ((m as Const (@{const_name Set.member}, + Type (_, [_, Type (_, [T, _])]))) $ p $ S) $ u) = + mkop s T (m, p, S, mk_collect p T (head_of u)) + | decomp (Const (s, _) $ u $ ((m as Const (@{const_name Set.member}, + Type (_, [_, Type (_, [T, _])]))) $ p $ S)) = + mkop s T (m, p, mk_collect p T (head_of u), S) + | decomp _ = NONE; + val simp = + full_simp_tac + (put_simpset HOL_basic_ss ctxt addsimps [mem_Collect_eq, @{thm split_conv}]) 1; + fun mk_rew t = (case strip_abs_vars t of + [] => NONE + | xs => (case decomp (strip_abs_body t) of + NONE => NONE + | SOME (bop, (m, p, S, S')) => + SOME (close (Goal.prove ctxt [] []) + (Logic.mk_equals (t, fold_rev Term.abs xs (m $ p $ (bop $ S $ S')))) + (K (EVERY + [resolve_tac ctxt [eq_reflection] 1, + REPEAT (resolve_tac ctxt @{thms ext} 1), + resolve_tac ctxt [iffI] 1, + EVERY [eresolve_tac ctxt [conjE] 1, resolve_tac ctxt [IntI] 1, simp, simp, + eresolve_tac ctxt [IntE] 1, resolve_tac ctxt [conjI] 1, simp, simp] ORELSE + EVERY [eresolve_tac ctxt [disjE] 1, resolve_tac ctxt [UnI1] 1, simp, + resolve_tac ctxt [UnI2] 1, simp, + eresolve_tac ctxt [UnE] 1, resolve_tac ctxt [disjI1] 1, simp, + resolve_tac ctxt [disjI2] 1, simp]]))) + handle ERROR _ => NONE)) + in + (case strip_comb (Thm.term_of ct) of + (h as Const (name, _), ts) => + if Symtab.defined tab name then + let val rews = map mk_rew ts + in + if forall is_none rews then NONE + else SOME (fold (fn th1 => fn th2 => Thm.combination th2 th1) + (map2 (fn SOME r => K r | NONE => Thm.reflexive o Thm.cterm_of ctxt) + rews ts) (Thm.reflexive (Thm.cterm_of ctxt h))) + end + else NONE + | _ => NONE) + end, + identifier = []}; (* only eta contract terms occurring as arguments of functions satisfying p *) fun eta_contract p = @@ -312,9 +315,12 @@ fun to_pred_simproc rules = let val rules' = map mk_meta_eq rules in - Simplifier.simproc_global_i @{theory HOL} "to_pred" [anyt] - (fn ctxt => - lookup_rule (Proof_Context.theory_of ctxt) (Thm.prop_of #> Logic.dest_equals) rules') + Simplifier.make_simproc @{context} "to_pred" + {lhss = [anyt], + proc = fn _ => fn ctxt => fn ct => + lookup_rule (Proof_Context.theory_of ctxt) + (Thm.prop_of #> Logic.dest_equals) rules' (Thm.term_of ct), + identifier = []} end; fun to_pred_proc thy rules t = @@ -463,13 +469,11 @@ (* define inductive sets using previously defined predicates *) val (defs, lthy2) = lthy1 - |> Proof_Context.concealed (* FIXME ?? *) |> fold_map Local_Theory.define (map (fn (((c, syn), (fs, U, _)), p) => ((c, syn), ((Thm.def_binding c, []), fold_rev lambda params (HOLogic.Collect_const U $ HOLogic.mk_psplits fs U HOLogic.boolT (list_comb (p, params3)))))) - (cnames_syn ~~ cs_info ~~ preds)) - ||> Proof_Context.restore_naming lthy1; + (cnames_syn ~~ cs_info ~~ preds)); (* prove theorems for converting predicate to set notation *) val lthy3 = fold diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/int_arith.ML --- a/src/HOL/Tools/int_arith.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/int_arith.ML Fri Sep 18 16:42:19 2015 +0100 @@ -20,33 +20,29 @@ That is, m and n consist only of 1s combined with "+", "-" and "*". *) -val zeroth = (Thm.symmetric o mk_meta_eq) @{thm of_int_0}; - -val lhss0 = [@{cpat "0::?'a::ring"}]; - -fun proc0 phi ctxt ct = - let val T = Thm.ctyp_of_cterm ct - in if Thm.typ_of T = @{typ int} then NONE else - SOME (Thm.instantiate' [SOME T] [] zeroth) - end; +val zeroth = Thm.symmetric (mk_meta_eq @{thm of_int_0}); val zero_to_of_int_zero_simproc = - make_simproc {lhss = lhss0, name = "zero_to_of_int_zero_simproc", - proc = proc0, identifier = []}; - -val oneth = (Thm.symmetric o mk_meta_eq) @{thm of_int_1}; + Simplifier.make_simproc @{context} "zero_to_of_int_zero_simproc" + {lhss = [@{term "0::'a::ring"}], + proc = fn _ => fn ctxt => fn ct => + let val T = Thm.ctyp_of_cterm ct in + if Thm.typ_of T = @{typ int} then NONE + else SOME (Thm.instantiate' [SOME T] [] zeroth) + end, + identifier = []}; -val lhss1 = [@{cpat "1::?'a::ring_1"}]; - -fun proc1 phi ctxt ct = - let val T = Thm.ctyp_of_cterm ct - in if Thm.typ_of T = @{typ int} then NONE else - SOME (Thm.instantiate' [SOME T] [] oneth) - end; +val oneth = Thm.symmetric (mk_meta_eq @{thm of_int_1}); val one_to_of_int_one_simproc = - make_simproc {lhss = lhss1, name = "one_to_of_int_one_simproc", - proc = proc1, identifier = []}; + Simplifier.make_simproc @{context} "one_to_of_int_one_simproc" + {lhss = [@{term "1::'a::ring_1"}], + proc = fn _ => fn ctxt => fn ct => + let val T = Thm.ctyp_of_cterm ct in + if Thm.typ_of T = @{typ int} then NONE + else SOME (Thm.instantiate' [SOME T] [] oneth) + end, + identifier = []}; fun check (Const (@{const_name Groups.one}, @{typ int})) = false | check (Const (@{const_name Groups.one}, _)) = true @@ -66,18 +62,18 @@ [@{thm of_int_less_iff}, @{thm of_int_le_iff}, @{thm of_int_eq_iff}]) addsimprocs [zero_to_of_int_zero_simproc,one_to_of_int_one_simproc]); -fun sproc phi ctxt ct = - if check (Thm.term_of ct) then SOME (Simplifier.rewrite (put_simpset conv_ss ctxt) ct) - else NONE; +val zero_one_idom_simproc = + Simplifier.make_simproc @{context} "zero_one_idom_simproc" + {lhss = + [@{term "(x::'a::ring_char_0) = y"}, + @{term "(x::'a::linordered_idom) < y"}, + @{term "(x::'a::linordered_idom) \ y"}], + proc = fn _ => fn ctxt => fn ct => + if check (Thm.term_of ct) + then SOME (Simplifier.rewrite (put_simpset conv_ss ctxt) ct) + else NONE, + identifier = []}; -val lhss' = - [@{cpat "(?x::?'a::ring_char_0) = (?y::?'a)"}, - @{cpat "(?x::?'a::linordered_idom) < (?y::?'a)"}, - @{cpat "(?x::?'a::linordered_idom) <= (?y::?'a)"}] - -val zero_one_idom_simproc = - make_simproc {lhss = lhss' , name = "zero_one_idom_simproc", - proc = sproc, identifier = []} fun number_of ctxt T n = if not (Sign.of_sort (Proof_Context.theory_of ctxt) (T, @{sort numeral})) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/lin_arith.ML --- a/src/HOL/Tools/lin_arith.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/lin_arith.ML Fri Sep 18 16:42:19 2015 +0100 @@ -9,7 +9,7 @@ val pre_tac: Proof.context -> int -> tactic val simple_tac: Proof.context -> int -> tactic val tac: Proof.context -> int -> tactic - val simproc: Proof.context -> term -> thm option + val simproc: Proof.context -> cterm -> thm option val add_inj_thms: thm list -> Context.generic -> Context.generic val add_lessD: thm -> Context.generic -> Context.generic val add_simps: thm list -> Context.generic -> Context.generic diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/nat_numeral_simprocs.ML --- a/src/HOL/Tools/nat_numeral_simprocs.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/nat_numeral_simprocs.ML Fri Sep 18 16:42:19 2015 +0100 @@ -216,10 +216,10 @@ val bal_add2 = @{thm nat_diff_add_eq2} RS trans ); -fun eq_cancel_numerals ctxt ct = EqCancelNumerals.proc ctxt (Thm.term_of ct) -fun less_cancel_numerals ctxt ct = LessCancelNumerals.proc ctxt (Thm.term_of ct) -fun le_cancel_numerals ctxt ct = LeCancelNumerals.proc ctxt (Thm.term_of ct) -fun diff_cancel_numerals ctxt ct = DiffCancelNumerals.proc ctxt (Thm.term_of ct) +val eq_cancel_numerals = EqCancelNumerals.proc +val less_cancel_numerals = LessCancelNumerals.proc +val le_cancel_numerals = LeCancelNumerals.proc +val diff_cancel_numerals = DiffCancelNumerals.proc (*** Applying CombineNumeralsFun ***) @@ -257,7 +257,7 @@ structure CombineNumerals = CombineNumeralsFun(CombineNumeralsData); -fun combine_numerals ctxt ct = CombineNumerals.proc ctxt (Thm.term_of ct) +val combine_numerals = CombineNumerals.proc (*** Applying CancelNumeralFactorFun ***) @@ -311,7 +311,8 @@ ); structure LessCancelNumeralFactor = CancelNumeralFactorFun - (open CancelNumeralFactorCommon +( + open CancelNumeralFactorCommon val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less} val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} HOLogic.natT val cancel = @{thm nat_mult_less_cancel1} RS trans @@ -319,18 +320,19 @@ ); structure LeCancelNumeralFactor = CancelNumeralFactorFun - (open CancelNumeralFactorCommon +( + open CancelNumeralFactorCommon val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq} val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} HOLogic.natT val cancel = @{thm nat_mult_le_cancel1} RS trans val neg_exchanges = true ) -fun eq_cancel_numeral_factor ctxt ct = EqCancelNumeralFactor.proc ctxt (Thm.term_of ct) -fun less_cancel_numeral_factor ctxt ct = LessCancelNumeralFactor.proc ctxt (Thm.term_of ct) -fun le_cancel_numeral_factor ctxt ct = LeCancelNumeralFactor.proc ctxt (Thm.term_of ct) -fun div_cancel_numeral_factor ctxt ct = DivCancelNumeralFactor.proc ctxt (Thm.term_of ct) -fun dvd_cancel_numeral_factor ctxt ct = DvdCancelNumeralFactor.proc ctxt (Thm.term_of ct) +val eq_cancel_numeral_factor = EqCancelNumeralFactor.proc +val less_cancel_numeral_factor = LessCancelNumeralFactor.proc +val le_cancel_numeral_factor = LeCancelNumeralFactor.proc +val div_cancel_numeral_factor = DivCancelNumeralFactor.proc +val dvd_cancel_numeral_factor = DvdCancelNumeralFactor.proc (*** Applying ExtractCommonTermFun ***) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/numeral.ML --- a/src/HOL/Tools/numeral.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/numeral.ML Fri Sep 18 16:42:19 2015 +0100 @@ -37,27 +37,33 @@ local -val zero = @{cpat "0"}; -val zeroT = Thm.ctyp_of_cterm zero; +val cterm_of = Thm.cterm_of @{context}; +fun tvar S = (("'a", 0), S); -val one = @{cpat "1"}; -val oneT = Thm.ctyp_of_cterm one; +val zero_tvar = tvar @{sort zero}; +val zero = cterm_of (Const (@{const_name zero_class.zero}, TVar zero_tvar)); -val numeral = @{cpat "numeral"}; -val numeralT = Thm.ctyp_of @{context} (Term.range_type (Thm.typ_of_cterm numeral)); +val one_tvar = tvar @{sort one}; +val one = cterm_of (Const (@{const_name one_class.one}, TVar one_tvar)); -val uminus = @{cpat "uminus"}; -val uminusT = Thm.ctyp_of @{context} (Term.range_type (Thm.typ_of_cterm uminus)); +val numeral_tvar = tvar @{sort numeral}; +val numeral = cterm_of (Const (@{const_name numeral}, @{typ num} --> TVar numeral_tvar)); -fun instT T V = Thm.instantiate_cterm ([(dest_TVar (Thm.typ_of V), T)], []); +val uminus_tvar = tvar @{sort uminus}; +val uminus = cterm_of (Const (@{const_name uminus}, TVar uminus_tvar --> TVar uminus_tvar)); + +fun instT T v = Thm.instantiate_cterm ([(v, T)], []); in -fun mk_cnumber T 0 = instT T zeroT zero - | mk_cnumber T 1 = instT T oneT one +fun mk_cnumber T 0 = instT T zero_tvar zero + | mk_cnumber T 1 = instT T one_tvar one | mk_cnumber T i = - if i > 0 then Thm.apply (instT T numeralT numeral) (mk_cnumeral i) - else Thm.apply (instT T uminusT uminus) (Thm.apply (instT T numeralT numeral) (mk_cnumeral (~i))); + if i > 0 then + Thm.apply (instT T numeral_tvar numeral) (mk_cnumeral i) + else + Thm.apply (instT T uminus_tvar uminus) + (Thm.apply (instT T numeral_tvar numeral) (mk_cnumeral (~ i))); end; diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/numeral_simprocs.ML --- a/src/HOL/Tools/numeral_simprocs.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/numeral_simprocs.ML Fri Sep 18 16:42:19 2015 +0100 @@ -16,8 +16,6 @@ signature NUMERAL_SIMPROCS = sig - val prep_simproc: theory -> string * string list * (Proof.context -> term -> thm option) - -> simproc val trans_tac: Proof.context -> thm option -> tactic val assoc_fold: Proof.context -> cterm -> thm option val combine_numerals: Proof.context -> cterm -> thm option @@ -37,7 +35,7 @@ val div_cancel_numeral_factor: Proof.context -> cterm -> thm option val divide_cancel_numeral_factor: Proof.context -> cterm -> thm option val field_combine_numerals: Proof.context -> cterm -> thm option - val field_divide_cancel_numeral_factor: simproc list + val field_divide_cancel_numeral_factor: simproc val num_ss: simpset val field_comp_conv: Proof.context -> conv end; @@ -45,9 +43,6 @@ structure Numeral_Simprocs : NUMERAL_SIMPROCS = struct -fun prep_simproc thy (name, pats, proc) = - Simplifier.simproc_global thy name pats proc; - fun trans_tac _ NONE = all_tac | trans_tac ctxt (SOME th) = ALLGOALS (resolve_tac ctxt [th RS trans]); @@ -65,7 +60,7 @@ which is not required for cancellation of common factors in divisions. UPDATE: this reasoning no longer applies (number_ring is gone) *) -fun mk_prod T = +fun mk_prod T = let val one = one_of T fun mk [] = one | mk [t] = t @@ -141,7 +136,7 @@ ordering is not well-founded.*) fun num_ord (i,j) = (case int_ord (abs i, abs j) of - EQUAL => int_ord (Int.sign i, Int.sign j) + EQUAL => int_ord (Int.sign i, Int.sign j) | ord => ord); (*This resembles Term_Ord.term_ord, but it puts binary numerals before other @@ -190,7 +185,7 @@ val field_post_simps = post_simps @ [@{thm divide_zero_left}, @{thm divide_1}] - + (*Simplify inverse Numeral1*) val inverse_1s = [@{thm inverse_numeral_1}]; @@ -202,7 +197,7 @@ @{thms add_neg_numeral_left} @ @{thms mult_numeral_left} @ @{thms arith_simps} @ @{thms rel_simps}; - + (*Binary arithmetic BUT NOT ADDITION since it may collapse adjacent terms during re-arrangement*) val non_add_simps = @@ -288,9 +283,9 @@ val bal_add2 = @{thm le_add_iff2} RS trans ); -fun eq_cancel_numerals ctxt ct = EqCancelNumerals.proc ctxt (Thm.term_of ct) -fun less_cancel_numerals ctxt ct = LessCancelNumerals.proc ctxt (Thm.term_of ct) -fun le_cancel_numerals ctxt ct = LeCancelNumerals.proc ctxt (Thm.term_of ct) +val eq_cancel_numerals = EqCancelNumerals.proc +val less_cancel_numerals = LessCancelNumerals.proc +val le_cancel_numerals = LeCancelNumerals.proc structure CombineNumeralsData = struct @@ -350,9 +345,9 @@ structure FieldCombineNumerals = CombineNumeralsFun(FieldCombineNumeralsData); -fun combine_numerals ctxt ct = CombineNumerals.proc ctxt (Thm.term_of ct) +val combine_numerals = CombineNumerals.proc -fun field_combine_numerals ctxt ct = FieldCombineNumerals.proc ctxt (Thm.term_of ct) +val field_combine_numerals = FieldCombineNumerals.proc (** Constant folding for multiplication in semirings **) @@ -433,37 +428,40 @@ ) structure LeCancelNumeralFactor = CancelNumeralFactorFun - (open CancelNumeralFactorCommon - val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq} +( + open CancelNumeralFactorCommon + val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq} val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} dummyT val cancel = @{thm mult_le_cancel_left} RS trans val neg_exchanges = true ) -fun eq_cancel_numeral_factor ctxt ct = EqCancelNumeralFactor.proc ctxt (Thm.term_of ct) -fun less_cancel_numeral_factor ctxt ct = LessCancelNumeralFactor.proc ctxt (Thm.term_of ct) -fun le_cancel_numeral_factor ctxt ct = LeCancelNumeralFactor.proc ctxt (Thm.term_of ct) -fun div_cancel_numeral_factor ctxt ct = DivCancelNumeralFactor.proc ctxt (Thm.term_of ct) -fun divide_cancel_numeral_factor ctxt ct = DivideCancelNumeralFactor.proc ctxt (Thm.term_of ct) +val eq_cancel_numeral_factor = EqCancelNumeralFactor.proc +val less_cancel_numeral_factor = LessCancelNumeralFactor.proc +val le_cancel_numeral_factor = LeCancelNumeralFactor.proc +val div_cancel_numeral_factor = DivCancelNumeralFactor.proc +val divide_cancel_numeral_factor = DivideCancelNumeralFactor.proc val field_divide_cancel_numeral_factor = - [prep_simproc @{theory} - ("field_divide_cancel_numeral_factor", - ["((l::'a::field) * m) / n", - "(l::'a::field) / (m * n)", - "((numeral v)::'a::field) / (numeral w)", - "((numeral v)::'a::field) / (- numeral w)", - "((- numeral v)::'a::field) / (numeral w)", - "((- numeral v)::'a::field) / (- numeral w)"], - DivideCancelNumeralFactor.proc)]; + Simplifier.make_simproc @{context} "field_divide_cancel_numeral_factor" + {lhss = + [@{term "((l::'a::field) * m) / n"}, + @{term "(l::'a::field) / (m * n)"}, + @{term "((numeral v)::'a::field) / (numeral w)"}, + @{term "((numeral v)::'a::field) / (- numeral w)"}, + @{term "((- numeral v)::'a::field) / (numeral w)"}, + @{term "((- numeral v)::'a::field) / (- numeral w)"}], + proc = K DivideCancelNumeralFactor.proc, + identifier = []} val field_cancel_numeral_factors = - prep_simproc @{theory} - ("field_eq_cancel_numeral_factor", - ["(l::'a::field) * m = n", - "(l::'a::field) = m * n"], - EqCancelNumeralFactor.proc) - :: field_divide_cancel_numeral_factor; + [Simplifier.make_simproc @{context} "field_eq_cancel_numeral_factor" + {lhss = + [@{term "(l::'a::field) * m = n"}, + @{term "(l::'a::field) = m * n"}], + proc = K EqCancelNumeralFactor.proc, + identifier = []}, + field_divide_cancel_numeral_factor] (** Declarations for ExtractCommonTerm **) @@ -476,7 +474,7 @@ handle TERM _ => find_first_t (t::past) u terms; (** Final simplification for the CancelFactor simprocs **) -val simplify_one = Arith_Data.simplify_meta_eq +val simplify_one = Arith_Data.simplify_meta_eq [@{thm mult_1_left}, @{thm mult_1_right}, @{thm div_by_1}, @{thm numeral_1_eq_1}]; fun cancel_simplify_meta_eq ctxt cancel_th th = @@ -484,7 +482,7 @@ local val Tp_Eq = Thm.reflexive (Thm.cterm_of @{theory_context HOL} HOLogic.Trueprop) - fun Eq_True_elim Eq = + fun Eq_True_elim Eq = Thm.equal_elim (Thm.combination Tp_Eq (Thm.symmetric Eq)) @{thm TrueI} in fun sign_conv pos_th neg_th ctxt t = @@ -515,7 +513,7 @@ simpset_of (put_simpset HOL_basic_ss @{context} addsimps mult_1s @ @{thms ac_simps minus_mult_commute}) fun norm_tac ctxt = ALLGOALS (simp_tac (put_simpset norm_ss ctxt)) - val simplify_meta_eq = cancel_simplify_meta_eq + val simplify_meta_eq = cancel_simplify_meta_eq fun mk_eq (a, b) = HOLogic.mk_Trueprop (HOLogic.mk_eq (a, b)) end; @@ -585,25 +583,31 @@ fun divide_cancel_factor ctxt ct = DivideCancelFactor.proc ctxt (Thm.term_of ct) local - val zr = @{cpat "0"} - val zT = Thm.ctyp_of_cterm zr - val geq = @{cpat HOL.eq} - val eqT = Thm.dest_ctyp (Thm.ctyp_of_cterm geq) |> hd - val add_frac_eq = mk_meta_eq @{thm "add_frac_eq"} - val add_frac_num = mk_meta_eq @{thm "add_frac_num"} - val add_num_frac = mk_meta_eq @{thm "add_num_frac"} + +val cterm_of = Thm.cterm_of @{context}; +fun tvar S = (("'a", 0), S); + +val zero_tvar = tvar @{sort zero}; +val zero = cterm_of (Const (@{const_name zero_class.zero}, TVar zero_tvar)); + +val type_tvar = tvar @{sort type}; +val geq = cterm_of (Const (@{const_name HOL.eq}, TVar type_tvar --> TVar type_tvar --> @{typ bool})); - fun prove_nz ctxt T t = - let - val z = Thm.instantiate_cterm ([(dest_TVar (Thm.typ_of zT), T)],[]) zr - val eq = Thm.instantiate_cterm ([(dest_TVar (Thm.typ_of eqT), T)],[]) geq - val th = Simplifier.rewrite (ctxt addsimps @{thms simp_thms}) - (Thm.apply @{cterm "Trueprop"} (Thm.apply @{cterm "Not"} - (Thm.apply (Thm.apply eq t) z))) - in Thm.equal_elim (Thm.symmetric th) TrueI - end +val add_frac_eq = mk_meta_eq @{thm "add_frac_eq"} +val add_frac_num = mk_meta_eq @{thm "add_frac_num"} +val add_num_frac = mk_meta_eq @{thm "add_num_frac"} - fun proc phi ctxt ct = +fun prove_nz ctxt T t = + let + val z = Thm.instantiate_cterm ([(zero_tvar, T)], []) zero + val eq = Thm.instantiate_cterm ([(type_tvar, T)], []) geq + val th = + Simplifier.rewrite (ctxt addsimps @{thms simp_thms}) + (Thm.apply @{cterm "Trueprop"} (Thm.apply @{cterm "Not"} + (Thm.apply (Thm.apply eq t) z))) + in Thm.equal_elim (Thm.symmetric th) TrueI end + +fun proc ctxt ct = let val ((x,y),(w,z)) = (Thm.dest_binop #> (fn (a,b) => (Thm.dest_binop a, Thm.dest_binop b))) ct @@ -611,11 +615,10 @@ val T = Thm.ctyp_of_cterm x val [y_nz, z_nz] = map (prove_nz ctxt T) [y, z] val th = Thm.instantiate' [SOME T] (map SOME [y,z,x,w]) add_frac_eq - in SOME (Thm.implies_elim (Thm.implies_elim th y_nz) z_nz) - end + in SOME (Thm.implies_elim (Thm.implies_elim th y_nz) z_nz) end handle CTERM _ => NONE | TERM _ => NONE | THM _ => NONE - fun proc2 phi ctxt ct = +fun proc2 ctxt ct = let val (l,r) = Thm.dest_binop ct val T = Thm.ctyp_of_cterm l @@ -636,12 +639,12 @@ end handle CTERM _ => NONE | TERM _ => NONE | THM _ => NONE - fun is_number (Const(@{const_name Rings.divide},_)$a$b) = is_number a andalso is_number b - | is_number t = can HOLogic.dest_number t +fun is_number (Const(@{const_name Rings.divide},_)$a$b) = is_number a andalso is_number b + | is_number t = can HOLogic.dest_number t - val is_number = is_number o Thm.term_of +val is_number = is_number o Thm.term_of - fun proc3 phi ctxt ct = +fun proc3 ctxt ct = (case Thm.term_of ct of Const(@{const_name Orderings.less},_)$(Const(@{const_name Rings.divide},_)$_$_)$_ => let @@ -685,41 +688,42 @@ val T = Thm.ctyp_of_cterm c val th = Thm.instantiate' [SOME T] (map SOME [a,b,c]) @{thm "eq_divide_eq"} in SOME (mk_meta_eq th) end - | _ => NONE) - handle TERM _ => NONE | CTERM _ => NONE | THM _ => NONE + | _ => NONE) handle TERM _ => NONE | CTERM _ => NONE | THM _ => NONE val add_frac_frac_simproc = - make_simproc {lhss = [@{cpat "(?x::?'a::field)/?y + (?w::?'a::field)/?z"}], - name = "add_frac_frac_simproc", - proc = proc, identifier = []} + Simplifier.make_simproc @{context} "add_frac_frac_simproc" + {lhss = [@{term "(x::'a::field) / y + (w::'a::field) / z"}], + proc = K proc, identifier = []} val add_frac_num_simproc = - make_simproc {lhss = [@{cpat "(?x::?'a::field)/?y + ?z"}, @{cpat "?z + (?x::?'a::field)/?y"}], - name = "add_frac_num_simproc", - proc = proc2, identifier = []} + Simplifier.make_simproc @{context} "add_frac_num_simproc" + {lhss = [@{term "(x::'a::field) / y + z"}, @{term "z + (x::'a::field) / y"}], + proc = K proc2, identifier = []} val ord_frac_simproc = - make_simproc - {lhss = [@{cpat "(?a::(?'a::{field, ord}))/?b < ?c"}, - @{cpat "(?a::(?'a::{field, ord}))/?b <= ?c"}, - @{cpat "?c < (?a::(?'a::{field, ord}))/?b"}, - @{cpat "?c <= (?a::(?'a::{field, ord}))/?b"}, - @{cpat "?c = ((?a::(?'a::{field, ord}))/?b)"}, - @{cpat "((?a::(?'a::{field, ord}))/ ?b) = ?c"}], - name = "ord_frac_simproc", proc = proc3, identifier = []} + Simplifier.make_simproc @{context} "ord_frac_simproc" + {lhss = + [@{term "(a::'a::{field,ord}) / b < c"}, + @{term "(a::'a::{field,ord}) / b \ c"}, + @{term "c < (a::'a::{field,ord}) / b"}, + @{term "c \ (a::'a::{field,ord}) / b"}, + @{term "c = (a::'a::{field,ord}) / b"}, + @{term "(a::'a::{field, ord}) / b = c"}], + proc = K proc3, identifier = []} -val ths = [@{thm "mult_numeral_1"}, @{thm "mult_numeral_1_right"}, - @{thm "divide_numeral_1"}, - @{thm "divide_zero"}, @{thm divide_zero_left}, - @{thm "divide_divide_eq_left"}, - @{thm "times_divide_eq_left"}, @{thm "times_divide_eq_right"}, - @{thm "times_divide_times_eq"}, - @{thm "divide_divide_eq_right"}, - @{thm diff_conv_add_uminus}, @{thm "minus_divide_left"}, - @{thm "add_divide_distrib"} RS sym, - @{thm Fields.field_divide_inverse} RS sym, @{thm inverse_divide}, - Conv.fconv_rule (Conv.arg_conv (Conv.arg1_conv (Conv.rewr_conv (mk_meta_eq @{thm mult.commute})))) - (@{thm Fields.field_divide_inverse} RS sym)] +val ths = + [@{thm "mult_numeral_1"}, @{thm "mult_numeral_1_right"}, + @{thm "divide_numeral_1"}, + @{thm "divide_zero"}, @{thm divide_zero_left}, + @{thm "divide_divide_eq_left"}, + @{thm "times_divide_eq_left"}, @{thm "times_divide_eq_right"}, + @{thm "times_divide_times_eq"}, + @{thm "divide_divide_eq_right"}, + @{thm diff_conv_add_uminus}, @{thm "minus_divide_left"}, + @{thm "add_divide_distrib"} RS sym, + @{thm Fields.field_divide_inverse} RS sym, @{thm inverse_divide}, + Conv.fconv_rule (Conv.arg_conv (Conv.arg1_conv (Conv.rewr_conv (mk_meta_eq @{thm mult.commute})))) + (@{thm Fields.field_divide_inverse} RS sym)] val field_comp_ss = simpset_of @@ -740,4 +744,3 @@ end end; - diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/record.ML --- a/src/HOL/Tools/record.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/record.ML Fri Sep 18 16:42:19 2015 +0100 @@ -99,7 +99,7 @@ val vs = map (Proof_Context.check_tfree ctxt) raw_vs; in thy - |> Typedef.add_typedef_global false (raw_tyco, vs, NoSyn) + |> Typedef.add_typedef_global (raw_tyco, vs, NoSyn) (HOLogic.mk_UNIV repT) NONE (fn ctxt' => resolve_tac ctxt' [UNIV_witness] 1) |-> (fn (tyco, info) => get_typedef_info tyco vs info) end; @@ -1059,9 +1059,13 @@ subrecord. *) val simproc = - Simplifier.simproc_global @{theory HOL} "record" ["x"] - (fn ctxt => fn t => - let val thy = Proof_Context.theory_of ctxt in + Simplifier.make_simproc @{context} "record" + {lhss = [@{term "x"}], + proc = fn _ => fn ctxt => fn ct => + let + val thy = Proof_Context.theory_of ctxt; + val t = Thm.term_of ct; + in (case t of (sel as Const (s, Type (_, [_, rangeS]))) $ ((upd as Const (u, Type (_, [_, Type (_, [rT, _])]))) $ k $ r) => @@ -1109,7 +1113,8 @@ end else NONE | _ => NONE) - end); + end, + identifier = []}; fun get_upd_acc_cong_thm upd acc thy ss = let @@ -1139,10 +1144,12 @@ we omit considering further updates if doing so would introduce both a more update and an update to a field within it.*) val upd_simproc = - Simplifier.simproc_global @{theory HOL} "record_upd" ["x"] - (fn ctxt => fn t => + Simplifier.make_simproc @{context} "record_upd" + {lhss = [@{term "x"}], + proc = fn _ => fn ctxt => fn ct => let val thy = Proof_Context.theory_of ctxt; + val t = Thm.term_of ct; (*We can use more-updators with other updators as long as none of the other updators go deeper than any more updator. min here is the depth of the deepest other @@ -1240,7 +1247,8 @@ (prove_unfold_defs thy noops' [simproc] (Logic.list_all (vars, Logic.mk_equals (lhs, rhs)))) else NONE - end); + end, + identifier = []}; end; @@ -1260,16 +1268,19 @@ Complexity: #components * #updates #updates *) val eq_simproc = - Simplifier.simproc_global @{theory HOL} "record_eq" ["r = s"] - (fn ctxt => fn t => - (case t of Const (@{const_name HOL.eq}, Type (_, [T, _])) $ _ $ _ => - (case rec_id ~1 T of - "" => NONE - | name => - (case get_equalities (Proof_Context.theory_of ctxt) name of - NONE => NONE - | SOME thm => SOME (thm RS @{thm Eq_TrueI}))) - | _ => NONE)); + Simplifier.make_simproc @{context} "record_eq" + {lhss = [@{term "r = s"}], + proc = fn _ => fn ctxt => fn ct => + (case Thm.term_of ct of + Const (@{const_name HOL.eq}, Type (_, [T, _])) $ _ $ _ => + (case rec_id ~1 T of + "" => NONE + | name => + (case get_equalities (Proof_Context.theory_of ctxt) name of + NONE => NONE + | SOME thm => SOME (thm RS @{thm Eq_TrueI}))) + | _ => NONE), + identifier = []}; (* split_simproc *) @@ -1280,9 +1291,10 @@ P t = ~1: completely split P t > 0: split up to given bound of record extensions.*) fun split_simproc P = - Simplifier.simproc_global @{theory HOL} "record_split" ["x"] - (fn ctxt => fn t => - (case t of + Simplifier.make_simproc @{context} "record_split" + {lhss = [@{term x}], + proc = fn _ => fn ctxt => fn ct => + (case Thm.term_of ct of Const (quantifier, Type (_, [Type (_, [T, _]), _])) $ _ => if quantifier = @{const_name Pure.all} orelse quantifier = @{const_name All} orelse @@ -1291,7 +1303,7 @@ (case rec_id ~1 T of "" => NONE | _ => - let val split = P t in + let val split = P (Thm.term_of ct) in if split <> 0 then (case get_splits (Proof_Context.theory_of ctxt) (rec_id split T) of NONE => NONE @@ -1305,13 +1317,16 @@ else NONE end) else NONE - | _ => NONE)); + | _ => NONE), + identifier = []}; val ex_sel_eq_simproc = - Simplifier.simproc_global @{theory HOL} "ex_sel_eq" ["Ex t"] - (fn ctxt => fn t => + Simplifier.make_simproc @{context} "ex_sel_eq" + {lhss = [@{term "Ex t"}], + proc = fn _ => fn ctxt => fn ct => let val thy = Proof_Context.theory_of ctxt; + val t = Thm.term_of ct; fun mkeq (lr, Teq, (sel, Tsel), x) i = if is_selector thy sel then let @@ -1344,7 +1359,8 @@ addsimps @{thms simp_thms} addsimprocs [split_simproc (K ~1)]) 1)) end handle TERM _ => NONE) | _ => NONE) - end); + end, + identifier = []}; (* split_simp_tac *) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/semiring_normalizer.ML --- a/src/HOL/Tools/semiring_normalizer.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/semiring_normalizer.ML Fri Sep 18 16:42:19 2015 +0100 @@ -4,7 +4,7 @@ Normalization of expressions in semirings. *) -signature SEMIRING_NORMALIZER = +signature SEMIRING_NORMALIZER = sig type entry val match: Proof.context -> cterm -> entry option @@ -13,8 +13,9 @@ val the_field: Proof.context -> thm -> cterm list * thm list val the_idom: Proof.context -> thm -> thm list val the_ideal: Proof.context -> thm -> thm list - val declare: thm -> {semiring: cterm list * thm list, ring: cterm list * thm list, - field: cterm list * thm list, idom: thm list, ideal: thm list} -> declaration + val declare: thm -> {semiring: term list * thm list, ring: term list * thm list, + field: term list * thm list, idom: thm list, ideal: thm list} -> + local_theory -> local_theory val semiring_normalize_conv: Proof.context -> conv val semiring_normalize_ord_conv: Proof.context -> (cterm -> cterm -> bool) -> conv @@ -40,7 +41,7 @@ sub: Proof.context -> conv} end -structure Semiring_Normalizer: SEMIRING_NORMALIZER = +structure Semiring_Normalizer: SEMIRING_NORMALIZER = struct (** data **) @@ -76,7 +77,7 @@ fun match ctxt tm = let fun match_inst - ({vars, semiring = (sr_ops, sr_rules), + ({vars, semiring = (sr_ops, sr_rules), ring = (r_ops, r_rules), field = (f_ops, f_rules), idom, ideal}, fns) pat = let @@ -92,7 +93,7 @@ val idom' = map substT idom; val ideal' = map substT ideal; - val result = ({vars = vars', semiring = semiring', + val result = ({vars = vars', semiring = semiring', ring = ring', field = field', idom = idom', ideal = ideal'}, fns); in SOME result end in (case try Thm.match (pat, tm) of @@ -105,7 +106,7 @@ get_first (match_inst entry) (sr_ops @ r_ops @ f_ops); in get_first match_struct (Data.get (Context.Proof ctxt)) end; - + (* extra-logical functions *) val semiring_norm_ss = @@ -137,9 +138,9 @@ fun dest_const ct = ((case Thm.term_of ct of Const (@{const_name Rings.divide},_) $ a $ b=> Rat.rat_of_quotient (snd (HOLogic.dest_number a), snd (HOLogic.dest_number b)) - | Const (@{const_name Fields.inverse},_)$t => + | Const (@{const_name Fields.inverse},_)$t => Rat.inv (Rat.rat_of_int (snd (HOLogic.dest_number t))) - | t => Rat.rat_of_int (snd (HOLogic.dest_number t))) + | t => Rat.rat_of_int (snd (HOLogic.dest_number t))) handle TERM _ => error "ring_dest_const") fun mk_const cT x = let val (a, b) = Rat.quotient_of_rat x @@ -165,62 +166,71 @@ val idomN = "idom"; fun declare raw_key - {semiring = raw_semiring, ring = raw_ring, field = raw_field, idom = raw_idom, ideal = raw_ideal} - phi context = + {semiring = raw_semiring0, ring = raw_ring0, field = raw_field0, idom = raw_idom, ideal = raw_ideal} + lthy = let - val ctxt = Context.proof_of context; - val key = Morphism.thm phi raw_key; - fun morphism_ops_rules (ops, rules) = (map (Morphism.cterm phi) ops, Morphism.fact phi rules); - val (sr_ops, sr_rules) = morphism_ops_rules raw_semiring; - val (r_ops, r_rules) = morphism_ops_rules raw_ring; - val (f_ops, f_rules) = morphism_ops_rules raw_field; - val idom = Morphism.fact phi raw_idom; - val ideal = Morphism.fact phi raw_ideal; - - fun check kind name xs n = - null xs orelse length xs = n orelse - error ("Expected " ^ string_of_int n ^ " " ^ kind ^ " for " ^ name); - val check_ops = check "operations"; - val check_rules = check "rules"; - val _ = - check_ops semiringN sr_ops 5 andalso - check_rules semiringN sr_rules 36 andalso - check_ops ringN r_ops 2 andalso - check_rules ringN r_rules 2 andalso - check_ops fieldN f_ops 2 andalso - check_rules fieldN f_rules 2 andalso - check_rules idomN idom 2; + val ctxt' = fold Variable.auto_fixes (fst raw_semiring0 @ fst raw_ring0 @ fst raw_field0) lthy; + val prepare_ops = apfst (Variable.export_terms ctxt' lthy #> map (Thm.cterm_of lthy)); + val raw_semiring = prepare_ops raw_semiring0; + val raw_ring = prepare_ops raw_ring0; + val raw_field = prepare_ops raw_field0; + in + lthy |> Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => fn context => + let + val ctxt = Context.proof_of context; + val key = Morphism.thm phi raw_key; + fun transform_ops_rules (ops, rules) = + (map (Morphism.cterm phi) ops, Morphism.fact phi rules); + val (sr_ops, sr_rules) = transform_ops_rules raw_semiring; + val (r_ops, r_rules) = transform_ops_rules raw_ring; + val (f_ops, f_rules) = transform_ops_rules raw_field; + val idom = Morphism.fact phi raw_idom; + val ideal = Morphism.fact phi raw_ideal; - val mk_meta = Local_Defs.meta_rewrite_rule ctxt; - val sr_rules' = map mk_meta sr_rules; - val r_rules' = map mk_meta r_rules; - val f_rules' = map mk_meta f_rules; + fun check kind name xs n = + null xs orelse length xs = n orelse + error ("Expected " ^ string_of_int n ^ " " ^ kind ^ " for " ^ name); + val check_ops = check "operations"; + val check_rules = check "rules"; + val _ = + check_ops semiringN sr_ops 5 andalso + check_rules semiringN sr_rules 36 andalso + check_ops ringN r_ops 2 andalso + check_rules ringN r_rules 2 andalso + check_ops fieldN f_ops 2 andalso + check_rules fieldN f_rules 2 andalso + check_rules idomN idom 2; + + val mk_meta = Local_Defs.meta_rewrite_rule ctxt; + val sr_rules' = map mk_meta sr_rules; + val r_rules' = map mk_meta r_rules; + val f_rules' = map mk_meta f_rules; + + fun rule i = nth sr_rules' (i - 1); - fun rule i = nth sr_rules' (i - 1); - - val (cx, cy) = Thm.dest_binop (hd sr_ops); - val cz = rule 34 |> Thm.rhs_of |> Thm.dest_arg |> Thm.dest_arg; - val cn = rule 36 |> Thm.rhs_of |> Thm.dest_arg |> Thm.dest_arg; - val ((clx, crx), (cly, cry)) = - rule 13 |> Thm.rhs_of |> Thm.dest_binop |> apply2 Thm.dest_binop; - val ((ca, cb), (cc, cd)) = - rule 20 |> Thm.lhs_of |> Thm.dest_binop |> apply2 Thm.dest_binop; - val cm = rule 1 |> Thm.rhs_of |> Thm.dest_arg; - val (cp, cq) = rule 26 |> Thm.lhs_of |> Thm.dest_binop |> apply2 Thm.dest_arg; + val (cx, cy) = Thm.dest_binop (hd sr_ops); + val cz = rule 34 |> Thm.rhs_of |> Thm.dest_arg |> Thm.dest_arg; + val cn = rule 36 |> Thm.rhs_of |> Thm.dest_arg |> Thm.dest_arg; + val ((clx, crx), (cly, cry)) = + rule 13 |> Thm.rhs_of |> Thm.dest_binop |> apply2 Thm.dest_binop; + val ((ca, cb), (cc, cd)) = + rule 20 |> Thm.lhs_of |> Thm.dest_binop |> apply2 Thm.dest_binop; + val cm = rule 1 |> Thm.rhs_of |> Thm.dest_arg; + val (cp, cq) = rule 26 |> Thm.lhs_of |> Thm.dest_binop |> apply2 Thm.dest_arg; + + val vars = [ca, cb, cc, cd, cm, cn, cp, cq, cx, cy, cz, clx, crx, cly, cry]; - val vars = [ca, cb, cc, cd, cm, cn, cp, cq, cx, cy, cz, clx, crx, cly, cry]; - - val semiring = (sr_ops, sr_rules'); - val ring = (r_ops, r_rules'); - val field = (f_ops, f_rules'); - val ideal' = map (Thm.symmetric o mk_meta) ideal - - in - context - |> Data.map (AList.update Thm.eq_thm (key, - ({vars = vars, semiring = semiring, ring = ring, field = field, idom = idom, ideal = ideal'}, - (if null f_ops then semiring_funs else field_funs)))) - end + val semiring = (sr_ops, sr_rules'); + val ring = (r_ops, r_rules'); + val field = (f_ops, f_rules'); + val ideal' = map (Thm.symmetric o mk_meta) ideal + in + context + |> Data.map (AList.update Thm.eq_thm (key, + ({vars = vars, semiring = semiring, ring = ring, field = field, idom = idom, ideal = ideal'}, + (if null f_ops then semiring_funs else field_funs)))) + end) + end; (** auxiliary **) @@ -255,7 +265,7 @@ fun zerone_conv ctxt cv = zero1_numeral_conv ctxt then_conv cv then_conv numeral01_conv ctxt; -val nat_add_ss = simpset_of +val nat_add_ss = simpset_of (put_simpset HOL_basic_ss @{context} addsimps @{thms arith_simps} @ @{thms diff_nat_numeral} @ @{thms rel_simps} @ @{thms if_False if_True Nat.add_0 add_Suc add_numeral_left Suc_eq_plus1} @@ -308,9 +318,9 @@ end | _ => (TrueI, TrueI, true_tm, true_tm, (fn t => (t,t)), true_tm, true_tm)); -val (divide_inverse, divide_tm, inverse_tm) = - (case (f_ops, f_rules) of - ([divide_pat, inverse_pat], [div_inv, _]) => +val (divide_inverse, divide_tm, inverse_tm) = + (case (f_ops, f_rules) of + ([divide_pat, inverse_pat], [div_inv, _]) => let val div_tm = funpow 2 Thm.dest_fun divide_pat val inv_tm = Thm.dest_fun inverse_pat in (div_inv, div_tm, inv_tm) @@ -420,7 +430,7 @@ else ((let val (lopr,r) = Thm.dest_comb tm val (opr,l) = Thm.dest_comb lopr - in if opr aconvc pow_tm andalso is_number r then l + in if opr aconvc pow_tm andalso is_number r then l else raise CTERM ("monomial_mul_conv",[tm]) end) handle CTERM _ => tm) (* FIXME !? *) fun vorder x y = @@ -803,9 +813,9 @@ let val th1 = Drule.fun_cong_rule (Drule.arg_cong_rule opr (polynomial_conv ctxt l)) r in Thm.transitive th1 (polynomial_pow_conv ctxt (concl th1)) end - else if opr aconvc divide_tm + else if opr aconvc divide_tm then - let val th1 = Thm.combination (Drule.arg_cong_rule opr (polynomial_conv ctxt l)) + let val th1 = Thm.combination (Drule.arg_cong_rule opr (polynomial_conv ctxt l)) (polynomial_conv ctxt r) val th2 = (Conv.rewr_conv divide_inverse then_conv polynomial_mul_conv ctxt) (Thm.rhs_of th1) @@ -846,7 +856,7 @@ (* various normalizing conversions *) -fun semiring_normalizers_ord_wrapper ctxt ({vars, semiring, ring, field, idom, ideal}, +fun semiring_normalizers_ord_wrapper ctxt ({vars, semiring, ring, field, idom, ideal}, {conv, dest_const, mk_const, is_const}) ord = let val pow_conv = @@ -862,14 +872,14 @@ ({vars = vars, semiring = semiring, ring = ring, field = field, idom = idom, ideal = ideal}, {conv = conv, dest_const = dest_const, mk_const = mk_const, is_const = is_const}) ord) ctxt; -fun semiring_normalize_wrapper ctxt data = +fun semiring_normalize_wrapper ctxt data = semiring_normalize_ord_wrapper ctxt data simple_cterm_ord; fun semiring_normalize_ord_conv ctxt ord tm = (case match ctxt tm of NONE => Thm.reflexive tm | SOME res => semiring_normalize_ord_wrapper ctxt res ord tm); - + fun semiring_normalize_conv ctxt = semiring_normalize_ord_conv ctxt simple_cterm_ord; end; diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/set_comprehension_pointfree.ML --- a/src/HOL/Tools/set_comprehension_pointfree.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/set_comprehension_pointfree.ML Fri Sep 18 16:42:19 2015 +0100 @@ -92,7 +92,7 @@ val strip_psplits = let fun strip [] qs vs t = (t, rev vs, qs) - | strip (p :: ps) qs vs (Const (@{const_name Product_Type.prod.case_prod}, _) $ t) = + | strip (p :: ps) qs vs (Const (@{const_name uncurry}, _) $ t) = strip ((1 :: p) :: (2 :: p) :: ps) (p :: qs) vs t | strip (_ :: ps) qs vs (Abs (s, T, t)) = strip ps qs ((s, T) :: vs) t | strip (_ :: ps) qs vs t = strip ps qs @@ -305,7 +305,7 @@ (* proof tactic *) -val case_prod_distrib = @{lemma "(case_prod g x) z = case_prod (% x y. (g x y) z) x" by (simp add: case_prod_beta)} +val case_prod_distrib = @{lemma "(uncurry g x) z = uncurry (\x y. (g x y) z) x" by (simp add: case_prod_beta)} val vimageI2' = @{lemma "f a \ A ==> a \ f -` A" by simp} val vimageE' = diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Tools/typedef.ML --- a/src/HOL/Tools/typedef.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Tools/typedef.ML Fri Sep 18 16:42:19 2015 +0100 @@ -16,16 +16,20 @@ val get_info: Proof.context -> string -> info list val get_info_global: theory -> string -> info list val interpretation: (string -> local_theory -> local_theory) -> theory -> theory - val add_typedef: bool -> binding * (string * sort) list * mixfix -> - term -> (binding * binding) option -> (Proof.context -> tactic) -> local_theory -> + type bindings = {Rep_name: binding, Abs_name: binding, type_definition_name: binding} + val default_bindings: binding -> bindings + val make_bindings: binding -> bindings option -> bindings + val make_morphisms: binding -> (binding * binding) option -> bindings + val add_typedef: binding * (string * sort) list * mixfix -> + term -> bindings option -> (Proof.context -> tactic) -> local_theory -> (string * info) * local_theory - val add_typedef_global: bool -> binding * (string * sort) list * mixfix -> - term -> (binding * binding) option -> (Proof.context -> tactic) -> theory -> + val add_typedef_global: binding * (string * sort) list * mixfix -> + term -> bindings option -> (Proof.context -> tactic) -> theory -> (string * info) * theory - val typedef: (binding * (string * sort) list * mixfix) * term * - (binding * binding) option -> local_theory -> Proof.state - val typedef_cmd: (binding * (string * string option) list * mixfix) * string * - (binding * binding) option -> local_theory -> Proof.state + val typedef: binding * (string * sort) list * mixfix -> term -> bindings option -> + local_theory -> Proof.state + val typedef_cmd: binding * (string * string option) list * mixfix -> string -> bindings option -> + local_theory -> Proof.state end; structure Typedef: TYPEDEF = @@ -105,7 +109,7 @@ (newT --> oldT) --> (oldT --> newT) --> HOLogic.mk_setT oldT --> HOLogic.boolT); in Logic.mk_implies (mk_inhabited A, HOLogic.mk_Trueprop (typedefC $ RepC $ AbsC $ A)) end; -fun primitive_typedef typedef_name newT oldT Rep_name Abs_name A lthy = +fun primitive_typedef type_definition_name newT oldT Rep_name Abs_name A lthy = let (* errors *) @@ -133,18 +137,35 @@ val ((axiom_name, axiom), axiom_lthy) = consts_lthy |> Local_Theory.background_theory_result - (Thm.add_axiom consts_lthy (typedef_name, mk_typedef newT oldT RepC AbsC A) ##> + (Thm.add_axiom consts_lthy (type_definition_name, mk_typedef newT oldT RepC AbsC A) ##> Theory.add_deps consts_lthy "" (dest_Const RepC) typedef_deps ##> Theory.add_deps consts_lthy "" (dest_Const AbsC) typedef_deps); in ((RepC, AbsC, axiom_name, axiom), axiom_lthy) end; +(* derived bindings *) + +type bindings = {Rep_name: binding, Abs_name: binding, type_definition_name: binding}; + +fun default_bindings name = + {Rep_name = Binding.prefix_name "Rep_" name, + Abs_name = Binding.prefix_name "Abs_" name, + type_definition_name = Binding.prefix_name "type_definition_" name}; + +fun make_bindings name NONE = default_bindings name + | make_bindings _ (SOME bindings) = bindings; + +fun make_morphisms name NONE = default_bindings name + | make_morphisms name (SOME (Rep_name, Abs_name)) = + {Rep_name = Rep_name, Abs_name = Abs_name, + type_definition_name = #type_definition_name (default_bindings name)}; + + (* prepare_typedef *) -fun prepare_typedef concealed prep_term (name, raw_args, mx) raw_set opt_morphs lthy = +fun prepare_typedef prep_term (name, raw_args, mx) raw_set opt_bindings lthy = let - val concealed_name = name |> concealed ? Binding.concealed; val bname = Binding.name_of name; @@ -174,16 +195,10 @@ (* axiomatization *) - val (Rep_name, Abs_name) = - (case opt_morphs of - NONE => (Binding.prefix_name "Rep_" concealed_name, - Binding.prefix_name "Abs_" concealed_name) - | SOME morphs => morphs); - - val typedef_name = Binding.prefix_name "type_definition_" concealed_name; + val {Rep_name, Abs_name, type_definition_name} = make_bindings name opt_bindings; val ((RepC, AbsC, axiom_name, typedef), typedef_lthy) = typedecl_lthy - |> primitive_typedef typedef_name newT oldT Rep_name Abs_name set; + |> primitive_typedef type_definition_name newT oldT Rep_name Abs_name set; val alias_lthy = typedef_lthy |> Local_Theory.const_alias Rep_name (#1 (Term.dest_Const RepC)) @@ -202,7 +217,7 @@ fun make th = Goal.norm_result lthy1 (typedef' RS th); val (((((((((((_, [type_definition]), Rep), Rep_inverse), Abs_inverse), Rep_inject), Abs_inject), Rep_cases), Abs_cases), Rep_induct), Abs_induct), lthy2) = lthy1 - |> Local_Theory.note ((typedef_name, []), [typedef']) + |> Local_Theory.note ((type_definition_name, []), [typedef']) ||>> note_qualify ((Rep_name, []), make @{thm type_definition.Rep}) ||>> note_qualify ((Binding.suffix_name "_inverse" Rep_name, []), make @{thm type_definition.Rep_inverse}) @@ -247,18 +262,18 @@ (* add_typedef: tactic interface *) -fun add_typedef concealed typ set opt_morphs tac lthy = +fun add_typedef typ set opt_bindings tac lthy = let val ((goal, _, typedef_result), lthy') = - prepare_typedef concealed Syntax.check_term typ set opt_morphs lthy; + prepare_typedef Syntax.check_term typ set opt_bindings lthy; val inhabited = Goal.prove lthy' [] [] goal (tac o #context) |> Goal.norm_result lthy' |> Thm.close_derivation; in typedef_result inhabited lthy' end; -fun add_typedef_global concealed typ set opt_morphs tac = +fun add_typedef_global typ set opt_bindings tac = Named_Target.theory_init - #> add_typedef concealed typ set opt_morphs tac + #> add_typedef typ set opt_bindings tac #> Local_Theory.exit_result_global (apsnd o transform_info); @@ -266,11 +281,11 @@ local -fun gen_typedef prep_term prep_constraint ((b, raw_args, mx), set, opt_morphs) lthy = +fun gen_typedef prep_term prep_constraint (b, raw_args, mx) set opt_bindings lthy = let val args = map (apsnd (prep_constraint lthy)) raw_args; val ((goal, goal_pat, typedef_result), lthy') = - prepare_typedef false prep_term (b, args, mx) set opt_morphs lthy; + prepare_typedef prep_term (b, args, mx) set opt_bindings lthy; fun after_qed [[th]] = snd o typedef_result th; in Proof.theorem NONE after_qed [[(goal, [goal_pat])]] lthy' end; @@ -291,6 +306,7 @@ (Parse.type_args_constrained -- Parse.binding -- Parse.opt_mixfix -- (@{keyword "="} |-- Parse.term) -- Scan.option (@{keyword "morphisms"} |-- Parse.!!! (Parse.binding -- Parse.binding)) - >> (fn ((((vs, t), mx), A), morphs) => fn lthy => typedef_cmd ((t, vs, mx), A, morphs) lthy)); + >> (fn ((((vs, t), mx), A), opt_morphs) => fn lthy => + typedef_cmd (t, vs, mx) A (SOME (make_morphisms t opt_morphs)) lthy)); end; diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Topological_Spaces.thy --- a/src/HOL/Topological_Spaces.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Topological_Spaces.thy Fri Sep 18 16:42:19 2015 +0100 @@ -212,7 +212,7 @@ lemma topological_space_generate_topology: "class.topological_space (generate_topology S)" - by default (auto intro: generate_topology.intros) + by standard (auto intro: generate_topology.intros) subsection \Order topologies\ diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/UNITY/Follows.thy --- a/src/HOL/UNITY/Follows.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/UNITY/Follows.thy Fri Sep 18 16:42:19 2015 +0100 @@ -179,7 +179,7 @@ "(M'::'a multiset) \ M \ M' #<=# M" instance - by default (auto simp add: less_eq_multiset_def less_multiset_def multiset_order.less_le_not_le add.commute multiset_order.add_right_mono) + by standard (auto simp add: less_eq_multiset_def less_multiset_def multiset_order.less_le_not_le add.commute multiset_order.add_right_mono) end lemma increasing_union: diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/UNITY/Guar.thy --- a/src/HOL/UNITY/Guar.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/UNITY/Guar.thy Fri Sep 18 16:42:19 2015 +0100 @@ -17,7 +17,7 @@ begin instance program :: (type) order - by default (auto simp add: program_less_le dest: component_antisym intro: component_trans) + by standard (auto simp add: program_less_le dest: component_antisym intro: component_trans) text{*Existential and Universal properties. I formalize the two-program case, proving equivalence with Chandy and Sanders's n-ary definitions*} diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Word/Word.thy --- a/src/HOL/Word/Word.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Word/Word.thy Fri Sep 18 16:42:19 2015 +0100 @@ -313,7 +313,7 @@ word_mod_def: "a mod b = word_of_int (uint a mod uint b)" instance - by default (transfer, simp add: algebra_simps)+ + by standard (transfer, simp add: algebra_simps)+ end @@ -384,7 +384,7 @@ word_less_def: "a < b \ uint a < uint b" instance - by default (auto simp: word_less_def word_le_def) + by standard (auto simp: word_less_def word_le_def) end @@ -1194,7 +1194,7 @@ by (fact word_less_def) lemma signed_linorder: "class.linorder word_sle word_sless" - by default (unfold word_sle_def word_sless_def, auto) + by standard (unfold word_sle_def word_sless_def, auto) interpretation signed: linorder "word_sle" "word_sless" by (rule signed_linorder) @@ -2215,7 +2215,7 @@ subsection {* Cardinality, finiteness of set of words *} instance word :: (len0) finite - by (default, simp add: type_definition.univ [OF type_definition_word]) + by standard (simp add: type_definition.univ [OF type_definition_word]) lemma card_word: "CARD('a::len0 word) = 2 ^ len_of TYPE('a)" by (simp add: type_definition.card [OF type_definition_word] nat_power_eq) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/Word/WordBitwise.thy --- a/src/HOL/Word/WordBitwise.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/Word/WordBitwise.thy Fri Sep 18 16:42:19 2015 +0100 @@ -497,8 +497,8 @@ text {* Tactic definition *} ML {* - -structure Word_Bitwise_Tac = struct +structure Word_Bitwise_Tac = +struct val word_ss = simpset_of @{theory_context Word}; @@ -523,10 +523,9 @@ end | _ => NONE; -val expand_upt_simproc = Simplifier.make_simproc - {lhss = [@{cpat "upt _ _"}], - name = "expand_upt", identifier = [], - proc = K upt_conv}; +val expand_upt_simproc = + Simplifier.make_simproc @{context} "expand_upt" + {lhss = [@{term "upt x y"}], proc = K upt_conv, identifier = []}; fun word_len_simproc_fn ctxt ct = case Thm.term_of ct of @@ -540,10 +539,9 @@ handle TERM _ => NONE | TYPE _ => NONE) | _ => NONE; -val word_len_simproc = Simplifier.make_simproc - {lhss = [@{cpat "len_of _"}], - name = "word_len", identifier = [], - proc = K word_len_simproc_fn}; +val word_len_simproc = + Simplifier.make_simproc @{context} "word_len" + {lhss = [@{term "len_of x"}], proc = K word_len_simproc_fn, identifier = []}; (* convert 5 or nat 5 to Suc 4 when n_sucs = 1, Suc (Suc 4) when n_sucs = 2, or just 5 (discarding nat) when n_sucs = 0 *) @@ -567,10 +565,10 @@ |> mk_meta_eq |> SOME end handle TERM _ => NONE; -fun nat_get_Suc_simproc n_sucs cts = Simplifier.make_simproc - {lhss = map (fn t => Thm.apply t @{cpat "?n :: nat"}) cts, - name = "nat_get_Suc", identifier = [], - proc = K (nat_get_Suc_simproc_fn n_sucs)}; +fun nat_get_Suc_simproc n_sucs ts = + Simplifier.make_simproc @{context} "nat_get_Suc" + {lhss = map (fn t => t $ @{term "n :: nat"}) ts, + proc = K (nat_get_Suc_simproc_fn n_sucs), identifier = []}; val no_split_ss = simpset_of (put_simpset HOL_ss @{context} @@ -601,10 +599,10 @@ rev_bl_order_simps} addsimprocs [expand_upt_simproc, nat_get_Suc_simproc 4 - [@{cpat replicate}, @{cpat "takefill ?x"}, - @{cpat drop}, @{cpat "bin_to_bl"}, - @{cpat "takefill_last ?x"}, - @{cpat "drop_nonempty ?x"}]], + [@{term replicate}, @{term "takefill x"}, + @{term drop}, @{term "bin_to_bl"}, + @{term "takefill_last x"}, + @{term "drop_nonempty x"}]], put_simpset no_split_ss @{context} addsimps @{thms xor3_simps carry_simps if_bool_simps} ]) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/ZF/Games.thy --- a/src/HOL/ZF/Games.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/ZF/Games.thy Fri Sep 18 16:42:19 2015 +0100 @@ -418,7 +418,7 @@ proof (induct x rule: wf_induct[OF wf_option_of]) case (1 "g") show ?case - proof (auto, goals) + proof (auto, goal_cases) {case prems: (1 y) from prems have "(y, g) \ option_of" by (auto) with 1 have "ge_game (y, y)" by auto @@ -462,7 +462,7 @@ proof (induct a rule: induct_game) case (1 a) show ?case - proof ((rule allI | rule impI)+, goals) + proof ((rule allI | rule impI)+, goal_cases) case prems: (1 x y z) show ?case proof - @@ -543,7 +543,7 @@ lemma plus_game_zero_right[simp]: "plus_game G zero_game = G" proof - have "H = zero_game \ plus_game G H = G " for G H - proof (induct G H rule: plus_game.induct, rule impI, goals) + proof (induct G H rule: plus_game.induct, rule impI, goal_cases) case prems: (1 G H) note induct_hyp = this[simplified prems, simplified] and this show ?case @@ -583,7 +583,7 @@ lemma plus_game_assoc: "plus_game (plus_game F G) H = plus_game F (plus_game G H)" proof - have "\F G H. a = [F, G, H] \ plus_game (plus_game F G) H = plus_game F (plus_game G H)" for a - proof (induct a rule: induct_game, (rule impI | rule allI)+, goals) + proof (induct a rule: induct_game, (rule impI | rule allI)+, goal_cases) case prems: (1 x F G H) let ?L = "plus_game (plus_game F G) H" let ?R = "plus_game F (plus_game G H)" @@ -626,7 +626,7 @@ qed lemma eq_game_plus_inverse: "eq_game (plus_game x (neg_game x)) zero_game" -proof (induct x rule: wf_induct[OF wf_option_of], goals) +proof (induct x rule: wf_induct[OF wf_option_of], goal_cases) case prems: (1 x) then have ihyp: "eq_game (plus_game y (neg_game y)) zero_game" if "zin y (options x)" for y using that by (auto simp add: prems) @@ -670,7 +670,7 @@ lemma ge_plus_game_left: "ge_game (y,z) = ge_game (plus_game x y, plus_game x z)" proof - have "\x y z. a = [x,y,z] \ ge_game (y,z) = ge_game (plus_game x y, plus_game x z)" for a - proof (induct a rule: induct_game, (rule impI | rule allI)+, goals) + proof (induct a rule: induct_game, (rule impI | rule allI)+, goal_cases) case prems: (1 a x y z) note induct_hyp = prems(1)[rule_format, simplified prems(2)] { @@ -780,7 +780,7 @@ lemma ge_neg_game: "ge_game (neg_game x, neg_game y) = ge_game (y, x)" proof - have "\x y. a = [x, y] \ ge_game (neg_game x, neg_game y) = ge_game (y, x)" for a - proof (induct a rule: induct_game, (rule impI | rule allI)+, goals) + proof (induct a rule: induct_game, (rule impI | rule allI)+, goal_cases) case prems: (1 a x y) note ihyp = prems(1)[rule_format, simplified prems(2)] { fix xl diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/ex/Adhoc_Overloading_Examples.thy --- a/src/HOL/ex/Adhoc_Overloading_Examples.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/ex/Adhoc_Overloading_Examples.thy Fri Sep 18 16:42:19 2015 +0100 @@ -88,7 +88,7 @@ "perms = {f. bij f \ finite {x. f x \ x}}" typedef 'a perm = "perms :: ('a \ 'a) set" - by (default) (auto simp: perms_def) + by standard (auto simp: perms_def) text {*First we need some auxiliary lemmas.*} lemma permsI [Pure.intro]: @@ -153,13 +153,14 @@ unfolding uminus_perm_def by (simp add: Abs_perm_inverse perms_inv Rep_perm) instance - apply default + apply standard unfolding Rep_perm_inject [symmetric] unfolding minus_perm_def unfolding Rep_perm_add unfolding Rep_perm_uminus unfolding Rep_perm_0 - by (simp_all add: o_assoc inv_o_cancel [OF bij_is_inj [OF bij_Rep_perm]]) + apply (simp_all add: o_assoc inv_o_cancel [OF bij_is_inj [OF bij_Rep_perm]]) + done end @@ -198,7 +199,7 @@ PERMUTE permute_atom interpretation atom_permute: permute permute_atom - by (default) (simp add: permute_atom_def Rep_perm_simps)+ + by standard (simp_all add: permute_atom_def Rep_perm_simps) text {*Permuting permutations.*} definition permute_perm :: "'a perm \ 'a perm \ 'a perm" where @@ -208,7 +209,7 @@ PERMUTE permute_perm interpretation perm_permute: permute permute_perm - apply default + apply standard unfolding permute_perm_def apply simp apply (simp only: diff_conv_add_uminus minus_add add.assoc) diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/ex/Dedekind_Real.thy --- a/src/HOL/ex/Dedekind_Real.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/ex/Dedekind_Real.thy Fri Sep 18 16:42:19 2015 +0100 @@ -1567,7 +1567,7 @@ "(sup :: real \ real \ real) = max" instance - by default (auto simp add: inf_real_def sup_real_def max_min_distrib2) + by standard (auto simp add: inf_real_def sup_real_def max_min_distrib2) end diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/ex/SOS.thy --- a/src/HOL/ex/SOS.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/ex/SOS.thy Fri Sep 18 16:42:19 2015 +0100 @@ -12,119 +12,131 @@ lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x \ a < 0" by sos -lemma "a1 >= 0 & a2 >= 0 \ (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) \ (a1 * b1 + a2 * b2 = 0) --> a1 * a2 - b1 * b2 >= (0::real)" +lemma "a1 \ 0 \ a2 \ 0 \ (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) \ (a1 * b1 + a2 * b2 = 0) \ + a1 * a2 - b1 * b2 \ (0::real)" by sos -lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x --> a < 0" +lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x \ a < 0" by sos -lemma "(0::real) <= x & x <= 1 & 0 <= y & y <= 1 --> x^2 + y^2 < 1 |(x - 1)^2 + y^2 < 1 | x^2 + (y - 1)^2 < 1 | (x - 1)^2 + (y - 1)^2 < 1" +lemma "(0::real) \ x \ x \ 1 \ 0 \ y \ y \ 1 \ + x\<^sup>2 + y\<^sup>2 < 1 \ (x - 1)\<^sup>2 + y\<^sup>2 < 1 \ x\<^sup>2 + (y - 1)\<^sup>2 < 1 \ (x - 1)\<^sup>2 + (y - 1)\<^sup>2 < 1" by sos -lemma "(0::real) <= x & 0 <= y & 0 <= z & x + y + z <= 3 --> x * y + x * z + y * z >= 3 * x * y * z" +lemma "(0::real) \ x \ 0 \ y \ 0 \ z \ x + y + z \ 3 \ x * y + x * z + y * z \ 3 * x * y * z" by sos -lemma "((x::real)^2 + y^2 + z^2 = 1) --> (x + y + z)^2 <= 3" +lemma "(x::real)\<^sup>2 + y\<^sup>2 + z\<^sup>2 = 1 \ (x + y + z)\<^sup>2 \ 3" by sos -lemma "(w^2 + x^2 + y^2 + z^2 = 1) --> (w + x + y + z)^2 <= (4::real)" +lemma "w\<^sup>2 + x\<^sup>2 + y\<^sup>2 + z\<^sup>2 = 1 \ (w + x + y + z)\<^sup>2 \ (4::real)" by sos -lemma "(x::real) >= 1 & y >= 1 --> x * y >= x + y - 1" +lemma "(x::real) \ 1 \ y \ 1 \ x * y \ x + y - 1" by sos -lemma "(x::real) > 1 & y > 1 --> x * y > x + y - 1" +lemma "(x::real) > 1 \ y > 1 \ x * y > x + y - 1" by sos -lemma "abs(x) <= 1 --> abs(64 * x^7 - 112 * x^5 + 56 * x^3 - 7 * x) <= (1::real)" +lemma "\x\ \ 1 \ \64 * x^7 - 112 * x^5 + 56 * x^3 - 7 * x\ \ (1::real)" by sos text \One component of denominator in dodecahedral example.\ -lemma "2 <= x & x <= 125841 / 50000 & 2 <= y & y <= 125841 / 50000 & 2 <= z & z <= 125841 / 50000 --> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= (0::real)" +lemma "2 \ x \ x \ 125841 / 50000 \ 2 \ y \ y \ 125841 / 50000 \ 2 \ z \ z \ 125841 / 50000 \ + 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) \ (0::real)" by sos text \Over a larger but simpler interval.\ -lemma "(2::real) <= x & x <= 4 & 2 <= y & y <= 4 & 2 <= z & z <= 4 --> 0 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)" +lemma "(2::real) \ x \ x \ 4 \ 2 \ y \ y \ 4 \ 2 \ z \ z \ 4 \ + 0 \ 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)" by sos text \We can do 12. I think 12 is a sharp bound; see PP's certificate.\ -lemma "2 <= (x::real) & x <= 4 & 2 <= y & y <= 4 & 2 <= z & z <= 4 --> 12 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)" +lemma "2 \ (x::real) \ x \ 4 \ 2 \ y \ y \ 4 \ 2 \ z \ z \ 4 \ + 12 \ 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)" by sos text \Inequality from sci.math (see "Leon-Sotelo, por favor").\ -lemma "0 <= (x::real) & 0 <= y & (x * y = 1) --> x + y <= x^2 + y^2" +lemma "0 \ (x::real) \ 0 \ y \ x * y = 1 \ x + y \ x\<^sup>2 + y\<^sup>2" by sos -lemma "0 <= (x::real) & 0 <= y & (x * y = 1) --> x * y * (x + y) <= x^2 + y^2" +lemma "0 \ (x::real) \ 0 \ y \ x * y = 1 \ x * y * (x + y) \ x\<^sup>2 + y\<^sup>2" by sos -lemma "0 <= (x::real) & 0 <= y --> x * y * (x + y)^2 <= (x^2 + y^2)^2" +lemma "0 \ (x::real) \ 0 \ y \ x * y * (x + y)\<^sup>2 \ (x\<^sup>2 + y\<^sup>2)\<^sup>2" by sos -lemma "(0::real) <= a & 0 <= b & 0 <= c & c * (2 * a + b)^3/ 27 <= x \ c * a^2 * b <= x" +lemma "(0::real) \ a \ 0 \ b \ 0 \ c \ c * (2 * a + b)^3 / 27 \ x \ c * a\<^sup>2 * b \ x" by sos -lemma "(0::real) < x --> 0 < 1 + x + x^2" +lemma "(0::real) < x \ 0 < 1 + x + x\<^sup>2" by sos -lemma "(0::real) <= x --> 0 < 1 + x + x^2" +lemma "(0::real) \ x \ 0 < 1 + x + x\<^sup>2" by sos -lemma "(0::real) < 1 + x^2" +lemma "(0::real) < 1 + x\<^sup>2" by sos -lemma "(0::real) <= 1 + 2 * x + x^2" +lemma "(0::real) \ 1 + 2 * x + x\<^sup>2" by sos -lemma "(0::real) < 1 + abs x" +lemma "(0::real) < 1 + \x\" by sos -lemma "(0::real) < 1 + (1 + x)^2 * (abs x)" +lemma "(0::real) < 1 + (1 + x)\<^sup>2 * \x\" by sos -lemma "abs ((1::real) + x^2) = (1::real) + x^2" +lemma "\(1::real) + x\<^sup>2\ = (1::real) + x\<^sup>2" by sos + lemma "(3::real) * x + 7 * a < 4 \ 3 < 2 * x \ a < 0" by sos -lemma "(0::real) < x --> 1 < y --> y * x <= z --> x < z" +lemma "(0::real) < x \ 1 < y \ y * x \ z \ x < z" by sos -lemma "(1::real) < x --> x^2 < y --> 1 < y" + +lemma "(1::real) < x \ x\<^sup>2 < y \ 1 < y" by sos -lemma "(b::real)^2 < 4 * a * c --> ~(a * x^2 + b * x + c = 0)" + +lemma "(b::real)\<^sup>2 < 4 * a * c \ a * x\<^sup>2 + b * x + c \ 0" by sos -lemma "(b::real)^2 < 4 * a * c --> ~(a * x^2 + b * x + c = 0)" - by sos -lemma "((a::real) * x^2 + b * x + c = 0) --> b^2 >= 4 * a * c" + +lemma "(b::real)\<^sup>2 < 4 * a * c \ a * x\<^sup>2 + b * x + c \ 0" by sos -lemma "(0::real) <= b & 0 <= c & 0 <= x & 0 <= y & (x^2 = c) & (y^2 = a^2 * c + b) --> a * c <= y * x" + +lemma "(a::real) * x\<^sup>2 + b * x + c = 0 \ b\<^sup>2 \ 4 * a * c" by sos -lemma "abs(x - z) <= e & abs(y - z) <= e & 0 <= u & 0 <= v & (u + v = 1) --> abs((u * x + v * y) - z) <= (e::real)" + +lemma "(0::real) \ b \ 0 \ c \ 0 \ x \ 0 \ y \ x\<^sup>2 = c \ y\<^sup>2 = a\<^sup>2 * c + b \ a * c \ y * x" by sos +lemma "\x - z\ \ e \ \y - z\ \ e \ 0 \ u \ 0 \ v \ u + v = 1 --> \(u * x + v * y) - z\ \ (e::real)" + by sos -(* lemma "((x::real) - y - 2 * x^4 = 0) & 0 <= x & x <= 2 & 0 <= y & y <= 3 --> y^2 - 7 * y - 12 * x + 17 >= 0" by sos *) (* Too hard?*) +lemma "(x::real) - y - 2 * x^4 = 0 \ 0 \ x \ x \ 2 \ 0 \ y \ y \ 3 \ y\<^sup>2 - 7 * y - 12 * x + 17 \ 0" + oops (*Too hard?*) -lemma "(0::real) <= x --> (1 + x + x^2)/(1 + x^2) <= 1 + x" +lemma "(0::real) \ x \ (1 + x + x\<^sup>2) / (1 + x\<^sup>2) \ 1 + x" by sos -lemma "(0::real) <= x --> 1 - x <= 1 / (1 + x + x^2)" +lemma "(0::real) \ x \ 1 - x \ 1 / (1 + x + x\<^sup>2)" by sos -lemma "(x::real) <= 1 / 2 --> - x - 2 * x^2 <= - x / (1 - x)" +lemma "(x::real) \ 1 / 2 \ - x - 2 * x\<^sup>2 \ - x / (1 - x)" by sos -lemma "4*r^2 = p^2 - 4*q & r >= (0::real) & x^2 + p*x + q = 0 --> 2*(x::real) = - p + 2*r | 2*x = -p - 2*r" +lemma "4 * r\<^sup>2 = p\<^sup>2 - 4 * q \ r \ (0::real) \ x\<^sup>2 + p * x + q = 0 \ + 2 * (x::real) = - p + 2 * r \ 2 * x = - p - 2 * r" by sos end - diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/ex/SOS_Cert.thy --- a/src/HOL/ex/SOS_Cert.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/ex/SOS_Cert.thy Fri Sep 18 16:42:19 2015 +0100 @@ -9,122 +9,134 @@ imports "~~/src/HOL/Library/Sum_of_Squares" begin -lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x \ a < 0" +lemma "(3::real) * x + 7 * a < 4 \ 3 < 2 * x \ a < 0" by (sos "((R<1 + (((A<1 * R<1) * (R<2 * [1]^2)) + (((A<0 * R<1) * (R<3 * [1]^2)) + ((A<=0 * R<1) * (R<14 * [1]^2))))))") -lemma "a1 >= 0 & a2 >= 0 \ (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) \ (a1 * b1 + a2 * b2 = 0) --> a1 * a2 - b1 * b2 >= (0::real)" +lemma "a1 \ 0 \ a2 \ 0 \ (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) \ (a1 * b1 + a2 * b2 = 0) \ + a1 * a2 - b1 * b2 \ (0::real)" by (sos "(((A<0 * R<1) + (([~1/2*a1*b2 + ~1/2*a2*b1] * A=0) + (([~1/2*a1*a2 + 1/2*b1*b2] * A=1) + (((A<0 * R<1) * ((R<1/2 * [b2]^2) + (R<1/2 * [b1]^2))) + ((A<=0 * (A<=1 * R<1)) * ((R<1/2 * [b2]^2) + ((R<1/2 * [b1]^2) + ((R<1/2 * [a2]^2) + (R<1/2 * [a1]^2))))))))))") -lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x --> a < 0" +lemma "(3::real) * x + 7 * a < 4 \ 3 < 2 * x \ a < 0" by (sos "((R<1 + (((A<1 * R<1) * (R<2 * [1]^2)) + (((A<0 * R<1) * (R<3 * [1]^2)) + ((A<=0 * R<1) * (R<14 * [1]^2))))))") -lemma "(0::real) <= x & x <= 1 & 0 <= y & y <= 1 --> x^2 + y^2 < 1 |(x - 1)^2 + y^2 < 1 | x^2 + (y - 1)^2 < 1 | (x - 1)^2 + (y - 1)^2 < 1" +lemma "(0::real) \ x \ x \ 1 \ 0 \ y \ y \ 1 \ + x\<^sup>2 + y\<^sup>2 < 1 \ (x - 1)\<^sup>2 + y\<^sup>2 < 1 \ x\<^sup>2 + (y - 1)\<^sup>2 < 1 \ (x - 1)\<^sup>2 + (y - 1)\<^sup>2 < 1" by (sos "((R<1 + (((A<=3 * (A<=4 * R<1)) * (R<1 * [1]^2)) + (((A<=2 * (A<=7 * R<1)) * (R<1 * [1]^2)) + (((A<=1 * (A<=6 * R<1)) * (R<1 * [1]^2)) + ((A<=0 * (A<=5 * R<1)) * (R<1 * [1]^2)))))))") -lemma "(0::real) <= x & 0 <= y & 0 <= z & x + y + z <= 3 --> x * y + x * z + y * z >= 3 * x * y * z" +lemma "(0::real) \ x \ 0 \ y \ 0 \ z \ x + y + z \ 3 \ x * y + x * z + y * z \ 3 * x * y * z" by (sos "(((A<0 * R<1) + (((A<0 * R<1) * (R<1/2 * [1]^2)) + (((A<=2 * R<1) * (R<1/2 * [~1*x + y]^2)) + (((A<=1 * R<1) * (R<1/2 * [~1*x + z]^2)) + (((A<=1 * (A<=2 * (A<=3 * R<1))) * (R<1/2 * [1]^2)) + (((A<=0 * R<1) * (R<1/2 * [~1*y + z]^2)) + (((A<=0 * (A<=2 * (A<=3 * R<1))) * (R<1/2 * [1]^2)) + ((A<=0 * (A<=1 * (A<=3 * R<1))) * (R<1/2 * [1]^2))))))))))") -lemma "((x::real)^2 + y^2 + z^2 = 1) --> (x + y + z)^2 <= 3" +lemma "(x::real)\<^sup>2 + y\<^sup>2 + z\<^sup>2 = 1 \ (x + y + z)\<^sup>2 \ 3" by (sos "(((A<0 * R<1) + (([~3] * A=0) + (R<1 * ((R<2 * [~1/2*x + ~1/2*y + z]^2) + (R<3/2 * [~1*x + y]^2))))))") -lemma "(w^2 + x^2 + y^2 + z^2 = 1) --> (w + x + y + z)^2 <= (4::real)" +lemma "w\<^sup>2 + x\<^sup>2 + y\<^sup>2 + z\<^sup>2 = 1 \ (w + x + y + z)\<^sup>2 \ (4::real)" by (sos "(((A<0 * R<1) + (([~4] * A=0) + (R<1 * ((R<3 * [~1/3*w + ~1/3*x + ~1/3*y + z]^2) + ((R<8/3 * [~1/2*w + ~1/2*x + y]^2) + (R<2 * [~1*w + x]^2)))))))") -lemma "(x::real) >= 1 & y >= 1 --> x * y >= x + y - 1" +lemma "(x::real) \ 1 \ y \ 1 \ x * y \ x + y - 1" by (sos "(((A<0 * R<1) + ((A<=0 * (A<=1 * R<1)) * (R<1 * [1]^2))))") -lemma "(x::real) > 1 & y > 1 --> x * y > x + y - 1" +lemma "(x::real) > 1 \ y > 1 \ x * y > x + y - 1" by (sos "((((A<0 * A<1) * R<1) + ((A<=0 * R<1) * (R<1 * [1]^2))))") -lemma "abs(x) <= 1 --> abs(64 * x^7 - 112 * x^5 + 56 * x^3 - 7 * x) <= (1::real)" +lemma "\x\ \ 1 \ \64 * x^7 - 112 * x^5 + 56 * x^3 - 7 * x\ \ (1::real)" by (sos "((((A<0 * R<1) + ((A<=1 * R<1) * (R<1 * [~8*x^3 + ~4*x^2 + 4*x + 1]^2)))) & ((((A<0 * A<1) * R<1) + ((A<=1 * (A<0 * R<1)) * (R<1 * [8*x^3 + ~4*x^2 + ~4*x + 1]^2)))))") text \One component of denominator in dodecahedral example.\ -lemma "2 <= x & x <= 125841 / 50000 & 2 <= y & y <= 125841 / 50000 & 2 <= z & z <= 125841 / 50000 --> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= (0::real)" +lemma "2 \ x \ x \ 125841 / 50000 \ 2 \ y \ y \ 125841 / 50000 \ 2 \ z \ z \ 125841 / 50000 \ + 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) \ (0::real)" by (sos "(((A<0 * R<1) + ((R<1 * ((R<5749028157/5000000000 * [~25000/222477*x + ~25000/222477*y + ~25000/222477*z + 1]^2) + ((R<864067/1779816 * [419113/864067*x + 419113/864067*y + z]^2) + ((R<320795/864067 * [419113/1283180*x + y]^2) + (R<1702293/5132720 * [x]^2))))) + (((A<=4 * (A<=5 * R<1)) * (R<3/2 * [1]^2)) + (((A<=3 * (A<=5 * R<1)) * (R<1/2 * [1]^2)) + (((A<=2 * (A<=4 * R<1)) * (R<1 * [1]^2)) + (((A<=2 * (A<=3 * R<1)) * (R<3/2 * [1]^2)) + (((A<=1 * (A<=5 * R<1)) * (R<1/2 * [1]^2)) + (((A<=1 * (A<=3 * R<1)) * (R<1/2 * [1]^2)) + (((A<=0 * (A<=4 * R<1)) * (R<1 * [1]^2)) + (((A<=0 * (A<=2 * R<1)) * (R<1 * [1]^2)) + ((A<=0 * (A<=1 * R<1)) * (R<3/2 * [1]^2)))))))))))))") text \Over a larger but simpler interval.\ -lemma "(2::real) <= x & x <= 4 & 2 <= y & y <= 4 & 2 <= z & z <= 4 --> 0 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)" +lemma "(2::real) \ x \ x \ 4 \ 2 \ y \ y \ 4 \ 2 \ z \ z \ 4 \ + 0 \ 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)" by (sos "((R<1 + ((R<1 * ((R<1 * [~1/6*x + ~1/6*y + ~1/6*z + 1]^2) + ((R<1/18 * [~1/2*x + ~1/2*y + z]^2) + (R<1/24 * [~1*x + y]^2)))) + (((A<0 * R<1) * (R<1/12 * [1]^2)) + (((A<=4 * (A<=5 * R<1)) * (R<1/6 * [1]^2)) + (((A<=2 * (A<=4 * R<1)) * (R<1/6 * [1]^2)) + (((A<=2 * (A<=3 * R<1)) * (R<1/6 * [1]^2)) + (((A<=0 * (A<=4 * R<1)) * (R<1/6 * [1]^2)) + (((A<=0 * (A<=2 * R<1)) * (R<1/6 * [1]^2)) + ((A<=0 * (A<=1 * R<1)) * (R<1/6 * [1]^2)))))))))))") text \We can do 12. I think 12 is a sharp bound; see PP's certificate.\ -lemma "2 <= (x::real) & x <= 4 & 2 <= y & y <= 4 & 2 <= z & z <= 4 --> 12 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)" +lemma "2 \ (x::real) \ x \ 4 \ 2 \ y \ y \ 4 \ 2 \ z \ z \ 4 \ + 12 \ 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)" by (sos "(((A<0 * R<1) + (((A<=4 * R<1) * (R<2/3 * [1]^2)) + (((A<=4 * (A<=5 * R<1)) * (R<1 * [1]^2)) + (((A<=3 * (A<=4 * R<1)) * (R<1/3 * [1]^2)) + (((A<=2 * R<1) * (R<2/3 * [1]^2)) + (((A<=2 * (A<=5 * R<1)) * (R<1/3 * [1]^2)) + (((A<=2 * (A<=4 * R<1)) * (R<8/3 * [1]^2)) + (((A<=2 * (A<=3 * R<1)) * (R<1 * [1]^2)) + (((A<=1 * (A<=4 * R<1)) * (R<1/3 * [1]^2)) + (((A<=1 * (A<=2 * R<1)) * (R<1/3 * [1]^2)) + (((A<=0 * R<1) * (R<2/3 * [1]^2)) + (((A<=0 * (A<=5 * R<1)) * (R<1/3 * [1]^2)) + (((A<=0 * (A<=4 * R<1)) * (R<8/3 * [1]^2)) + (((A<=0 * (A<=3 * R<1)) * (R<1/3 * [1]^2)) + (((A<=0 * (A<=2 * R<1)) * (R<8/3 * [1]^2)) + ((A<=0 * (A<=1 * R<1)) * (R<1 * [1]^2))))))))))))))))))") text \Inequality from sci.math (see "Leon-Sotelo, por favor").\ -lemma "0 <= (x::real) & 0 <= y & (x * y = 1) --> x + y <= x^2 + y^2" +lemma "0 \ (x::real) \ 0 \ y \ x * y = 1 \ x + y \ x\<^sup>2 + y\<^sup>2" by (sos "(((A<0 * R<1) + (([1] * A=0) + (R<1 * ((R<1 * [~1/2*x + ~1/2*y + 1]^2) + (R<3/4 * [~1*x + y]^2))))))") -lemma "0 <= (x::real) & 0 <= y & (x * y = 1) --> x * y * (x + y) <= x^2 + y^2" +lemma "0 \ (x::real) \ 0 \ y \ x * y = 1 \ x * y * (x + y) \ x\<^sup>2 + y\<^sup>2" by (sos "(((A<0 * R<1) + (([~1*x + ~1*y + 1] * A=0) + (R<1 * ((R<1 * [~1/2*x + ~1/2*y + 1]^2) + (R<3/4 * [~1*x + y]^2))))))") -lemma "0 <= (x::real) & 0 <= y --> x * y * (x + y)^2 <= (x^2 + y^2)^2" +lemma "0 \ (x::real) \ 0 \ y \ x * y * (x + y)\<^sup>2 \ (x\<^sup>2 + y\<^sup>2)\<^sup>2" by (sos "(((A<0 * R<1) + (R<1 * ((R<1 * [~1/2*x^2 + y^2 + ~1/2*x*y]^2) + (R<3/4 * [~1*x^2 + x*y]^2)))))") -lemma "(0::real) <= a & 0 <= b & 0 <= c & c * (2 * a + b)^3/ 27 <= x \ c * a^2 * b <= x" +lemma "(0::real) \ a \ 0 \ b \ 0 \ c \ c * (2 * a + b)^3 / 27 \ x \ c * a\<^sup>2 * b \ x" by (sos "(((A<0 * R<1) + (((A<=3 * R<1) * (R<1 * [1]^2)) + (((A<=1 * (A<=2 * R<1)) * (R<1/27 * [~1*a + b]^2)) + ((A<=0 * (A<=2 * R<1)) * (R<8/27 * [~1*a + b]^2))))))") -lemma "(0::real) < x --> 0 < 1 + x + x^2" +lemma "(0::real) < x \ 0 < 1 + x + x\<^sup>2" by (sos "((R<1 + ((R<1 * (R<1 * [x]^2)) + (((A<0 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2))))))") -lemma "(0::real) <= x --> 0 < 1 + x + x^2" +lemma "(0::real) \ x \ 0 < 1 + x + x\<^sup>2" by (sos "((R<1 + ((R<1 * (R<1 * [x]^2)) + (((A<=1 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2))))))") -lemma "(0::real) < 1 + x^2" +lemma "(0::real) < 1 + x\<^sup>2" by (sos "((R<1 + ((R<1 * (R<1 * [x]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2)))))") -lemma "(0::real) <= 1 + 2 * x + x^2" +lemma "(0::real) \ 1 + 2 * x + x\<^sup>2" by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [x + 1]^2))))") -lemma "(0::real) < 1 + abs x" +lemma "(0::real) < 1 + \x\" by (sos "((R<1 + (((A<=1 * R<1) * (R<1/2 * [1]^2)) + ((A<=0 * R<1) * (R<1/2 * [1]^2)))))") -lemma "(0::real) < 1 + (1 + x)^2 * (abs x)" +lemma "(0::real) < 1 + (1 + x)\<^sup>2 * \x\" by (sos "(((R<1 + (((A<=1 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [x + 1]^2))))) & ((R<1 + (((A<0 * R<1) * (R<1 * [x + 1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2))))))") -lemma "abs ((1::real) + x^2) = (1::real) + x^2" +lemma "\(1::real) + x\<^sup>2\ = (1::real) + x\<^sup>2" by (sos "(() & (((R<1 + ((R<1 * (R<1 * [x]^2)) + ((A<1 * R<1) * (R<1/2 * [1]^2))))) & ((R<1 + ((R<1 * (R<1 * [x]^2)) + ((A<0 * R<1) * (R<1 * [1]^2)))))))") + lemma "(3::real) * x + 7 * a < 4 \ 3 < 2 * x \ a < 0" by (sos "((R<1 + (((A<1 * R<1) * (R<2 * [1]^2)) + (((A<0 * R<1) * (R<3 * [1]^2)) + ((A<=0 * R<1) * (R<14 * [1]^2))))))") -lemma "(0::real) < x --> 1 < y --> y * x <= z --> x < z" +lemma "(0::real) < x \ 1 < y \ y * x \ z \ x < z" by (sos "((((A<0 * A<1) * R<1) + (((A<=1 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2)))))") -lemma "(1::real) < x --> x^2 < y --> 1 < y" + +lemma "(1::real) < x \ x\<^sup>2 < y \ 1 < y" by (sos "((((A<0 * A<1) * R<1) + ((R<1 * ((R<1/10 * [~2*x + y + 1]^2) + (R<1/10 * [~1*x + y]^2))) + (((A<1 * R<1) * (R<1/2 * [1]^2)) + (((A<0 * R<1) * (R<1 * [x]^2)) + (((A<=0 * R<1) * ((R<1/10 * [x + 1]^2) + (R<1/10 * [x]^2))) + (((A<=0 * (A<1 * R<1)) * (R<1/5 * [1]^2)) + ((A<=0 * (A<0 * R<1)) * (R<1/5 * [1]^2)))))))))") -lemma "(b::real)^2 < 4 * a * c --> ~(a * x^2 + b * x + c = 0)" + +lemma "(b::real)\<^sup>2 < 4 * a * c \ a * x\<^sup>2 + b * x + c \ 0" by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [2*a*x + b]^2))))") -lemma "(b::real)^2 < 4 * a * c --> ~(a * x^2 + b * x + c = 0)" + +lemma "(b::real)\<^sup>2 < 4 * a * c \ a * x^2 + b * x + c \ 0" by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [2*a*x + b]^2))))") -lemma "((a::real) * x^2 + b * x + c = 0) --> b^2 >= 4 * a * c" + +lemma "(a::real) * x\<^sup>2 + b * x + c = 0 \ b\<^sup>2 \ 4 * a * c" by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [2*a*x + b]^2))))") -lemma "(0::real) <= b & 0 <= c & 0 <= x & 0 <= y & (x^2 = c) & (y^2 = a^2 * c + b) --> a * c <= y * x" + +lemma "(0::real) \ b \ 0 \ c \ 0 \ x \ 0 \ y \ x\<^sup>2 = c \ y\<^sup>2 = a\<^sup>2 * c + b \ a * c \ y * x" by (sos "(((A<0 * (A<0 * R<1)) + (((A<=2 * (A<=3 * (A<0 * R<1))) * (R<2 * [1]^2)) + ((A<=0 * (A<=1 * R<1)) * (R<1 * [1]^2)))))") -lemma "abs(x - z) <= e & abs(y - z) <= e & 0 <= u & 0 <= v & (u + v = 1) --> abs((u * x + v * y) - z) <= (e::real)" + +lemma "\x - z\ \ e \ \y - z\ \ e \ 0 \ u \ 0 \ v \ u + v = 1 \ \(u * x + v * y) - z\ \ (e::real)" by (sos "((((A<0 * R<1) + (((A<=3 * (A<=6 * R<1)) * (R<1 * [1]^2)) + ((A<=1 * (A<=5 * R<1)) * (R<1 * [1]^2))))) & ((((A<0 * A<1) * R<1) + (((A<=3 * (A<=5 * (A<0 * R<1))) * (R<1 * [1]^2)) + ((A<=1 * (A<=4 * (A<0 * R<1))) * (R<1 * [1]^2))))))") -(* lemma "((x::real) - y - 2 * x^4 = 0) & 0 <= x & x <= 2 & 0 <= y & y <= 3 --> y^2 - 7 * y - 12 * x + 17 >= 0" by sos *) (* Too hard?*) +lemma "(x::real) - y - 2 * x^4 = 0 \ 0 \ x \ x \ 2 \ 0 \ y \ y \ 3 \ y\<^sup>2 - 7 * y - 12 * x + 17 \ 0" + oops (*Too hard?*) -lemma "(0::real) <= x --> (1 + x + x^2)/(1 + x^2) <= 1 + x" +lemma "(0::real) \ x \ (1 + x + x\<^sup>2) / (1 + x\<^sup>2) \ 1 + x" by (sos "(((((A<0 * A<1) * R<1) + ((A<=0 * (A<0 * R<1)) * (R<1 * [x]^2)))) & ((R<1 + ((R<1 * (R<1 * [x]^2)) + ((A<0 * R<1) * (R<1 * [1]^2))))))") -lemma "(0::real) <= x --> 1 - x <= 1 / (1 + x + x^2)" +lemma "(0::real) \ x \ 1 - x \ 1 / (1 + x + x\<^sup>2)" by (sos "(((R<1 + (([~4/3] * A=0) + ((R<1 * ((R<1/3 * [3/2*x + 1]^2) + (R<7/12 * [x]^2))) + ((A<=0 * R<1) * (R<1/3 * [1]^2)))))) & (((((A<0 * A<1) * R<1) + ((A<=0 * (A<0 * R<1)) * (R<1 * [x]^2)))) & ((R<1 + ((R<1 * (R<1 * [x]^2)) + (((A<0 * R<1) * (R<1 * [1]^2)) + ((A<=0 * R<1) * (R<1 * [1]^2))))))))") -lemma "(x::real) <= 1 / 2 --> - x - 2 * x^2 <= - x / (1 - x)" +lemma "(x::real) \ 1 / 2 \ - x - 2 * x\<^sup>2 \ - x / (1 - x)" by (sos "((((A<0 * A<1) * R<1) + ((A<=0 * (A<0 * R<1)) * (R<1 * [x]^2))))") -lemma "4*r^2 = p^2 - 4*q & r >= (0::real) & x^2 + p*x + q = 0 --> 2*(x::real) = - p + 2*r | 2*x = -p - 2*r" +lemma "4 * r\<^sup>2 = p\<^sup>2 - 4 * q \ r \ (0::real) \ x\<^sup>2 + p * x + q = 0 \ 2 * (x::real) = - p + 2 * r \ 2 * x = - p - 2 * r" by (sos "((((((A<0 * A<1) * R<1) + ([~4] * A=0))) & ((((A<0 * A<1) * R<1) + ([4] * A=0)))) & (((((A<0 * A<1) * R<1) + ([4] * A=0))) & ((((A<0 * A<1) * R<1) + ([~4] * A=0)))))") end - diff -r 2bd401e364f9 -r 5977962f8e66 src/HOL/ex/Tree23.thy --- a/src/HOL/ex/Tree23.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/HOL/ex/Tree23.thy Fri Sep 18 16:42:19 2015 +0100 @@ -377,7 +377,7 @@ done } note B = this show "full (Suc n) t \ dfull n (del k t)" - proof (induct k t arbitrary: n rule: del.induct, goals) + proof (induct k t arbitrary: n rule: del.induct, goal_cases) case (1 k n) thus "dfull n (del (Some k) Empty)" by simp next diff -r 2bd401e364f9 -r 5977962f8e66 src/Provers/Arith/cancel_numeral_factor.ML --- a/src/Provers/Arith/cancel_numeral_factor.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Provers/Arith/cancel_numeral_factor.ML Fri Sep 18 16:42:19 2015 +0100 @@ -37,16 +37,14 @@ functor CancelNumeralFactorFun(Data: CANCEL_NUMERAL_FACTOR_DATA): - sig - val proc: Proof.context -> term -> thm option - end -= + sig val proc: Proof.context -> cterm -> thm option end = struct (*the simplification procedure*) -fun proc ctxt t = +fun proc ctxt ct = let val prems = Simplifier.prems_of ctxt; + val t = Thm.term_of ct; val ([t'], ctxt') = Variable.import_terms true [t] ctxt val export = singleton (Variable.export ctxt' ctxt) (* FIXME ctxt vs. ctxt' *) diff -r 2bd401e364f9 -r 5977962f8e66 src/Provers/Arith/cancel_numerals.ML --- a/src/Provers/Arith/cancel_numerals.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Provers/Arith/cancel_numerals.ML Fri Sep 18 16:42:19 2015 +0100 @@ -44,7 +44,7 @@ signature CANCEL_NUMERALS = sig - val proc: Proof.context -> term -> thm option + val proc: Proof.context -> cterm -> thm option end; functor CancelNumeralsFun(Data: CANCEL_NUMERALS_DATA): CANCEL_NUMERALS = @@ -65,9 +65,10 @@ in seek terms1 end; (*the simplification procedure*) -fun proc ctxt t = +fun proc ctxt ct = let val prems = Simplifier.prems_of ctxt + val t = Thm.term_of ct val ([t'], ctxt') = Variable.import_terms true [t] ctxt val export = singleton (Variable.export ctxt' ctxt) (* FIXME ctxt vs. ctxt' (!?) *) diff -r 2bd401e364f9 -r 5977962f8e66 src/Provers/Arith/combine_numerals.ML --- a/src/Provers/Arith/combine_numerals.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Provers/Arith/combine_numerals.ML Fri Sep 18 16:42:19 2015 +0100 @@ -38,7 +38,7 @@ functor CombineNumeralsFun(Data: COMBINE_NUMERALS_DATA): sig - val proc: Proof.context -> term -> thm option + val proc: Proof.context -> cterm -> thm option end = struct @@ -65,8 +65,9 @@ | NONE => find_repeated (tab, t::past, terms); (*the simplification procedure*) -fun proc ctxt t = +fun proc ctxt ct = let + val t = Thm.term_of ct val ([t'], ctxt') = Variable.import_terms true [t] ctxt val export = singleton (Variable.export ctxt' ctxt) (* FIXME ctxt vs. ctxt' (!?) *) diff -r 2bd401e364f9 -r 5977962f8e66 src/Provers/Arith/fast_lin_arith.ML --- a/src/Provers/Arith/fast_lin_arith.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Provers/Arith/fast_lin_arith.ML Fri Sep 18 16:42:19 2015 +0100 @@ -87,7 +87,7 @@ sig val prems_lin_arith_tac: Proof.context -> int -> tactic val lin_arith_tac: Proof.context -> int -> tactic - val lin_arith_simproc: Proof.context -> term -> thm option + val lin_arith_simproc: Proof.context -> cterm -> thm option val map_data: ({add_mono_thms: thm list, mult_mono_thms: thm list, inj_thms: thm list, lessD: thm list, neqE: thm list, simpset: simpset, @@ -775,7 +775,7 @@ let val thms = maps LA_Logic.atomize (Simplifier.prems_of ctxt) val Hs = map Thm.prop_of thms - val Tconcl = LA_Logic.mk_Trueprop concl + val Tconcl = LA_Logic.mk_Trueprop (Thm.term_of concl) in case prove ctxt [] false Hs Tconcl of (* concl provable? *) (split_neq, SOME js) => prover ctxt thms Tconcl js split_neq true diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/Concurrent/time_limit.ML --- a/src/Pure/Concurrent/time_limit.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/Concurrent/time_limit.ML Fri Sep 18 16:42:19 2015 +0100 @@ -36,4 +36,3 @@ end); end; - diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/General/graphics_file.scala --- a/src/Pure/General/graphics_file.scala Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/General/graphics_file.scala Fri Sep 18 16:42:19 2015 +0100 @@ -15,6 +15,8 @@ import org.jfree.chart.JFreeChart +import com.lowagie.text.pdf.{PdfWriter, BaseFont, FontMapper, DefaultFontMapper} + object Graphics_File { @@ -39,10 +41,24 @@ /* PDF */ - def write_pdf(file: JFile, paint: Graphics2D => Unit, width: Int, height: Int) + private def font_mapper(): FontMapper = + { + val mapper = new DefaultFontMapper + for { + font <- Path.split(Isabelle_System.getenv_strict("ISABELLE_FONTS")) + name <- Library.try_unsuffix(".ttf", font.base.implode) + } { + val parameters = new DefaultFontMapper.BaseFontParameters(File.platform_path(font)) + parameters.encoding = BaseFont.IDENTITY_H + mapper.putName(name, parameters) + } + mapper + } + + def write_pdf( + file: JFile, paint: Graphics2D => Unit, width: Int, height: Int) { import com.lowagie.text.{Document, Rectangle} - import com.lowagie.text.pdf.PdfWriter val out = new BufferedOutputStream(new FileOutputStream(file)) try { @@ -54,7 +70,7 @@ val cb = writer.getDirectContent() val tp = cb.createTemplate(width, height) - val gfx = tp.createGraphics(width, height) + val gfx = tp.createGraphics(width, height, font_mapper()) paint(gfx) gfx.dispose @@ -78,4 +94,3 @@ def write_pdf(path: Path, chart: JFreeChart, width: Int, height: Int): Unit = write_pdf(path.file, chart, width, height) } - diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/General/symbol.scala --- a/src/Pure/General/symbol.scala Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/General/symbol.scala Fri Sep 18 16:42:19 2015 +0100 @@ -289,7 +289,7 @@ props match { case Nil => Nil case _ :: Nil => err() - case Key(x) :: y :: rest => (x -> y) :: read_props(rest) + case Key(x) :: y :: rest => (x -> y.replace('\u2423', ' ')) :: read_props(rest) case _ => err() } } diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/Isar/isar_cmd.ML --- a/src/Pure/Isar/isar_cmd.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/Isar/isar_cmd.ML Fri Sep 18 16:42:19 2015 +0100 @@ -168,8 +168,9 @@ ML_Lex.read_source false source |> ML_Context.expression (Input.range_of source) "proc" "Morphism.morphism -> Proof.context -> cterm -> thm option" - ("Context.map_proof (Simplifier.def_simproc_cmd {name = " ^ ML_Syntax.make_binding name ^ ", \ - \lhss = " ^ ML_Syntax.print_strings lhss ^ ", proc = proc, \ + ("Context.map_proof (Simplifier.define_simproc_cmd " ^ + ML_Syntax.atomic (ML_Syntax.make_binding name) ^ + "{lhss = " ^ ML_Syntax.print_strings lhss ^ ", proc = proc, \ \identifier = Library.maps ML_Context.thms " ^ ML_Syntax.print_strings identifier ^ "})") |> Context.proof_map; diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/Isar/local_theory.ML --- a/src/Pure/Isar/local_theory.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/Isar/local_theory.ML Fri Sep 18 16:42:19 2015 +0100 @@ -368,10 +368,11 @@ fun init_target background_naming operations after_close lthy = let val _ = assert lthy; + val after_close' = Proof_Context.restore_naming lthy #> after_close; val (scope, target) = Proof_Context.new_scope lthy; val lthy' = target - |> Data.map (cons (make_lthy (background_naming, operations, after_close, true, target))); + |> Data.map (cons (make_lthy (background_naming, operations, after_close', true, target))); in (scope, lthy') end; fun open_target lthy = diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/Isar/method.ML --- a/src/Pure/Isar/method.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/Isar/method.ML Fri Sep 18 16:42:19 2015 +0100 @@ -17,7 +17,7 @@ val SIMPLE_METHOD: tactic -> method val SIMPLE_METHOD': (int -> tactic) -> method val SIMPLE_METHOD'': ((int -> tactic) -> tactic) -> (int -> tactic) -> method - val goals_tac: Proof.context -> string list -> cases_tactic + val goal_cases_tac: Proof.context -> string list -> cases_tactic val cheating: Proof.context -> bool -> method val intro: Proof.context -> thm list -> method val elim: Proof.context -> thm list -> method @@ -130,7 +130,7 @@ (* goals as cases *) -fun goals_tac ctxt case_names st = +fun goal_cases_tac ctxt case_names st = let val cases = (if null case_names then map string_of_int (1 upto Thm.nprems_of st) else case_names) @@ -693,21 +693,20 @@ "succeed after delay (in seconds)" #> setup @{binding "-"} (Scan.succeed (K insert_facts)) "insert current facts, nothing else" #> - setup @{binding goals} (Scan.lift (Scan.repeat Args.name_token) >> (fn names => fn ctxt => - METHOD_CASES (fn facts => - Seq.THEN (ALLGOALS (insert_tac facts), fn st => - let - val _ = - (case drop (Thm.nprems_of st) names of - [] => () - | bad => - if detect_closure_state st then () - else - (* FIXME Seq.Error *) - error ("Excessive case names: " ^ commas_quote (map Token.content_of bad) ^ - Position.here (Position.set_range (Token.range_of bad)))); - in goals_tac ctxt (map Token.content_of names) st end)))) - "insert facts and bind cases for goals" #> + setup @{binding goal_cases} (Scan.lift (Scan.repeat Args.name_token) >> (fn names => fn ctxt => + METHOD_CASES (fn facts => fn st => + let + val _ = + (case drop (Thm.nprems_of st) names of + [] => () + | bad => + if detect_closure_state st then () + else + (* FIXME Seq.Error *) + error ("Excessive case names: " ^ commas_quote (map Token.content_of bad) ^ + Position.here (Position.set_range (Token.range_of bad)))); + in goal_cases_tac ctxt (map Token.content_of names) st end))) + "bind cases for goals" #> setup @{binding insert} (Attrib.thms >> (K o insert)) "insert theorems, ignoring facts" #> setup @{binding intro} (Attrib.thms >> (fn ths => fn ctxt => intro ctxt ths)) diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/Isar/proof.ML --- a/src/Pure/Isar/proof.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/Isar/proof.ML Fri Sep 18 16:42:19 2015 +0100 @@ -1083,8 +1083,9 @@ val goal_ctxt = ctxt |> (fold o fold) Variable.auto_fixes propss |> fold Variable.bind_term binds; - fun after_qed' (result_ctxt, results) ctxt' = - after_qed (burrow (Proof_Context.export result_ctxt ctxt') results) ctxt'; + fun after_qed' (result_ctxt, results) ctxt' = ctxt' + |> Proof_Context.restore_naming ctxt + |> after_qed (burrow (Proof_Context.export result_ctxt ctxt') results); in ctxt |> init diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/Isar/proof_context.ML --- a/src/Pure/Isar/proof_context.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/Isar/proof_context.ML Fri Sep 18 16:42:19 2015 +0100 @@ -1249,7 +1249,7 @@ val _ = if legacy then legacy_feature ("Bad case " ^ quote name ^ Position.here pos ^ - " -- use proof method \"goals\" instead") + " -- use proof method \"goal_cases\" instead") else (); val _ = List.app (fn NONE => () | SOME b => ignore (check_var internal b)) param_specs; diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/ML-Systems/windows_path.ML --- a/src/Pure/ML-Systems/windows_path.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/ML-Systems/windows_path.ML Fri Sep 18 16:42:19 2015 +0100 @@ -13,11 +13,10 @@ (case Char.fromString drive of NONE => drive ^ ":" | SOME d => String.str (Char.toUpper d) ^ ":"); - in OS.Path.toString {vol = vol, arcs = arcs, isAbs = true} end + in String.concatWith "\\" (vol :: arcs) end | arcs => (case OS.Process.getEnv "CYGWIN_ROOT" of - SOME root => - OS.Path.concat (root, OS.Path.toString {vol = "", arcs = arcs, isAbs = false}) + SOME root => OS.Path.concat (root, String.concatWith "\\" arcs) | NONE => raise Fail "Unknown environment variable CYGWIN_ROOT")) else String.translate (fn #"/" => "\\" | c => String.str c) path; diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/ML/exn_properties_polyml.ML --- a/src/Pure/ML/exn_properties_polyml.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/ML/exn_properties_polyml.ML Fri Sep 18 16:42:19 2015 +0100 @@ -21,7 +21,7 @@ [] => [] | [XML.Text file] => if file = "Standard Basis" then [] - else [(Markup.fileN, file)] + else [(Markup.fileN, ml_standard_path file)] | body => XML.Decode.properties body); fun position_of loc = diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/ML/ml_antiquotations.ML --- a/src/Pure/ML/ml_antiquotations.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/ML/ml_antiquotations.ML Fri Sep 18 16:42:19 2015 +0100 @@ -77,12 +77,7 @@ "Thm.cterm_of ML_context " ^ ML_Syntax.atomic (ML_Syntax.print_term t))) #> ML_Antiquotation.value @{binding cprop} (Args.prop >> (fn t => - "Thm.cterm_of ML_context " ^ ML_Syntax.atomic (ML_Syntax.print_term t))) #> - - ML_Antiquotation.value @{binding cpat} - (Args.context -- - Scan.lift Args.name_inner_syntax >> uncurry Proof_Context.read_term_pattern >> (fn t => - "Thm.cterm_of ML_context " ^ ML_Syntax.atomic (ML_Syntax.print_term t)))); + "Thm.cterm_of ML_context " ^ ML_Syntax.atomic (ML_Syntax.print_term t)))); (* type classes *) diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/Tools/doc.scala --- a/src/Pure/Tools/doc.scala Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/Tools/doc.scala Fri Sep 18 16:42:19 2015 +0100 @@ -58,19 +58,24 @@ }) def contents(): List[Entry] = - (for { - (dir, line) <- contents_lines() - entry <- - line match { - case Section_Entry(text) => - Library.try_unsuffix("!", text) match { - case None => Some(Section(text, false)) - case Some(txt) => Some(Section(txt, true)) - } - case Doc_Entry(name, title) => Some(Doc(name, title, dir + Path.basic(name))) - case _ => None - } - } yield entry) ::: release_notes() ::: examples() + { + val main_contents = + for { + (dir, line) <- contents_lines() + entry <- + line match { + case Section_Entry(text) => + Library.try_unsuffix("!", text) match { + case None => Some(Section(text, false)) + case Some(txt) => Some(Section(txt, true)) + } + case Doc_Entry(name, title) => Some(Doc(name, title, dir + Path.basic(name))) + case _ => None + } + } yield entry + + examples() ::: release_notes() ::: main_contents + } /* view */ @@ -104,4 +109,3 @@ } } } - diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/Tools/main.scala --- a/src/Pure/Tools/main.scala Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/Tools/main.scala Fri Sep 18 16:42:19 2015 +0100 @@ -29,7 +29,7 @@ system_dialog.join_exit } - def build + def build() { try { GUI.init_laf() @@ -74,7 +74,7 @@ catch { case exn: Throwable => exit_error(exn) } } - def start + def start() { val do_start = { @@ -161,9 +161,9 @@ } } - build + build() val rc = system_dialog.join - if (rc == 0) start else sys.exit(rc) + if (rc == 0) start() else sys.exit(rc) } diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/pure_thy.ML --- a/src/Pure/pure_thy.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/pure_thy.ML Fri Sep 18 16:42:19 2015 +0100 @@ -176,11 +176,6 @@ #> Sign.add_syntax (Symbol.xsymbolsN, true) [(tycon "fun", typ "type => type => type", Mixfix ("(_/ \\ _)", [1, 0], 0)), ("_bracket", typ "types => type => type", Mixfix ("([_]/ \\ _)", [0, 0], 0)), - ("_ofsort", typ "tid_position => sort => type", Mixfix ("_\\_", [1000, 0], 1000)), - ("_constrain", typ "logic => type => logic", Mixfix ("_\\_", [4, 0], 3)), - ("_constrain", typ "prop' => type => prop'", Mixfix ("_\\_", [4, 0], 3)), - ("_idtyp", typ "id_position => type => idt", Mixfix ("_\\_", [], 0)), - ("_idtypdummy", typ "type => idt", Mixfix ("'_()\\_", [], 0)), ("_lambda", typ "pttrns => 'a => logic", Mixfix ("(3\\_./ _)", [0, 3], 3)), (const "Pure.eq", typ "'a => 'a => prop", Infix ("\\", 2)), (const "Pure.all_binder", typ "idts => prop => prop", Mixfix ("(3\\_./ _)", [0, 0], 0)), diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/raw_simplifier.ML --- a/src/Pure/raw_simplifier.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/raw_simplifier.ML Fri Sep 18 16:42:19 2015 +0100 @@ -35,10 +35,10 @@ safe_solvers: string list} type simproc val eq_simproc: simproc * simproc -> bool + val cert_simproc: theory -> string -> + {lhss: term list, proc: morphism -> Proof.context -> cterm -> thm option, identifier: thm list} + -> simproc val transform_simproc: morphism -> simproc -> simproc - val make_simproc: {name: string, lhss: cterm list, - proc: morphism -> Proof.context -> cterm -> thm option, identifier: thm list} -> simproc - val mk_simproc: string -> cterm list -> (Proof.context -> term -> thm option) -> simproc val simpset_of: Proof.context -> simpset val put_simpset: simpset -> Proof.context -> Proof.context val simpset_map: Proof.context -> (Proof.context -> Proof.context) -> simpset -> simpset @@ -105,10 +105,6 @@ val solver: Proof.context -> solver -> int -> tactic val simp_depth_limit_raw: Config.raw val default_mk_sym: Proof.context -> thm -> thm option - val simproc_global_i: theory -> string -> term list -> - (Proof.context -> term -> thm option) -> simproc - val simproc_global: theory -> string -> string list -> - (Proof.context -> term -> thm option) -> simproc val simp_trace_depth_limit_raw: Config.raw val simp_trace_raw: Config.raw val simp_debug_raw: Config.raw @@ -675,6 +671,10 @@ fun eq_simproc (Simproc {id = id1, ...}, Simproc {id = id2, ...}) = eq_procid (id1, id2); +fun cert_simproc thy name {lhss, proc, identifier} = + Simproc {name = name, lhss = map (Sign.cert_term thy) lhss, proc = proc, + id = (stamp (), map Thm.trim_context identifier)}; + fun transform_simproc phi (Simproc {name, lhss, proc, id = (s, ths)}) = Simproc {name = name, @@ -682,19 +682,6 @@ proc = Morphism.transform phi proc, id = (s, Morphism.fact phi ths)}; -fun make_simproc {name, lhss, proc, identifier} = - Simproc {name = name, lhss = map Thm.term_of lhss, proc = proc, - id = (stamp (), map Thm.trim_context identifier)}; - -fun mk_simproc name lhss proc = - make_simproc {name = name, lhss = lhss, proc = fn _ => fn ctxt => fn ct => - proc ctxt (Thm.term_of ct), identifier = []}; - -(* FIXME avoid global thy and Logic.varify_global *) -fun simproc_global_i thy name = mk_simproc name o map (Thm.global_cterm_of thy o Logic.varify_global); -fun simproc_global thy name = simproc_global_i thy name o map (Syntax.read_term_global thy); - - local fun add_proc (proc as Proc {name, lhs, ...}) ctxt = diff -r 2bd401e364f9 -r 5977962f8e66 src/Pure/simplifier.ML --- a/src/Pure/simplifier.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Pure/simplifier.ML Fri Sep 18 16:42:19 2015 +0100 @@ -36,12 +36,11 @@ val cong_del: attribute val check_simproc: Proof.context -> xstring * Position.T -> string val the_simproc: Proof.context -> string -> simproc - val def_simproc: {name: binding, lhss: term list, - proc: morphism -> Proof.context -> cterm -> thm option, identifier: thm list} -> - local_theory -> local_theory - val def_simproc_cmd: {name: binding, lhss: string list, - proc: morphism -> Proof.context -> cterm -> thm option, identifier: thm list} -> - local_theory -> local_theory + type 'a simproc_spec = + {lhss: 'a list, proc: morphism -> Proof.context -> cterm -> thm option, identifier: thm list} + val make_simproc: Proof.context -> string -> term simproc_spec -> simproc + val define_simproc: binding -> term simproc_spec -> local_theory -> local_theory + val define_simproc_cmd: binding -> string simproc_spec -> local_theory -> local_theory val pretty_simpset: bool -> Proof.context -> Pretty.T val default_mk_sym: Proof.context -> thm -> thm option val prems_of: Proof.context -> thm list @@ -61,10 +60,6 @@ val set_subgoaler: (Proof.context -> int -> tactic) -> Proof.context -> Proof.context type trace_ops val set_trace_ops: trace_ops -> theory -> theory - val simproc_global_i: theory -> string -> term list -> - (Proof.context -> term -> thm option) -> simproc - val simproc_global: theory -> string -> string list -> - (Proof.context -> term -> thm option) -> simproc val rewrite: Proof.context -> conv val asm_rewrite: Proof.context -> conv val full_rewrite: Proof.context -> conv @@ -122,21 +117,27 @@ (* define simprocs *) +type 'a simproc_spec = + {lhss: 'a list, proc: morphism -> Proof.context -> cterm -> thm option, identifier: thm list}; + +fun make_simproc ctxt name {lhss, proc, identifier} = + let + val ctxt' = fold Variable.auto_fixes lhss ctxt; + val lhss' = Variable.export_terms ctxt' ctxt lhss; + in + cert_simproc (Proof_Context.theory_of ctxt) name + {lhss = lhss', proc = proc, identifier = identifier} + end; + local -fun gen_simproc prep {name = b, lhss, proc, identifier} lthy = +fun def_simproc prep b {lhss, proc, identifier} lthy = let - val simproc = make_simproc - {name = Local_Theory.full_name lthy b, - lhss = - let - val lhss' = prep lthy lhss; - val ctxt' = fold Variable.auto_fixes lhss' lthy; - in Variable.export_terms ctxt' lthy lhss' end |> map (Thm.cterm_of lthy), - proc = proc, - identifier = identifier}; + val simproc = + make_simproc lthy (Local_Theory.full_name lthy b) + {lhss = prep lthy lhss, proc = proc, identifier = identifier}; in - lthy |> Local_Theory.declaration {syntax = false, pervasive = true} (fn phi => fn context => + lthy |> Local_Theory.declaration {syntax = false, pervasive = false} (fn phi => fn context => let val b' = Morphism.binding phi b; val simproc' = transform_simproc phi simproc; @@ -149,8 +150,8 @@ in -val def_simproc = gen_simproc Syntax.check_terms; -val def_simproc_cmd = gen_simproc Syntax.read_terms; +val define_simproc = def_simproc Syntax.check_terms; +val define_simproc_cmd = def_simproc Syntax.read_terms; end; diff -r 2bd401e364f9 -r 5977962f8e66 src/Tools/Code/code_ml.ML --- a/src/Tools/Code/code_ml.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Tools/Code/code_ml.ML Fri Sep 18 16:42:19 2015 +0100 @@ -454,8 +454,7 @@ [str "let", p, str "=", print_term is_pseudo_fun some_thm vars NOBR t, str "in"]) val (ps, vars') = fold_map print_let binds vars; in - brackify_block fxy (Pretty.chunks ps) [] - (print_term is_pseudo_fun some_thm vars' NOBR body) + brackets [Pretty.chunks ps, print_term is_pseudo_fun some_thm vars' NOBR body] end | print_case is_pseudo_fun some_thm vars fxy { term = t, typ = ty, clauses = clause :: clauses, ... } = let diff -r 2bd401e364f9 -r 5977962f8e66 src/Tools/Code/code_scala.ML --- a/src/Tools/Code/code_scala.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Tools/Code/code_scala.ML Fri Sep 18 16:42:19 2015 +0100 @@ -63,15 +63,13 @@ (print_term tyvars is_pat some_thm vars BR t1) [t2]) | print_term tyvars is_pat some_thm vars fxy (IVar v) = print_var vars v - | print_term tyvars is_pat some_thm vars fxy ((v, ty) `|=> t) = + | print_term tyvars is_pat some_thm vars fxy (t as _ `|=> _) = let - val vars' = intro_vars (the_list v) vars; + val (vs_tys, body) = Code_Thingol.unfold_abs t; + val (ps, vars') = fold_map (print_abs_head tyvars) vs_tys vars; + val vars' = intro_vars (map_filter fst vs_tys) vars; in - concat [ - enclose "(" ")" [constraint (print_var vars' v) (print_typ tyvars NOBR ty)], - str "=>", - print_term tyvars false some_thm vars' NOBR t - ] + brackets (ps @| print_term tyvars false some_thm vars' NOBR body) end | print_term tyvars is_pat some_thm vars fxy (ICase case_expr) = (case Code_Thingol.unfold_const_app (#primitive case_expr) @@ -80,6 +78,15 @@ then print_case tyvars some_thm vars fxy case_expr else print_app tyvars is_pat some_thm vars fxy app | NONE => print_case tyvars some_thm vars fxy case_expr) + and print_abs_head tyvars (some_v, ty) vars = + let + val vars' = intro_vars (the_list some_v) vars; + in + (concat [ + enclose "(" ")" [constraint (print_var vars' some_v) (print_typ tyvars NOBR ty)], + str "=>" + ], vars') + end and print_app tyvars is_pat some_thm vars fxy (app as ({ sym, typargs, dom, ... }, ts)) = let diff -r 2bd401e364f9 -r 5977962f8e66 src/Tools/Graphview/graph_file.scala --- a/src/Tools/Graphview/graph_file.scala Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Tools/Graphview/graph_file.scala Fri Sep 18 16:42:19 2015 +0100 @@ -23,7 +23,7 @@ def paint(gfx: Graphics2D) { - gfx.setColor(Color.WHITE) + gfx.setColor(graphview.background_color) gfx.fillRect(0, 0, w, h) gfx.translate(- box.x, - box.y) graphview.paint(gfx) diff -r 2bd401e364f9 -r 5977962f8e66 src/Tools/Graphview/graph_panel.scala --- a/src/Tools/Graphview/graph_panel.scala Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Tools/Graphview/graph_panel.scala Fri Sep 18 16:42:19 2015 +0100 @@ -331,12 +331,22 @@ tooltip = "Regenerate graph layout according to built-in algorithm" } + private val editor_style = new CheckBox() { + selected = graphview.editor_style + action = Action("Editor style") { + graphview.editor_style = selected + graphview.update_layout() + refresh() + } + tooltip = "Use editor font and colors for painting" + } + private val colorations = new Button { action = Action("Colorations") { color_dialog.open } } private val filters = new Button { action = Action("Filters") { mutator_dialog.open } } private val controls = new Wrap_Panel(Wrap_Panel.Alignment.Right)(show_content, show_arrow_heads, show_dummies, - save_image, zoom, fit_window, update_layout) // FIXME colorations, filters + save_image, zoom, fit_window, update_layout, editor_style) // FIXME colorations, filters diff -r 2bd401e364f9 -r 5977962f8e66 src/Tools/Graphview/graphview.scala --- a/src/Tools/Graphview/graphview.scala Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Tools/Graphview/graphview.scala Fri Sep 18 16:42:19 2015 +0100 @@ -94,8 +94,8 @@ def foreground_color: Color = Color.BLACK def background_color: Color = Color.WHITE - def selection_color: Color = Color.GREEN - def highlight_color: Color = Color.YELLOW + def selection_color: Color = new Color(204, 204, 255) + def highlight_color: Color = new Color(255, 255, 224) def error_color: Color = Color.RED def dummy_color: Color = Color.GRAY @@ -116,6 +116,7 @@ var show_content = false var show_arrow_heads = false var show_dummies = false + var editor_style = false object Colors { diff -r 2bd401e364f9 -r 5977962f8e66 src/Tools/induct.ML --- a/src/Tools/induct.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Tools/induct.ML Fri Sep 18 16:42:19 2015 +0100 @@ -158,8 +158,10 @@ | SOME (i, k, j) => SOME (swap_params_conv ctxt k j (K (swap_prems_conv i)) ct)); val rearrange_eqs_simproc = - Simplifier.simproc_global Pure.thy "rearrange_eqs" ["Pure.all t"] - (fn ctxt => fn t => mk_swap_rrule ctxt (Thm.cterm_of ctxt t)); + Simplifier.make_simproc @{context} "rearrange_eqs" + {lhss = [@{term "Pure.all(t)"}], + proc = fn _ => fn ctxt => fn ct => mk_swap_rrule ctxt ct, + identifier = []}; (* rotate k premises to the left by j, skipping over first j premises *) diff -r 2bd401e364f9 -r 5977962f8e66 src/Tools/jEdit/etc/options --- a/src/Tools/jEdit/etc/options Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Tools/jEdit/etc/options Fri Sep 18 16:42:19 2015 +0100 @@ -9,7 +9,7 @@ public option jedit_auto_load : bool = false -- "load all required files automatically to resolve theory imports" -public option jedit_auto_resolve : bool = true +public option jedit_auto_resolve : bool = false -- "automatically resolve auxiliary files within the editor" public option jedit_reset_font_size : int = 18 diff -r 2bd401e364f9 -r 5977962f8e66 src/Tools/jEdit/etc/settings --- a/src/Tools/jEdit/etc/settings Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Tools/jEdit/etc/settings Fri Sep 18 16:42:19 2015 +0100 @@ -4,10 +4,10 @@ JEDIT_SETTINGS="$ISABELLE_HOME_USER/jedit" JEDIT_OPTIONS="-reuseview -noserver -nobackground -log=9" -#JEDIT_JAVA_OPTIONS="-Xms128m -Xmx512m -Xss1m" -JEDIT_JAVA_OPTIONS="-Xms128m -Xmx1024m -Xss4m" -#JEDIT_JAVA_OPTIONS="-Xms512m -Xmx4096m -Xss8m" -JEDIT_SYSTEM_OPTIONS="-Duser.language=en -Dawt.useSystemAAFontSettings=on -Dswing.aatext=true -Dapple.laf.useScreenMenuBar=true -Dapple.awt.application.name=Isabelle" + +JEDIT_JAVA_OPTIONS32="-Xms128m -Xmx1024m -Xss4m" +JEDIT_JAVA_OPTIONS64="-Xms512m -Xmx2560m -Xss8m" +JEDIT_JAVA_SYSTEM_OPTIONS="-Duser.language=en -Dawt.useSystemAAFontSettings=on -Dswing.aatext=true -Dapple.laf.useScreenMenuBar=true -Dapple.awt.application.name=Isabelle" ISABELLE_JEDIT_OPTIONS="" diff -r 2bd401e364f9 -r 5977962f8e66 src/Tools/jEdit/lib/Tools/jedit --- a/src/Tools/jEdit/lib/Tools/jedit Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Tools/jEdit/lib/Tools/jedit Fri Sep 18 16:42:19 2015 +0100 @@ -5,6 +5,18 @@ # DESCRIPTION: Isabelle/jEdit interface wrapper +## settings + +case "$ISABELLE_JAVA_PLATFORM" in + x86_64-*) + JEDIT_JAVA_OPTIONS="$JEDIT_JAVA_OPTIONS64" + ;; + *) + JEDIT_JAVA_OPTIONS="$JEDIT_JAVA_OPTIONS32" + ;; +esac + + ## sources declare -a SOURCES=( @@ -81,8 +93,7 @@ echo "Usage: isabelle $PRG [OPTIONS] [FILES ...]" echo echo " Options are:" - echo " -J OPTION add JVM runtime option" - echo " (default JEDIT_JAVA_OPTIONS=$JEDIT_JAVA_OPTIONS)" + echo " -J OPTION add JVM runtime option (default $JEDIT_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_OPTIONS)" echo " -b build only" echo " -d DIR include session directory" echo " -f fresh build" @@ -93,7 +104,7 @@ echo " -n no build of session image on startup" echo " -s system build mode for session image" echo - echo " Start jEdit with Isabelle plugin setup and open theory FILES" + echo " Start jEdit with Isabelle plugin setup and open FILES" echo " (default \"$USER_HOME/Scratch.thy\")." echo exit 1 @@ -170,7 +181,7 @@ done } -declare -a JAVA_ARGS; eval "JAVA_ARGS=($JEDIT_JAVA_OPTIONS $JEDIT_SYSTEM_OPTIONS)" +declare -a JAVA_ARGS; eval "JAVA_ARGS=($JEDIT_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_OPTIONS)" declare -a ARGS=() diff -r 2bd401e364f9 -r 5977962f8e66 src/Tools/jEdit/lib/Tools/jedit_client --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/Tools/jEdit/lib/Tools/jedit_client Fri Sep 18 16:42:19 2015 +0100 @@ -0,0 +1,115 @@ +#!/usr/bin/env bash +# +# Author: Makarius +# +# DESCRIPTION: Isabelle/jEdit client for already running application + +## settings + +SERVER_NAME="${ISABELLE_IDENTIFIER:-Isabelle}" + +case "$ISABELLE_JAVA_PLATFORM" in + x86_64-*) + JEDIT_JAVA_OPTIONS="$JEDIT_JAVA_OPTIONS64" + ;; + *) + JEDIT_JAVA_OPTIONS="$JEDIT_JAVA_OPTIONS32" + ;; +esac + +declare -a JAVA_ARGS; eval "JAVA_ARGS=($JEDIT_JAVA_SYSTEM_OPTIONS $JEDIT_JAVA_OPTIONS)" + + +## diagnostics + +PRG="$(basename "$0")" + +function usage() +{ + echo + echo "Usage: isabelle $PRG [OPTIONS] [FILES ...]" + echo + echo " Options are:" + echo " -c only check presence of server" + echo " -n only report server name" + echo " -s NAME server name (default $SERVER_NAME)" + echo + echo " Connect to already running Isabelle/jEdit instance and open FILES" + echo + exit 1 +} + +function fail() +{ + echo "$1" >&2 + exit 2 +} + +function failed() +{ + fail "Failed!" +} + + +## process command line + +# options + +CHECK_ONLY="false" +NAME_ONLY="false" + +while getopts "cns:" OPT +do + case "$OPT" in + c) + CHECK_ONLY="true" + ;; + n) + NAME_ONLY="true" + ;; + s) + SERVER_NAME="$OPTARG" + ;; + \?) + usage + ;; + esac +done + +shift $(($OPTIND - 1)) + + +# args + +declare -a ARGS=() + +while [ "$#" -gt 0 ] +do + ARGS["${#ARGS[@]}"]="$(jvmpath "$1")" + shift +done + + +## main + +if [ "$CHECK_ONLY" = true ] +then + [ -f "$JEDIT_SETTINGS/$SERVER_NAME" ] + exit $? +fi + +if [ "$NAME_ONLY" = true ] +then + echo "$SERVER_NAME" + exit +fi + +"$ISABELLE_TOOL" jedit -b || exit $? + +if [ -f "$JEDIT_SETTINGS/$SERVER_NAME" ] +then + exec "$ISABELLE_TOOL" java "${JAVA_ARGS[@]}" -jar "$JEDIT_HOME/dist/jedit.jar" \ + "-settings=$(jvmpath "$JEDIT_SETTINGS")" -server="$SERVER_NAME" -reuseview "${ARGS[@]}" +else + fail "Isabelle/jEdit server \"$SERVER_NAME\" not active" +fi diff -r 2bd401e364f9 -r 5977962f8e66 src/Tools/jEdit/src/graphview_dockable.scala --- a/src/Tools/jEdit/src/graphview_dockable.scala Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Tools/jEdit/src/graphview_dockable.scala Fri Sep 18 16:42:19 2015 +0100 @@ -76,14 +76,31 @@ } override def make_font(): Font = - GUI.imitate_font(Font_Info.main().font, - options.string("graphview_font_family"), - options.real("graphview_font_scale")) + if (editor_style) Font_Info.main(PIDE.options.real("graphview_font_scale")).font + else + GUI.imitate_font(Font_Info.main().font, + options.string("graphview_font_family"), + options.real("graphview_font_scale")) + + override def foreground_color = + if (editor_style) view.getTextArea.getPainter.getForeground + else super.foreground_color - override def foreground_color = view.getTextArea.getPainter.getForeground - override def selection_color = view.getTextArea.getPainter.getSelectionColor - override def highlight_color = view.getTextArea.getPainter.getLineHighlightColor + override def background_color = + if (editor_style) view.getTextArea.getPainter.getBackground + else super.background_color + + override def selection_color = + if (editor_style) view.getTextArea.getPainter.getSelectionColor + else super.selection_color + + override def highlight_color = + if (editor_style) view.getTextArea.getPainter.getLineHighlightColor + else super.highlight_color + override def error_color = PIDE.options.color_value("error_color") + + editor_style = true } new isabelle.graphview.Main_Panel(graphview) case Exn.Exn(exn) => new TextArea(Exn.message(exn)) diff -r 2bd401e364f9 -r 5977962f8e66 src/Tools/jEdit/src/rendering.scala --- a/src/Tools/jEdit/src/rendering.scala Fri Sep 18 16:27:37 2015 +0100 +++ b/src/Tools/jEdit/src/rendering.scala Fri Sep 18 16:42:19 2015 +0100 @@ -14,7 +14,7 @@ import javax.swing.Icon import org.gjt.sp.jedit.syntax.{Token => JEditToken} -import org.gjt.sp.jedit.{jEdit, View} +import org.gjt.sp.jedit.jEdit import scala.collection.immutable.SortedMap @@ -719,6 +719,8 @@ /* text color */ + val foreground_color = jEdit.getColorProperty("view.fgColor") + private lazy val text_colors: Map[String, Color] = Map( Markup.KEYWORD1 -> keyword1_color, Markup.KEYWORD2 -> keyword2_color, @@ -726,12 +728,12 @@ Markup.QUASI_KEYWORD -> quasi_keyword_color, Markup.IMPROPER -> improper_color, Markup.OPERATOR -> operator_color, - Markup.STRING -> Color.BLACK, - Markup.ALT_STRING -> Color.BLACK, - Markup.VERBATIM -> Color.BLACK, - Markup.CARTOUCHE -> Color.BLACK, + Markup.STRING -> foreground_color, + Markup.ALT_STRING -> foreground_color, + Markup.VERBATIM -> foreground_color, + Markup.CARTOUCHE -> foreground_color, Markup.LITERAL -> keyword1_color, - Markup.DELIMITER -> Color.BLACK, + Markup.DELIMITER -> foreground_color, Markup.TFREE -> tfree_color, Markup.TVAR -> tvar_color, Markup.FREE -> free_color, @@ -746,7 +748,7 @@ Markup.ML_KEYWORD1 -> keyword1_color, Markup.ML_KEYWORD2 -> keyword2_color, Markup.ML_KEYWORD3 -> keyword3_color, - Markup.ML_DELIMITER -> Color.BLACK, + Markup.ML_DELIMITER -> foreground_color, Markup.ML_NUMERAL -> inner_numeral_color, Markup.ML_CHAR -> inner_quoted_color, Markup.ML_STRING -> inner_quoted_color, diff -r 2bd401e364f9 -r 5977962f8e66 src/ZF/Datatype_ZF.thy --- a/src/ZF/Datatype_ZF.thy Fri Sep 18 16:27:37 2015 +0100 +++ b/src/ZF/Datatype_ZF.thy Fri Sep 18 16:42:19 2015 +0100 @@ -70,8 +70,9 @@ val datatype_ss = simpset_of @{context}; - fun proc ctxt old = - let val thy = Proof_Context.theory_of ctxt + fun proc ctxt ct = + let val old = Thm.term_of ct + val thy = Proof_Context.theory_of ctxt val _ = if !trace then writeln ("data_free: OLD = " ^ Syntax.string_of_term ctxt old) else () @@ -104,7 +105,9 @@ handle Match => NONE; - val conv = Simplifier.simproc_global @{theory} "data_free" ["(x::i) = y"] proc; + val conv = + Simplifier.make_simproc @{context} "data_free" + {lhss = [@{term "(x::i) = y"}], proc = K proc, identifier = []}; end; \ diff -r 2bd401e364f9 -r 5977962f8e66 src/ZF/arith_data.ML --- a/src/ZF/arith_data.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/ZF/arith_data.ML Fri Sep 18 16:42:19 2015 +0100 @@ -76,9 +76,6 @@ (warning (msg ^ "\nCancellation failed: no typing information? (" ^ name ^ ")"); NONE) end; -fun prep_simproc thy (name, pats, proc) = - Simplifier.simproc_global thy name pats proc; - (*** Use CancelNumerals simproc without binary numerals, just for cancellation ***) @@ -202,22 +199,24 @@ val nat_cancel = - map (prep_simproc @{theory}) - [("nateq_cancel_numerals", - ["l #+ m = n", "l = m #+ n", - "l #* m = n", "l = m #* n", - "succ(m) = n", "m = succ(n)"], - EqCancelNumerals.proc), - ("natless_cancel_numerals", - ["l #+ m < n", "l < m #+ n", - "l #* m < n", "l < m #* n", - "succ(m) < n", "m < succ(n)"], - LessCancelNumerals.proc), - ("natdiff_cancel_numerals", - ["(l #+ m) #- n", "l #- (m #+ n)", - "(l #* m) #- n", "l #- (m #* n)", - "succ(m) #- n", "m #- succ(n)"], - DiffCancelNumerals.proc)]; + [Simplifier.make_simproc @{context} "nateq_cancel_numerals" + {lhss = + [@{term "l #+ m = n"}, @{term "l = m #+ n"}, + @{term "l #* m = n"}, @{term "l = m #* n"}, + @{term "succ(m) = n"}, @{term "m = succ(n)"}], + proc = K EqCancelNumerals.proc, identifier = []}, + Simplifier.make_simproc @{context} "natless_cancel_numerals" + {lhss = + [@{term "l #+ m < n"}, @{term "l < m #+ n"}, + @{term "l #* m < n"}, @{term "l < m #* n"}, + @{term "succ(m) < n"}, @{term "m < succ(n)"}], + proc = K LessCancelNumerals.proc, identifier = []}, + Simplifier.make_simproc @{context} "natdiff_cancel_numerals" + {lhss = + [@{term "(l #+ m) #- n"}, @{term "l #- (m #+ n)"}, + @{term "(l #* m) #- n"}, @{term "l #- (m #* n)"}, + @{term "succ(m) #- n"}, @{term "m #- succ(n)"}], + proc = K DiffCancelNumerals.proc, identifier = []}]; end; diff -r 2bd401e364f9 -r 5977962f8e66 src/ZF/int_arith.ML --- a/src/ZF/int_arith.ML Fri Sep 18 16:27:37 2015 +0100 +++ b/src/ZF/int_arith.ML Fri Sep 18 16:42:19 2015 +0100 @@ -146,9 +146,6 @@ val int_mult_minus_simps = [@{thm zmult_assoc}, @{thm zmult_zminus} RS @{thm sym}, int_minus_mult_eq_1_to_2]; -fun prep_simproc thy (name, pats, proc) = - Simplifier.simproc_global thy name pats proc; - structure CancelNumeralsCommon = struct val mk_sum = (fn _ : typ => mk_sum) @@ -210,22 +207,24 @@ ); val cancel_numerals = - map (prep_simproc @{theory}) - [("inteq_cancel_numerals", - ["l $+ m = n", "l = m $+ n", - "l $- m = n", "l = m $- n", - "l $* m = n", "l = m $* n"], - EqCancelNumerals.proc), - ("intless_cancel_numerals", - ["l $+ m $< n", "l $< m $+ n", - "l $- m $< n", "l $< m $- n", - "l $* m $< n", "l $< m $* n"], - LessCancelNumerals.proc), - ("intle_cancel_numerals", - ["l $+ m $<= n", "l $<= m $+ n", - "l $- m $<= n", "l $<= m $- n", - "l $* m $<= n", "l $<= m $* n"], - LeCancelNumerals.proc)]; + [Simplifier.make_simproc @{context} "inteq_cancel_numerals" + {lhss = + [@{term "l $+ m = n"}, @{term "l = m $+ n"}, + @{term "l $- m = n"}, @{term "l = m $- n"}, + @{term "l $* m = n"}, @{term "l = m $* n"}], + proc = K EqCancelNumerals.proc, identifier = []}, + Simplifier.make_simproc @{context} "intless_cancel_numerals" + {lhss = + [@{term "l $+ m $< n"}, @{term "l $< m $+ n"}, + @{term "l $- m $< n"}, @{term "l $< m $- n"}, + @{term "l $* m $< n"}, @{term "l $< m $* n"}], + proc = K LessCancelNumerals.proc, identifier = []}, + Simplifier.make_simproc @{context} "intle_cancel_numerals" + {lhss = + [@{term "l $+ m $<= n"}, @{term "l $<= m $+ n"}, + @{term "l $- m $<= n"}, @{term "l $<= m $- n"}, + @{term "l $* m $<= n"}, @{term "l $<= m $* n"}], + proc = K LeCancelNumerals.proc, identifier = []}]; (*version without the hyps argument*) @@ -268,8 +267,9 @@ structure CombineNumerals = CombineNumeralsFun(CombineNumeralsData); val combine_numerals = - prep_simproc @{theory} - ("int_combine_numerals", ["i $+ j", "i $- j"], CombineNumerals.proc); + Simplifier.make_simproc @{context} "int_combine_numerals" + {lhss = [@{term "i $+ j"}, @{term "i $- j"}], + proc = K CombineNumerals.proc, identifier = []}; @@ -314,8 +314,8 @@ structure CombineNumeralsProd = CombineNumeralsFun(CombineNumeralsProdData); val combine_numerals_prod = - prep_simproc @{theory} - ("int_combine_numerals_prod", ["i $* j"], CombineNumeralsProd.proc); + Simplifier.make_simproc @{context} "int_combine_numerals_prod" + {lhss = [@{term "i $* j"}], proc = K CombineNumeralsProd.proc, identifier = []}; end;