--- a/.hgtags Sun Nov 29 12:56:30 2009 +1100
+++ b/.hgtags Mon Nov 30 08:08:31 2009 +0100
@@ -27,3 +27,6 @@
9db7854eafc75143cda2509a5325eb9150331866 isa2009-1-test
9db7854eafc75143cda2509a5325eb9150331866 isa2009-1-test
4328de748fb2ceffe4ad5a6d5fbf3347f6aecfa6 isa2009-1-test
+14ff44e21bec0e1b99d0f7322949b4fd012333e0 isa2009-1-test
+14ff44e21bec0e1b99d0f7322949b4fd012333e0 isa2009-1-test
+e1c262952b0285fa93f2e153891bc573d3de0f33 isa2009-1-test
--- a/ANNOUNCE Sun Nov 29 12:56:30 2009 +1100
+++ b/ANNOUNCE Mon Nov 30 08:08:31 2009 +0100
@@ -26,11 +26,16 @@
* HOL: various parts of multivariate analysis.
+* HOL-Library: proof method "sos" (sum of squares) for nonlinear real
+arithmetic, based on external semidefinite programming solvers.
+
* HOLCF: new definitional domain package.
* Revised tutorial on locales.
-* Support for Poly/ML 5.3.0, with improved reporting of compiler
+* ML: tacticals for subgoal focus.
+
+* ML: support for Poly/ML 5.3.0, with improved reporting of compiler
errors and run-time exceptions, including detailed source positions.
* Parallel checking of nested Isar proofs, with improved scalability
--- a/Admin/MacOS/App1/script Sun Nov 29 12:56:30 2009 +1100
+++ b/Admin/MacOS/App1/script Mon Nov 30 08:08:31 2009 +0100
@@ -48,8 +48,9 @@
/Applications/Emacs.app/Contents/MacOS/Emacs \
"")"
+declare -a EMACS_OPTIONS=()
if [ -n "$PROOFGENERAL_EMACS" ]; then
- EMACS_OPTIONS="-p $PROOFGENERAL_EMACS"
+ EMACS_OPTIONS=(-p "$PROOFGENERAL_EMACS")
fi
@@ -57,7 +58,7 @@
OUTPUT="/tmp/isabelle$$.out"
-( "$ISABELLE_TOOL" emacs $EMACS_OPTIONS "$@" ) > "$OUTPUT" 2>&1
+( "$ISABELLE_TOOL" emacs "${EMACS_OPTIONS[@]}" "$@" ) > "$OUTPUT" 2>&1
RC=$?
if [ "$RC" != 0 ]; then
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Admin/ProofGeneral/interface Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,262 @@
+#!/usr/bin/env bash
+#
+# interface,v 9.1 2008/02/06 15:40:45 makarius Exp
+#
+# Proof General interface wrapper for Isabelle.
+
+
+## self references
+
+THIS="$(cd "$(dirname "$0")"; pwd)"
+SUPER="$(cd "$THIS/.."; pwd)"
+
+
+## diagnostics
+
+usage()
+{
+ echo
+ echo "Usage: Isabelle [OPTIONS] [FILES ...]"
+ echo
+ echo " Options are:"
+ echo " -I BOOL use Isabelle/Isar (default: true, implied by -P true)"
+ echo " -L NAME abbreviates -l NAME -k NAME"
+ echo " -P BOOL actually start Proof General (default true), otherwise"
+ echo " run plain tty session"
+ echo " -U BOOL enable Unicode (UTF-8) communication (default true)"
+ echo " -X BOOL configure the X-Symbol package on startup (default true)"
+ echo " -f SIZE set X-Symbol font size (default 12)"
+ echo " -g GEOMETRY specify Emacs geometry"
+ echo " -k NAME use specific isar-keywords for named logic"
+ echo " -l NAME logic image name (default \$ISABELLE_LOGIC=$ISABELLE_LOGIC)"
+ echo " -m MODE add print mode for output"
+ echo " -p NAME Emacs program name (default emacs)"
+ echo " -u BOOL use personal .emacs file (default true)"
+ echo " -w BOOL use window system (default true)"
+ echo " -x BOOL enable the X-Symbol package on startup (default false)"
+ echo
+ echo "Starts Proof General for Isabelle with theory and proof FILES"
+ echo "(default Scratch.thy)."
+ echo
+ echo " PROOFGENERAL_OPTIONS=$PROOFGENERAL_OPTIONS"
+ echo
+ exit 1
+}
+
+fail()
+{
+ echo "$1" >&2
+ exit 2
+}
+
+
+## process command line
+
+# options
+
+ISABELLE_OPTIONS=""
+ISAR="true"
+START_PG="true"
+GEOMETRY=""
+KEYWORDS=""
+LOGIC="$ISABELLE_LOGIC"
+PROGNAME="emacs"
+INITFILE="true"
+WINDOWSYSTEM="true"
+XSYMBOL=""
+XSYMBOL_SETUP=true
+XSYMBOL_FONTSIZE="12"
+UNICODE=""
+
+getoptions()
+{
+ OPTIND=1
+ while getopts "I:L:P:U:X:f:g:k:l:m:p:u:w:x:" OPT
+ do
+ case "$OPT" in
+ I)
+ ISAR="$OPTARG"
+ ;;
+ L)
+ KEYWORDS="$OPTARG"
+ LOGIC="$OPTARG"
+ ;;
+ P)
+ START_PG="$OPTARG"
+ ;;
+ U)
+ UNICODE="$OPTARG"
+ ;;
+ X)
+ XSYMBOL_SETUP="$OPTARG"
+ ;;
+ f)
+ XSYMBOL_FONTSIZE="$OPTARG"
+ ;;
+ g)
+ GEOMETRY="$OPTARG"
+ ;;
+ k)
+ KEYWORDS="$OPTARG"
+ ;;
+ l)
+ LOGIC="$OPTARG"
+ ;;
+ m)
+ if [ -z "$ISABELLE_OPTIONS" ]; then
+ ISABELLE_OPTIONS="-m $OPTARG"
+ else
+ ISABELLE_OPTIONS="$ISABELLE_OPTIONS -m $OPTARG"
+ fi
+ ;;
+ p)
+ PROGNAME="$OPTARG"
+ ;;
+ u)
+ INITFILE="$OPTARG"
+ ;;
+ w)
+ WINDOWSYSTEM="$OPTARG"
+ ;;
+ x)
+ XSYMBOL="$OPTARG"
+ ;;
+ \?)
+ usage
+ ;;
+ esac
+ done
+}
+
+eval "OPTIONS=($PROOFGENERAL_OPTIONS)"
+getoptions "${OPTIONS[@]}"
+
+getoptions "$@"
+shift $(($OPTIND - 1))
+
+
+# args
+
+declare -a FILES=()
+
+if [ "$#" -eq 0 ]; then
+ FILES["${#FILES[@]}"]="Scratch.thy"
+else
+ while [ "$#" -gt 0 ]; do
+ FILES["${#FILES[@]}"]="$1"
+ shift
+ done
+fi
+
+
+## smart X11 font installation
+
+function checkfonts ()
+{
+ XLSFONTS=$(xlsfonts -fn "-xsymb-xsymb0-*" 2>&1) || return 1
+
+ case "$XLSFONTS" in
+ xlsfonts:*)
+ return 1
+ ;;
+ esac
+
+ return 0
+}
+
+function installfonts ()
+{
+ checkfonts "$XSYMBOL_PATTERN" || eval $XSYMBOL_INSTALLFONTS
+}
+
+
+## main
+
+# Isabelle2008 compatibility
+[ -z "$ISABELLE_PROCESS" ] && export ISABELLE_PROCESS="$ISABELLE"
+[ -z "$ISABELLE_TOOL" ] && export ISABELLE_TOOL="$ISATOOL"
+
+if [ "$START_PG" = false ]; then
+
+ [ "$ISAR" = true ] && ISABELLE_OPTIONS="$ISABELLE_OPTIONS -I"
+ exec "$ISABELLE_PROCESS" $ISABELLE_OPTIONS "$LOGIC"
+
+else
+
+ declare -a ARGS=()
+
+ if [ -n "$GEOMETRY" ]; then
+ ARGS["${#ARGS[@]}"]="-geometry"
+ ARGS["${#ARGS[@]}"]="$GEOMETRY"
+ fi
+
+ [ "$INITFILE" = false ] && ARGS["${#ARGS[@]}"]="-q"
+
+ if [ "$WINDOWSYSTEM" = false ]; then
+ ARGS["${#ARGS[@]}"]="-nw"
+ XSYMBOL=false
+ elif [ -z "$DISPLAY" ]; then
+ XSYMBOL=false
+ else
+ [ -n "$XSYMBOL_INSTALLFONTS" -a "$XSYMBOL_SETUP" = true ] && installfonts
+ fi
+
+ if [ $(uname -s) = Darwin -a -d "$HOME/Library/Fonts" ]
+ then
+ if [ ! -f "$HOME/Library/Fonts/XSymb0Medium.ttf" -o ! -f "$HOME/Library/Fonts/XSymb1Medium.ttf" ]
+ then
+ cp -f "$SUPER/x-symbol/etc/fonts-ttf/XSymb0Medium.ttf" "$HOME/Library/Fonts/"
+ cp -f "$SUPER/x-symbol/etc/fonts-ttf/XSymb1Medium.ttf" "$HOME/Library/Fonts/"
+ sleep 3
+ fi
+ fi
+
+ ARGS["${#ARGS[@]}"]="-l"
+ ARGS["${#ARGS[@]}"]="$SUPER/isar/interface-setup.el"
+
+ if [ -n "$KEYWORDS" ]; then
+ if [ -f "$ISABELLE_HOME_USER/etc/isar-keywords-$KEYWORDS.el" ]; then
+ ARGS["${#ARGS[@]}"]="-l"
+ ARGS["${#ARGS[@]}"]="$ISABELLE_HOME_USER/etc/isar-keywords-$KEYWORDS.el"
+ elif [ -f "$ISABELLE_HOME/etc/isar-keywords-$KEYWORDS.el" ]; then
+ ARGS["${#ARGS[@]}"]="-l"
+ ARGS["${#ARGS[@]}"]="$ISABELLE_HOME/etc/isar-keywords-$KEYWORDS.el"
+ else
+ fail "No isar-keywords file for '$KEYWORDS'"
+ fi
+ elif [ -f "$ISABELLE_HOME_USER/etc/isar-keywords.el" ]; then
+ ARGS["${#ARGS[@]}"]="-l"
+ ARGS["${#ARGS[@]}"]="$ISABELLE_HOME_USER/etc/isar-keywords.el"
+ elif [ -f "$ISABELLE_HOME/etc/isar-keywords.el" ]; then
+ ARGS["${#ARGS[@]}"]="-l"
+ ARGS["${#ARGS[@]}"]="$ISABELLE_HOME/etc/isar-keywords.el"
+ fi
+
+ for FILE in "$ISABELLE_HOME/etc/proofgeneral-settings.el" \
+ "$ISABELLE_HOME_USER/etc/proofgeneral-settings.el"
+ do
+ if [ -f "$FILE" ]; then
+ ARGS["${#ARGS[@]}"]="-l"
+ ARGS["${#ARGS[@]}"]="$FILE"
+ fi
+ done
+
+ case "$LOGIC" in
+ /*)
+ ;;
+ */*)
+ LOGIC="$(pwd -P)/$LOGIC"
+ ;;
+ esac
+
+ export PROOFGENERAL_HOME="$SUPER"
+ export PROOFGENERAL_ASSISTANTS="isar"
+ export PROOFGENERAL_LOGIC="$LOGIC"
+ export PROOFGENERAL_XSYMBOL="$XSYMBOL"
+ export PROOFGENERAL_UNICODE="$UNICODE"
+
+ export ISABELLE_OPTIONS XSYMBOL_FONTSIZE
+
+ exec "$PROGNAME" "${ARGS[@]}" "${FILES[@]}"
+
+fi
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Admin/ProofGeneral/isar-antiq-regexp.patch Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,21 @@
+--- a/isar/isar-syntax.el Wed Aug 06 11:43:47 2008 +0200
++++ b/isar/isar-syntax.el Thu Sep 18 15:21:16 2008 +0200
+@@ -252,14 +252,9 @@
+
+ ;; antiquotations
+
+-;; the \{0,10\} bound is there because otherwise font-lock sometimes hangs for
+-;; incomplete antiquotations like @{text bla"} (even though it is supposed to
+-;; stop at eol anyway).
+-
+-(defconst isar-antiq-regexp
+- (concat "@{\\(?:[^\"{}]+\\|" isar-string "\\)\\{0,10\\}}")
+- "Regexp matching Isabelle/Isar antiquoations.")
+-
++(defconst isar-antiq-regexp
++ (concat "@{\\(?:[^\"{}]\\|" isar-string "\\)*}")
++ "Regexp matching Isabelle/Isar antiquotations.")
+
+ ;; keyword nesting
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Admin/ProofGeneral/menu.patch Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,30 @@
+--- a/isar/isar.el 2008-07-10 20:47:49.000000000 +0200
++++ b/isar/isar.el 2009-11-26 20:51:44.103016094 +0100
+@@ -339,9 +339,12 @@
+ (error "Aborted."))
+ [(control p)])
+
+-(proof-definvisible isar-cmd-refute "refute" [r])
+ (proof-definvisible isar-cmd-quickcheck "quickcheck" [(control q)])
++(proof-definvisible isar-cmd-nitpick "nitpick" [(control n)])
++(proof-definvisible isar-cmd-refute "refute" [r])
+ (proof-definvisible isar-cmd-sledgehammer "sledgehammer" [(control s)])
++(proof-definvisible isar-cmd-atp-kill "atp_kill")
++(proof-definvisible isar-cmd-atp-info "atp_info")
+
+ (defpgdefault menu-entries
+ (append
+@@ -349,9 +352,12 @@
+ (list
+ (cons "Commands"
+ (list
+- ["refute" isar-cmd-refute t]
+ ["quickcheck" isar-cmd-quickcheck t]
++ ["nitpick" isar-cmd-nitpick t]
++ ["refute" isar-cmd-refute t]
+ ["sledgehammer" isar-cmd-sledgehammer t]
++ ["sledgehammer: kill" isar-cmd-atp-kill t]
++ ["sledgehammer: info" isar-cmd-atp-info t]
+ ["display draft" isar-cmd-display-draft t])))
+ (list
+ (cons "Show me ..."
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Admin/ProofGeneral/progname.patch Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,89 @@
+--- a/isar/isabelle-system.el 2008-07-17 00:37:36.000000000 +0200
++++ b/isar/isabelle-system.el 2009-11-30 17:06:05.508481278 +0100
+@@ -97,8 +97,8 @@
+ (if (or proof-rsh-command
+ (file-executable-p isa-isatool-command))
+ (let ((setting (isa-shell-command-to-string
+- (concat isa-isatool-command
+- " getenv -b " envvar))))
++ (concat "\"" isa-isatool-command
++ "\" getenv -b " envvar))))
+ (if (string-equal setting "")
+ default
+ setting))
+@@ -125,15 +125,12 @@
+ :type 'file
+ :group 'isabelle)
+
+-(defvar isabelle-prog-name nil
+- "Set from `isabelle-set-prog-name', has name of logic appended sometimes.")
+-
+ (defun isa-tool-list-logics ()
+ "Generate a list of available object logics."
+ (if (isa-set-isatool-command)
+ (delete "" (split-string
+ (isa-shell-command-to-string
+- (concat isa-isatool-command " findlogics")) "[ \t]"))))
++ (concat "\"" isa-isatool-command "\" findlogics")) "[ \t]"))))
+
+ (defcustom isabelle-logics-available nil
+ "*List of logics available to use with Isabelle.
+@@ -177,7 +174,7 @@
+
+ (defun isabelle-set-prog-name (&optional filename)
+ "Make proper command line for running Isabelle.
+-This function sets `isabelle-prog-name' and `proof-prog-name'."
++This function sets `proof-prog-name' and `isar-prog-args'."
+ (let*
+ ;; The ISABELLE and PROOFGENERAL_LOGIC values (set when run
+ ;; under the interface wrapper script) indicate command line
+@@ -187,21 +184,20 @@
+ (getenv "ISABELLE") ; command line override
+ (isa-getenv "ISABELLE") ; choose to match isatool
+ "isabelle")) ; to
+- (isabelle-opts (getenv "ISABELLE_OPTIONS"))
+- (opts (concat " -PI" ;; Proof General + Isar
+- (if proof-shell-unicode " -m PGASCII" "")
+- (if (and isabelle-opts (not (equal isabelle-opts "")))
+- (concat " " isabelle-opts) "")))
++ (isabelle-opts (split-string (getenv "ISABELLE_OPTIONS")))
++ (opts (append (list "-PI") ;; Proof General + Isar
++ (if proof-shell-unicode (list "-m" "PGASCII") nil)
++ isabelle-opts))
+ (logic (or isabelle-chosen-logic
+ (getenv "PROOFGENERAL_LOGIC")))
+ (logicarg (if (and logic (not (equal logic "")))
+- (concat " " logic) "")))
++ (list logic) nil)))
+ (setq isabelle-chosen-logic-prev isabelle-chosen-logic)
+- (setq isabelle-prog-name (concat isabelle opts logicarg))
+- (setq proof-prog-name isabelle-prog-name)))
++ (setq isar-prog-args (append opts logicarg))
++ (setq proof-prog-name isabelle)))
+
+ (defun isabelle-choose-logic (logic)
+- "Adjust isabelle-prog-name and proof-prog-name for running LOGIC."
++ "Adjust proof-prog-name and isar-prog-args for running LOGIC."
+ (interactive
+ (list (completing-read
+ "Use logic: "
+@@ -224,9 +220,7 @@
+ (if (isa-set-isatool-command)
+ (apply 'start-process
+ "isa-view-doc" nil
+- (append (split-string
+- isa-isatool-command)
+- (list "doc" docname)))))
++ (list isa-isatool-command "doc" docname))))
+
+ (defun isa-tool-list-docs ()
+ "Generate a list of documentation files available, with descriptions.
+@@ -236,7 +230,7 @@
+ passed to isa-tool-doc-command, DOCNAME will be viewed."
+ (if (isa-set-isatool-command)
+ (let ((docs (isa-shell-command-to-string
+- (concat isa-isatool-command " doc"))))
++ (concat "\"" isa-isatool-command "\" doc"))))
+ (unless (string-equal docs "")
+ (mapcan
+ (function (lambda (docdes)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Admin/ProofGeneral/timeout.patch Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,11 @@
+--- a/generic/proof-config.el 2008-07-21 18:37:10.000000000 +0200
++++ b/generic/proof-config.el 2009-11-29 17:41:37.409062091 +0100
+@@ -1493,7 +1493,7 @@
+ :type '(choice string (const nil))
+ :group 'proof-shell)
+
+-(defcustom proof-shell-quit-timeout 4
++(defcustom proof-shell-quit-timeout 45
+ ;; FIXME could add option to quiz user before rude kill.
+ "The number of seconds to wait after sending proof-shell-quit-cmd.
+ After this timeout, the proof shell will be killed off more rudely.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Admin/ProofGeneral/version.patch Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,20 @@
+--- a/generic/proof-site.el 2008-07-23 14:40:14.000000000 +0200
++++ b/generic/proof-site.el 2009-11-28 16:13:56.409505412 +0100
+@@ -55,7 +55,7 @@
+
+ (eval-and-compile
+ ;; WARNING: do not edit next line (constant is edited in Makefile.devel)
+- (defconst proof-general-version "Proof General Version 3.7.1. Released by da on Wed 23 Jul 2008."
++ (defconst proof-general-version "Proof General Version 3.7.1.1. Fabricated by makarius on Mon 30 Nov 2009."
+ "Version string identifying Proof General release."))
+
+ (defconst proof-general-short-version
+@@ -64,7 +64,7 @@
+ (string-match "Version \\([^ ]+\\)\\." proof-general-version)
+ (match-string 1 proof-general-version))))
+
+-(defconst proof-general-version-year "2008")
++(defconst proof-general-version-year "2009")
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;
--- a/Admin/isatest/settings/at-poly-5.1-para-e Sun Nov 29 12:56:30 2009 +1100
+++ b/Admin/isatest/settings/at-poly-5.1-para-e Mon Nov 30 08:08:31 2009 +0100
@@ -22,6 +22,6 @@
ISABELLE_OUTPUT="$ISABELLE_HOME_USER/heaps"
ISABELLE_BROWSER_INFO="$ISABELLE_HOME_USER/browser_info"
-ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -M 20"
+ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -M 10"
HOL_USEDIR_OPTIONS="-p 2 -q 0"
--- a/Admin/makebin Sun Nov 29 12:56:30 2009 +1100
+++ b/Admin/makebin Mon Nov 30 08:08:31 2009 +0100
@@ -109,6 +109,8 @@
touch "heaps/$COMPILER/log/HOL.gz"
touch "heaps/$COMPILER/HOL-Nominal"
touch "heaps/$COMPILER/log/HOL-Nominal.gz"
+ touch "heaps/$COMPILER/HOLCF"
+ touch "heaps/$COMPILER/log/HOLCF.gz"
touch "heaps/$COMPILER/ZF"
touch "heaps/$COMPILER/log/ZF.gz"
mkdir browser_info
@@ -116,6 +118,7 @@
./build -bait
else
./build -b -m HOL-Nominal HOL
+ ./build -b HOLCF
./build -b ZF
rm -f "heaps/$COMPILER/Pure" "heaps/$COMPILER/FOL"
fi
@@ -133,7 +136,7 @@
gzip -f "${ISABELLE_NAME}_library.tar"
cp -f "${ISABELLE_NAME}_library.tar.gz" "$ARCHIVE_DIR"
else
- for IMG in HOL HOL-Nominal ZF
+ for IMG in HOL HOL-Nominal HOLCF ZF
do
tar cf "${IMG}_$PLATFORM.tar" \
"$ISABELLE_NAME/heaps/$COMPILER/$IMG" \
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Admin/makebundle Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,75 @@
+#!/usr/bin/env bash
+#
+# makebundle -- re-package with add-on components
+
+## global settings
+
+TMP="/var/tmp/isabelle-makebundle$$"
+
+
+## diagnostics
+
+PRG=$(basename "$0")
+
+function usage()
+{
+ echo
+ echo "Usage: $PRG ARCHIVE COMPONENTS"
+ echo
+ echo " Re-package Isabelle distribution with add-on components."
+ echo
+ exit 1
+}
+
+function fail()
+{
+ echo "$1" >&2
+ exit 2
+}
+
+
+## process command line
+
+[ "$#" -lt 1 ] && usage
+
+ARCHIVE="$1"; shift
+
+declare -a COMPONENTS
+COMPONENTS=("$@")
+
+
+## main
+
+mkdir "$TMP" || fail "Cannot create directory $TMP"
+
+ARCHIVE_DIR="$(cd $(dirname "$ARCHIVE"); echo "$PWD")"
+ISABELLE_NAME="$(basename "$ARCHIVE" .tar.gz)"
+ISABELLE_HOME="$TMP/$ISABELLE_NAME"
+
+[ ! -f "$ARCHIVE" ] && fail "Bad archive file $ARCHIVE"
+tar -C "$TMP" -x -z -f "$ARCHIVE"
+
+echo "#bundled components" >> "$ISABELLE_HOME/etc/components"
+
+for COMPONENT in "${COMPONENTS[@]}"
+do
+ tar -C "$ISABELLE_HOME/contrib" -x -z -f "$COMPONENT"
+ NAME="$(basename "$COMPONENT" .tar.gz)"
+ [ -d "$ISABELLE_HOME/contrib/$NAME" ] || fail "Bad archive content $COMPONENT"
+
+ if [ -e "$ISABELLE_HOME/contrib/$NAME/etc/settings" ]; then
+ echo "component $NAME"
+ echo "contrib/$NAME" >> "$ISABELLE_HOME/etc/components"
+ else
+ echo "package $NAME"
+ fi
+done
+
+tar -C "$TMP" -c -z \
+ -f "${ARCHIVE_DIR}/${ISABELLE_NAME}_bundle.tar.gz" \
+ Isabelle "$ISABELLE_NAME"
+
+
+# clean up
+cd /tmp
+rm -rf "$TMP"
--- a/Admin/makedist Sun Nov 29 12:56:30 2009 +1100
+++ b/Admin/makedist Mon Nov 30 08:08:31 2009 +0100
@@ -4,7 +4,8 @@
## global settings
-REPOS="http://isabelle.in.tum.de/repos/isabelle"
+REPOS_NAME="isabelle-release"
+REPOS="http://isabelle.in.tum.de/repos/${REPOS_NAME}"
DISTPREFIX=${DISTPREFIX:-~/tmp/isadist}
@@ -92,12 +93,12 @@
{ wget -q "$REPOS/archive/${VERSION}.tar.gz" -O- | tar -xzf -; } || \
fail "Failed to retrieve $VERSION"
-IDENT=$(echo * | sed 's/isabelle-//')
+IDENT=$(echo * | sed "s/${REPOS_NAME}-//")
-rm -f "isabelle-$IDENT/.hg_archival.txt"
-rm -f "isabelle-$IDENT/.hgtags"
-rm -f "isabelle-$IDENT/.hgignore"
-rm -f "isabelle-$IDENT/README_REPOSITORY"
+rm -f "${REPOS_NAME}-${IDENT}/.hg_archival.txt"
+rm -f "${REPOS_NAME}-${IDENT}/.hgtags"
+rm -f "${REPOS_NAME}-${IDENT}/.hgignore"
+rm -f "${REPOS_NAME}-${IDENT}/README_REPOSITORY"
# dist name
@@ -118,7 +119,7 @@
[ -e "$DISTBASE/$DISTNAME" ] && { purge_tmp; fail "$DISTBASE/$DISTNAME already exists!"; }
cd "$DISTBASE"
-mv "$DISTPREFIX/$TMP/isabelle-$IDENT" "$DISTNAME"
+mv "$DISTPREFIX/$TMP/${REPOS_NAME}-${IDENT}" "$DISTNAME"
purge_tmp
cd "$DISTNAME" || fail "No dist directory: $DISTBASE/$DISTNAME"
--- a/bin/isabelle Sun Nov 29 12:56:30 2009 +1100
+++ b/bin/isabelle Mon Nov 30 08:08:31 2009 +0100
@@ -30,7 +30,7 @@
echo " Start Isabelle tool NAME with ARGS; pass \"-?\" for tool specific help."
echo
echo " Available tools are:"
- for DIR in ${TOOLS[@]}
+ for DIR in "${TOOLS[@]}"
do
if [ -d "$DIR" ]; then
for TOOL in "$DIR"/*
--- a/bin/isabelle-process Sun Nov 29 12:56:30 2009 +1100
+++ b/bin/isabelle-process Mon Nov 30 08:08:31 2009 +0100
@@ -181,7 +181,9 @@
case "$OUTPUT" in
"")
- [ -z "$READONLY" -a -w "$INFILE" ] && OUTFILE="$INFILE"
+ if [ -z "$READONLY" -a -w "$INFILE" ]; then
+ perl -e "exit (((stat('$INFILE'))[2] & 0222) != 0 ? 0 : 1);" && OUTFILE="$INFILE"
+ fi
;;
*/*)
OUTFILE="$OUTPUT"
--- a/doc-src/Classes/Thy/document/Classes.tex Sun Nov 29 12:56:30 2009 +1100
+++ b/doc-src/Classes/Thy/document/Classes.tex Mon Nov 30 08:08:31 2009 +0100
@@ -1260,7 +1260,7 @@
\hspace*{0pt}\\
\hspace*{0pt}fun inverse{\char95}int i = IntInf.{\char126}~i;\\
\hspace*{0pt}\\
-\hspace*{0pt}val neutral{\char95}int :~IntInf.int = (0 :~IntInf.int)\\
+\hspace*{0pt}val neutral{\char95}int :~IntInf.int = (0 :~IntInf.int);\\
\hspace*{0pt}\\
\hspace*{0pt}fun mult{\char95}int i j = IntInf.+ (i,~j);\\
\hspace*{0pt}\\
@@ -1285,7 +1285,7 @@
\hspace*{0pt} ~~~else inverse A{\char95}~(pow{\char95}nat (monoid{\char95}group A{\char95}) (nat (IntInf.{\char126}~k)) x));\\
\hspace*{0pt}\\
\hspace*{0pt}val example :~IntInf.int =\\
-\hspace*{0pt} ~pow{\char95}int group{\char95}int (10 :~IntInf.int) ({\char126}2 :~IntInf.int)\\
+\hspace*{0pt} ~pow{\char95}int group{\char95}int (10 :~IntInf.int) ({\char126}2 :~IntInf.int);\\
\hspace*{0pt}\\
\hspace*{0pt}end;~(*struct Example*)%
\end{isamarkuptext}%
--- a/doc-src/Codegen/Thy/Program.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/doc-src/Codegen/Thy/Program.thy Mon Nov 30 08:08:31 2009 +0100
@@ -430,5 +430,220 @@
likely to be used in such situations.
*}
+subsection {* Inductive Predicates *}
+(*<*)
+hide const append
+
+inductive append
+where
+ "append [] ys ys"
+| "append xs ys zs ==> append (x # xs) ys (x # zs)"
+(*>*)
+text {*
+To execute inductive predicates, a special preprocessor, the predicate
+ compiler, generates code equations from the introduction rules of the predicates.
+The mechanisms of this compiler are described in \cite{Berghofer-Bulwahn-Haftmann:2009:TPHOL}.
+Consider the simple predicate @{const append} given by these two
+introduction rules:
+*}
+text %quote {*
+@{thm append.intros(1)[of ys]}\\
+\noindent@{thm append.intros(2)[of xs ys zs x]}
+*}
+text {*
+\noindent To invoke the compiler, simply use @{command_def "code_pred"}:
+*}
+code_pred %quote append .
+text {*
+\noindent The @{command "code_pred"} command takes the name
+of the inductive predicate and then you put a period to discharge
+a trivial correctness proof.
+The compiler infers possible modes
+for the predicate and produces the derived code equations.
+Modes annotate which (parts of the) arguments are to be taken as input,
+and which output. Modes are similar to types, but use the notation @{text "i"}
+for input and @{text "o"} for output.
+
+For @{term "append"}, the compiler can infer the following modes:
+\begin{itemize}
+\item @{text "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool"}
+\item @{text "i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool"}
+\item @{text "o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool"}
+\end{itemize}
+You can compute sets of predicates using @{command_def "values"}:
+*}
+values %quote "{zs. append [(1::nat),2,3] [4,5] zs}"
+text {* \noindent outputs @{text "{[1, 2, 3, 4, 5]}"}, and *}
+values %quote "{(xs, ys). append xs ys [(2::nat),3]}"
+text {* \noindent outputs @{text "{([], [2, 3]), ([2], [3]), ([2, 3], [])}"}. *}
+text {*
+\noindent If you are only interested in the first elements of the set
+comprehension (with respect to a depth-first search on the introduction rules), you can
+pass an argument to
+@{command "values"} to specify the number of elements you want:
+*}
+
+values %quote 1 "{(xs, ys). append xs ys [(1::nat),2,3,4]}"
+values %quote 3 "{(xs, ys). append xs ys [(1::nat),2,3,4]}"
+
+text {*
+\noindent The @{command "values"} command can only compute set
+ comprehensions for which a mode has been inferred.
+
+The code equations for a predicate are made available as theorems with
+ the suffix @{text "equation"}, and can be inspected with:
+*}
+thm %quote append.equation
+text {*
+\noindent More advanced options are described in the following subsections.
+*}
+subsubsection {* Alternative names for functions *}
+text {*
+By default, the functions generated from a predicate are named after the predicate with the
+mode mangled into the name (e.g., @{text "append_i_i_o"}).
+You can specify your own names as follows:
+*}
+code_pred %quote (modes: i => i => o => bool as concat,
+ o => o => i => bool as split,
+ i => o => i => bool as suffix) append .
+
+subsubsection {* Alternative introduction rules *}
+text {*
+Sometimes the introduction rules of an predicate are not executable because they contain
+non-executable constants or specific modes could not be inferred.
+It is also possible that the introduction rules yield a function that loops forever
+due to the execution in a depth-first search manner.
+Therefore, you can declare alternative introduction rules for predicates with the attribute
+@{attribute "code_pred_intro"}.
+For example, the transitive closure is defined by:
+*}
+text %quote {*
+@{thm tranclp.intros(1)[of r a b]}\\
+\noindent @{thm tranclp.intros(2)[of r a b c]}
+*}
+text {*
+\noindent These rules do not suit well for executing the transitive closure
+with the mode @{text "(i \<Rightarrow> o \<Rightarrow> bool) \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool"}, as the second rule will
+cause an infinite loop in the recursive call.
+This can be avoided using the following alternative rules which are
+declared to the predicate compiler by the attribute @{attribute "code_pred_intro"}:
+*}
+lemma %quote [code_pred_intro]:
+ "r a b \<Longrightarrow> r\<^sup>+\<^sup>+ a b"
+ "r a b \<Longrightarrow> r\<^sup>+\<^sup>+ b c \<Longrightarrow> r\<^sup>+\<^sup>+ a c"
+by auto
+text {*
+\noindent After declaring all alternative rules for the transitive closure,
+you invoke @{command "code_pred"} as usual.
+As you have declared alternative rules for the predicate, you are urged to prove that these
+introduction rules are complete, i.e., that you can derive an elimination rule for the
+alternative rules:
+*}
+code_pred %quote tranclp
+proof -
+ case tranclp
+ from this converse_tranclpE[OF this(1)] show thesis by metis
+qed
+text {*
+\noindent Alternative rules can also be used for constants that have not
+been defined inductively. For example, the lexicographic order which
+is defined as: *}
+text %quote {*
+@{thm [display] lexord_def[of "r"]}
+*}
+text {*
+\noindent To make it executable, you can derive the following two rules and prove the
+elimination rule:
+*}
+(*<*)
+lemma append: "append xs ys zs = (xs @ ys = zs)"
+by (induct xs arbitrary: ys zs) (auto elim: append.cases intro: append.intros)
+(*>*)
+lemma %quote [code_pred_intro]:
+ "append xs (a # v) ys \<Longrightarrow> lexord r (xs, ys)"
+(*<*)unfolding lexord_def Collect_def by (auto simp add: append)(*>*)
+
+lemma %quote [code_pred_intro]:
+ "append u (a # v) xs \<Longrightarrow> append u (b # w) ys \<Longrightarrow> r (a, b)
+ \<Longrightarrow> lexord r (xs, ys)"
+(*<*)unfolding lexord_def Collect_def append mem_def apply simp
+apply (rule disjI2) by auto
+(*>*)
+
+code_pred %quote lexord
+(*<*)
+proof -
+ fix r a1
+ assume lexord: "lexord r a1"
+ assume 1: "\<And> xs ys a v. a1 = (xs, ys) \<Longrightarrow> append xs (a # v) ys \<Longrightarrow> thesis"
+ assume 2: "\<And> xs ys u a v b w. a1 = (xs, ys) \<Longrightarrow> append u (a # v) xs \<Longrightarrow> append u (b # w) ys \<Longrightarrow> r (a, b) \<Longrightarrow> thesis"
+ obtain xs ys where a1: "a1 = (xs, ys)" by fastsimp
+ {
+ assume "\<exists>a v. ys = xs @ a # v"
+ from this 1 a1 have thesis
+ by (fastsimp simp add: append)
+ } moreover
+ {
+ assume "\<exists>u a b v w. (a, b) \<in> r \<and> xs = u @ a # v \<and> ys = u @ b # w"
+ from this 2 a1 have thesis by (fastsimp simp add: append mem_def)
+ } moreover
+ note lexord[simplified a1]
+ ultimately show thesis
+ unfolding lexord_def
+ by (fastsimp simp add: Collect_def)
+qed
+(*>*)
+subsubsection {* Options for values *}
+text {*
+In the presence of higher-order predicates, multiple modes for some predicate could be inferred
+that are not disambiguated by the pattern of the set comprehension.
+To disambiguate the modes for the arguments of a predicate, you can state
+the modes explicitly in the @{command "values"} command.
+Consider the simple predicate @{term "succ"}:
+*}
+inductive succ :: "nat \<Rightarrow> nat \<Rightarrow> bool"
+where
+ "succ 0 (Suc 0)"
+| "succ x y \<Longrightarrow> succ (Suc x) (Suc y)"
+
+code_pred succ .
+
+text {*
+\noindent For this, the predicate compiler can infer modes @{text "o \<Rightarrow> o \<Rightarrow> bool"}, @{text "i \<Rightarrow> o \<Rightarrow> bool"},
+ @{text "o \<Rightarrow> i \<Rightarrow> bool"} and @{text "i \<Rightarrow> i \<Rightarrow> bool"}.
+The invocation of @{command "values"} @{text "{n. tranclp succ 10 n}"} loops, as multiple
+modes for the predicate @{text "succ"} are possible and here the first mode @{text "o \<Rightarrow> o \<Rightarrow> bool"}
+is chosen. To choose another mode for the argument, you can declare the mode for the argument between
+the @{command "values"} and the number of elements.
+*}
+values %quote [mode: i => o => bool] 20 "{n. tranclp succ 10 n}"
+values %quote [mode: o => i => bool] 10 "{n. tranclp succ n 10}"
+
+subsubsection {* Embedding into functional code within Isabelle/HOL *}
+text {*
+To embed the computation of an inductive predicate into functions that are defined in Isabelle/HOL,
+you have a number of options:
+\begin{itemize}
+\item You want to use the first-order predicate with the mode
+ where all arguments are input. Then you can use the predicate directly, e.g.
+\begin{quote}
+ @{text "valid_suffix ys zs = "}\\
+ @{text "(if append [Suc 0, 2] ys zs then Some ys else None)"}
+\end{quote}
+\item If you know that the execution returns only one value (it is deterministic), then you can
+ use the combinator @{term "Predicate.the"}, e.g., a functional concatenation of lists
+ is defined with
+\begin{quote}
+ @{term "functional_concat xs ys = Predicate.the (append_i_i_o xs ys)"}
+\end{quote}
+ Note that if the evaluation does not return a unique value, it raises a run-time error
+ @{term "not_unique"}.
+\end{itemize}
+*}
+subsubsection {* Further Examples *}
+text {* Further examples for compiling inductive predicates can be found in
+the @{text "HOL/ex/Predicate_Compile_ex"} theory file.
+There are also some examples in the Archive of Formal Proofs, notably
+in the @{text "POPLmark-deBruijn"} and the @{text "FeatherweightJava"} sessions.
+*}
end
-
\ No newline at end of file
--- a/doc-src/Codegen/Thy/document/Program.tex Sun Nov 29 12:56:30 2009 +1100
+++ b/doc-src/Codegen/Thy/document/Program.tex Mon Nov 30 08:08:31 2009 +0100
@@ -968,6 +968,458 @@
\end{isamarkuptext}%
\isamarkuptrue%
%
+\isamarkupsubsection{Inductive Predicates%
+}
+\isamarkuptrue%
+%
+\begin{isamarkuptext}%
+To execute inductive predicates, a special preprocessor, the predicate
+ compiler, generates code equations from the introduction rules of the predicates.
+The mechanisms of this compiler are described in \cite{Berghofer-Bulwahn-Haftmann:2009:TPHOL}.
+Consider the simple predicate \isa{append} given by these two
+introduction rules:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+%
+\begin{isamarkuptext}%
+\isa{append\ {\isacharbrackleft}{\isacharbrackright}\ ys\ ys}\\
+\noindent\isa{append\ xs\ ys\ zs\ {\isasymLongrightarrow}\ append\ {\isacharparenleft}x\ {\isacharhash}\ xs{\isacharparenright}\ ys\ {\isacharparenleft}x\ {\isacharhash}\ zs{\isacharparenright}}%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent To invoke the compiler, simply use \indexdef{}{command}{code\_pred}\hypertarget{command.code-pred}{\hyperlink{command.code-pred}{\mbox{\isa{\isacommand{code{\isacharunderscore}pred}}}}}:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+\isacommand{code{\isacharunderscore}pred}\isamarkupfalse%
+\ append\ \isacommand{{\isachardot}}\isamarkupfalse%
+%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent The \hyperlink{command.code-pred}{\mbox{\isa{\isacommand{code{\isacharunderscore}pred}}}} command takes the name
+of the inductive predicate and then you put a period to discharge
+a trivial correctness proof.
+The compiler infers possible modes
+for the predicate and produces the derived code equations.
+Modes annotate which (parts of the) arguments are to be taken as input,
+and which output. Modes are similar to types, but use the notation \isa{i}
+for input and \isa{o} for output.
+
+For \isa{append}, the compiler can infer the following modes:
+\begin{itemize}
+\item \isa{i\ {\isasymRightarrow}\ i\ {\isasymRightarrow}\ i\ {\isasymRightarrow}\ bool}
+\item \isa{i\ {\isasymRightarrow}\ i\ {\isasymRightarrow}\ o\ {\isasymRightarrow}\ bool}
+\item \isa{o\ {\isasymRightarrow}\ o\ {\isasymRightarrow}\ i\ {\isasymRightarrow}\ bool}
+\end{itemize}
+You can compute sets of predicates using \indexdef{}{command}{values}\hypertarget{command.values}{\hyperlink{command.values}{\mbox{\isa{\isacommand{values}}}}}:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+\isacommand{values}\isamarkupfalse%
+\ {\isachardoublequoteopen}{\isacharbraceleft}zs{\isachardot}\ append\ {\isacharbrackleft}{\isacharparenleft}{\isadigit{1}}{\isacharcolon}{\isacharcolon}nat{\isacharparenright}{\isacharcomma}{\isadigit{2}}{\isacharcomma}{\isadigit{3}}{\isacharbrackright}\ {\isacharbrackleft}{\isadigit{4}}{\isacharcomma}{\isadigit{5}}{\isacharbrackright}\ zs{\isacharbraceright}{\isachardoublequoteclose}%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent outputs \isa{{\isacharbraceleft}{\isacharbrackleft}{\isadigit{1}}{\isacharcomma}\ {\isadigit{2}}{\isacharcomma}\ {\isadigit{3}}{\isacharcomma}\ {\isadigit{4}}{\isacharcomma}\ {\isadigit{5}}{\isacharbrackright}{\isacharbraceright}}, and%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+\isacommand{values}\isamarkupfalse%
+\ {\isachardoublequoteopen}{\isacharbraceleft}{\isacharparenleft}xs{\isacharcomma}\ ys{\isacharparenright}{\isachardot}\ append\ xs\ ys\ {\isacharbrackleft}{\isacharparenleft}{\isadigit{2}}{\isacharcolon}{\isacharcolon}nat{\isacharparenright}{\isacharcomma}{\isadigit{3}}{\isacharbrackright}{\isacharbraceright}{\isachardoublequoteclose}%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent outputs \isa{{\isacharbraceleft}{\isacharparenleft}{\isacharbrackleft}{\isacharbrackright}{\isacharcomma}\ {\isacharbrackleft}{\isadigit{2}}{\isacharcomma}\ {\isadigit{3}}{\isacharbrackright}{\isacharparenright}{\isacharcomma}\ {\isacharparenleft}{\isacharbrackleft}{\isadigit{2}}{\isacharbrackright}{\isacharcomma}\ {\isacharbrackleft}{\isadigit{3}}{\isacharbrackright}{\isacharparenright}{\isacharcomma}\ {\isacharparenleft}{\isacharbrackleft}{\isadigit{2}}{\isacharcomma}\ {\isadigit{3}}{\isacharbrackright}{\isacharcomma}\ {\isacharbrackleft}{\isacharbrackright}{\isacharparenright}{\isacharbraceright}}.%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\begin{isamarkuptext}%
+\noindent If you are only interested in the first elements of the set
+comprehension (with respect to a depth-first search on the introduction rules), you can
+pass an argument to
+\hyperlink{command.values}{\mbox{\isa{\isacommand{values}}}} to specify the number of elements you want:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+\isacommand{values}\isamarkupfalse%
+\ {\isadigit{1}}\ {\isachardoublequoteopen}{\isacharbraceleft}{\isacharparenleft}xs{\isacharcomma}\ ys{\isacharparenright}{\isachardot}\ append\ xs\ ys\ {\isacharbrackleft}{\isacharparenleft}{\isadigit{1}}{\isacharcolon}{\isacharcolon}nat{\isacharparenright}{\isacharcomma}{\isadigit{2}}{\isacharcomma}{\isadigit{3}}{\isacharcomma}{\isadigit{4}}{\isacharbrackright}{\isacharbraceright}{\isachardoublequoteclose}\isanewline
+\isacommand{values}\isamarkupfalse%
+\ {\isadigit{3}}\ {\isachardoublequoteopen}{\isacharbraceleft}{\isacharparenleft}xs{\isacharcomma}\ ys{\isacharparenright}{\isachardot}\ append\ xs\ ys\ {\isacharbrackleft}{\isacharparenleft}{\isadigit{1}}{\isacharcolon}{\isacharcolon}nat{\isacharparenright}{\isacharcomma}{\isadigit{2}}{\isacharcomma}{\isadigit{3}}{\isacharcomma}{\isadigit{4}}{\isacharbrackright}{\isacharbraceright}{\isachardoublequoteclose}%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent The \hyperlink{command.values}{\mbox{\isa{\isacommand{values}}}} command can only compute set
+ comprehensions for which a mode has been inferred.
+
+The code equations for a predicate are made available as theorems with
+ the suffix \isa{equation}, and can be inspected with:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+\isacommand{thm}\isamarkupfalse%
+\ append{\isachardot}equation%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent More advanced options are described in the following subsections.%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isamarkupsubsubsection{Alternative names for functions%
+}
+\isamarkuptrue%
+%
+\begin{isamarkuptext}%
+By default, the functions generated from a predicate are named after the predicate with the
+mode mangled into the name (e.g., \isa{append{\isacharunderscore}i{\isacharunderscore}i{\isacharunderscore}o}).
+You can specify your own names as follows:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+\isacommand{code{\isacharunderscore}pred}\isamarkupfalse%
+\ {\isacharparenleft}modes{\isacharcolon}\ i\ {\isacharequal}{\isachargreater}\ i\ {\isacharequal}{\isachargreater}\ o\ {\isacharequal}{\isachargreater}\ bool\ as\ concat{\isacharcomma}\isanewline
+\ \ o\ {\isacharequal}{\isachargreater}\ o\ {\isacharequal}{\isachargreater}\ i\ {\isacharequal}{\isachargreater}\ bool\ as\ split{\isacharcomma}\isanewline
+\ \ i\ {\isacharequal}{\isachargreater}\ o\ {\isacharequal}{\isachargreater}\ i\ {\isacharequal}{\isachargreater}\ bool\ as\ suffix{\isacharparenright}\ append\ \isacommand{{\isachardot}}\isamarkupfalse%
+%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isamarkupsubsubsection{Alternative introduction rules%
+}
+\isamarkuptrue%
+%
+\begin{isamarkuptext}%
+Sometimes the introduction rules of an predicate are not executable because they contain
+non-executable constants or specific modes could not be inferred.
+It is also possible that the introduction rules yield a function that loops forever
+due to the execution in a depth-first search manner.
+Therefore, you can declare alternative introduction rules for predicates with the attribute
+\hyperlink{attribute.code-pred-intro}{\mbox{\isa{code{\isacharunderscore}pred{\isacharunderscore}intro}}}.
+For example, the transitive closure is defined by:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+%
+\begin{isamarkuptext}%
+\isa{r\ a\ b\ {\isasymLongrightarrow}\ r\isactrlsup {\isacharplus}\isactrlsup {\isacharplus}\ a\ b}\\
+\noindent \isa{{\isasymlbrakk}r\isactrlsup {\isacharplus}\isactrlsup {\isacharplus}\ a\ b{\isacharsemicolon}\ r\ b\ c{\isasymrbrakk}\ {\isasymLongrightarrow}\ r\isactrlsup {\isacharplus}\isactrlsup {\isacharplus}\ a\ c}%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent These rules do not suit well for executing the transitive closure
+with the mode \isa{{\isacharparenleft}i\ {\isasymRightarrow}\ o\ {\isasymRightarrow}\ bool{\isacharparenright}\ {\isasymRightarrow}\ i\ {\isasymRightarrow}\ o\ {\isasymRightarrow}\ bool}, as the second rule will
+cause an infinite loop in the recursive call.
+This can be avoided using the following alternative rules which are
+declared to the predicate compiler by the attribute \hyperlink{attribute.code-pred-intro}{\mbox{\isa{code{\isacharunderscore}pred{\isacharunderscore}intro}}}:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+\isacommand{lemma}\isamarkupfalse%
+\ {\isacharbrackleft}code{\isacharunderscore}pred{\isacharunderscore}intro{\isacharbrackright}{\isacharcolon}\isanewline
+\ \ {\isachardoublequoteopen}r\ a\ b\ {\isasymLongrightarrow}\ r\isactrlsup {\isacharplus}\isactrlsup {\isacharplus}\ a\ b{\isachardoublequoteclose}\isanewline
+\ \ {\isachardoublequoteopen}r\ a\ b\ {\isasymLongrightarrow}\ r\isactrlsup {\isacharplus}\isactrlsup {\isacharplus}\ b\ c\ {\isasymLongrightarrow}\ r\isactrlsup {\isacharplus}\isactrlsup {\isacharplus}\ a\ c{\isachardoublequoteclose}\isanewline
+\isacommand{by}\isamarkupfalse%
+\ auto%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent After declaring all alternative rules for the transitive closure,
+you invoke \hyperlink{command.code-pred}{\mbox{\isa{\isacommand{code{\isacharunderscore}pred}}}} as usual.
+As you have declared alternative rules for the predicate, you are urged to prove that these
+introduction rules are complete, i.e., that you can derive an elimination rule for the
+alternative rules:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+\isacommand{code{\isacharunderscore}pred}\isamarkupfalse%
+\ tranclp\isanewline
+\isacommand{proof}\isamarkupfalse%
+\ {\isacharminus}\isanewline
+\ \ \isacommand{case}\isamarkupfalse%
+\ tranclp\isanewline
+\ \ \isacommand{from}\isamarkupfalse%
+\ this\ converse{\isacharunderscore}tranclpE{\isacharbrackleft}OF\ this{\isacharparenleft}{\isadigit{1}}{\isacharparenright}{\isacharbrackright}\ \isacommand{show}\isamarkupfalse%
+\ thesis\ \isacommand{by}\isamarkupfalse%
+\ metis\isanewline
+\isacommand{qed}\isamarkupfalse%
+%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent Alternative rules can also be used for constants that have not
+been defined inductively. For example, the lexicographic order which
+is defined as:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+%
+\begin{isamarkuptext}%
+\begin{isabelle}%
+lexord\ r\ {\isasymequiv}\isanewline
+{\isacharbraceleft}{\isacharparenleft}x{\isacharcomma}\ y{\isacharparenright}{\isachardot}\isanewline
+\isaindent{\ }{\isasymexists}a\ v{\isachardot}\ y\ {\isacharequal}\ x\ {\isacharat}\ a\ {\isacharhash}\ v\ {\isasymor}\isanewline
+\isaindent{\ {\isasymexists}a\ v{\isachardot}\ }{\isacharparenleft}{\isasymexists}u\ a\ b\ v\ w{\isachardot}\ {\isacharparenleft}a{\isacharcomma}\ b{\isacharparenright}\ {\isasymin}\ r\ {\isasymand}\ x\ {\isacharequal}\ u\ {\isacharat}\ a\ {\isacharhash}\ v\ {\isasymand}\ y\ {\isacharequal}\ u\ {\isacharat}\ b\ {\isacharhash}\ w{\isacharparenright}{\isacharbraceright}%
+\end{isabelle}%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent To make it executable, you can derive the following two rules and prove the
+elimination rule:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimproof
+%
+\endisadelimproof
+%
+\isatagproof
+%
+\endisatagproof
+{\isafoldproof}%
+%
+\isadelimproof
+%
+\endisadelimproof
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+\isacommand{lemma}\isamarkupfalse%
+\ {\isacharbrackleft}code{\isacharunderscore}pred{\isacharunderscore}intro{\isacharbrackright}{\isacharcolon}\isanewline
+\ \ {\isachardoublequoteopen}append\ xs\ {\isacharparenleft}a\ {\isacharhash}\ v{\isacharparenright}\ ys\ {\isasymLongrightarrow}\ lexord\ r\ {\isacharparenleft}xs{\isacharcomma}\ ys{\isacharparenright}{\isachardoublequoteclose}\isanewline
+\isacommand{lemma}\isamarkupfalse%
+\ {\isacharbrackleft}code{\isacharunderscore}pred{\isacharunderscore}intro{\isacharbrackright}{\isacharcolon}\isanewline
+\ \ {\isachardoublequoteopen}append\ u\ {\isacharparenleft}a\ {\isacharhash}\ v{\isacharparenright}\ xs\ {\isasymLongrightarrow}\ append\ u\ {\isacharparenleft}b\ {\isacharhash}\ w{\isacharparenright}\ ys\ {\isasymLongrightarrow}\ r\ {\isacharparenleft}a{\isacharcomma}\ b{\isacharparenright}\isanewline
+\ \ {\isasymLongrightarrow}\ lexord\ r\ {\isacharparenleft}xs{\isacharcomma}\ ys{\isacharparenright}{\isachardoublequoteclose}\isanewline
+\isacommand{code{\isacharunderscore}pred}\isamarkupfalse%
+\ lexord%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isamarkupsubsubsection{Options for values%
+}
+\isamarkuptrue%
+%
+\begin{isamarkuptext}%
+In the presence of higher-order predicates, multiple modes for some predicate could be inferred
+that are not disambiguated by the pattern of the set comprehension.
+To disambiguate the modes for the arguments of a predicate, you can state
+the modes explicitly in the \hyperlink{command.values}{\mbox{\isa{\isacommand{values}}}} command.
+Consider the simple predicate \isa{succ}:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+\isacommand{inductive}\isamarkupfalse%
+\ succ\ {\isacharcolon}{\isacharcolon}\ {\isachardoublequoteopen}nat\ {\isasymRightarrow}\ nat\ {\isasymRightarrow}\ bool{\isachardoublequoteclose}\isanewline
+\isakeyword{where}\isanewline
+\ \ {\isachardoublequoteopen}succ\ {\isadigit{0}}\ {\isacharparenleft}Suc\ {\isadigit{0}}{\isacharparenright}{\isachardoublequoteclose}\isanewline
+{\isacharbar}\ {\isachardoublequoteopen}succ\ x\ y\ {\isasymLongrightarrow}\ succ\ {\isacharparenleft}Suc\ x{\isacharparenright}\ {\isacharparenleft}Suc\ y{\isacharparenright}{\isachardoublequoteclose}\isanewline
+\isanewline
+\isacommand{code{\isacharunderscore}pred}\isamarkupfalse%
+\ succ%
+\isadelimproof
+\ %
+\endisadelimproof
+%
+\isatagproof
+\isacommand{{\isachardot}}\isamarkupfalse%
+%
+\endisatagproof
+{\isafoldproof}%
+%
+\isadelimproof
+%
+\endisadelimproof
+%
+\begin{isamarkuptext}%
+\noindent For this, the predicate compiler can infer modes \isa{o\ {\isasymRightarrow}\ o\ {\isasymRightarrow}\ bool}, \isa{i\ {\isasymRightarrow}\ o\ {\isasymRightarrow}\ bool},
+ \isa{o\ {\isasymRightarrow}\ i\ {\isasymRightarrow}\ bool} and \isa{i\ {\isasymRightarrow}\ i\ {\isasymRightarrow}\ bool}.
+The invocation of \hyperlink{command.values}{\mbox{\isa{\isacommand{values}}}} \isa{{\isacharbraceleft}n{\isachardot}\ tranclp\ succ\ {\isadigit{1}}{\isadigit{0}}\ n{\isacharbraceright}} loops, as multiple
+modes for the predicate \isa{succ} are possible and here the first mode \isa{o\ {\isasymRightarrow}\ o\ {\isasymRightarrow}\ bool}
+is chosen. To choose another mode for the argument, you can declare the mode for the argument between
+the \hyperlink{command.values}{\mbox{\isa{\isacommand{values}}}} and the number of elements.%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+\isacommand{values}\isamarkupfalse%
+\ {\isacharbrackleft}mode{\isacharcolon}\ i\ {\isacharequal}{\isachargreater}\ o\ {\isacharequal}{\isachargreater}\ bool{\isacharbrackright}\ {\isadigit{2}}{\isadigit{0}}\ {\isachardoublequoteopen}{\isacharbraceleft}n{\isachardot}\ tranclp\ succ\ {\isadigit{1}}{\isadigit{0}}\ n{\isacharbraceright}{\isachardoublequoteclose}\isanewline
+\isacommand{values}\isamarkupfalse%
+\ {\isacharbrackleft}mode{\isacharcolon}\ o\ {\isacharequal}{\isachargreater}\ i\ {\isacharequal}{\isachargreater}\ bool{\isacharbrackright}\ {\isadigit{1}}{\isadigit{0}}\ {\isachardoublequoteopen}{\isacharbraceleft}n{\isachardot}\ tranclp\ succ\ n\ {\isadigit{1}}{\isadigit{0}}{\isacharbraceright}{\isachardoublequoteclose}%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isamarkupsubsubsection{Embedding into functional code within Isabelle/HOL%
+}
+\isamarkuptrue%
+%
+\begin{isamarkuptext}%
+To embed the computation of an inductive predicate into functions that are defined in Isabelle/HOL,
+you have a number of options:
+\begin{itemize}
+\item You want to use the first-order predicate with the mode
+ where all arguments are input. Then you can use the predicate directly, e.g.
+\begin{quote}
+ \isa{valid{\isacharunderscore}suffix\ ys\ zs\ {\isacharequal}}\\
+ \isa{{\isacharparenleft}if\ append\ {\isacharbrackleft}Suc\ {\isadigit{0}}{\isacharcomma}\ {\isadigit{2}}{\isacharbrackright}\ ys\ zs\ then\ Some\ ys\ else\ None{\isacharparenright}}
+\end{quote}
+\item If you know that the execution returns only one value (it is deterministic), then you can
+ use the combinator \isa{Predicate{\isachardot}the}, e.g., a functional concatenation of lists
+ is defined with
+\begin{quote}
+ \isa{functional{\isacharunderscore}concat\ xs\ ys\ {\isacharequal}\ Predicate{\isachardot}the\ {\isacharparenleft}append{\isacharunderscore}i{\isacharunderscore}i{\isacharunderscore}o\ xs\ ys{\isacharparenright}}
+\end{quote}
+ Note that if the evaluation does not return a unique value, it raises a run-time error
+ \isa{not{\isacharunderscore}unique}.
+\end{itemize}%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isamarkupsubsubsection{Further Examples%
+}
+\isamarkuptrue%
+%
+\begin{isamarkuptext}%
+Further examples for compiling inductive predicates can be found in
+the \isa{HOL{\isacharslash}ex{\isacharslash}Predicate{\isacharunderscore}Compile{\isacharunderscore}ex} theory file.
+There are also some examples in the Archive of Formal Proofs, notably
+in the \isa{POPLmark{\isacharminus}deBruijn} and the \isa{FeatherweightJava} sessions.%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
\isadelimtheory
%
\endisadelimtheory
@@ -982,7 +1434,7 @@
%
\endisadelimtheory
\isanewline
-\ \end{isabellebody}%
+\end{isabellebody}%
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "root"
--- a/doc-src/Codegen/codegen.tex Sun Nov 29 12:56:30 2009 +1100
+++ b/doc-src/Codegen/codegen.tex Mon Nov 30 08:08:31 2009 +0100
@@ -13,7 +13,7 @@
\title{\includegraphics[scale=0.5]{isabelle_isar}
\\[4ex] Code generation from Isabelle/HOL theories}
-\author{\emph{Florian Haftmann}}
+\author{\emph{Florian Haftmann with contributions from Lukas Bulwahn}}
\begin{document}
--- a/doc-src/manual.bib Sun Nov 29 12:56:30 2009 +1100
+++ b/doc-src/manual.bib Mon Nov 30 08:08:31 2009 +0100
@@ -172,6 +172,14 @@
title = {Calculational reasoning revisited --- an {Isabelle/Isar} experience},
crossref = {tphols2001}}
+@inProceedings{Berghofer-Bulwahn-Haftmann:2009:TPHOL,
+ author = {Berghofer, Stefan and Bulwahn, Lukas and Haftmann, Florian},
+ booktitle = {Theorem Proving in Higher Order Logics},
+ pages = {131--146},
+ title = {Turning Inductive into Equational Specifications},
+ year = {2009}
+}
+
@INPROCEEDINGS{Berghofer-Nipkow:2000:TPHOL,
crossref = "tphols2000",
title = "Proof terms for simply typed higher order logic",
--- a/etc/settings Sun Nov 29 12:56:30 2009 +1100
+++ b/etc/settings Mon Nov 30 08:08:31 2009 +0100
@@ -208,21 +208,9 @@
## Set HOME only for tools you have installed!
# External provers
-E_HOME=$(choosefrom \
- "$ISABELLE_HOME/contrib/E/$ML_PLATFORM" \
- "$ISABELLE_HOME/../E/$ML_PLATFORM" \
- "/usr/local/E/$ML_PLATFORM" \
- "")
-VAMPIRE_HOME=$(choosefrom \
- "$ISABELLE_HOME/contrib/vampire/$ML_PLATFORM" \
- "$ISABELLE_HOME/../vampire/$ML_PLATFORM" \
- "/usr/local/vampire/$ML_PLATFORM" \
- "")
-SPASS_HOME=$(choosefrom \
- "$ISABELLE_HOME/contrib/spass/$ML_PLATFORM/bin" \
- "$ISABELLE_HOME/../spass/$ML_PLATFORM/bin" \
- "/usr/local/spass/$ML_PLATFORM" \
- "")
+#E_HOME=/usr/local/bin
+#SPASS_HOME=/usr/local/bin
+#VAMPIRE_HOME=/usr/local/bin
# HOL4 proof objects (cf. Isabelle/src/HOL/Import)
#HOL4_PROOFS="$ISABELLE_HOME_USER/proofs:$ISABELLE_HOME/proofs"
--- a/lib/Tools/findlogics Sun Nov 29 12:56:30 2009 +1100
+++ b/lib/Tools/findlogics Mon Nov 30 08:08:31 2009 +0100
@@ -39,4 +39,4 @@
done
done
-echo $({ for L in ${LOGICS[@]}; do echo "$L"; done; } | sort | uniq)
+echo $({ for L in "${LOGICS[@]}"; do echo "$L"; done; } | sort | uniq)
--- a/src/FOLP/simp.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/FOLP/simp.ML Mon Nov 30 08:08:31 2009 +0100
@@ -419,11 +419,11 @@
if lhs_is_NORM(thm,i) then (ss, res1(thm,trans_norms,i), anet,ats,cs)
else case Seq.pull(cong_tac i thm) of
SOME(thm',_) =>
- let val ps = prems_of thm and ps' = prems_of thm';
+ let val ps = prems_of thm
+ and ps' = prems_of thm';
val n = length(ps')-length(ps);
val a = length(Logic.strip_assums_hyp(List.nth(ps,i-1)))
- val l = map (fn p => length(Logic.strip_assums_hyp(p)))
- (Library.take(n,Library.drop(i-1,ps')));
+ val l = map (length o Logic.strip_assums_hyp) (take n (drop (i-1) ps'));
in (simp_refl(rev(l),a,REW::ss),thm',anet,ats,cs) end
| NONE => (REW::ss,thm,anet,ats,cs);
@@ -535,7 +535,7 @@
fun Pinst(f,fT,(eq,eqT),k,i,T,yik,Ts) =
let fun xn_list(x,n) =
let val ixs = map_range (fn i => (x^(radixstring(26,"a",i)),0)) (n - 1);
- in ListPair.map eta_Var (ixs, Library.take(n+1,Ts)) end
+ in ListPair.map eta_Var (ixs, take (n+1) Ts) end
val lhs = list_comb(f,xn_list("X",k-1))
val rhs = list_comb(f,xn_list("X",i-1) @ [Bound 0] @ yik)
in Abs("", T, Const(eq,[fT,fT]--->eqT) $ lhs $ rhs) end;
--- a/src/HOL/Bali/AxExample.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Bali/AxExample.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1,11 +1,12 @@
(* Title: HOL/Bali/AxExample.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* Example of a proof based on the Bali axiomatic semantics *}
-theory AxExample imports AxSem Example begin
+theory AxExample
+imports AxSem Example
+begin
constdefs
arr_inv :: "st \<Rightarrow> bool"
--- a/src/HOL/Bali/Basis.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Bali/Basis.thy Mon Nov 30 08:08:31 2009 +0100
@@ -216,8 +216,8 @@
In1l :: "'al \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
In1r :: "'ar \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
translations
- "In1l e" == "In1 (Inl e)"
- "In1r c" == "In1 (Inr c)"
+ "In1l e" == "In1 (CONST Inl e)"
+ "In1r c" == "In1 (CONST Inr c)"
syntax the_In1l :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'al"
the_In1r :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'ar"
@@ -233,7 +233,7 @@
(* e.g. lemmas is_stmt_rews = is_stmt_def [of "In1l x", simplified] *)
translations
- "option"<= (type) "Datatype.option"
+ "option"<= (type) "Option.option"
"list" <= (type) "List.list"
"sum3" <= (type) "Basis.sum3"
--- a/src/HOL/Bali/Example.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Bali/Example.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1,10 +1,11 @@
(* Title: HOL/Bali/Example.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* Example Bali program *}
-theory Example imports Eval WellForm begin
+theory Example
+imports Eval WellForm
+begin
text {*
The following example Bali program includes:
@@ -1235,24 +1236,24 @@
translations
"obj_a" <= "\<lparr>tag=Arr (PrimT Boolean) (CONST two)
- ,values=CONST empty(Inr 0\<mapsto>Bool False)(Inr (CONST one)\<mapsto>Bool False)\<rparr>"
+ ,values=CONST empty(CONST Inr 0\<mapsto>Bool False)(CONST Inr (CONST one)\<mapsto>Bool False)\<rparr>"
"obj_b" <= "\<lparr>tag=CInst (CONST Ext)
- ,values=(CONST empty(Inl (CONST vee, CONST Base)\<mapsto>Null )
- (Inl (CONST vee, CONST Ext )\<mapsto>Intg 0))\<rparr>"
+ ,values=(CONST empty(CONST Inl (CONST vee, CONST Base)\<mapsto>Null )
+ (CONST Inl (CONST vee, CONST Ext )\<mapsto>Intg 0))\<rparr>"
"obj_c" == "\<lparr>tag=CInst (SXcpt NullPointer),values=CONST empty\<rparr>"
- "arr_N" == "CONST empty(Inl (CONST arr, CONST Base)\<mapsto>Null)"
- "arr_a" == "CONST empty(Inl (CONST arr, CONST Base)\<mapsto>Addr a)"
- "globs1" == "CONST empty(Inr (CONST Ext) \<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)
- (Inr (CONST Base) \<mapsto>\<lparr>tag=CONST undefined, values=arr_N\<rparr>)
- (Inr Object\<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)"
- "globs2" == "CONST empty(Inr (CONST Ext) \<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)
- (Inr Object\<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)
- (Inl a\<mapsto>obj_a)
- (Inr (CONST Base) \<mapsto>\<lparr>tag=CONST undefined, values=arr_a\<rparr>)"
- "globs3" == "globs2(Inl b\<mapsto>obj_b)"
- "globs8" == "globs3(Inl c\<mapsto>obj_c)"
+ "arr_N" == "CONST empty(CONST Inl (CONST arr, CONST Base)\<mapsto>Null)"
+ "arr_a" == "CONST empty(CONST Inl (CONST arr, CONST Base)\<mapsto>Addr a)"
+ "globs1" == "CONST empty(CONST Inr (CONST Ext) \<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)
+ (CONST Inr (CONST Base) \<mapsto>\<lparr>tag=CONST undefined, values=arr_N\<rparr>)
+ (CONST Inr Object\<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)"
+ "globs2" == "CONST empty(CONST Inr (CONST Ext) \<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)
+ (CONST Inr Object\<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)
+ (CONST Inl a\<mapsto>obj_a)
+ (CONST Inr (CONST Base) \<mapsto>\<lparr>tag=CONST undefined, values=arr_a\<rparr>)"
+ "globs3" == "globs2(CONST Inl b\<mapsto>obj_b)"
+ "globs8" == "globs3(CONST Inl c\<mapsto>obj_c)"
"locs3" == "CONST empty(VName (CONST e)\<mapsto>Addr b)"
- "locs4" == "CONST empty(VName (CONST z)\<mapsto>Null)(Inr()\<mapsto>Addr b)"
+ "locs4" == "CONST empty(VName (CONST z)\<mapsto>Null)(CONST Inr()\<mapsto>Addr b)"
"locs8" == "locs3(VName (CONST z)\<mapsto>Addr c)"
"s0" == " st (CONST empty) (CONST empty)"
"s0'" == " Norm s0"
--- a/src/HOL/Bali/State.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Bali/State.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1,10 +1,11 @@
(* Title: HOL/Bali/State.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* State for evaluation of Java expressions and statements *}
-theory State imports DeclConcepts begin
+theory State
+imports DeclConcepts
+begin
text {*
design issues:
@@ -138,8 +139,8 @@
Stat :: "qtname \<Rightarrow> oref"
translations
- "Heap" => "Inl"
- "Stat" => "Inr"
+ "Heap" => "CONST Inl"
+ "Stat" => "CONST Inr"
"oref" <= (type) "loc + qtname"
constdefs
@@ -328,7 +329,7 @@
init_class_obj :: "prog \<Rightarrow> qtname \<Rightarrow> st \<Rightarrow> st"
translations
- "init_class_obj G C" == "init_obj G CONST undefined (Inr C)"
+ "init_class_obj G C" == "init_obj G CONST undefined (CONST Inr C)"
lemma gupd_def2 [simp]: "gupd(r\<mapsto>obj) (st g l) = st (g(r\<mapsto>obj)) l"
apply (unfold gupd_def)
--- a/src/HOL/Bali/WellType.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Bali/WellType.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1,10 +1,11 @@
(* Title: HOL/Bali/WellType.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* Well-typedness of Java programs *}
-theory WellType imports DeclConcepts begin
+theory WellType
+imports DeclConcepts
+begin
text {*
improvements over Java Specification 1.0:
@@ -443,10 +444,10 @@
translations
"E\<turnstile>t\<Colon> T" == "E,empty_dt\<Turnstile>t\<Colon> T"
- "E\<turnstile>s\<Colon>\<surd>" == "E\<turnstile>In1r s\<Colon>Inl (PrimT Void)"
- "E\<turnstile>e\<Colon>-T" == "E\<turnstile>In1l e\<Colon>Inl T"
- "E\<turnstile>e\<Colon>=T" == "E\<turnstile>In2 e\<Colon>Inl T"
- "E\<turnstile>e\<Colon>\<doteq>T" == "E\<turnstile>In3 e\<Colon>Inr T"
+ "E\<turnstile>s\<Colon>\<surd>" == "E\<turnstile>In1r s\<Colon>CONST Inl (PrimT Void)"
+ "E\<turnstile>e\<Colon>-T" == "E\<turnstile>In1l e\<Colon>CONST Inl T"
+ "E\<turnstile>e\<Colon>=T" == "E\<turnstile>In2 e\<Colon>CONST Inl T"
+ "E\<turnstile>e\<Colon>\<doteq>T" == "E\<turnstile>In3 e\<Colon>CONST Inr T"
declare not_None_eq [simp del]
--- a/src/HOL/Datatype.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Datatype.thy Mon Nov 30 08:08:31 2009 +0100
@@ -8,9 +8,16 @@
header {* Analogues of the Cartesian Product and Disjoint Sum for Datatypes *}
theory Datatype
-imports Nat Product_Type
+imports Product_Type Sum_Type Nat
+uses
+ ("Tools/Datatype/datatype_rep_proofs.ML")
+ ("Tools/Datatype/datatype.ML")
+ ("Tools/inductive_realizer.ML")
+ ("Tools/Datatype/datatype_realizer.ML")
begin
+subsection {* The datatype universe *}
+
typedef (Node)
('a,'b) node = "{p. EX f x k. p = (f::nat=>'b+nat, x::'a+nat) & f k = Inr 0}"
--{*it is a subtype of @{text "(nat=>'b+nat) * ('a+nat)"}*}
@@ -513,75 +520,13 @@
hide (open) type node item
hide (open) const Push Node Atom Leaf Numb Lim Split Case
-
-section {* Datatypes *}
-
-subsection {* Representing sums *}
-
-rep_datatype (sum) Inl Inr
-proof -
- fix P
- fix s :: "'a + 'b"
- assume x: "\<And>x\<Colon>'a. P (Inl x)" and y: "\<And>y\<Colon>'b. P (Inr y)"
- then show "P s" by (auto intro: sumE [of s])
-qed simp_all
-
-lemma sum_case_KK[simp]: "sum_case (%x. a) (%x. a) = (%x. a)"
- by (rule ext) (simp split: sum.split)
-
-lemma surjective_sum: "sum_case (%x::'a. f (Inl x)) (%y::'b. f (Inr y)) s = f(s)"
- apply (rule_tac s = s in sumE)
- apply (erule ssubst)
- apply (rule sum.cases(1))
- apply (erule ssubst)
- apply (rule sum.cases(2))
- done
-
-lemma sum_case_weak_cong: "s = t ==> sum_case f g s = sum_case f g t"
- -- {* Prevents simplification of @{text f} and @{text g}: much faster. *}
- by simp
+use "Tools/Datatype/datatype_rep_proofs.ML"
+use "Tools/Datatype/datatype.ML"
-lemma sum_case_inject:
- "sum_case f1 f2 = sum_case g1 g2 ==> (f1 = g1 ==> f2 = g2 ==> P) ==> P"
-proof -
- assume a: "sum_case f1 f2 = sum_case g1 g2"
- assume r: "f1 = g1 ==> f2 = g2 ==> P"
- show P
- apply (rule r)
- apply (rule ext)
- apply (cut_tac x = "Inl x" in a [THEN fun_cong], simp)
- apply (rule ext)
- apply (cut_tac x = "Inr x" in a [THEN fun_cong], simp)
- done
-qed
-
-constdefs
- Suml :: "('a => 'c) => 'a + 'b => 'c"
- "Suml == (%f. sum_case f undefined)"
-
- Sumr :: "('b => 'c) => 'a + 'b => 'c"
- "Sumr == sum_case undefined"
+use "Tools/inductive_realizer.ML"
+setup InductiveRealizer.setup
-lemma [code]:
- "Suml f (Inl x) = f x"
- by (simp add: Suml_def)
-
-lemma [code]:
- "Sumr f (Inr x) = f x"
- by (simp add: Sumr_def)
-
-lemma Suml_inject: "Suml f = Suml g ==> f = g"
- by (unfold Suml_def) (erule sum_case_inject)
-
-lemma Sumr_inject: "Sumr f = Sumr g ==> f = g"
- by (unfold Sumr_def) (erule sum_case_inject)
-
-primrec Projl :: "'a + 'b => 'a"
-where Projl_Inl: "Projl (Inl x) = x"
-
-primrec Projr :: "'a + 'b => 'b"
-where Projr_Inr: "Projr (Inr x) = x"
-
-hide (open) const Suml Sumr Projl Projr
+use "Tools/Datatype/datatype_realizer.ML"
+setup DatatypeRealizer.setup
end
--- a/src/HOL/Finite_Set.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Finite_Set.thy Mon Nov 30 08:08:31 2009 +0100
@@ -6,7 +6,7 @@
header {* Finite sets *}
theory Finite_Set
-imports Nat Product_Type Power
+imports Power Product_Type Sum_Type
begin
subsection {* Definition and basic properties *}
@@ -1157,8 +1157,8 @@
==> setsum (%x. f x) A = setsum (%x. g x) B"
by(fastsimp simp: simp_implies_def setsum_def intro: comm_monoid_add.fold_image_cong)
-lemma setsum_cong2: "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> f x = g x\<rbrakk> \<Longrightarrow> setsum f A = setsum g A";
-by (rule setsum_cong[OF refl], auto);
+lemma setsum_cong2: "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> f x = g x\<rbrakk> \<Longrightarrow> setsum f A = setsum g A"
+by (rule setsum_cong[OF refl], auto)
lemma setsum_reindex_cong:
"[|inj_on f A; B = f ` A; !!a. a:A \<Longrightarrow> g a = h (f a)|]
--- a/src/HOL/Import/hol4rews.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Import/hol4rews.ML Mon Nov 30 08:08:31 2009 +0100
@@ -480,7 +480,7 @@
then
let
val paths = Long_Name.explode isa
- val i = Library.drop(length paths - 2,paths)
+ val i = drop (length paths - 2) paths
in
case i of
[seg,con] => output_thy ^ "." ^ seg ^ "." ^ con
--- a/src/HOL/Inductive.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Inductive.thy Mon Nov 30 08:08:31 2009 +0100
@@ -5,17 +5,16 @@
header {* Knaster-Tarski Fixpoint Theorem and inductive definitions *}
theory Inductive
-imports Lattices Sum_Type
+imports Complete_Lattice
uses
("Tools/inductive.ML")
"Tools/dseq.ML"
("Tools/inductive_codegen.ML")
- ("Tools/Datatype/datatype_aux.ML")
- ("Tools/Datatype/datatype_prop.ML")
- ("Tools/Datatype/datatype_rep_proofs.ML")
+ "Tools/Datatype/datatype_aux.ML"
+ "Tools/Datatype/datatype_prop.ML"
+ "Tools/Datatype/datatype_case.ML"
("Tools/Datatype/datatype_abs_proofs.ML")
- ("Tools/Datatype/datatype_case.ML")
- ("Tools/Datatype/datatype.ML")
+ ("Tools/Datatype/datatype_data.ML")
("Tools/old_primrec.ML")
("Tools/primrec.ML")
("Tools/Datatype/datatype_codegen.ML")
@@ -277,13 +276,9 @@
text {* Package setup. *}
-use "Tools/Datatype/datatype_aux.ML"
-use "Tools/Datatype/datatype_prop.ML"
-use "Tools/Datatype/datatype_rep_proofs.ML"
use "Tools/Datatype/datatype_abs_proofs.ML"
-use "Tools/Datatype/datatype_case.ML"
-use "Tools/Datatype/datatype.ML"
-setup Datatype.setup
+use "Tools/Datatype/datatype_data.ML"
+setup Datatype_Data.setup
use "Tools/old_primrec.ML"
use "Tools/primrec.ML"
@@ -306,7 +301,7 @@
fun fun_tr ctxt [cs] =
let
val x = Free (Name.variant (Term.add_free_names cs []) "x", dummyT);
- val ft = DatatypeCase.case_tr true Datatype.info_of_constr
+ val ft = DatatypeCase.case_tr true Datatype_Data.info_of_constr
ctxt [x, cs]
in lambda x ft end
in [("_lam_pats_syntax", fun_tr)] end
--- a/src/HOL/IsaMakefile Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/IsaMakefile Mon Nov 30 08:08:31 2009 +0100
@@ -168,10 +168,11 @@
Tools/Datatype/datatype_aux.ML \
Tools/Datatype/datatype_case.ML \
Tools/Datatype/datatype_codegen.ML \
- Tools/Datatype/datatype.ML \
+ Tools/Datatype/datatype_data.ML \
Tools/Datatype/datatype_prop.ML \
Tools/Datatype/datatype_realizer.ML \
Tools/Datatype/datatype_rep_proofs.ML \
+ Tools/Datatype/datatype.ML \
Tools/dseq.ML \
Tools/Function/context_tree.ML \
Tools/Function/decompose.ML \
@@ -848,20 +849,20 @@
MicroJava/J/JListExample.thy MicroJava/JVM/JVMExec.thy \
MicroJava/JVM/JVMInstructions.thy MicroJava/JVM/JVMState.thy \
MicroJava/JVM/JVMExecInstr.thy MicroJava/JVM/JVMListExample.thy \
- MicroJava/JVM/JVMExceptions.thy MicroJava/BV/BVSpec.thy \
+ MicroJava/JVM/JVMExceptions.thy MicroJava/DFA/Abstract_BV.thy \
+ MicroJava/DFA/Err.thy MicroJava/DFA/Kildall.thy \
+ MicroJava/DFA/LBVComplete.thy MicroJava/DFA/LBVCorrect.thy \
+ MicroJava/DFA/LBVSpec.thy MicroJava/DFA/Listn.thy \
+ MicroJava/DFA/Opt.thy MicroJava/DFA/Product.thy \
+ MicroJava/DFA/SemilatAlg.thy MicroJava/DFA/Semilat.thy \
+ MicroJava/DFA/Semilattices.thy MicroJava/DFA/Typing_Framework_err.thy \
+ MicroJava/DFA/Typing_Framework.thy MicroJava/BV/BVSpec.thy \
MicroJava/BV/BVSpecTypeSafe.thy MicroJava/BV/Correct.thy \
- MicroJava/BV/Err.thy MicroJava/BV/JType.thy MicroJava/BV/JVM.thy \
- MicroJava/BV/JVMType.thy MicroJava/BV/Kildall.thy \
- MicroJava/BV/LBVSpec.thy MicroJava/BV/Listn.thy MicroJava/BV/Opt.thy \
- MicroJava/BV/Product.thy MicroJava/BV/Semilat.thy \
+ MicroJava/BV/JType.thy MicroJava/BV/JVM.thy MicroJava/BV/JVMType.thy \
MicroJava/BV/Effect.thy MicroJava/BV/EffectMono.thy \
- MicroJava/BV/Typing_Framework.thy \
- MicroJava/BV/Typing_Framework_err.thy \
MicroJava/BV/Typing_Framework_JVM.thy MicroJava/BV/BVExample.thy \
- MicroJava/BV/LBVSpec.thy MicroJava/BV/LBVCorrect.thy \
- MicroJava/BV/LBVComplete.thy MicroJava/BV/LBVJVM.thy \
- MicroJava/document/root.bib MicroJava/document/root.tex \
- MicroJava/document/introduction.tex
+ MicroJava/BV/LBVJVM.thy MicroJava/document/root.bib \
+ MicroJava/document/root.tex MicroJava/document/introduction.tex
@$(ISABELLE_TOOL) usedir -g true $(OUT)/HOL MicroJava
--- a/src/HOL/Library/Sum_Of_Squares/sum_of_squares.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Library/Sum_Of_Squares/sum_of_squares.ML Mon Nov 30 08:08:31 2009 +0100
@@ -537,8 +537,8 @@
fun token s =
Scan.repeat ($$ " ") |-- word s --| Scan.repeat ($$ " ")
val numeral = Scan.one isnum
- val decimalint = Scan.repeat numeral >> (rat_of_string o implode)
- val decimalfrac = Scan.repeat numeral
+ val decimalint = Scan.repeat1 numeral >> (rat_of_string o implode)
+ val decimalfrac = Scan.repeat1 numeral
>> (fn s => rat_of_string(implode s) // pow10 (length s))
val decimalsig =
decimalint -- Scan.option (Scan.$$ "." |-- decimalfrac)
--- a/src/HOL/MicroJava/BV/Altern.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/BV/Altern.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1,15 +1,12 @@
(* Title: HOL/MicroJava/BV/Altern.thy
- ID: $Id$
Author: Martin Strecker
*)
-
-(* Alternative definition of well-typing of bytecode,
- used in compiler type correctness proof *)
+header {* Alternative definition of well-typing of bytecode, used in compiler type correctness proof *}
-
-theory Altern imports BVSpec begin
-
+theory Altern
+imports BVSpec
+begin
constdefs
check_type :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> JVMType.state \<Rightarrow> bool"
--- a/src/HOL/MicroJava/BV/BVExample.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/BV/BVExample.thy Mon Nov 30 08:08:31 2009 +0100
@@ -66,27 +66,28 @@
text {* The subclass releation spelled out: *}
lemma subcls1:
- "subcls1 E = (\<lambda>C D. (C, D) \<in> {(list_name,Object), (test_name,Object), (Xcpt NullPointer, Object),
- (Xcpt ClassCast, Object), (Xcpt OutOfMemory, Object)})"
+ "subcls1 E = {(list_name,Object), (test_name,Object), (Xcpt NullPointer, Object),
+ (Xcpt ClassCast, Object), (Xcpt OutOfMemory, Object)}"
apply (simp add: subcls1_def2)
apply (simp add: name_defs class_defs system_defs E_def class_def)
-apply (auto simp: expand_fun_eq)
+apply (simp add: Sigma_def)
+apply auto
done
text {* The subclass relation is acyclic; hence its converse is well founded: *}
lemma notin_rtrancl:
- "r\<^sup>*\<^sup>* a b \<Longrightarrow> a \<noteq> b \<Longrightarrow> (\<And>y. \<not> r a y) \<Longrightarrow> False"
- by (auto elim: converse_rtranclpE)
+ "(a, b) \<in> r\<^sup>* \<Longrightarrow> a \<noteq> b \<Longrightarrow> (\<And>y. (a, y) \<notin> r) \<Longrightarrow> False"
+ by (auto elim: converse_rtranclE)
-lemma acyclic_subcls1_E: "acyclicP (subcls1 E)"
- apply (rule acyclicI [to_pred])
+lemma acyclic_subcls1_E: "acyclic (subcls1 E)"
+ apply (rule acyclicI)
apply (simp add: subcls1)
- apply (auto dest!: tranclpD)
+ apply (auto dest!: tranclD)
apply (auto elim!: notin_rtrancl simp add: name_defs distinct_classes)
done
-lemma wf_subcls1_E: "wfP ((subcls1 E)\<inverse>\<inverse>)"
- apply (rule finite_acyclic_wf_converse [to_pred])
+lemma wf_subcls1_E: "wf ((subcls1 E)\<inverse>)"
+ apply (rule finite_acyclic_wf_converse)
apply (simp add: subcls1 del: insert_iff)
apply (rule acyclic_subcls1_E)
done
--- a/src/HOL/MicroJava/BV/BVNoTypeError.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/BV/BVNoTypeError.thy Mon Nov 30 08:08:31 2009 +0100
@@ -4,7 +4,9 @@
header {* \isaheader{Welltyped Programs produce no Type Errors} *}
-theory BVNoTypeError imports "../JVM/JVMDefensive" BVSpecTypeSafe begin
+theory BVNoTypeError
+imports "../JVM/JVMDefensive" BVSpecTypeSafe
+begin
text {*
Some simple lemmas about the type testing functions of the
--- a/src/HOL/MicroJava/BV/BVSpec.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/BV/BVSpec.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1,8 +1,6 @@
(* Title: HOL/MicroJava/BV/BVSpec.thy
- ID: $Id$
Author: Cornelia Pusch, Gerwin Klein
Copyright 1999 Technische Universitaet Muenchen
-
*)
header {* \isaheader{The Bytecode Verifier}\label{sec:BVSpec} *}
--- a/src/HOL/MicroJava/BV/Correct.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/BV/Correct.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1,15 +1,13 @@
-
(* Title: HOL/MicroJava/BV/Correct.thy
- ID: $Id$
Author: Cornelia Pusch, Gerwin Klein
Copyright 1999 Technische Universitaet Muenchen
-
-The invariant for the type safety proof.
*)
header {* \isaheader{BV Type Safety Invariant} *}
-theory Correct imports BVSpec "../JVM/JVMExec" begin
+theory Correct
+imports BVSpec "../JVM/JVMExec"
+begin
constdefs
approx_val :: "[jvm_prog,aheap,val,ty err] \<Rightarrow> bool"
--- a/src/HOL/MicroJava/BV/Effect.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/BV/Effect.thy Mon Nov 30 08:08:31 2009 +0100
@@ -9,7 +9,6 @@
imports JVMType "../JVM/JVMExceptions"
begin
-
types
succ_type = "(p_count \<times> state_type option) list"
--- a/src/HOL/MicroJava/BV/EffectMono.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/BV/EffectMono.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1,13 +1,13 @@
(* Title: HOL/MicroJava/BV/EffMono.thy
- ID: $Id$
Author: Gerwin Klein
Copyright 2000 Technische Universitaet Muenchen
*)
header {* \isaheader{Monotonicity of eff and app} *}
-theory EffectMono imports Effect begin
-
+theory EffectMono
+imports Effect
+begin
lemma PrimT_PrimT: "(G \<turnstile> xb \<preceq> PrimT p) = (xb = PrimT p)"
by (auto elim: widen.cases)
--- a/src/HOL/MicroJava/BV/Err.thy Sun Nov 29 12:56:30 2009 +1100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,353 +0,0 @@
-(* Title: HOL/MicroJava/BV/Err.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 2000 TUM
-
-The error type
-*)
-
-header {* \isaheader{The Error Type} *}
-
-theory Err
-imports Semilat
-begin
-
-datatype 'a err = Err | OK 'a
-
-types 'a ebinop = "'a \<Rightarrow> 'a \<Rightarrow> 'a err"
- 'a esl = "'a set * 'a ord * 'a ebinop"
-
-consts
- ok_val :: "'a err \<Rightarrow> 'a"
-primrec
- "ok_val (OK x) = x"
-
-constdefs
- lift :: "('a \<Rightarrow> 'b err) \<Rightarrow> ('a err \<Rightarrow> 'b err)"
-"lift f e == case e of Err \<Rightarrow> Err | OK x \<Rightarrow> f x"
-
- lift2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c err) \<Rightarrow> 'a err \<Rightarrow> 'b err \<Rightarrow> 'c err"
-"lift2 f e1 e2 ==
- case e1 of Err \<Rightarrow> Err
- | OK x \<Rightarrow> (case e2 of Err \<Rightarrow> Err | OK y \<Rightarrow> f x y)"
-
- le :: "'a ord \<Rightarrow> 'a err ord"
-"le r e1 e2 ==
- case e2 of Err \<Rightarrow> True |
- OK y \<Rightarrow> (case e1 of Err \<Rightarrow> False | OK x \<Rightarrow> x <=_r y)"
-
- sup :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a err \<Rightarrow> 'b err \<Rightarrow> 'c err)"
-"sup f == lift2(%x y. OK(x +_f y))"
-
- err :: "'a set \<Rightarrow> 'a err set"
-"err A == insert Err {x . ? y:A. x = OK y}"
-
- esl :: "'a sl \<Rightarrow> 'a esl"
-"esl == %(A,r,f). (A,r, %x y. OK(f x y))"
-
- sl :: "'a esl \<Rightarrow> 'a err sl"
-"sl == %(A,r,f). (err A, le r, lift2 f)"
-
-syntax
- err_semilat :: "'a esl \<Rightarrow> bool"
-translations
-"err_semilat L" == "semilat(Err.sl L)"
-
-
-consts
- strict :: "('a \<Rightarrow> 'b err) \<Rightarrow> ('a err \<Rightarrow> 'b err)"
-primrec
- "strict f Err = Err"
- "strict f (OK x) = f x"
-
-lemma strict_Some [simp]:
- "(strict f x = OK y) = (\<exists> z. x = OK z \<and> f z = OK y)"
- by (cases x, auto)
-
-lemma not_Err_eq:
- "(x \<noteq> Err) = (\<exists>a. x = OK a)"
- by (cases x) auto
-
-lemma not_OK_eq:
- "(\<forall>y. x \<noteq> OK y) = (x = Err)"
- by (cases x) auto
-
-lemma unfold_lesub_err:
- "e1 <=_(le r) e2 == le r e1 e2"
- by (simp add: lesub_def)
-
-lemma le_err_refl:
- "!x. x <=_r x \<Longrightarrow> e <=_(Err.le r) e"
-apply (unfold lesub_def Err.le_def)
-apply (simp split: err.split)
-done
-
-lemma le_err_trans [rule_format]:
- "order r \<Longrightarrow> e1 <=_(le r) e2 \<longrightarrow> e2 <=_(le r) e3 \<longrightarrow> e1 <=_(le r) e3"
-apply (unfold unfold_lesub_err le_def)
-apply (simp split: err.split)
-apply (blast intro: order_trans)
-done
-
-lemma le_err_antisym [rule_format]:
- "order r \<Longrightarrow> e1 <=_(le r) e2 \<longrightarrow> e2 <=_(le r) e1 \<longrightarrow> e1=e2"
-apply (unfold unfold_lesub_err le_def)
-apply (simp split: err.split)
-apply (blast intro: order_antisym)
-done
-
-lemma OK_le_err_OK:
- "(OK x <=_(le r) OK y) = (x <=_r y)"
- by (simp add: unfold_lesub_err le_def)
-
-lemma order_le_err [iff]:
- "order(le r) = order r"
-apply (rule iffI)
- apply (subst Semilat.order_def)
- apply (blast dest: order_antisym OK_le_err_OK [THEN iffD2]
- intro: order_trans OK_le_err_OK [THEN iffD1])
-apply (subst Semilat.order_def)
-apply (blast intro: le_err_refl le_err_trans le_err_antisym
- dest: order_refl)
-done
-
-lemma le_Err [iff]: "e <=_(le r) Err"
- by (simp add: unfold_lesub_err le_def)
-
-lemma Err_le_conv [iff]:
- "Err <=_(le r) e = (e = Err)"
- by (simp add: unfold_lesub_err le_def split: err.split)
-
-lemma le_OK_conv [iff]:
- "e <=_(le r) OK x = (? y. e = OK y & y <=_r x)"
- by (simp add: unfold_lesub_err le_def split: err.split)
-
-lemma OK_le_conv:
- "OK x <=_(le r) e = (e = Err | (? y. e = OK y & x <=_r y))"
- by (simp add: unfold_lesub_err le_def split: err.split)
-
-lemma top_Err [iff]: "top (le r) Err";
- by (simp add: top_def)
-
-lemma OK_less_conv [rule_format, iff]:
- "OK x <_(le r) e = (e=Err | (? y. e = OK y & x <_r y))"
- by (simp add: lesssub_def lesub_def le_def split: err.split)
-
-lemma not_Err_less [rule_format, iff]:
- "~(Err <_(le r) x)"
- by (simp add: lesssub_def lesub_def le_def split: err.split)
-
-lemma semilat_errI [intro]:
- assumes semilat: "semilat (A, r, f)"
- shows "semilat(err A, Err.le r, lift2(%x y. OK(f x y)))"
- apply(insert semilat)
- apply (unfold semilat_Def closed_def plussub_def lesub_def
- lift2_def Err.le_def err_def)
- apply (simp split: err.split)
- done
-
-lemma err_semilat_eslI_aux:
- assumes semilat: "semilat (A, r, f)"
- shows "err_semilat(esl(A,r,f))"
- apply (unfold sl_def esl_def)
- apply (simp add: semilat_errI[OF semilat])
- done
-
-lemma err_semilat_eslI [intro, simp]:
- "\<And>L. semilat L \<Longrightarrow> err_semilat(esl L)"
-by(simp add: err_semilat_eslI_aux split_tupled_all)
-
-lemma acc_err [simp, intro!]: "acc r \<Longrightarrow> acc(le r)"
-apply (unfold acc_def lesub_def le_def lesssub_def)
-apply (simp add: wfP_eq_minimal split: err.split)
-apply clarify
-apply (case_tac "Err : Q")
- apply blast
-apply (erule_tac x = "{a . OK a : Q}" in allE)
-apply (case_tac "x")
- apply fast
-apply blast
-done
-
-lemma Err_in_err [iff]: "Err : err A"
- by (simp add: err_def)
-
-lemma Ok_in_err [iff]: "(OK x : err A) = (x:A)"
- by (auto simp add: err_def)
-
-section {* lift *}
-
-lemma lift_in_errI:
- "\<lbrakk> e : err S; !x:S. e = OK x \<longrightarrow> f x : err S \<rbrakk> \<Longrightarrow> lift f e : err S"
-apply (unfold lift_def)
-apply (simp split: err.split)
-apply blast
-done
-
-lemma Err_lift2 [simp]:
- "Err +_(lift2 f) x = Err"
- by (simp add: lift2_def plussub_def)
-
-lemma lift2_Err [simp]:
- "x +_(lift2 f) Err = Err"
- by (simp add: lift2_def plussub_def split: err.split)
-
-lemma OK_lift2_OK [simp]:
- "OK x +_(lift2 f) OK y = x +_f y"
- by (simp add: lift2_def plussub_def split: err.split)
-
-
-section {* sup *}
-
-lemma Err_sup_Err [simp]:
- "Err +_(Err.sup f) x = Err"
- by (simp add: plussub_def Err.sup_def Err.lift2_def)
-
-lemma Err_sup_Err2 [simp]:
- "x +_(Err.sup f) Err = Err"
- by (simp add: plussub_def Err.sup_def Err.lift2_def split: err.split)
-
-lemma Err_sup_OK [simp]:
- "OK x +_(Err.sup f) OK y = OK(x +_f y)"
- by (simp add: plussub_def Err.sup_def Err.lift2_def)
-
-lemma Err_sup_eq_OK_conv [iff]:
- "(Err.sup f ex ey = OK z) = (? x y. ex = OK x & ey = OK y & f x y = z)"
-apply (unfold Err.sup_def lift2_def plussub_def)
-apply (rule iffI)
- apply (simp split: err.split_asm)
-apply clarify
-apply simp
-done
-
-lemma Err_sup_eq_Err [iff]:
- "(Err.sup f ex ey = Err) = (ex=Err | ey=Err)"
-apply (unfold Err.sup_def lift2_def plussub_def)
-apply (simp split: err.split)
-done
-
-section {* semilat (err A) (le r) f *}
-
-lemma semilat_le_err_Err_plus [simp]:
- "\<lbrakk> x: err A; semilat(err A, le r, f) \<rbrakk> \<Longrightarrow> Err +_f x = Err"
- by (blast intro: Semilat.le_iff_plus_unchanged [OF Semilat.intro, THEN iffD1]
- Semilat.le_iff_plus_unchanged2 [OF Semilat.intro, THEN iffD1])
-
-lemma semilat_le_err_plus_Err [simp]:
- "\<lbrakk> x: err A; semilat(err A, le r, f) \<rbrakk> \<Longrightarrow> x +_f Err = Err"
- by (blast intro: Semilat.le_iff_plus_unchanged [OF Semilat.intro, THEN iffD1]
- Semilat.le_iff_plus_unchanged2 [OF Semilat.intro, THEN iffD1])
-
-lemma semilat_le_err_OK1:
- "\<lbrakk> x:A; y:A; semilat(err A, le r, f); OK x +_f OK y = OK z \<rbrakk>
- \<Longrightarrow> x <=_r z";
-apply (rule OK_le_err_OK [THEN iffD1])
-apply (erule subst)
-apply (simp add: Semilat.ub1 [OF Semilat.intro])
-done
-
-lemma semilat_le_err_OK2:
- "\<lbrakk> x:A; y:A; semilat(err A, le r, f); OK x +_f OK y = OK z \<rbrakk>
- \<Longrightarrow> y <=_r z"
-apply (rule OK_le_err_OK [THEN iffD1])
-apply (erule subst)
-apply (simp add: Semilat.ub2 [OF Semilat.intro])
-done
-
-lemma eq_order_le:
- "\<lbrakk> x=y; order r \<rbrakk> \<Longrightarrow> x <=_r y"
-apply (unfold Semilat.order_def)
-apply blast
-done
-
-lemma OK_plus_OK_eq_Err_conv [simp]:
- assumes "x:A" and "y:A" and "semilat(err A, le r, fe)"
- shows "((OK x) +_fe (OK y) = Err) = (~(? z:A. x <=_r z & y <=_r z))"
-proof -
- have plus_le_conv3: "\<And>A x y z f r.
- \<lbrakk> semilat (A,r,f); x +_f y <=_r z; x:A; y:A; z:A \<rbrakk>
- \<Longrightarrow> x <=_r z \<and> y <=_r z"
- by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1])
- from prems show ?thesis
- apply (rule_tac iffI)
- apply clarify
- apply (drule OK_le_err_OK [THEN iffD2])
- apply (drule OK_le_err_OK [THEN iffD2])
- apply (drule Semilat.lub [OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
- apply assumption
- apply assumption
- apply simp
- apply simp
- apply simp
- apply simp
- apply (case_tac "(OK x) +_fe (OK y)")
- apply assumption
- apply (rename_tac z)
- apply (subgoal_tac "OK z: err A")
- apply (drule eq_order_le)
- apply (erule Semilat.orderI [OF Semilat.intro])
- apply (blast dest: plus_le_conv3)
- apply (erule subst)
- apply (blast intro: Semilat.closedI [OF Semilat.intro] closedD)
- done
-qed
-
-section {* semilat (err(Union AS)) *}
-
-(* FIXME? *)
-lemma all_bex_swap_lemma [iff]:
- "(!x. (? y:A. x = f y) \<longrightarrow> P x) = (!y:A. P(f y))"
- by blast
-
-lemma closed_err_Union_lift2I:
- "\<lbrakk> !A:AS. closed (err A) (lift2 f); AS ~= {};
- !A:AS.!B:AS. A~=B \<longrightarrow> (!a:A.!b:B. a +_f b = Err) \<rbrakk>
- \<Longrightarrow> closed (err(Union AS)) (lift2 f)"
-apply (unfold closed_def err_def)
-apply simp
-apply clarify
-apply simp
-apply fast
-done
-
-text {*
- If @{term "AS = {}"} the thm collapses to
- @{prop "order r & closed {Err} f & Err +_f Err = Err"}
- which may not hold
-*}
-lemma err_semilat_UnionI:
- "\<lbrakk> !A:AS. err_semilat(A, r, f); AS ~= {};
- !A:AS.!B:AS. A~=B \<longrightarrow> (!a:A.!b:B. ~ a <=_r b & a +_f b = Err) \<rbrakk>
- \<Longrightarrow> err_semilat(Union AS, r, f)"
-apply (unfold semilat_def sl_def)
-apply (simp add: closed_err_Union_lift2I)
-apply (rule conjI)
- apply blast
-apply (simp add: err_def)
-apply (rule conjI)
- apply clarify
- apply (rename_tac A a u B b)
- apply (case_tac "A = B")
- apply simp
- apply simp
-apply (rule conjI)
- apply clarify
- apply (rename_tac A a u B b)
- apply (case_tac "A = B")
- apply simp
- apply simp
-apply clarify
-apply (rename_tac A ya yb B yd z C c a b)
-apply (case_tac "A = B")
- apply (case_tac "A = C")
- apply simp
- apply (rotate_tac -1)
- apply simp
-apply (rotate_tac -1)
-apply (case_tac "B = C")
- apply simp
-apply (rotate_tac -1)
-apply simp
-done
-
-end
--- a/src/HOL/MicroJava/BV/JType.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/BV/JType.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1,12 +1,13 @@
(* Title: HOL/MicroJava/BV/JType.thy
- ID: $Id$
Author: Tobias Nipkow, Gerwin Klein
Copyright 2000 TUM
*)
header {* \isaheader{The Java Type System as Semilattice} *}
-theory JType imports "../J/WellForm" Err begin
+theory JType
+imports "../DFA/Semilattices" "../J/WellForm"
+begin
constdefs
super :: "'a prog \<Rightarrow> cname \<Rightarrow> cname"
@@ -34,7 +35,7 @@
is_ty :: "'c prog \<Rightarrow> ty \<Rightarrow> bool"
"is_ty G T == case T of PrimT P \<Rightarrow> True | RefT R \<Rightarrow>
- (case R of NullT \<Rightarrow> True | ClassT C \<Rightarrow> (subcls1 G)^** C Object)"
+ (case R of NullT \<Rightarrow> True | ClassT C \<Rightarrow> (C, Object) \<in> (subcls1 G)^*)"
translations
@@ -78,7 +79,7 @@
have "R \<noteq> ClassT Object \<Longrightarrow> ?thesis"
by (auto simp add: is_ty_def is_class_def split_tupled_all
elim!: subcls1.cases
- elim: converse_rtranclpE
+ elim: converse_rtranclE
split: ref_ty.splits)
ultimately
show ?thesis by blast
@@ -86,7 +87,7 @@
qed
lemma order_widen:
- "acyclicP (subcls1 G) \<Longrightarrow> order (subtype G)"
+ "acyclic (subcls1 G) \<Longrightarrow> order (subtype G)"
apply (unfold Semilat.order_def lesub_def subtype_def)
apply (auto intro: widen_trans)
apply (case_tac x)
@@ -102,16 +103,16 @@
apply (case_tac ref_tya)
apply simp
apply simp
- apply (auto dest: acyclic_impl_antisym_rtrancl [to_pred] antisymD)
+ apply (auto dest: acyclic_impl_antisym_rtrancl antisymD)
done
lemma wf_converse_subcls1_impl_acc_subtype:
- "wfP ((subcls1 G)^--1) \<Longrightarrow> acc (subtype G)"
+ "wf ((subcls1 G)^-1) \<Longrightarrow> acc (subtype G)"
apply (unfold Semilat.acc_def lesssub_def)
-apply (drule_tac p = "inf ((subcls1 G)^--1) op \<noteq>" in wfP_subset)
+apply (drule_tac p = "((subcls1 G)^-1) - Id" in wf_subset)
apply auto
-apply (drule wfP_trancl)
-apply (simp add: wfP_eq_minimal)
+apply (drule wf_trancl)
+apply (simp add: wf_eq_minimal)
apply clarify
apply (unfold lesub_def subtype_def)
apply (rename_tac M T)
@@ -146,20 +147,20 @@
apply (case_tac t)
apply simp
apply simp
-apply (insert rtranclp_r_diff_Id [symmetric, standard, of "subcls1 G"])
+apply (insert rtrancl_r_diff_Id [symmetric, standard, of "subcls1 G"])
apply simp
-apply (erule rtranclp.cases)
+apply (erule rtrancl.cases)
apply blast
-apply (drule rtranclp_converseI)
-apply (subgoal_tac "(inf (subcls1 G) op \<noteq>)^--1 = (inf ((subcls1 G)^--1) op \<noteq>)")
+apply (drule rtrancl_converseI)
+apply (subgoal_tac "(subcls1 G - Id)^-1 = (subcls1 G)^-1 - Id")
prefer 2
- apply (simp add: converse_meet)
+ apply (simp add: converse_Int) apply safe[1]
apply simp
-apply (blast intro: rtranclp_into_tranclp2)
-done
+apply (blast intro: rtrancl_into_trancl2)
+done
lemma closed_err_types:
- "\<lbrakk> ws_prog G; single_valuedP (subcls1 G); acyclicP (subcls1 G) \<rbrakk>
+ "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G) \<rbrakk>
\<Longrightarrow> closed (err (types G)) (lift2 (sup G))"
apply (unfold closed_def plussub_def lift2_def sup_def)
apply (auto split: err.split)
@@ -171,13 +172,13 @@
lemma sup_subtype_greater:
- "\<lbrakk> ws_prog G; single_valuedP (subcls1 G); acyclicP (subcls1 G);
+ "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G);
is_type G t1; is_type G t2; sup G t1 t2 = OK s \<rbrakk>
\<Longrightarrow> subtype G t1 s \<and> subtype G t2 s"
proof -
assume ws_prog: "ws_prog G"
- assume single_valued: "single_valuedP (subcls1 G)"
- assume acyclic: "acyclicP (subcls1 G)"
+ assume single_valued: "single_valued (subcls1 G)"
+ assume acyclic: "acyclic (subcls1 G)"
{ fix c1 c2
assume is_class: "is_class G c1" "is_class G c2"
@@ -188,7 +189,7 @@
by (blast intro: subcls_C_Object)
with ws_prog single_valued
obtain u where
- "is_lub ((subcls1 G)^** ) c1 c2 u"
+ "is_lub ((subcls1 G)^* ) c1 c2 u"
by (blast dest: single_valued_has_lubs)
moreover
note acyclic
@@ -210,14 +211,14 @@
qed
lemma sup_subtype_smallest:
- "\<lbrakk> ws_prog G; single_valuedP (subcls1 G); acyclicP (subcls1 G);
+ "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G);
is_type G a; is_type G b; is_type G c;
subtype G a c; subtype G b c; sup G a b = OK d \<rbrakk>
\<Longrightarrow> subtype G d c"
proof -
assume ws_prog: "ws_prog G"
- assume single_valued: "single_valuedP (subcls1 G)"
- assume acyclic: "acyclicP (subcls1 G)"
+ assume single_valued: "single_valued (subcls1 G)"
+ assume acyclic: "acyclic (subcls1 G)"
{ fix c1 c2 D
assume is_class: "is_class G c1" "is_class G c2"
@@ -229,7 +230,7 @@
by (blast intro: subcls_C_Object)
with ws_prog single_valued
obtain u where
- lub: "is_lub ((subcls1 G)^** ) c1 c2 u"
+ lub: "is_lub ((subcls1 G)^*) c1 c2 u"
by (blast dest: single_valued_has_lubs)
with acyclic
have "exec_lub (subcls1 G) (super G) c1 c2 = u"
@@ -260,12 +261,12 @@
split: ty.splits ref_ty.splits)
lemma err_semilat_JType_esl_lemma:
- "\<lbrakk> ws_prog G; single_valuedP (subcls1 G); acyclicP (subcls1 G) \<rbrakk>
+ "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G) \<rbrakk>
\<Longrightarrow> err_semilat (esl G)"
proof -
assume ws_prog: "ws_prog G"
- assume single_valued: "single_valuedP (subcls1 G)"
- assume acyclic: "acyclicP (subcls1 G)"
+ assume single_valued: "single_valued (subcls1 G)"
+ assume acyclic: "acyclic (subcls1 G)"
hence "order (subtype G)"
by (rule order_widen)
@@ -275,10 +276,10 @@
by (rule closed_err_types)
moreover
- from ws_prog single_valued acyclic
+ from ws_prog single_valued acyclic
have
- "(\<forall>x\<in>err (types G). \<forall>y\<in>err (types G). x <=_(le (subtype G)) x +_(lift2 (sup G)) y) \<and>
- (\<forall>x\<in>err (types G). \<forall>y\<in>err (types G). y <=_(le (subtype G)) x +_(lift2 (sup G)) y)"
+ "(\<forall>x\<in>err (types G). \<forall>y\<in>err (types G). x <=_(Err.le (subtype G)) x +_(lift2 (sup G)) y) \<and>
+ (\<forall>x\<in>err (types G). \<forall>y\<in>err (types G). y <=_(Err.le (subtype G)) x +_(lift2 (sup G)) y)"
by (auto simp add: lesub_def plussub_def Err.le_def lift2_def sup_subtype_greater split: err.split)
moreover
@@ -286,18 +287,18 @@
from ws_prog single_valued acyclic
have
"\<forall>x\<in>err (types G). \<forall>y\<in>err (types G). \<forall>z\<in>err (types G).
- x <=_(le (subtype G)) z \<and> y <=_(le (subtype G)) z \<longrightarrow> x +_(lift2 (sup G)) y <=_(le (subtype G)) z"
+ x <=_(Err.le (subtype G)) z \<and> y <=_(Err.le (subtype G)) z \<longrightarrow> x +_(lift2 (sup G)) y <=_(Err.le (subtype G)) z"
by (unfold lift2_def plussub_def lesub_def Err.le_def)
(auto intro: sup_subtype_smallest sup_exists split: err.split)
ultimately
show ?thesis
- by (unfold esl_def semilat_def sl_def) auto
+ by (unfold esl_def semilat_def Err.sl_def) auto
qed
lemma single_valued_subcls1:
- "ws_prog G \<Longrightarrow> single_valuedP (subcls1 G)"
+ "ws_prog G \<Longrightarrow> single_valued (subcls1 G)"
by (auto simp add: ws_prog_def unique_def single_valued_def
intro: subcls1I elim!: subcls1.cases)
--- a/src/HOL/MicroJava/BV/JVM.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/BV/JVM.thy Mon Nov 30 08:08:31 2009 +0100
@@ -5,8 +5,9 @@
header {* \isaheader{Kildall for the JVM}\label{sec:JVM} *}
-theory JVM imports Kildall Typing_Framework_JVM begin
-
+theory JVM
+imports Typing_Framework_JVM
+begin
constdefs
kiljvm :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> exception_table \<Rightarrow>
@@ -39,7 +40,7 @@
simp add: symmetric sl_triple_conv)
apply (simp (no_asm) add: JVM_le_unfold)
apply (blast intro!: order_widen wf_converse_subcls1_impl_acc_subtype
- dest: wf_subcls1 wfP_acyclicP wf_prog_ws_prog)
+ dest: wf_subcls1 wf_acyclic wf_prog_ws_prog)
apply (simp add: JVM_le_unfold)
apply (erule exec_pres_type)
apply assumption
--- a/src/HOL/MicroJava/BV/JVMType.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/BV/JVMType.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1,13 +1,13 @@
(* Title: HOL/MicroJava/BV/JVM.thy
- ID: $Id$
Author: Gerwin Klein
Copyright 2000 TUM
-
*)
header {* \isaheader{The JVM Type System as Semilattice} *}
-theory JVMType imports Opt Product Listn JType begin
+theory JVMType
+imports JType
+begin
types
locvars_type = "ty err list"
--- a/src/HOL/MicroJava/BV/Kildall.thy Sun Nov 29 12:56:30 2009 +1100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,498 +0,0 @@
-(* Title: HOL/MicroJava/BV/Kildall.thy
- ID: $Id$
- Author: Tobias Nipkow, Gerwin Klein
- Copyright 2000 TUM
-
-Kildall's algorithm
-*)
-
-header {* \isaheader{Kildall's Algorithm}\label{sec:Kildall} *}
-
-theory Kildall
-imports SemilatAlg While_Combinator
-begin
-
-
-consts
- iter :: "'s binop \<Rightarrow> 's step_type \<Rightarrow>
- 's list \<Rightarrow> nat set \<Rightarrow> 's list \<times> nat set"
- propa :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> nat set \<Rightarrow> 's list * nat set"
-
-primrec
-"propa f [] ss w = (ss,w)"
-"propa f (q'#qs) ss w = (let (q,t) = q';
- u = t +_f ss!q;
- w' = (if u = ss!q then w else insert q w)
- in propa f qs (ss[q := u]) w')"
-
-defs iter_def:
-"iter f step ss w ==
- while (%(ss,w). w \<noteq> {})
- (%(ss,w). let p = SOME p. p \<in> w
- in propa f (step p (ss!p)) ss (w-{p}))
- (ss,w)"
-
-constdefs
- unstables :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> nat set"
-"unstables r step ss == {p. p < size ss \<and> \<not>stable r step ss p}"
-
- kildall :: "'s ord \<Rightarrow> 's binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> 's list"
-"kildall r f step ss == fst(iter f step ss (unstables r step ss))"
-
-consts merges :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> 's list"
-primrec
-"merges f [] ss = ss"
-"merges f (p'#ps) ss = (let (p,s) = p' in merges f ps (ss[p := s +_f ss!p]))"
-
-
-lemmas [simp] = Let_def Semilat.le_iff_plus_unchanged [OF Semilat.intro, symmetric]
-
-
-lemma (in Semilat) nth_merges:
- "\<And>ss. \<lbrakk>p < length ss; ss \<in> list n A; \<forall>(p,t)\<in>set ps. p<n \<and> t\<in>A \<rbrakk> \<Longrightarrow>
- (merges f ps ss)!p = map snd [(p',t') \<leftarrow> ps. p'=p] ++_f ss!p"
- (is "\<And>ss. \<lbrakk>_; _; ?steptype ps\<rbrakk> \<Longrightarrow> ?P ss ps")
-proof (induct ps)
- show "\<And>ss. ?P ss []" by simp
-
- fix ss p' ps'
- assume ss: "ss \<in> list n A"
- assume l: "p < length ss"
- assume "?steptype (p'#ps')"
- then obtain a b where
- p': "p'=(a,b)" and ab: "a<n" "b\<in>A" and ps': "?steptype ps'"
- by (cases p') auto
- assume "\<And>ss. p< length ss \<Longrightarrow> ss \<in> list n A \<Longrightarrow> ?steptype ps' \<Longrightarrow> ?P ss ps'"
- from this [OF _ _ ps'] have IH: "\<And>ss. ss \<in> list n A \<Longrightarrow> p < length ss \<Longrightarrow> ?P ss ps'" .
-
- from ss ab
- have "ss[a := b +_f ss!a] \<in> list n A" by (simp add: closedD)
- moreover
- from calculation l
- have "p < length (ss[a := b +_f ss!a])" by simp
- ultimately
- have "?P (ss[a := b +_f ss!a]) ps'" by (rule IH)
- with p' l
- show "?P ss (p'#ps')" by simp
-qed
-
-
-(** merges **)
-
-lemma length_merges [rule_format, simp]:
- "\<forall>ss. size(merges f ps ss) = size ss"
- by (induct_tac ps, auto)
-
-
-lemma (in Semilat) merges_preserves_type_lemma:
-shows "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A)
- \<longrightarrow> merges f ps xs \<in> list n A"
-apply (insert closedI)
-apply (unfold closed_def)
-apply (induct_tac ps)
- apply simp
-apply clarsimp
-done
-
-lemma (in Semilat) merges_preserves_type [simp]:
- "\<lbrakk> xs \<in> list n A; \<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A \<rbrakk>
- \<Longrightarrow> merges f ps xs \<in> list n A"
-by (simp add: merges_preserves_type_lemma)
-
-lemma (in Semilat) merges_incr_lemma:
- "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A) \<longrightarrow> xs <=[r] merges f ps xs"
-apply (induct_tac ps)
- apply simp
-apply simp
-apply clarify
-apply (rule order_trans)
- apply simp
- apply (erule list_update_incr)
- apply simp
- apply simp
-apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
-done
-
-lemma (in Semilat) merges_incr:
- "\<lbrakk> xs \<in> list n A; \<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A \<rbrakk>
- \<Longrightarrow> xs <=[r] merges f ps xs"
- by (simp add: merges_incr_lemma)
-
-
-lemma (in Semilat) merges_same_conv [rule_format]:
- "(\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x\<in>A) \<longrightarrow>
- (merges f ps xs = xs) = (\<forall>(p,x)\<in>set ps. x <=_r xs!p))"
- apply (induct_tac ps)
- apply simp
- apply clarsimp
- apply (rename_tac p x ps xs)
- apply (rule iffI)
- apply (rule context_conjI)
- apply (subgoal_tac "xs[p := x +_f xs!p] <=[r] xs")
- apply (drule_tac p = p in le_listD)
- apply simp
- apply simp
- apply (erule subst, rule merges_incr)
- apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
- apply clarify
- apply (rule conjI)
- apply simp
- apply (blast dest: boundedD)
- apply blast
- apply clarify
- apply (erule allE)
- apply (erule impE)
- apply assumption
- apply (drule bspec)
- apply assumption
- apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
- apply blast
- apply clarify
- apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
- done
-
-
-lemma (in Semilat) list_update_le_listI [rule_format]:
- "set xs <= A \<longrightarrow> set ys <= A \<longrightarrow> xs <=[r] ys \<longrightarrow> p < size xs \<longrightarrow>
- x <=_r ys!p \<longrightarrow> x\<in>A \<longrightarrow> xs[p := x +_f xs!p] <=[r] ys"
- apply(insert semilat)
- apply (unfold Listn.le_def lesub_def semilat_def)
- apply (simp add: list_all2_conv_all_nth nth_list_update)
- done
-
-lemma (in Semilat) merges_pres_le_ub:
- assumes "set ts <= A" and "set ss <= A"
- and "\<forall>(p,t)\<in>set ps. t <=_r ts!p \<and> t \<in> A \<and> p < size ts" and "ss <=[r] ts"
- shows "merges f ps ss <=[r] ts"
-proof -
- { fix t ts ps
- have
- "\<And>qs. \<lbrakk>set ts <= A; \<forall>(p,t)\<in>set ps. t <=_r ts!p \<and> t \<in> A \<and> p< size ts \<rbrakk> \<Longrightarrow>
- set qs <= set ps \<longrightarrow>
- (\<forall>ss. set ss <= A \<longrightarrow> ss <=[r] ts \<longrightarrow> merges f qs ss <=[r] ts)"
- apply (induct_tac qs)
- apply simp
- apply (simp (no_asm_simp))
- apply clarify
- apply (rotate_tac -2)
- apply simp
- apply (erule allE, erule impE, erule_tac [2] mp)
- apply (drule bspec, assumption)
- apply (simp add: closedD)
- apply (drule bspec, assumption)
- apply (simp add: list_update_le_listI)
- done
- } note this [dest]
-
- from prems show ?thesis by blast
-qed
-
-
-(** propa **)
-
-
-lemma decomp_propa:
- "\<And>ss w. (\<forall>(q,t)\<in>set qs. q < size ss) \<Longrightarrow>
- propa f qs ss w =
- (merges f qs ss, {q. \<exists>t. (q,t)\<in>set qs \<and> t +_f ss!q \<noteq> ss!q} Un w)"
- apply (induct qs)
- apply simp
- apply (simp (no_asm))
- apply clarify
- apply simp
- apply (rule conjI)
- apply blast
- apply (simp add: nth_list_update)
- apply blast
- done
-
-(** iter **)
-
-lemma (in Semilat) stable_pres_lemma:
-shows "\<lbrakk>pres_type step n A; bounded step n;
- ss \<in> list n A; p \<in> w; \<forall>q\<in>w. q < n;
- \<forall>q. q < n \<longrightarrow> q \<notin> w \<longrightarrow> stable r step ss q; q < n;
- \<forall>s'. (q,s') \<in> set (step p (ss ! p)) \<longrightarrow> s' +_f ss ! q = ss ! q;
- q \<notin> w \<or> q = p \<rbrakk>
- \<Longrightarrow> stable r step (merges f (step p (ss!p)) ss) q"
- apply (unfold stable_def)
- apply (subgoal_tac "\<forall>s'. (q,s') \<in> set (step p (ss!p)) \<longrightarrow> s' : A")
- prefer 2
- apply clarify
- apply (erule pres_typeD)
- prefer 3 apply assumption
- apply (rule listE_nth_in)
- apply assumption
- apply simp
- apply simp
- apply simp
- apply clarify
- apply (subst nth_merges)
- apply simp
- apply (blast dest: boundedD)
- apply assumption
- apply clarify
- apply (rule conjI)
- apply (blast dest: boundedD)
- apply (erule pres_typeD)
- prefer 3 apply assumption
- apply simp
- apply simp
-apply(subgoal_tac "q < length ss")
-prefer 2 apply simp
- apply (frule nth_merges [of q _ _ "step p (ss!p)"]) (* fixme: why does method subst not work?? *)
-apply assumption
- apply clarify
- apply (rule conjI)
- apply (blast dest: boundedD)
- apply (erule pres_typeD)
- prefer 3 apply assumption
- apply simp
- apply simp
- apply (drule_tac P = "\<lambda>x. (a, b) \<in> set (step q x)" in subst)
- apply assumption
-
- apply (simp add: plusplus_empty)
- apply (cases "q \<in> w")
- apply simp
- apply (rule ub1')
- apply (rule semilat)
- apply clarify
- apply (rule pres_typeD)
- apply assumption
- prefer 3 apply assumption
- apply (blast intro: listE_nth_in dest: boundedD)
- apply (blast intro: pres_typeD dest: boundedD)
- apply (blast intro: listE_nth_in dest: boundedD)
- apply assumption
-
- apply simp
- apply (erule allE, erule impE, assumption, erule impE, assumption)
- apply (rule order_trans)
- apply simp
- defer
- apply (rule pp_ub2)(*
- apply assumption*)
- apply simp
- apply clarify
- apply simp
- apply (rule pres_typeD)
- apply assumption
- prefer 3 apply assumption
- apply (blast intro: listE_nth_in dest: boundedD)
- apply (blast intro: pres_typeD dest: boundedD)
- apply (blast intro: listE_nth_in dest: boundedD)
- apply blast
- done
-
-
-lemma (in Semilat) merges_bounded_lemma:
- "\<lbrakk> mono r step n A; bounded step n;
- \<forall>(p',s') \<in> set (step p (ss!p)). s' \<in> A; ss \<in> list n A; ts \<in> list n A; p < n;
- ss <=[r] ts; \<forall>p. p < n \<longrightarrow> stable r step ts p \<rbrakk>
- \<Longrightarrow> merges f (step p (ss!p)) ss <=[r] ts"
- apply (unfold stable_def)
- apply (rule merges_pres_le_ub)
- apply simp
- apply simp
- prefer 2 apply assumption
-
- apply clarsimp
- apply (drule boundedD, assumption+)
- apply (erule allE, erule impE, assumption)
- apply (drule bspec, assumption)
- apply simp
-
- apply (drule monoD [of _ _ _ _ p "ss!p" "ts!p"])
- apply assumption
- apply simp
- apply (simp add: le_listD)
-
- apply (drule lesub_step_typeD, assumption)
- apply clarify
- apply (drule bspec, assumption)
- apply simp
- apply (blast intro: order_trans)
- done
-
-lemma termination_lemma:
- assumes semilat: "semilat (A, r, f)"
- shows "\<lbrakk> ss \<in> list n A; \<forall>(q,t)\<in>set qs. q<n \<and> t\<in>A; p\<in>w \<rbrakk> \<Longrightarrow>
- ss <[r] merges f qs ss \<or>
- merges f qs ss = ss \<and> {q. \<exists>t. (q,t)\<in>set qs \<and> t +_f ss!q \<noteq> ss!q} Un (w-{p}) < w" (is "PROP ?P")
-proof -
- interpret Semilat A r f using assms by (rule Semilat.intro)
- show "PROP ?P" apply(insert semilat)
- apply (unfold lesssub_def)
- apply (simp (no_asm_simp) add: merges_incr)
- apply (rule impI)
- apply (rule merges_same_conv [THEN iffD1, elim_format])
- apply assumption+
- defer
- apply (rule sym, assumption)
- defer apply simp
- apply (subgoal_tac "\<forall>q t. \<not>((q, t) \<in> set qs \<and> t +_f ss ! q \<noteq> ss ! q)")
- apply (blast intro!: psubsetI elim: equalityE)
- apply clarsimp
- apply (drule bspec, assumption)
- apply (drule bspec, assumption)
- apply clarsimp
- done
-qed
-
-lemma iter_properties[rule_format]:
- assumes semilat: "semilat (A, r, f)"
- shows "\<lbrakk> acc r ; pres_type step n A; mono r step n A;
- bounded step n; \<forall>p\<in>w0. p < n; ss0 \<in> list n A;
- \<forall>p<n. p \<notin> w0 \<longrightarrow> stable r step ss0 p \<rbrakk> \<Longrightarrow>
- iter f step ss0 w0 = (ss',w')
- \<longrightarrow>
- ss' \<in> list n A \<and> stables r step ss' \<and> ss0 <=[r] ss' \<and>
- (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow> ss' <=[r] ts)"
- (is "PROP ?P")
-proof -
- interpret Semilat A r f using assms by (rule Semilat.intro)
- show "PROP ?P" apply(insert semilat)
-apply (unfold iter_def stables_def)
-apply (rule_tac P = "%(ss,w).
- ss \<in> list n A \<and> (\<forall>p<n. p \<notin> w \<longrightarrow> stable r step ss p) \<and> ss0 <=[r] ss \<and>
- (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow> ss <=[r] ts) \<and>
- (\<forall>p\<in>w. p < n)" and
- r = "{(ss',ss) . ss <[r] ss'} <*lex*> finite_psubset"
- in while_rule)
-
--- "Invariant holds initially:"
-apply (simp add:stables_def)
-
--- "Invariant is preserved:"
-apply(simp add: stables_def split_paired_all)
-apply(rename_tac ss w)
-apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
- prefer 2; apply (fast intro: someI)
-apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
- prefer 2
- apply clarify
- apply (rule conjI)
- apply(clarsimp, blast dest!: boundedD)
- apply (erule pres_typeD)
- prefer 3
- apply assumption
- apply (erule listE_nth_in)
- apply simp
- apply simp
-apply (subst decomp_propa)
- apply fast
-apply simp
-apply (rule conjI)
- apply (rule merges_preserves_type)
- apply blast
- apply clarify
- apply (rule conjI)
- apply(clarsimp, fast dest!: boundedD)
- apply (erule pres_typeD)
- prefer 3
- apply assumption
- apply (erule listE_nth_in)
- apply blast
- apply blast
-apply (rule conjI)
- apply clarify
- apply (blast intro!: stable_pres_lemma)
-apply (rule conjI)
- apply (blast intro!: merges_incr intro: le_list_trans)
-apply (rule conjI)
- apply clarsimp
- apply (blast intro!: merges_bounded_lemma)
-apply (blast dest!: boundedD)
-
-
--- "Postcondition holds upon termination:"
-apply(clarsimp simp add: stables_def split_paired_all)
-
--- "Well-foundedness of the termination relation:"
-apply (rule wf_lex_prod)
- apply (insert orderI [THEN acc_le_listI])
- apply (simp add: acc_def lesssub_def wfP_wf_eq [symmetric])
-apply (rule wf_finite_psubset)
-
--- "Loop decreases along termination relation:"
-apply(simp add: stables_def split_paired_all)
-apply(rename_tac ss w)
-apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
- prefer 2; apply (fast intro: someI)
-apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
- prefer 2
- apply clarify
- apply (rule conjI)
- apply(clarsimp, blast dest!: boundedD)
- apply (erule pres_typeD)
- prefer 3
- apply assumption
- apply (erule listE_nth_in)
- apply blast
- apply blast
-apply (subst decomp_propa)
- apply blast
-apply clarify
-apply (simp del: listE_length
- add: lex_prod_def finite_psubset_def
- bounded_nat_set_is_finite)
-apply (rule termination_lemma)
-apply assumption+
-defer
-apply assumption
-apply clarsimp
-done
-
-qed
-
-lemma kildall_properties:
-assumes semilat: "semilat (A, r, f)"
-shows "\<lbrakk> acc r; pres_type step n A; mono r step n A;
- bounded step n; ss0 \<in> list n A \<rbrakk> \<Longrightarrow>
- kildall r f step ss0 \<in> list n A \<and>
- stables r step (kildall r f step ss0) \<and>
- ss0 <=[r] kildall r f step ss0 \<and>
- (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow>
- kildall r f step ss0 <=[r] ts)"
- (is "PROP ?P")
-proof -
- interpret Semilat A r f using assms by (rule Semilat.intro)
- show "PROP ?P"
-apply (unfold kildall_def)
-apply(case_tac "iter f step ss0 (unstables r step ss0)")
-apply(simp)
-apply (rule iter_properties)
-apply (simp_all add: unstables_def stable_def)
-apply (rule semilat)
-done
-qed
-
-lemma is_bcv_kildall:
-assumes semilat: "semilat (A, r, f)"
-shows "\<lbrakk> acc r; top r T; pres_type step n A; bounded step n; mono r step n A \<rbrakk>
- \<Longrightarrow> is_bcv r T step n A (kildall r f step)"
- (is "PROP ?P")
-proof -
- interpret Semilat A r f using assms by (rule Semilat.intro)
- show "PROP ?P"
-apply(unfold is_bcv_def wt_step_def)
-apply(insert semilat kildall_properties[of A])
-apply(simp add:stables_def)
-apply clarify
-apply(subgoal_tac "kildall r f step ss \<in> list n A")
- prefer 2 apply (simp(no_asm_simp))
-apply (rule iffI)
- apply (rule_tac x = "kildall r f step ss" in bexI)
- apply (rule conjI)
- apply (blast)
- apply (simp (no_asm_simp))
- apply(assumption)
-apply clarify
-apply(subgoal_tac "kildall r f step ss!p <=_r ts!p")
- apply simp
-apply (blast intro!: le_listD less_lengthI)
-done
-qed
-
-end
--- a/src/HOL/MicroJava/BV/LBVComplete.thy Sun Nov 29 12:56:30 2009 +1100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,379 +0,0 @@
-(* Title: HOL/MicroJava/BV/LBVComplete.thy
- ID: $Id$
- Author: Gerwin Klein
- Copyright 2000 Technische Universitaet Muenchen
-*)
-
-header {* \isaheader{Completeness of the LBV} *}
-
-theory LBVComplete
-imports LBVSpec Typing_Framework
-begin
-
-constdefs
- is_target :: "['s step_type, 's list, nat] \<Rightarrow> bool"
- "is_target step phi pc' \<equiv>
- \<exists>pc s'. pc' \<noteq> pc+1 \<and> pc < length phi \<and> (pc',s') \<in> set (step pc (phi!pc))"
-
- make_cert :: "['s step_type, 's list, 's] \<Rightarrow> 's certificate"
- "make_cert step phi B \<equiv>
- map (\<lambda>pc. if is_target step phi pc then phi!pc else B) [0..<length phi] @ [B]"
-
-lemma [code]:
- "is_target step phi pc' =
- list_ex (\<lambda>pc. pc' \<noteq> pc+1 \<and> pc' mem (map fst (step pc (phi!pc)))) [0..<length phi]"
-by (force simp: list_ex_iff is_target_def mem_iff)
-
-
-locale lbvc = lbv +
- fixes phi :: "'a list" ("\<phi>")
- fixes c :: "'a list"
- defines cert_def: "c \<equiv> make_cert step \<phi> \<bottom>"
-
- assumes mono: "mono r step (length \<phi>) A"
- assumes pres: "pres_type step (length \<phi>) A"
- assumes phi: "\<forall>pc < length \<phi>. \<phi>!pc \<in> A \<and> \<phi>!pc \<noteq> \<top>"
- assumes bounded: "bounded step (length \<phi>)"
-
- assumes B_neq_T: "\<bottom> \<noteq> \<top>"
-
-
-lemma (in lbvc) cert: "cert_ok c (length \<phi>) \<top> \<bottom> A"
-proof (unfold cert_ok_def, intro strip conjI)
- note [simp] = make_cert_def cert_def nth_append
-
- show "c!length \<phi> = \<bottom>" by simp
-
- fix pc assume pc: "pc < length \<phi>"
- from pc phi B_A show "c!pc \<in> A" by simp
- from pc phi B_neq_T show "c!pc \<noteq> \<top>" by simp
-qed
-
-lemmas [simp del] = split_paired_Ex
-
-
-lemma (in lbvc) cert_target [intro?]:
- "\<lbrakk> (pc',s') \<in> set (step pc (\<phi>!pc));
- pc' \<noteq> pc+1; pc < length \<phi>; pc' < length \<phi> \<rbrakk>
- \<Longrightarrow> c!pc' = \<phi>!pc'"
- by (auto simp add: cert_def make_cert_def nth_append is_target_def)
-
-
-lemma (in lbvc) cert_approx [intro?]:
- "\<lbrakk> pc < length \<phi>; c!pc \<noteq> \<bottom> \<rbrakk>
- \<Longrightarrow> c!pc = \<phi>!pc"
- by (auto simp add: cert_def make_cert_def nth_append)
-
-
-lemma (in lbv) le_top [simp, intro]:
- "x <=_r \<top>"
- by (insert top) simp
-
-
-lemma (in lbv) merge_mono:
- assumes less: "ss2 <=|r| ss1"
- assumes x: "x \<in> A"
- assumes ss1: "snd`set ss1 \<subseteq> A"
- assumes ss2: "snd`set ss2 \<subseteq> A"
- shows "merge c pc ss2 x <=_r merge c pc ss1 x" (is "?s2 <=_r ?s1")
-proof-
- have "?s1 = \<top> \<Longrightarrow> ?thesis" by simp
- moreover {
- assume merge: "?s1 \<noteq> T"
- from x ss1 have "?s1 =
- (if \<forall>(pc', s')\<in>set ss1. pc' \<noteq> pc + 1 \<longrightarrow> s' <=_r c!pc'
- then (map snd [(p', t') \<leftarrow> ss1 . p'=pc+1]) ++_f x
- else \<top>)"
- by (rule merge_def)
- with merge obtain
- app: "\<forall>(pc',s')\<in>set ss1. pc' \<noteq> pc+1 \<longrightarrow> s' <=_r c!pc'"
- (is "?app ss1") and
- sum: "(map snd [(p',t') \<leftarrow> ss1 . p' = pc+1] ++_f x) = ?s1"
- (is "?map ss1 ++_f x = _" is "?sum ss1 = _")
- by (simp split: split_if_asm)
- from app less
- have "?app ss2" by (blast dest: trans_r lesub_step_typeD)
- moreover {
- from ss1 have map1: "set (?map ss1) \<subseteq> A" by auto
- with x have "?sum ss1 \<in> A" by (auto intro!: plusplus_closed semilat)
- with sum have "?s1 \<in> A" by simp
- moreover
- have mapD: "\<And>x ss. x \<in> set (?map ss) \<Longrightarrow> \<exists>p. (p,x) \<in> set ss \<and> p=pc+1" by auto
- from x map1
- have "\<forall>x \<in> set (?map ss1). x <=_r ?sum ss1"
- by clarify (rule pp_ub1)
- with sum have "\<forall>x \<in> set (?map ss1). x <=_r ?s1" by simp
- with less have "\<forall>x \<in> set (?map ss2). x <=_r ?s1"
- by (fastsimp dest!: mapD lesub_step_typeD intro: trans_r)
- moreover
- from map1 x have "x <=_r (?sum ss1)" by (rule pp_ub2)
- with sum have "x <=_r ?s1" by simp
- moreover
- from ss2 have "set (?map ss2) \<subseteq> A" by auto
- ultimately
- have "?sum ss2 <=_r ?s1" using x by - (rule pp_lub)
- }
- moreover
- from x ss2 have
- "?s2 =
- (if \<forall>(pc', s')\<in>set ss2. pc' \<noteq> pc + 1 \<longrightarrow> s' <=_r c!pc'
- then map snd [(p', t') \<leftarrow> ss2 . p' = pc + 1] ++_f x
- else \<top>)"
- by (rule merge_def)
- ultimately have ?thesis by simp
- }
- ultimately show ?thesis by (cases "?s1 = \<top>") auto
-qed
-
-
-lemma (in lbvc) wti_mono:
- assumes less: "s2 <=_r s1"
- assumes pc: "pc < length \<phi>"
- assumes s1: "s1 \<in> A"
- assumes s2: "s2 \<in> A"
- shows "wti c pc s2 <=_r wti c pc s1" (is "?s2' <=_r ?s1'")
-proof -
- from mono pc s2 less have "step pc s2 <=|r| step pc s1" by (rule monoD)
- moreover
- from cert B_A pc have "c!Suc pc \<in> A" by (rule cert_okD3)
- moreover
- from pres s1 pc
- have "snd`set (step pc s1) \<subseteq> A" by (rule pres_typeD2)
- moreover
- from pres s2 pc
- have "snd`set (step pc s2) \<subseteq> A" by (rule pres_typeD2)
- ultimately
- show ?thesis by (simp add: wti merge_mono)
-qed
-
-lemma (in lbvc) wtc_mono:
- assumes less: "s2 <=_r s1"
- assumes pc: "pc < length \<phi>"
- assumes s1: "s1 \<in> A"
- assumes s2: "s2 \<in> A"
- shows "wtc c pc s2 <=_r wtc c pc s1" (is "?s2' <=_r ?s1'")
-proof (cases "c!pc = \<bottom>")
- case True
- moreover from less pc s1 s2 have "wti c pc s2 <=_r wti c pc s1" by (rule wti_mono)
- ultimately show ?thesis by (simp add: wtc)
-next
- case False
- have "?s1' = \<top> \<Longrightarrow> ?thesis" by simp
- moreover {
- assume "?s1' \<noteq> \<top>"
- with False have c: "s1 <=_r c!pc" by (simp add: wtc split: split_if_asm)
- with less have "s2 <=_r c!pc" ..
- with False c have ?thesis by (simp add: wtc)
- }
- ultimately show ?thesis by (cases "?s1' = \<top>") auto
-qed
-
-
-lemma (in lbv) top_le_conv [simp]:
- "\<top> <=_r x = (x = \<top>)"
- by (insert semilat) (simp add: top top_le_conv)
-
-lemma (in lbv) neq_top [simp, elim]:
- "\<lbrakk> x <=_r y; y \<noteq> \<top> \<rbrakk> \<Longrightarrow> x \<noteq> \<top>"
- by (cases "x = T") auto
-
-
-lemma (in lbvc) stable_wti:
- assumes stable: "stable r step \<phi> pc"
- assumes pc: "pc < length \<phi>"
- shows "wti c pc (\<phi>!pc) \<noteq> \<top>"
-proof -
- let ?step = "step pc (\<phi>!pc)"
- from stable
- have less: "\<forall>(q,s')\<in>set ?step. s' <=_r \<phi>!q" by (simp add: stable_def)
-
- from cert B_A pc
- have cert_suc: "c!Suc pc \<in> A" by (rule cert_okD3)
- moreover
- from phi pc have "\<phi>!pc \<in> A" by simp
- from pres this pc
- have stepA: "snd`set ?step \<subseteq> A" by (rule pres_typeD2)
- ultimately
- have "merge c pc ?step (c!Suc pc) =
- (if \<forall>(pc',s')\<in>set ?step. pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'
- then map snd [(p',t') \<leftarrow> ?step.p'=pc+1] ++_f c!Suc pc
- else \<top>)" unfolding mrg_def by (rule lbv.merge_def [OF lbvc.axioms(1), OF lbvc_axioms])
- moreover {
- fix pc' s' assume s': "(pc', s') \<in> set ?step" and suc_pc: "pc' \<noteq> pc+1"
- with less have "s' <=_r \<phi>!pc'" by auto
- also
- from bounded pc s' have "pc' < length \<phi>" by (rule boundedD)
- with s' suc_pc pc have "c!pc' = \<phi>!pc'" ..
- hence "\<phi>!pc' = c!pc'" ..
- finally have "s' <=_r c!pc'" .
- } hence "\<forall>(pc',s')\<in>set ?step. pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'" by auto
- moreover
- from pc have "Suc pc = length \<phi> \<or> Suc pc < length \<phi>" by auto
- hence "map snd [(p',t') \<leftarrow> ?step.p'=pc+1] ++_f c!Suc pc \<noteq> \<top>"
- (is "?map ++_f _ \<noteq> _")
- proof (rule disjE)
- assume pc': "Suc pc = length \<phi>"
- with cert have "c!Suc pc = \<bottom>" by (simp add: cert_okD2)
- moreover
- from pc' bounded pc
- have "\<forall>(p',t')\<in>set ?step. p'\<noteq>pc+1" by clarify (drule boundedD, auto)
- hence "[(p',t') \<leftarrow> ?step.p'=pc+1] = []" by (blast intro: filter_False)
- hence "?map = []" by simp
- ultimately show ?thesis by (simp add: B_neq_T)
- next
- assume pc': "Suc pc < length \<phi>"
- from pc' phi have "\<phi>!Suc pc \<in> A" by simp
- moreover note cert_suc
- moreover from stepA
- have "set ?map \<subseteq> A" by auto
- moreover
- have "\<And>s. s \<in> set ?map \<Longrightarrow> \<exists>t. (Suc pc, t) \<in> set ?step" by auto
- with less have "\<forall>s' \<in> set ?map. s' <=_r \<phi>!Suc pc" by auto
- moreover
- from pc' have "c!Suc pc <=_r \<phi>!Suc pc"
- by (cases "c!Suc pc = \<bottom>") (auto dest: cert_approx)
- ultimately
- have "?map ++_f c!Suc pc <=_r \<phi>!Suc pc" by (rule pp_lub)
- moreover
- from pc' phi have "\<phi>!Suc pc \<noteq> \<top>" by simp
- ultimately
- show ?thesis by auto
- qed
- ultimately
- have "merge c pc ?step (c!Suc pc) \<noteq> \<top>" by simp
- thus ?thesis by (simp add: wti)
-qed
-
-lemma (in lbvc) wti_less:
- assumes stable: "stable r step \<phi> pc"
- assumes suc_pc: "Suc pc < length \<phi>"
- shows "wti c pc (\<phi>!pc) <=_r \<phi>!Suc pc" (is "?wti <=_r _")
-proof -
- let ?step = "step pc (\<phi>!pc)"
-
- from stable
- have less: "\<forall>(q,s')\<in>set ?step. s' <=_r \<phi>!q" by (simp add: stable_def)
-
- from suc_pc have pc: "pc < length \<phi>" by simp
- with cert B_A have cert_suc: "c!Suc pc \<in> A" by (rule cert_okD3)
- moreover
- from phi pc have "\<phi>!pc \<in> A" by simp
- with pres pc have stepA: "snd`set ?step \<subseteq> A" by - (rule pres_typeD2)
- moreover
- from stable pc have "?wti \<noteq> \<top>" by (rule stable_wti)
- hence "merge c pc ?step (c!Suc pc) \<noteq> \<top>" by (simp add: wti)
- ultimately
- have "merge c pc ?step (c!Suc pc) =
- map snd [(p',t')\<leftarrow> ?step.p'=pc+1] ++_f c!Suc pc" by (rule merge_not_top_s)
- hence "?wti = \<dots>" (is "_ = (?map ++_f _)" is "_ = ?sum") by (simp add: wti)
- also {
- from suc_pc phi have "\<phi>!Suc pc \<in> A" by simp
- moreover note cert_suc
- moreover from stepA have "set ?map \<subseteq> A" by auto
- moreover
- have "\<And>s. s \<in> set ?map \<Longrightarrow> \<exists>t. (Suc pc, t) \<in> set ?step" by auto
- with less have "\<forall>s' \<in> set ?map. s' <=_r \<phi>!Suc pc" by auto
- moreover
- from suc_pc have "c!Suc pc <=_r \<phi>!Suc pc"
- by (cases "c!Suc pc = \<bottom>") (auto dest: cert_approx)
- ultimately
- have "?sum <=_r \<phi>!Suc pc" by (rule pp_lub)
- }
- finally show ?thesis .
-qed
-
-lemma (in lbvc) stable_wtc:
- assumes stable: "stable r step phi pc"
- assumes pc: "pc < length \<phi>"
- shows "wtc c pc (\<phi>!pc) \<noteq> \<top>"
-proof -
- from stable pc have wti: "wti c pc (\<phi>!pc) \<noteq> \<top>" by (rule stable_wti)
- show ?thesis
- proof (cases "c!pc = \<bottom>")
- case True with wti show ?thesis by (simp add: wtc)
- next
- case False
- with pc have "c!pc = \<phi>!pc" ..
- with False wti show ?thesis by (simp add: wtc)
- qed
-qed
-
-lemma (in lbvc) wtc_less:
- assumes stable: "stable r step \<phi> pc"
- assumes suc_pc: "Suc pc < length \<phi>"
- shows "wtc c pc (\<phi>!pc) <=_r \<phi>!Suc pc" (is "?wtc <=_r _")
-proof (cases "c!pc = \<bottom>")
- case True
- moreover from stable suc_pc have "wti c pc (\<phi>!pc) <=_r \<phi>!Suc pc"
- by (rule wti_less)
- ultimately show ?thesis by (simp add: wtc)
-next
- case False
- from suc_pc have pc: "pc < length \<phi>" by simp
- with stable have "?wtc \<noteq> \<top>" by (rule stable_wtc)
- with False have "?wtc = wti c pc (c!pc)"
- by (unfold wtc) (simp split: split_if_asm)
- also from pc False have "c!pc = \<phi>!pc" ..
- finally have "?wtc = wti c pc (\<phi>!pc)" .
- also from stable suc_pc have "wti c pc (\<phi>!pc) <=_r \<phi>!Suc pc" by (rule wti_less)
- finally show ?thesis .
-qed
-
-
-lemma (in lbvc) wt_step_wtl_lemma:
- assumes wt_step: "wt_step r \<top> step \<phi>"
- shows "\<And>pc s. pc+length ls = length \<phi> \<Longrightarrow> s <=_r \<phi>!pc \<Longrightarrow> s \<in> A \<Longrightarrow> s\<noteq>\<top> \<Longrightarrow>
- wtl ls c pc s \<noteq> \<top>"
- (is "\<And>pc s. _ \<Longrightarrow> _ \<Longrightarrow> _ \<Longrightarrow> _ \<Longrightarrow> ?wtl ls pc s \<noteq> _")
-proof (induct ls)
- fix pc s assume "s\<noteq>\<top>" thus "?wtl [] pc s \<noteq> \<top>" by simp
-next
- fix pc s i ls
- assume "\<And>pc s. pc+length ls=length \<phi> \<Longrightarrow> s <=_r \<phi>!pc \<Longrightarrow> s \<in> A \<Longrightarrow> s\<noteq>\<top> \<Longrightarrow>
- ?wtl ls pc s \<noteq> \<top>"
- moreover
- assume pc_l: "pc + length (i#ls) = length \<phi>"
- hence suc_pc_l: "Suc pc + length ls = length \<phi>" by simp
- ultimately
- have IH: "\<And>s. s <=_r \<phi>!Suc pc \<Longrightarrow> s \<in> A \<Longrightarrow> s \<noteq> \<top> \<Longrightarrow> ?wtl ls (Suc pc) s \<noteq> \<top>" .
-
- from pc_l obtain pc: "pc < length \<phi>" by simp
- with wt_step have stable: "stable r step \<phi> pc" by (simp add: wt_step_def)
- from this pc have wt_phi: "wtc c pc (\<phi>!pc) \<noteq> \<top>" by (rule stable_wtc)
- assume s_phi: "s <=_r \<phi>!pc"
- from phi pc have phi_pc: "\<phi>!pc \<in> A" by simp
- assume s: "s \<in> A"
- with s_phi pc phi_pc have wt_s_phi: "wtc c pc s <=_r wtc c pc (\<phi>!pc)" by (rule wtc_mono)
- with wt_phi have wt_s: "wtc c pc s \<noteq> \<top>" by simp
- moreover
- assume s': "s \<noteq> \<top>"
- ultimately
- have "ls = [] \<Longrightarrow> ?wtl (i#ls) pc s \<noteq> \<top>" by simp
- moreover {
- assume "ls \<noteq> []"
- with pc_l have suc_pc: "Suc pc < length \<phi>" by (auto simp add: neq_Nil_conv)
- with stable have "wtc c pc (phi!pc) <=_r \<phi>!Suc pc" by (rule wtc_less)
- with wt_s_phi have "wtc c pc s <=_r \<phi>!Suc pc" by (rule trans_r)
- moreover
- from cert suc_pc have "c!pc \<in> A" "c!(pc+1) \<in> A"
- by (auto simp add: cert_ok_def)
- from pres this s pc have "wtc c pc s \<in> A" by (rule wtc_pres)
- ultimately
- have "?wtl ls (Suc pc) (wtc c pc s) \<noteq> \<top>" using IH wt_s by blast
- with s' wt_s have "?wtl (i#ls) pc s \<noteq> \<top>" by simp
- }
- ultimately show "?wtl (i#ls) pc s \<noteq> \<top>" by (cases ls) blast+
-qed
-
-
-theorem (in lbvc) wtl_complete:
- assumes wt: "wt_step r \<top> step \<phi>"
- and s: "s <=_r \<phi>!0" "s \<in> A" "s \<noteq> \<top>"
- and len: "length ins = length phi"
- shows "wtl ins c 0 s \<noteq> \<top>"
-proof -
- from len have "0+length ins = length phi" by simp
- from wt this s show ?thesis by (rule wt_step_wtl_lemma)
-qed
-
-end
--- a/src/HOL/MicroJava/BV/LBVCorrect.thy Sun Nov 29 12:56:30 2009 +1100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,223 +0,0 @@
-(*
- ID: $Id$
- Author: Gerwin Klein
- Copyright 1999 Technische Universitaet Muenchen
-*)
-
-header {* \isaheader{Correctness of the LBV} *}
-
-theory LBVCorrect
-imports LBVSpec Typing_Framework
-begin
-
-locale lbvs = lbv +
- fixes s0 :: 'a ("s\<^sub>0")
- fixes c :: "'a list"
- fixes ins :: "'b list"
- fixes phi :: "'a list" ("\<phi>")
- defines phi_def:
- "\<phi> \<equiv> map (\<lambda>pc. if c!pc = \<bottom> then wtl (take pc ins) c 0 s0 else c!pc)
- [0..<length ins]"
-
- assumes bounded: "bounded step (length ins)"
- assumes cert: "cert_ok c (length ins) \<top> \<bottom> A"
- assumes pres: "pres_type step (length ins) A"
-
-
-lemma (in lbvs) phi_None [intro?]:
- "\<lbrakk> pc < length ins; c!pc = \<bottom> \<rbrakk> \<Longrightarrow> \<phi> ! pc = wtl (take pc ins) c 0 s0"
- by (simp add: phi_def)
-
-lemma (in lbvs) phi_Some [intro?]:
- "\<lbrakk> pc < length ins; c!pc \<noteq> \<bottom> \<rbrakk> \<Longrightarrow> \<phi> ! pc = c ! pc"
- by (simp add: phi_def)
-
-lemma (in lbvs) phi_len [simp]:
- "length \<phi> = length ins"
- by (simp add: phi_def)
-
-
-lemma (in lbvs) wtl_suc_pc:
- assumes all: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>"
- assumes pc: "pc+1 < length ins"
- shows "wtl (take (pc+1) ins) c 0 s0 \<le>\<^sub>r \<phi>!(pc+1)"
-proof -
- from all pc
- have "wtc c (pc+1) (wtl (take (pc+1) ins) c 0 s0) \<noteq> T" by (rule wtl_all)
- with pc show ?thesis by (simp add: phi_def wtc split: split_if_asm)
-qed
-
-
-lemma (in lbvs) wtl_stable:
- assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
- assumes s0: "s0 \<in> A"
- assumes pc: "pc < length ins"
- shows "stable r step \<phi> pc"
-proof (unfold stable_def, clarify)
- fix pc' s' assume step: "(pc',s') \<in> set (step pc (\<phi> ! pc))"
- (is "(pc',s') \<in> set (?step pc)")
-
- from bounded pc step have pc': "pc' < length ins" by (rule boundedD)
-
- from wtl have tkpc: "wtl (take pc ins) c 0 s0 \<noteq> \<top>" (is "?s1 \<noteq> _") by (rule wtl_take)
- from wtl have s2: "wtl (take (pc+1) ins) c 0 s0 \<noteq> \<top>" (is "?s2 \<noteq> _") by (rule wtl_take)
-
- from wtl pc have wt_s1: "wtc c pc ?s1 \<noteq> \<top>" by (rule wtl_all)
-
- have c_Some: "\<forall>pc t. pc < length ins \<longrightarrow> c!pc \<noteq> \<bottom> \<longrightarrow> \<phi>!pc = c!pc"
- by (simp add: phi_def)
- from pc have c_None: "c!pc = \<bottom> \<Longrightarrow> \<phi>!pc = ?s1" ..
-
- from wt_s1 pc c_None c_Some
- have inst: "wtc c pc ?s1 = wti c pc (\<phi>!pc)"
- by (simp add: wtc split: split_if_asm)
-
- from pres cert s0 wtl pc have "?s1 \<in> A" by (rule wtl_pres)
- with pc c_Some cert c_None
- have "\<phi>!pc \<in> A" by (cases "c!pc = \<bottom>") (auto dest: cert_okD1)
- with pc pres
- have step_in_A: "snd`set (?step pc) \<subseteq> A" by (auto dest: pres_typeD2)
-
- show "s' <=_r \<phi>!pc'"
- proof (cases "pc' = pc+1")
- case True
- with pc' cert
- have cert_in_A: "c!(pc+1) \<in> A" by (auto dest: cert_okD1)
- from True pc' have pc1: "pc+1 < length ins" by simp
- with tkpc have "?s2 = wtc c pc ?s1" by - (rule wtl_Suc)
- with inst
- have merge: "?s2 = merge c pc (?step pc) (c!(pc+1))" by (simp add: wti)
- also
- from s2 merge have "\<dots> \<noteq> \<top>" (is "?merge \<noteq> _") by simp
- with cert_in_A step_in_A
- have "?merge = (map snd [(p',t') \<leftarrow> ?step pc. p'=pc+1] ++_f (c!(pc+1)))"
- by (rule merge_not_top_s)
- finally
- have "s' <=_r ?s2" using step_in_A cert_in_A True step
- by (auto intro: pp_ub1')
- also
- from wtl pc1 have "?s2 <=_r \<phi>!(pc+1)" by (rule wtl_suc_pc)
- also note True [symmetric]
- finally show ?thesis by simp
- next
- case False
- from wt_s1 inst
- have "merge c pc (?step pc) (c!(pc+1)) \<noteq> \<top>" by (simp add: wti)
- with step_in_A
- have "\<forall>(pc', s')\<in>set (?step pc). pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'"
- by - (rule merge_not_top)
- with step False
- have ok: "s' <=_r c!pc'" by blast
- moreover
- from ok
- have "c!pc' = \<bottom> \<Longrightarrow> s' = \<bottom>" by simp
- moreover
- from c_Some pc'
- have "c!pc' \<noteq> \<bottom> \<Longrightarrow> \<phi>!pc' = c!pc'" by auto
- ultimately
- show ?thesis by (cases "c!pc' = \<bottom>") auto
- qed
-qed
-
-
-lemma (in lbvs) phi_not_top:
- assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
- assumes pc: "pc < length ins"
- shows "\<phi>!pc \<noteq> \<top>"
-proof (cases "c!pc = \<bottom>")
- case False with pc
- have "\<phi>!pc = c!pc" ..
- also from cert pc have "\<dots> \<noteq> \<top>" by (rule cert_okD4)
- finally show ?thesis .
-next
- case True with pc
- have "\<phi>!pc = wtl (take pc ins) c 0 s0" ..
- also from wtl have "\<dots> \<noteq> \<top>" by (rule wtl_take)
- finally show ?thesis .
-qed
-
-lemma (in lbvs) phi_in_A:
- assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
- assumes s0: "s0 \<in> A"
- shows "\<phi> \<in> list (length ins) A"
-proof -
- { fix x assume "x \<in> set \<phi>"
- then obtain xs ys where "\<phi> = xs @ x # ys"
- by (auto simp add: in_set_conv_decomp)
- then obtain pc where pc: "pc < length \<phi>" and x: "\<phi>!pc = x"
- by (simp add: that [of "length xs"] nth_append)
-
- from pres cert wtl s0 pc
- have "wtl (take pc ins) c 0 s0 \<in> A" by (auto intro!: wtl_pres)
- moreover
- from pc have "pc < length ins" by simp
- with cert have "c!pc \<in> A" ..
- ultimately
- have "\<phi>!pc \<in> A" using pc by (simp add: phi_def)
- hence "x \<in> A" using x by simp
- }
- hence "set \<phi> \<subseteq> A" ..
- thus ?thesis by (unfold list_def) simp
-qed
-
-
-lemma (in lbvs) phi0:
- assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
- assumes 0: "0 < length ins"
- shows "s0 <=_r \<phi>!0"
-proof (cases "c!0 = \<bottom>")
- case True
- with 0 have "\<phi>!0 = wtl (take 0 ins) c 0 s0" ..
- moreover have "wtl (take 0 ins) c 0 s0 = s0" by simp
- ultimately have "\<phi>!0 = s0" by simp
- thus ?thesis by simp
-next
- case False
- with 0 have "phi!0 = c!0" ..
- moreover
- from wtl have "wtl (take 1 ins) c 0 s0 \<noteq> \<top>" by (rule wtl_take)
- with 0 False
- have "s0 <=_r c!0" by (auto simp add: neq_Nil_conv wtc split: split_if_asm)
- ultimately
- show ?thesis by simp
-qed
-
-
-theorem (in lbvs) wtl_sound:
- assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
- assumes s0: "s0 \<in> A"
- shows "\<exists>ts. wt_step r \<top> step ts"
-proof -
- have "wt_step r \<top> step \<phi>"
- proof (unfold wt_step_def, intro strip conjI)
- fix pc assume "pc < length \<phi>"
- then have pc: "pc < length ins" by simp
- with wtl show "\<phi>!pc \<noteq> \<top>" by (rule phi_not_top)
- from wtl s0 pc show "stable r step \<phi> pc" by (rule wtl_stable)
- qed
- thus ?thesis ..
-qed
-
-
-theorem (in lbvs) wtl_sound_strong:
- assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
- assumes s0: "s0 \<in> A"
- assumes nz: "0 < length ins"
- shows "\<exists>ts \<in> list (length ins) A. wt_step r \<top> step ts \<and> s0 <=_r ts!0"
-proof -
- from wtl s0 have "\<phi> \<in> list (length ins) A" by (rule phi_in_A)
- moreover
- have "wt_step r \<top> step \<phi>"
- proof (unfold wt_step_def, intro strip conjI)
- fix pc assume "pc < length \<phi>"
- then have pc: "pc < length ins" by simp
- with wtl show "\<phi>!pc \<noteq> \<top>" by (rule phi_not_top)
- from wtl s0 pc show "stable r step \<phi> pc" by (rule wtl_stable)
- qed
- moreover
- from wtl nz have "s0 <=_r \<phi>!0" by (rule phi0)
- ultimately
- show ?thesis by fast
-qed
-
-end
--- a/src/HOL/MicroJava/BV/LBVJVM.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/BV/LBVJVM.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/BV/JVM.thy
- ID: $Id$
Author: Tobias Nipkow, Gerwin Klein
Copyright 2000 TUM
*)
@@ -7,7 +6,7 @@
header {* \isaheader{LBV for the JVM}\label{sec:JVM} *}
theory LBVJVM
-imports LBVCorrect LBVComplete Typing_Framework_JVM
+imports Typing_Framework_JVM
begin
types prog_cert = "cname \<Rightarrow> sig \<Rightarrow> JVMType.state list"
--- a/src/HOL/MicroJava/BV/LBVSpec.thy Sun Nov 29 12:56:30 2009 +1100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,381 +0,0 @@
-(* Title: HOL/MicroJava/BV/LBVSpec.thy
- Author: Gerwin Klein
- Copyright 1999 Technische Universitaet Muenchen
-*)
-
-header {* \isaheader{The Lightweight Bytecode Verifier} *}
-
-theory LBVSpec
-imports SemilatAlg Opt
-begin
-
-types
- 's certificate = "'s list"
-
-consts
-merge :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> nat \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's \<Rightarrow> 's"
-primrec
-"merge cert f r T pc [] x = x"
-"merge cert f r T pc (s#ss) x = merge cert f r T pc ss (let (pc',s') = s in
- if pc'=pc+1 then s' +_f x
- else if s' <=_r (cert!pc') then x
- else T)"
-
-constdefs
-wtl_inst :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow>
- 's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's"
-"wtl_inst cert f r T step pc s \<equiv> merge cert f r T pc (step pc s) (cert!(pc+1))"
-
-wtl_cert :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow>
- 's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's"
-"wtl_cert cert f r T B step pc s \<equiv>
- if cert!pc = B then
- wtl_inst cert f r T step pc s
- else
- if s <=_r (cert!pc) then wtl_inst cert f r T step pc (cert!pc) else T"
-
-consts
-wtl_inst_list :: "'a list \<Rightarrow> 's certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow>
- 's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's"
-primrec
-"wtl_inst_list [] cert f r T B step pc s = s"
-"wtl_inst_list (i#is) cert f r T B step pc s =
- (let s' = wtl_cert cert f r T B step pc s in
- if s' = T \<or> s = T then T else wtl_inst_list is cert f r T B step (pc+1) s')"
-
-constdefs
- cert_ok :: "'s certificate \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow> 's set \<Rightarrow> bool"
- "cert_ok cert n T B A \<equiv> (\<forall>i < n. cert!i \<in> A \<and> cert!i \<noteq> T) \<and> (cert!n = B)"
-
-constdefs
- bottom :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool"
- "bottom r B \<equiv> \<forall>x. B <=_r x"
-
-
-locale lbv = Semilat +
- fixes T :: "'a" ("\<top>")
- fixes B :: "'a" ("\<bottom>")
- fixes step :: "'a step_type"
- assumes top: "top r \<top>"
- assumes T_A: "\<top> \<in> A"
- assumes bot: "bottom r \<bottom>"
- assumes B_A: "\<bottom> \<in> A"
-
- fixes merge :: "'a certificate \<Rightarrow> nat \<Rightarrow> (nat \<times> 'a) list \<Rightarrow> 'a \<Rightarrow> 'a"
- defines mrg_def: "merge cert \<equiv> LBVSpec.merge cert f r \<top>"
-
- fixes wti :: "'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
- defines wti_def: "wti cert \<equiv> wtl_inst cert f r \<top> step"
-
- fixes wtc :: "'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
- defines wtc_def: "wtc cert \<equiv> wtl_cert cert f r \<top> \<bottom> step"
-
- fixes wtl :: "'b list \<Rightarrow> 'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
- defines wtl_def: "wtl ins cert \<equiv> wtl_inst_list ins cert f r \<top> \<bottom> step"
-
-
-lemma (in lbv) wti:
- "wti c pc s \<equiv> merge c pc (step pc s) (c!(pc+1))"
- by (simp add: wti_def mrg_def wtl_inst_def)
-
-lemma (in lbv) wtc:
- "wtc c pc s \<equiv> if c!pc = \<bottom> then wti c pc s else if s <=_r c!pc then wti c pc (c!pc) else \<top>"
- by (unfold wtc_def wti_def wtl_cert_def)
-
-
-lemma cert_okD1 [intro?]:
- "cert_ok c n T B A \<Longrightarrow> pc < n \<Longrightarrow> c!pc \<in> A"
- by (unfold cert_ok_def) fast
-
-lemma cert_okD2 [intro?]:
- "cert_ok c n T B A \<Longrightarrow> c!n = B"
- by (simp add: cert_ok_def)
-
-lemma cert_okD3 [intro?]:
- "cert_ok c n T B A \<Longrightarrow> B \<in> A \<Longrightarrow> pc < n \<Longrightarrow> c!Suc pc \<in> A"
- by (drule Suc_leI) (auto simp add: le_eq_less_or_eq dest: cert_okD1 cert_okD2)
-
-lemma cert_okD4 [intro?]:
- "cert_ok c n T B A \<Longrightarrow> pc < n \<Longrightarrow> c!pc \<noteq> T"
- by (simp add: cert_ok_def)
-
-declare Let_def [simp]
-
-section "more semilattice lemmas"
-
-
-lemma (in lbv) sup_top [simp, elim]:
- assumes x: "x \<in> A"
- shows "x +_f \<top> = \<top>"
-proof -
- from top have "x +_f \<top> <=_r \<top>" ..
- moreover from x T_A have "\<top> <=_r x +_f \<top>" ..
- ultimately show ?thesis ..
-qed
-
-lemma (in lbv) plusplussup_top [simp, elim]:
- "set xs \<subseteq> A \<Longrightarrow> xs ++_f \<top> = \<top>"
- by (induct xs) auto
-
-
-
-lemma (in Semilat) pp_ub1':
- assumes S: "snd`set S \<subseteq> A"
- assumes y: "y \<in> A" and ab: "(a, b) \<in> set S"
- shows "b <=_r map snd [(p', t') \<leftarrow> S . p' = a] ++_f y"
-proof -
- from S have "\<forall>(x,y) \<in> set S. y \<in> A" by auto
- with semilat y ab show ?thesis by - (rule ub1')
-qed
-
-lemma (in lbv) bottom_le [simp, intro]:
- "\<bottom> <=_r x"
- by (insert bot) (simp add: bottom_def)
-
-lemma (in lbv) le_bottom [simp]:
- "x <=_r \<bottom> = (x = \<bottom>)"
- by (blast intro: antisym_r)
-
-
-
-section "merge"
-
-lemma (in lbv) merge_Nil [simp]:
- "merge c pc [] x = x" by (simp add: mrg_def)
-
-lemma (in lbv) merge_Cons [simp]:
- "merge c pc (l#ls) x = merge c pc ls (if fst l=pc+1 then snd l +_f x
- else if snd l <=_r (c!fst l) then x
- else \<top>)"
- by (simp add: mrg_def split_beta)
-
-lemma (in lbv) merge_Err [simp]:
- "snd`set ss \<subseteq> A \<Longrightarrow> merge c pc ss \<top> = \<top>"
- by (induct ss) auto
-
-lemma (in lbv) merge_not_top:
- "\<And>x. snd`set ss \<subseteq> A \<Longrightarrow> merge c pc ss x \<noteq> \<top> \<Longrightarrow>
- \<forall>(pc',s') \<in> set ss. (pc' \<noteq> pc+1 \<longrightarrow> s' <=_r (c!pc'))"
- (is "\<And>x. ?set ss \<Longrightarrow> ?merge ss x \<Longrightarrow> ?P ss")
-proof (induct ss)
- show "?P []" by simp
-next
- fix x ls l
- assume "?set (l#ls)" then obtain set: "snd`set ls \<subseteq> A" by simp
- assume merge: "?merge (l#ls) x"
- moreover
- obtain pc' s' where l: "l = (pc',s')" by (cases l)
- ultimately
- obtain x' where merge': "?merge ls x'" by simp
- assume "\<And>x. ?set ls \<Longrightarrow> ?merge ls x \<Longrightarrow> ?P ls" hence "?P ls" using set merge' .
- moreover
- from merge set
- have "pc' \<noteq> pc+1 \<longrightarrow> s' <=_r (c!pc')" by (simp add: l split: split_if_asm)
- ultimately
- show "?P (l#ls)" by (simp add: l)
-qed
-
-
-lemma (in lbv) merge_def:
- shows
- "\<And>x. x \<in> A \<Longrightarrow> snd`set ss \<subseteq> A \<Longrightarrow>
- merge c pc ss x =
- (if \<forall>(pc',s') \<in> set ss. pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc' then
- map snd [(p',t') \<leftarrow> ss. p'=pc+1] ++_f x
- else \<top>)"
- (is "\<And>x. _ \<Longrightarrow> _ \<Longrightarrow> ?merge ss x = ?if ss x" is "\<And>x. _ \<Longrightarrow> _ \<Longrightarrow> ?P ss x")
-proof (induct ss)
- fix x show "?P [] x" by simp
-next
- fix x assume x: "x \<in> A"
- fix l::"nat \<times> 'a" and ls
- assume "snd`set (l#ls) \<subseteq> A"
- then obtain l: "snd l \<in> A" and ls: "snd`set ls \<subseteq> A" by auto
- assume "\<And>x. x \<in> A \<Longrightarrow> snd`set ls \<subseteq> A \<Longrightarrow> ?P ls x"
- hence IH: "\<And>x. x \<in> A \<Longrightarrow> ?P ls x" using ls by iprover
- obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
- hence "?merge (l#ls) x = ?merge ls
- (if pc'=pc+1 then s' +_f x else if s' <=_r c!pc' then x else \<top>)"
- (is "?merge (l#ls) x = ?merge ls ?if'")
- by simp
- also have "\<dots> = ?if ls ?if'"
- proof -
- from l have "s' \<in> A" by simp
- with x have "s' +_f x \<in> A" by simp
- with x T_A have "?if' \<in> A" by auto
- hence "?P ls ?if'" by (rule IH) thus ?thesis by simp
- qed
- also have "\<dots> = ?if (l#ls) x"
- proof (cases "\<forall>(pc', s')\<in>set (l#ls). pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'")
- case True
- hence "\<forall>(pc', s')\<in>set ls. pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'" by auto
- moreover
- from True have
- "map snd [(p',t')\<leftarrow>ls . p'=pc+1] ++_f ?if' =
- (map snd [(p',t')\<leftarrow>l#ls . p'=pc+1] ++_f x)"
- by simp
- ultimately
- show ?thesis using True by simp
- next
- case False
- moreover
- from ls have "set (map snd [(p', t')\<leftarrow>ls . p' = Suc pc]) \<subseteq> A" by auto
- ultimately show ?thesis by auto
- qed
- finally show "?P (l#ls) x" .
-qed
-
-lemma (in lbv) merge_not_top_s:
- assumes x: "x \<in> A" and ss: "snd`set ss \<subseteq> A"
- assumes m: "merge c pc ss x \<noteq> \<top>"
- shows "merge c pc ss x = (map snd [(p',t') \<leftarrow> ss. p'=pc+1] ++_f x)"
-proof -
- from ss m have "\<forall>(pc',s') \<in> set ss. (pc' \<noteq> pc+1 \<longrightarrow> s' <=_r c!pc')"
- by (rule merge_not_top)
- with x ss m show ?thesis by - (drule merge_def, auto split: split_if_asm)
-qed
-
-section "wtl-inst-list"
-
-lemmas [iff] = not_Err_eq
-
-lemma (in lbv) wtl_Nil [simp]: "wtl [] c pc s = s"
- by (simp add: wtl_def)
-
-lemma (in lbv) wtl_Cons [simp]:
- "wtl (i#is) c pc s =
- (let s' = wtc c pc s in if s' = \<top> \<or> s = \<top> then \<top> else wtl is c (pc+1) s')"
- by (simp add: wtl_def wtc_def)
-
-lemma (in lbv) wtl_Cons_not_top:
- "wtl (i#is) c pc s \<noteq> \<top> =
- (wtc c pc s \<noteq> \<top> \<and> s \<noteq> T \<and> wtl is c (pc+1) (wtc c pc s) \<noteq> \<top>)"
- by (auto simp del: split_paired_Ex)
-
-lemma (in lbv) wtl_top [simp]: "wtl ls c pc \<top> = \<top>"
- by (cases ls) auto
-
-lemma (in lbv) wtl_not_top:
- "wtl ls c pc s \<noteq> \<top> \<Longrightarrow> s \<noteq> \<top>"
- by (cases "s=\<top>") auto
-
-lemma (in lbv) wtl_append [simp]:
- "\<And>pc s. wtl (a@b) c pc s = wtl b c (pc+length a) (wtl a c pc s)"
- by (induct a) auto
-
-lemma (in lbv) wtl_take:
- "wtl is c pc s \<noteq> \<top> \<Longrightarrow> wtl (take pc' is) c pc s \<noteq> \<top>"
- (is "?wtl is \<noteq> _ \<Longrightarrow> _")
-proof -
- assume "?wtl is \<noteq> \<top>"
- hence "?wtl (take pc' is @ drop pc' is) \<noteq> \<top>" by simp
- thus ?thesis by (auto dest!: wtl_not_top simp del: append_take_drop_id)
-qed
-
-lemma take_Suc:
- "\<forall>n. n < length l \<longrightarrow> take (Suc n) l = (take n l)@[l!n]" (is "?P l")
-proof (induct l)
- show "?P []" by simp
-next
- fix x xs assume IH: "?P xs"
- show "?P (x#xs)"
- proof (intro strip)
- fix n assume "n < length (x#xs)"
- with IH show "take (Suc n) (x # xs) = take n (x # xs) @ [(x # xs) ! n]"
- by (cases n, auto)
- qed
-qed
-
-lemma (in lbv) wtl_Suc:
- assumes suc: "pc+1 < length is"
- assumes wtl: "wtl (take pc is) c 0 s \<noteq> \<top>"
- shows "wtl (take (pc+1) is) c 0 s = wtc c pc (wtl (take pc is) c 0 s)"
-proof -
- from suc have "take (pc+1) is=(take pc is)@[is!pc]" by (simp add: take_Suc)
- with suc wtl show ?thesis by (simp add: min_max.inf_absorb2)
-qed
-
-lemma (in lbv) wtl_all:
- assumes all: "wtl is c 0 s \<noteq> \<top>" (is "?wtl is \<noteq> _")
- assumes pc: "pc < length is"
- shows "wtc c pc (wtl (take pc is) c 0 s) \<noteq> \<top>"
-proof -
- from pc have "0 < length (drop pc is)" by simp
- then obtain i r where Cons: "drop pc is = i#r"
- by (auto simp add: neq_Nil_conv simp del: length_drop drop_eq_Nil)
- hence "i#r = drop pc is" ..
- with all have take: "?wtl (take pc is@i#r) \<noteq> \<top>" by simp
- from pc have "is!pc = drop pc is ! 0" by simp
- with Cons have "is!pc = i" by simp
- with take pc show ?thesis by (auto simp add: min_max.inf_absorb2)
-qed
-
-section "preserves-type"
-
-lemma (in lbv) merge_pres:
- assumes s0: "snd`set ss \<subseteq> A" and x: "x \<in> A"
- shows "merge c pc ss x \<in> A"
-proof -
- from s0 have "set (map snd [(p', t')\<leftarrow>ss . p'=pc+1]) \<subseteq> A" by auto
- with x have "(map snd [(p', t')\<leftarrow>ss . p'=pc+1] ++_f x) \<in> A"
- by (auto intro!: plusplus_closed semilat)
- with s0 x show ?thesis by (simp add: merge_def T_A)
-qed
-
-
-lemma pres_typeD2:
- "pres_type step n A \<Longrightarrow> s \<in> A \<Longrightarrow> p < n \<Longrightarrow> snd`set (step p s) \<subseteq> A"
- by auto (drule pres_typeD)
-
-
-lemma (in lbv) wti_pres [intro?]:
- assumes pres: "pres_type step n A"
- assumes cert: "c!(pc+1) \<in> A"
- assumes s_pc: "s \<in> A" "pc < n"
- shows "wti c pc s \<in> A"
-proof -
- from pres s_pc have "snd`set (step pc s) \<subseteq> A" by (rule pres_typeD2)
- with cert show ?thesis by (simp add: wti merge_pres)
-qed
-
-
-lemma (in lbv) wtc_pres:
- assumes pres: "pres_type step n A"
- assumes cert: "c!pc \<in> A" and cert': "c!(pc+1) \<in> A"
- assumes s: "s \<in> A" and pc: "pc < n"
- shows "wtc c pc s \<in> A"
-proof -
- have "wti c pc s \<in> A" using pres cert' s pc ..
- moreover have "wti c pc (c!pc) \<in> A" using pres cert' cert pc ..
- ultimately show ?thesis using T_A by (simp add: wtc)
-qed
-
-
-lemma (in lbv) wtl_pres:
- assumes pres: "pres_type step (length is) A"
- assumes cert: "cert_ok c (length is) \<top> \<bottom> A"
- assumes s: "s \<in> A"
- assumes all: "wtl is c 0 s \<noteq> \<top>"
- shows "pc < length is \<Longrightarrow> wtl (take pc is) c 0 s \<in> A"
- (is "?len pc \<Longrightarrow> ?wtl pc \<in> A")
-proof (induct pc)
- from s show "?wtl 0 \<in> A" by simp
-next
- fix n assume IH: "Suc n < length is"
- then have n: "n < length is" by simp
- from IH have n1: "n+1 < length is" by simp
- assume prem: "n < length is \<Longrightarrow> ?wtl n \<in> A"
- have "wtc c n (?wtl n) \<in> A"
- using pres _ _ _ n
- proof (rule wtc_pres)
- from prem n show "?wtl n \<in> A" .
- from cert n show "c!n \<in> A" by (rule cert_okD1)
- from cert n1 show "c!(n+1) \<in> A" by (rule cert_okD1)
- qed
- also
- from all n have "?wtl n \<noteq> \<top>" by - (rule wtl_take)
- with n1 have "wtc c n (?wtl n) = ?wtl (n+1)" by (rule wtl_Suc [symmetric])
- finally show "?wtl (Suc n) \<in> A" by simp
-qed
-
-end
--- a/src/HOL/MicroJava/BV/Listn.thy Sun Nov 29 12:56:30 2009 +1100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,544 +0,0 @@
-(* Title: HOL/MicroJava/BV/Listn.thy
- Author: Tobias Nipkow
- Copyright 2000 TUM
-
-Lists of a fixed length
-*)
-
-header {* \isaheader{Fixed Length Lists} *}
-
-theory Listn
-imports Err
-begin
-
-constdefs
-
- list :: "nat \<Rightarrow> 'a set \<Rightarrow> 'a list set"
-"list n A == {xs. length xs = n & set xs <= A}"
-
- le :: "'a ord \<Rightarrow> ('a list)ord"
-"le r == list_all2 (%x y. x <=_r y)"
-
-syntax "@lesublist" :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
- ("(_ /<=[_] _)" [50, 0, 51] 50)
-syntax "@lesssublist" :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
- ("(_ /<[_] _)" [50, 0, 51] 50)
-translations
- "x <=[r] y" == "x <=_(Listn.le r) y"
- "x <[r] y" == "x <_(Listn.le r) y"
-
-constdefs
- map2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list"
-"map2 f == (%xs ys. map (split f) (zip xs ys))"
-
-syntax "@plussublist" :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b list \<Rightarrow> 'c list"
- ("(_ /+[_] _)" [65, 0, 66] 65)
-translations "x +[f] y" == "x +_(map2 f) y"
-
-consts coalesce :: "'a err list \<Rightarrow> 'a list err"
-primrec
-"coalesce [] = OK[]"
-"coalesce (ex#exs) = Err.sup (op #) ex (coalesce exs)"
-
-constdefs
- sl :: "nat \<Rightarrow> 'a sl \<Rightarrow> 'a list sl"
-"sl n == %(A,r,f). (list n A, le r, map2 f)"
-
- sup :: "('a \<Rightarrow> 'b \<Rightarrow> 'c err) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list err"
-"sup f == %xs ys. if size xs = size ys then coalesce(xs +[f] ys) else Err"
-
- upto_esl :: "nat \<Rightarrow> 'a esl \<Rightarrow> 'a list esl"
-"upto_esl m == %(A,r,f). (Union{list n A |n. n <= m}, le r, sup f)"
-
-lemmas [simp] = set_update_subsetI
-
-lemma unfold_lesub_list:
- "xs <=[r] ys == Listn.le r xs ys"
- by (simp add: lesub_def)
-
-lemma Nil_le_conv [iff]:
- "([] <=[r] ys) = (ys = [])"
-apply (unfold lesub_def Listn.le_def)
-apply simp
-done
-
-lemma Cons_notle_Nil [iff]:
- "~ x#xs <=[r] []"
-apply (unfold lesub_def Listn.le_def)
-apply simp
-done
-
-
-lemma Cons_le_Cons [iff]:
- "x#xs <=[r] y#ys = (x <=_r y & xs <=[r] ys)"
-apply (unfold lesub_def Listn.le_def)
-apply simp
-done
-
-lemma Cons_less_Conss [simp]:
- "order r \<Longrightarrow>
- x#xs <_(Listn.le r) y#ys =
- (x <_r y & xs <=[r] ys | x = y & xs <_(Listn.le r) ys)"
-apply (unfold lesssub_def)
-apply blast
-done
-
-lemma list_update_le_cong:
- "\<lbrakk> i<size xs; xs <=[r] ys; x <=_r y \<rbrakk> \<Longrightarrow> xs[i:=x] <=[r] ys[i:=y]";
-apply (unfold unfold_lesub_list)
-apply (unfold Listn.le_def)
-apply (simp add: list_all2_conv_all_nth nth_list_update)
-done
-
-
-lemma le_listD:
- "\<lbrakk> xs <=[r] ys; p < size xs \<rbrakk> \<Longrightarrow> xs!p <=_r ys!p"
-apply (unfold Listn.le_def lesub_def)
-apply (simp add: list_all2_conv_all_nth)
-done
-
-lemma le_list_refl:
- "!x. x <=_r x \<Longrightarrow> xs <=[r] xs"
-apply (unfold unfold_lesub_list)
-apply (simp add: Listn.le_def list_all2_conv_all_nth)
-done
-
-lemma le_list_trans:
- "\<lbrakk> order r; xs <=[r] ys; ys <=[r] zs \<rbrakk> \<Longrightarrow> xs <=[r] zs"
-apply (unfold unfold_lesub_list)
-apply (simp add: Listn.le_def list_all2_conv_all_nth)
-apply clarify
-apply simp
-apply (blast intro: order_trans)
-done
-
-lemma le_list_antisym:
- "\<lbrakk> order r; xs <=[r] ys; ys <=[r] xs \<rbrakk> \<Longrightarrow> xs = ys"
-apply (unfold unfold_lesub_list)
-apply (simp add: Listn.le_def list_all2_conv_all_nth)
-apply (rule nth_equalityI)
- apply blast
-apply clarify
-apply simp
-apply (blast intro: order_antisym)
-done
-
-lemma order_listI [simp, intro!]:
- "order r \<Longrightarrow> order(Listn.le r)"
-apply (subst Semilat.order_def)
-apply (blast intro: le_list_refl le_list_trans le_list_antisym
- dest: order_refl)
-done
-
-
-lemma lesub_list_impl_same_size [simp]:
- "xs <=[r] ys \<Longrightarrow> size ys = size xs"
-apply (unfold Listn.le_def lesub_def)
-apply (simp add: list_all2_conv_all_nth)
-done
-
-lemma lesssub_list_impl_same_size:
- "xs <_(Listn.le r) ys \<Longrightarrow> size ys = size xs"
-apply (unfold lesssub_def)
-apply auto
-done
-
-lemma le_list_appendI:
- "\<And>b c d. a <=[r] b \<Longrightarrow> c <=[r] d \<Longrightarrow> a@c <=[r] b@d"
-apply (induct a)
- apply simp
-apply (case_tac b)
-apply auto
-done
-
-lemma le_listI:
- "length a = length b \<Longrightarrow> (\<And>n. n < length a \<Longrightarrow> a!n <=_r b!n) \<Longrightarrow> a <=[r] b"
- apply (unfold lesub_def Listn.le_def)
- apply (simp add: list_all2_conv_all_nth)
- done
-
-lemma listI:
- "\<lbrakk> length xs = n; set xs <= A \<rbrakk> \<Longrightarrow> xs : list n A"
-apply (unfold list_def)
-apply blast
-done
-
-lemma listE_length [simp]:
- "xs : list n A \<Longrightarrow> length xs = n"
-apply (unfold list_def)
-apply blast
-done
-
-lemma less_lengthI:
- "\<lbrakk> xs : list n A; p < n \<rbrakk> \<Longrightarrow> p < length xs"
- by simp
-
-lemma listE_set [simp]:
- "xs : list n A \<Longrightarrow> set xs <= A"
-apply (unfold list_def)
-apply blast
-done
-
-lemma list_0 [simp]:
- "list 0 A = {[]}"
-apply (unfold list_def)
-apply auto
-done
-
-lemma in_list_Suc_iff:
- "(xs : list (Suc n) A) = (\<exists>y\<in> A. \<exists>ys\<in> list n A. xs = y#ys)"
-apply (unfold list_def)
-apply (case_tac "xs")
-apply auto
-done
-
-lemma Cons_in_list_Suc [iff]:
- "(x#xs : list (Suc n) A) = (x\<in> A & xs : list n A)";
-apply (simp add: in_list_Suc_iff)
-done
-
-lemma list_not_empty:
- "\<exists>a. a\<in> A \<Longrightarrow> \<exists>xs. xs : list n A";
-apply (induct "n")
- apply simp
-apply (simp add: in_list_Suc_iff)
-apply blast
-done
-
-
-lemma nth_in [rule_format, simp]:
- "!i n. length xs = n \<longrightarrow> set xs <= A \<longrightarrow> i < n \<longrightarrow> (xs!i) : A"
-apply (induct "xs")
- apply simp
-apply (simp add: nth_Cons split: nat.split)
-done
-
-lemma listE_nth_in:
- "\<lbrakk> xs : list n A; i < n \<rbrakk> \<Longrightarrow> (xs!i) : A"
- by auto
-
-
-lemma listn_Cons_Suc [elim!]:
- "l#xs \<in> list n A \<Longrightarrow> (\<And>n'. n = Suc n' \<Longrightarrow> l \<in> A \<Longrightarrow> xs \<in> list n' A \<Longrightarrow> P) \<Longrightarrow> P"
- by (cases n) auto
-
-lemma listn_appendE [elim!]:
- "a@b \<in> list n A \<Longrightarrow> (\<And>n1 n2. n=n1+n2 \<Longrightarrow> a \<in> list n1 A \<Longrightarrow> b \<in> list n2 A \<Longrightarrow> P) \<Longrightarrow> P"
-proof -
- have "\<And>n. a@b \<in> list n A \<Longrightarrow> \<exists>n1 n2. n=n1+n2 \<and> a \<in> list n1 A \<and> b \<in> list n2 A"
- (is "\<And>n. ?list a n \<Longrightarrow> \<exists>n1 n2. ?P a n n1 n2")
- proof (induct a)
- fix n assume "?list [] n"
- hence "?P [] n 0 n" by simp
- thus "\<exists>n1 n2. ?P [] n n1 n2" by fast
- next
- fix n l ls
- assume "?list (l#ls) n"
- then obtain n' where n: "n = Suc n'" "l \<in> A" and list_n': "ls@b \<in> list n' A" by fastsimp
- assume "\<And>n. ls @ b \<in> list n A \<Longrightarrow> \<exists>n1 n2. n = n1 + n2 \<and> ls \<in> list n1 A \<and> b \<in> list n2 A"
- hence "\<exists>n1 n2. n' = n1 + n2 \<and> ls \<in> list n1 A \<and> b \<in> list n2 A" by this (rule list_n')
- then obtain n1 n2 where "n' = n1 + n2" "ls \<in> list n1 A" "b \<in> list n2 A" by fast
- with n have "?P (l#ls) n (n1+1) n2" by simp
- thus "\<exists>n1 n2. ?P (l#ls) n n1 n2" by fastsimp
- qed
- moreover
- assume "a@b \<in> list n A" "\<And>n1 n2. n=n1+n2 \<Longrightarrow> a \<in> list n1 A \<Longrightarrow> b \<in> list n2 A \<Longrightarrow> P"
- ultimately
- show ?thesis by blast
-qed
-
-
-lemma listt_update_in_list [simp, intro!]:
- "\<lbrakk> xs : list n A; x\<in> A \<rbrakk> \<Longrightarrow> xs[i := x] : list n A"
-apply (unfold list_def)
-apply simp
-done
-
-lemma plus_list_Nil [simp]:
- "[] +[f] xs = []"
-apply (unfold plussub_def map2_def)
-apply simp
-done
-
-lemma plus_list_Cons [simp]:
- "(x#xs) +[f] ys = (case ys of [] \<Rightarrow> [] | y#ys \<Rightarrow> (x +_f y)#(xs +[f] ys))"
- by (simp add: plussub_def map2_def split: list.split)
-
-lemma length_plus_list [rule_format, simp]:
- "!ys. length(xs +[f] ys) = min(length xs) (length ys)"
-apply (induct xs)
- apply simp
-apply clarify
-apply (simp (no_asm_simp) split: list.split)
-done
-
-lemma nth_plus_list [rule_format, simp]:
- "!xs ys i. length xs = n \<longrightarrow> length ys = n \<longrightarrow> i<n \<longrightarrow>
- (xs +[f] ys)!i = (xs!i) +_f (ys!i)"
-apply (induct n)
- apply simp
-apply clarify
-apply (case_tac xs)
- apply simp
-apply (force simp add: nth_Cons split: list.split nat.split)
-done
-
-
-lemma (in Semilat) plus_list_ub1 [rule_format]:
- "\<lbrakk> set xs <= A; set ys <= A; size xs = size ys \<rbrakk>
- \<Longrightarrow> xs <=[r] xs +[f] ys"
-apply (unfold unfold_lesub_list)
-apply (simp add: Listn.le_def list_all2_conv_all_nth)
-done
-
-lemma (in Semilat) plus_list_ub2:
- "\<lbrakk>set xs <= A; set ys <= A; size xs = size ys \<rbrakk>
- \<Longrightarrow> ys <=[r] xs +[f] ys"
-apply (unfold unfold_lesub_list)
-apply (simp add: Listn.le_def list_all2_conv_all_nth)
-done
-
-lemma (in Semilat) plus_list_lub [rule_format]:
-shows "!xs ys zs. set xs <= A \<longrightarrow> set ys <= A \<longrightarrow> set zs <= A
- \<longrightarrow> size xs = n & size ys = n \<longrightarrow>
- xs <=[r] zs & ys <=[r] zs \<longrightarrow> xs +[f] ys <=[r] zs"
-apply (unfold unfold_lesub_list)
-apply (simp add: Listn.le_def list_all2_conv_all_nth)
-done
-
-lemma (in Semilat) list_update_incr [rule_format]:
- "x\<in> A \<Longrightarrow> set xs <= A \<longrightarrow>
- (!i. i<size xs \<longrightarrow> xs <=[r] xs[i := x +_f xs!i])"
-apply (unfold unfold_lesub_list)
-apply (simp add: Listn.le_def list_all2_conv_all_nth)
-apply (induct xs)
- apply simp
-apply (simp add: in_list_Suc_iff)
-apply clarify
-apply (simp add: nth_Cons split: nat.split)
-done
-
-lemma equals0I_aux:
- "(\<And>y. A y \<Longrightarrow> False) \<Longrightarrow> A = bot_class.bot"
- by (rule equals0I) (auto simp add: mem_def)
-
-lemma acc_le_listI [intro!]:
- "\<lbrakk> order r; acc r \<rbrakk> \<Longrightarrow> acc(Listn.le r)"
-apply (unfold acc_def)
-apply (subgoal_tac
- "wfP (SUP n. (\<lambda>ys xs. size xs = n & size ys = n & xs <_(Listn.le r) ys))")
- apply (erule wfP_subset)
- apply (blast intro: lesssub_list_impl_same_size)
-apply (rule wfP_SUP)
- prefer 2
- apply clarify
- apply (rename_tac m n)
- apply (case_tac "m=n")
- apply simp
- apply (fast intro!: equals0I_aux dest: not_sym)
-apply clarify
-apply (rename_tac n)
-apply (induct_tac n)
- apply (simp add: lesssub_def cong: conj_cong)
-apply (rename_tac k)
-apply (simp add: wfP_eq_minimal)
-apply (simp (no_asm) add: length_Suc_conv cong: conj_cong)
-apply clarify
-apply (rename_tac M m)
-apply (case_tac "\<exists>x xs. size xs = k & x#xs : M")
- prefer 2
- apply (erule thin_rl)
- apply (erule thin_rl)
- apply blast
-apply (erule_tac x = "{a. \<exists>xs. size xs = k & a#xs:M}" in allE)
-apply (erule impE)
- apply blast
-apply (thin_tac "\<exists>x xs. ?P x xs")
-apply clarify
-apply (rename_tac maxA xs)
-apply (erule_tac x = "{ys. size ys = size xs & maxA#ys : M}" in allE)
-apply (erule impE)
- apply blast
-apply clarify
-apply (thin_tac "m : M")
-apply (thin_tac "maxA#xs : M")
-apply (rule bexI)
- prefer 2
- apply assumption
-apply clarify
-apply simp
-apply blast
-done
-
-lemma closed_listI:
- "closed S f \<Longrightarrow> closed (list n S) (map2 f)"
-apply (unfold closed_def)
-apply (induct n)
- apply simp
-apply clarify
-apply (simp add: in_list_Suc_iff)
-apply clarify
-apply simp
-done
-
-
-lemma Listn_sl_aux:
-assumes "semilat (A, r, f)" shows "semilat (Listn.sl n (A,r,f))"
-proof -
- interpret Semilat A r f using assms by (rule Semilat.intro)
-show ?thesis
-apply (unfold Listn.sl_def)
-apply (simp (no_asm) only: semilat_Def split_conv)
-apply (rule conjI)
- apply simp
-apply (rule conjI)
- apply (simp only: closedI closed_listI)
-apply (simp (no_asm) only: list_def)
-apply (simp (no_asm_simp) add: plus_list_ub1 plus_list_ub2 plus_list_lub)
-done
-qed
-
-lemma Listn_sl: "\<And>L. semilat L \<Longrightarrow> semilat (Listn.sl n L)"
- by(simp add: Listn_sl_aux split_tupled_all)
-
-lemma coalesce_in_err_list [rule_format]:
- "!xes. xes : list n (err A) \<longrightarrow> coalesce xes : err(list n A)"
-apply (induct n)
- apply simp
-apply clarify
-apply (simp add: in_list_Suc_iff)
-apply clarify
-apply (simp (no_asm) add: plussub_def Err.sup_def lift2_def split: err.split)
-apply force
-done
-
-lemma lem: "\<And>x xs. x +_(op #) xs = x#xs"
- by (simp add: plussub_def)
-
-lemma coalesce_eq_OK1_D [rule_format]:
- "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
- !xs. xs : list n A \<longrightarrow> (!ys. ys : list n A \<longrightarrow>
- (!zs. coalesce (xs +[f] ys) = OK zs \<longrightarrow> xs <=[r] zs))"
-apply (induct n)
- apply simp
-apply clarify
-apply (simp add: in_list_Suc_iff)
-apply clarify
-apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
-apply (force simp add: semilat_le_err_OK1)
-done
-
-lemma coalesce_eq_OK2_D [rule_format]:
- "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
- !xs. xs : list n A \<longrightarrow> (!ys. ys : list n A \<longrightarrow>
- (!zs. coalesce (xs +[f] ys) = OK zs \<longrightarrow> ys <=[r] zs))"
-apply (induct n)
- apply simp
-apply clarify
-apply (simp add: in_list_Suc_iff)
-apply clarify
-apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
-apply (force simp add: semilat_le_err_OK2)
-done
-
-lemma lift2_le_ub:
- "\<lbrakk> semilat(err A, Err.le r, lift2 f); x\<in> A; y\<in> A; x +_f y = OK z;
- u\<in> A; x <=_r u; y <=_r u \<rbrakk> \<Longrightarrow> z <=_r u"
-apply (unfold semilat_Def plussub_def err_def)
-apply (simp add: lift2_def)
-apply clarify
-apply (rotate_tac -3)
-apply (erule thin_rl)
-apply (erule thin_rl)
-apply force
-done
-
-lemma coalesce_eq_OK_ub_D [rule_format]:
- "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
- !xs. xs : list n A \<longrightarrow> (!ys. ys : list n A \<longrightarrow>
- (!zs us. coalesce (xs +[f] ys) = OK zs & xs <=[r] us & ys <=[r] us
- & us : list n A \<longrightarrow> zs <=[r] us))"
-apply (induct n)
- apply simp
-apply clarify
-apply (simp add: in_list_Suc_iff)
-apply clarify
-apply (simp (no_asm_use) split: err.split_asm add: lem Err.sup_def lift2_def)
-apply clarify
-apply (rule conjI)
- apply (blast intro: lift2_le_ub)
-apply blast
-done
-
-lemma lift2_eq_ErrD:
- "\<lbrakk> x +_f y = Err; semilat(err A, Err.le r, lift2 f); x\<in> A; y\<in> A \<rbrakk>
- \<Longrightarrow> ~(\<exists>u\<in> A. x <=_r u & y <=_r u)"
- by (simp add: OK_plus_OK_eq_Err_conv [THEN iffD1])
-
-
-lemma coalesce_eq_Err_D [rule_format]:
- "\<lbrakk> semilat(err A, Err.le r, lift2 f) \<rbrakk>
- \<Longrightarrow> !xs. xs\<in> list n A \<longrightarrow> (!ys. ys\<in> list n A \<longrightarrow>
- coalesce (xs +[f] ys) = Err \<longrightarrow>
- ~(\<exists>zs\<in> list n A. xs <=[r] zs & ys <=[r] zs))"
-apply (induct n)
- apply simp
-apply clarify
-apply (simp add: in_list_Suc_iff)
-apply clarify
-apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
- apply (blast dest: lift2_eq_ErrD)
-done
-
-lemma closed_err_lift2_conv:
- "closed (err A) (lift2 f) = (\<forall>x\<in> A. \<forall>y\<in> A. x +_f y : err A)"
-apply (unfold closed_def)
-apply (simp add: err_def)
-done
-
-lemma closed_map2_list [rule_format]:
- "closed (err A) (lift2 f) \<Longrightarrow>
- \<forall>xs. xs : list n A \<longrightarrow> (\<forall>ys. ys : list n A \<longrightarrow>
- map2 f xs ys : list n (err A))"
-apply (unfold map2_def)
-apply (induct n)
- apply simp
-apply clarify
-apply (simp add: in_list_Suc_iff)
-apply clarify
-apply (simp add: plussub_def closed_err_lift2_conv)
-done
-
-lemma closed_lift2_sup:
- "closed (err A) (lift2 f) \<Longrightarrow>
- closed (err (list n A)) (lift2 (sup f))"
- by (fastsimp simp add: closed_def plussub_def sup_def lift2_def
- coalesce_in_err_list closed_map2_list
- split: err.split)
-
-lemma err_semilat_sup:
- "err_semilat (A,r,f) \<Longrightarrow>
- err_semilat (list n A, Listn.le r, sup f)"
-apply (unfold Err.sl_def)
-apply (simp only: split_conv)
-apply (simp (no_asm) only: semilat_Def plussub_def)
-apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
-apply (rule conjI)
- apply (drule Semilat.orderI [OF Semilat.intro])
- apply simp
-apply (simp (no_asm) only: unfold_lesub_err Err.le_def err_def sup_def lift2_def)
-apply (simp (no_asm_simp) add: coalesce_eq_OK1_D coalesce_eq_OK2_D split: err.split)
-apply (blast intro: coalesce_eq_OK_ub_D dest: coalesce_eq_Err_D)
-done
-
-lemma err_semilat_upto_esl:
- "\<And>L. err_semilat L \<Longrightarrow> err_semilat(upto_esl m L)"
-apply (unfold Listn.upto_esl_def)
-apply (simp (no_asm_simp) only: split_tupled_all)
-apply simp
-apply (fastsimp intro!: err_semilat_UnionI err_semilat_sup
- dest: lesub_list_impl_same_size
- simp add: plussub_def Listn.sup_def)
-done
-
-end
--- a/src/HOL/MicroJava/BV/Opt.thy Sun Nov 29 12:56:30 2009 +1100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,295 +0,0 @@
-(* Title: HOL/MicroJava/BV/Opt.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 2000 TUM
-
-More about options
-*)
-
-header {* \isaheader{More about Options} *}
-
-theory Opt
-imports Err
-begin
-
-constdefs
- le :: "'a ord \<Rightarrow> 'a option ord"
-"le r o1 o2 == case o2 of None \<Rightarrow> o1=None |
- Some y \<Rightarrow> (case o1 of None \<Rightarrow> True
- | Some x \<Rightarrow> x <=_r y)"
-
- opt :: "'a set \<Rightarrow> 'a option set"
-"opt A == insert None {x . ? y:A. x = Some y}"
-
- sup :: "'a ebinop \<Rightarrow> 'a option ebinop"
-"sup f o1 o2 ==
- case o1 of None \<Rightarrow> OK o2 | Some x \<Rightarrow> (case o2 of None \<Rightarrow> OK o1
- | Some y \<Rightarrow> (case f x y of Err \<Rightarrow> Err | OK z \<Rightarrow> OK (Some z)))"
-
- esl :: "'a esl \<Rightarrow> 'a option esl"
-"esl == %(A,r,f). (opt A, le r, sup f)"
-
-lemma unfold_le_opt:
- "o1 <=_(le r) o2 =
- (case o2 of None \<Rightarrow> o1=None |
- Some y \<Rightarrow> (case o1 of None \<Rightarrow> True | Some x \<Rightarrow> x <=_r y))"
-apply (unfold lesub_def le_def)
-apply (rule refl)
-done
-
-lemma le_opt_refl:
- "order r \<Longrightarrow> o1 <=_(le r) o1"
-by (simp add: unfold_le_opt split: option.split)
-
-lemma le_opt_trans [rule_format]:
- "order r \<Longrightarrow>
- o1 <=_(le r) o2 \<longrightarrow> o2 <=_(le r) o3 \<longrightarrow> o1 <=_(le r) o3"
-apply (simp add: unfold_le_opt split: option.split)
-apply (blast intro: order_trans)
-done
-
-lemma le_opt_antisym [rule_format]:
- "order r \<Longrightarrow> o1 <=_(le r) o2 \<longrightarrow> o2 <=_(le r) o1 \<longrightarrow> o1=o2"
-apply (simp add: unfold_le_opt split: option.split)
-apply (blast intro: order_antisym)
-done
-
-lemma order_le_opt [intro!,simp]:
- "order r \<Longrightarrow> order(le r)"
-apply (subst Semilat.order_def)
-apply (blast intro: le_opt_refl le_opt_trans le_opt_antisym)
-done
-
-lemma None_bot [iff]:
- "None <=_(le r) ox"
-apply (unfold lesub_def le_def)
-apply (simp split: option.split)
-done
-
-lemma Some_le [iff]:
- "(Some x <=_(le r) ox) = (? y. ox = Some y & x <=_r y)"
-apply (unfold lesub_def le_def)
-apply (simp split: option.split)
-done
-
-lemma le_None [iff]:
- "(ox <=_(le r) None) = (ox = None)";
-apply (unfold lesub_def le_def)
-apply (simp split: option.split)
-done
-
-
-lemma OK_None_bot [iff]:
- "OK None <=_(Err.le (le r)) x"
- by (simp add: lesub_def Err.le_def le_def split: option.split err.split)
-
-lemma sup_None1 [iff]:
- "x +_(sup f) None = OK x"
- by (simp add: plussub_def sup_def split: option.split)
-
-lemma sup_None2 [iff]:
- "None +_(sup f) x = OK x"
- by (simp add: plussub_def sup_def split: option.split)
-
-
-lemma None_in_opt [iff]:
- "None : opt A"
-by (simp add: opt_def)
-
-lemma Some_in_opt [iff]:
- "(Some x : opt A) = (x:A)"
-apply (unfold opt_def)
-apply auto
-done
-
-
-lemma semilat_opt [intro, simp]:
- "\<And>L. err_semilat L \<Longrightarrow> err_semilat (Opt.esl L)"
-proof (unfold Opt.esl_def Err.sl_def, simp add: split_tupled_all)
-
- fix A r f
- assume s: "semilat (err A, Err.le r, lift2 f)"
-
- let ?A0 = "err A"
- let ?r0 = "Err.le r"
- let ?f0 = "lift2 f"
-
- from s
- obtain
- ord: "order ?r0" and
- clo: "closed ?A0 ?f0" and
- ub1: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. x <=_?r0 x +_?f0 y" and
- ub2: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. y <=_?r0 x +_?f0 y" and
- lub: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. \<forall>z\<in>?A0. x <=_?r0 z \<and> y <=_?r0 z \<longrightarrow> x +_?f0 y <=_?r0 z"
- by (unfold semilat_def) simp
-
- let ?A = "err (opt A)"
- let ?r = "Err.le (Opt.le r)"
- let ?f = "lift2 (Opt.sup f)"
-
- from ord
- have "order ?r"
- by simp
-
- moreover
-
- have "closed ?A ?f"
- proof (unfold closed_def, intro strip)
- fix x y
- assume x: "x : ?A"
- assume y: "y : ?A"
-
- { fix a b
- assume ab: "x = OK a" "y = OK b"
-
- with x
- have a: "\<And>c. a = Some c \<Longrightarrow> c : A"
- by (clarsimp simp add: opt_def)
-
- from ab y
- have b: "\<And>d. b = Some d \<Longrightarrow> d : A"
- by (clarsimp simp add: opt_def)
-
- { fix c d assume "a = Some c" "b = Some d"
- with ab x y
- have "c:A & d:A"
- by (simp add: err_def opt_def Bex_def)
- with clo
- have "f c d : err A"
- by (simp add: closed_def plussub_def err_def lift2_def)
- moreover
- fix z assume "f c d = OK z"
- ultimately
- have "z : A" by simp
- } note f_closed = this
-
- have "sup f a b : ?A"
- proof (cases a)
- case None
- thus ?thesis
- by (simp add: sup_def opt_def) (cases b, simp, simp add: b Bex_def)
- next
- case Some
- thus ?thesis
- by (auto simp add: sup_def opt_def Bex_def a b f_closed split: err.split option.split)
- qed
- }
-
- thus "x +_?f y : ?A"
- by (simp add: plussub_def lift2_def split: err.split)
- qed
-
- moreover
-
- { fix a b c
- assume "a \<in> opt A" "b \<in> opt A" "a +_(sup f) b = OK c"
- moreover
- from ord have "order r" by simp
- moreover
- { fix x y z
- assume "x \<in> A" "y \<in> A"
- hence "OK x \<in> err A \<and> OK y \<in> err A" by simp
- with ub1 ub2
- have "(OK x) <=_(Err.le r) (OK x) +_(lift2 f) (OK y) \<and>
- (OK y) <=_(Err.le r) (OK x) +_(lift2 f) (OK y)"
- by blast
- moreover
- assume "x +_f y = OK z"
- ultimately
- have "x <=_r z \<and> y <=_r z"
- by (auto simp add: plussub_def lift2_def Err.le_def lesub_def)
- }
- ultimately
- have "a <=_(le r) c \<and> b <=_(le r) c"
- by (auto simp add: sup_def le_def lesub_def plussub_def
- dest: order_refl split: option.splits err.splits)
- }
-
- hence "(\<forall>x\<in>?A. \<forall>y\<in>?A. x <=_?r x +_?f y) \<and> (\<forall>x\<in>?A. \<forall>y\<in>?A. y <=_?r x +_?f y)"
- by (auto simp add: lesub_def plussub_def Err.le_def lift2_def split: err.split)
-
- moreover
-
- have "\<forall>x\<in>?A. \<forall>y\<in>?A. \<forall>z\<in>?A. x <=_?r z \<and> y <=_?r z \<longrightarrow> x +_?f y <=_?r z"
- proof (intro strip, elim conjE)
- fix x y z
- assume xyz: "x : ?A" "y : ?A" "z : ?A"
- assume xz: "x <=_?r z"
- assume yz: "y <=_?r z"
-
- { fix a b c
- assume ok: "x = OK a" "y = OK b" "z = OK c"
-
- { fix d e g
- assume some: "a = Some d" "b = Some e" "c = Some g"
-
- with ok xyz
- obtain "OK d:err A" "OK e:err A" "OK g:err A"
- by simp
- with lub
- have "\<lbrakk> (OK d) <=_(Err.le r) (OK g); (OK e) <=_(Err.le r) (OK g) \<rbrakk>
- \<Longrightarrow> (OK d) +_(lift2 f) (OK e) <=_(Err.le r) (OK g)"
- by blast
- hence "\<lbrakk> d <=_r g; e <=_r g \<rbrakk> \<Longrightarrow> \<exists>y. d +_f e = OK y \<and> y <=_r g"
- by simp
-
- with ok some xyz xz yz
- have "x +_?f y <=_?r z"
- by (auto simp add: sup_def le_def lesub_def lift2_def plussub_def Err.le_def)
- } note this [intro!]
-
- from ok xyz xz yz
- have "x +_?f y <=_?r z"
- by - (cases a, simp, cases b, simp, cases c, simp, blast)
- }
-
- with xyz xz yz
- show "x +_?f y <=_?r z"
- by - (cases x, simp, cases y, simp, cases z, simp+)
- qed
-
- ultimately
-
- show "semilat (?A,?r,?f)"
- by (unfold semilat_def) simp
-qed
-
-lemma top_le_opt_Some [iff]:
- "top (le r) (Some T) = top r T"
-apply (unfold top_def)
-apply (rule iffI)
- apply blast
-apply (rule allI)
-apply (case_tac "x")
-apply simp+
-done
-
-lemma Top_le_conv:
- "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T <=_r x) = (x = T)"
-apply (unfold top_def)
-apply (blast intro: order_antisym)
-done
-
-
-lemma acc_le_optI [intro!]:
- "acc r \<Longrightarrow> acc(le r)"
-apply (unfold acc_def lesub_def le_def lesssub_def)
-apply (simp add: wfP_eq_minimal split: option.split)
-apply clarify
-apply (case_tac "? a. Some a : Q")
- apply (erule_tac x = "{a . Some a : Q}" in allE)
- apply blast
-apply (case_tac "x")
- apply blast
-apply blast
-done
-
-lemma option_map_in_optionI:
- "\<lbrakk> ox : opt S; !x:S. ox = Some x \<longrightarrow> f x : S \<rbrakk>
- \<Longrightarrow> Option.map f ox : opt S";
-apply (unfold Option.map_def)
-apply (simp split: option.split)
-apply blast
-done
-
-end
--- a/src/HOL/MicroJava/BV/Product.thy Sun Nov 29 12:56:30 2009 +1100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,146 +0,0 @@
-(* Title: HOL/MicroJava/BV/Product.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 2000 TUM
-
-Products as semilattices
-*)
-
-header {* \isaheader{Products as Semilattices} *}
-
-theory Product
-imports Err
-begin
-
-constdefs
- le :: "'a ord \<Rightarrow> 'b ord \<Rightarrow> ('a * 'b) ord"
-"le rA rB == %(a,b) (a',b'). a <=_rA a' & b <=_rB b'"
-
- sup :: "'a ebinop \<Rightarrow> 'b ebinop \<Rightarrow> ('a * 'b)ebinop"
-"sup f g == %(a1,b1)(a2,b2). Err.sup Pair (a1 +_f a2) (b1 +_g b2)"
-
- esl :: "'a esl \<Rightarrow> 'b esl \<Rightarrow> ('a * 'b ) esl"
-"esl == %(A,rA,fA) (B,rB,fB). (A <*> B, le rA rB, sup fA fB)"
-
-syntax "@lesubprod" :: "'a*'b \<Rightarrow> 'a ord \<Rightarrow> 'b ord \<Rightarrow> 'b \<Rightarrow> bool"
- ("(_ /<='(_,_') _)" [50, 0, 0, 51] 50)
-translations "p <=(rA,rB) q" == "p <=_(Product.le rA rB) q"
-
-lemma unfold_lesub_prod:
- "p <=(rA,rB) q == le rA rB p q"
- by (simp add: lesub_def)
-
-lemma le_prod_Pair_conv [iff]:
- "((a1,b1) <=(rA,rB) (a2,b2)) = (a1 <=_rA a2 & b1 <=_rB b2)"
- by (simp add: lesub_def le_def)
-
-lemma less_prod_Pair_conv:
- "((a1,b1) <_(Product.le rA rB) (a2,b2)) =
- (a1 <_rA a2 & b1 <=_rB b2 | a1 <=_rA a2 & b1 <_rB b2)"
-apply (unfold lesssub_def)
-apply simp
-apply blast
-done
-
-lemma order_le_prod [iff]:
- "order(Product.le rA rB) = (order rA & order rB)"
-apply (unfold Semilat.order_def)
-apply simp
-apply blast
-done
-
-
-lemma acc_le_prodI [intro!]:
- "\<lbrakk> acc rA; acc rB \<rbrakk> \<Longrightarrow> acc(Product.le rA rB)"
-apply (unfold acc_def)
-apply (rule wfP_subset)
- apply (erule wf_lex_prod [to_pred, THEN wfP_wf_eq [THEN iffD2]])
- apply assumption
-apply (auto simp add: lesssub_def less_prod_Pair_conv lex_prod_def)
-done
-
-
-lemma closed_lift2_sup:
- "\<lbrakk> closed (err A) (lift2 f); closed (err B) (lift2 g) \<rbrakk> \<Longrightarrow>
- closed (err(A<*>B)) (lift2(sup f g))";
-apply (unfold closed_def plussub_def lift2_def err_def sup_def)
-apply (simp split: err.split)
-apply blast
-done
-
-lemma unfold_plussub_lift2:
- "e1 +_(lift2 f) e2 == lift2 f e1 e2"
- by (simp add: plussub_def)
-
-
-lemma plus_eq_Err_conv [simp]:
- assumes "x:A" and "y:A"
- and "semilat(err A, Err.le r, lift2 f)"
- shows "(x +_f y = Err) = (~(? z:A. x <=_r z & y <=_r z))"
-proof -
- have plus_le_conv2:
- "\<And>r f z. \<lbrakk> z : err A; semilat (err A, r, f); OK x : err A; OK y : err A;
- OK x +_f OK y <=_r z\<rbrakk> \<Longrightarrow> OK x <=_r z \<and> OK y <=_r z"
- by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1])
- from prems show ?thesis
- apply (rule_tac iffI)
- apply clarify
- apply (drule OK_le_err_OK [THEN iffD2])
- apply (drule OK_le_err_OK [THEN iffD2])
- apply (drule Semilat.lub [OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
- apply assumption
- apply assumption
- apply simp
- apply simp
- apply simp
- apply simp
- apply (case_tac "x +_f y")
- apply assumption
- apply (rename_tac "z")
- apply (subgoal_tac "OK z: err A")
- apply (frule plus_le_conv2)
- apply assumption
- apply simp
- apply blast
- apply simp
- apply (blast dest: Semilat.orderI [OF Semilat.intro] order_refl)
- apply blast
- apply (erule subst)
- apply (unfold semilat_def err_def closed_def)
- apply simp
- done
-qed
-
-lemma err_semilat_Product_esl:
- "\<And>L1 L2. \<lbrakk> err_semilat L1; err_semilat L2 \<rbrakk> \<Longrightarrow> err_semilat(Product.esl L1 L2)"
-apply (unfold esl_def Err.sl_def)
-apply (simp (no_asm_simp) only: split_tupled_all)
-apply simp
-apply (simp (no_asm) only: semilat_Def)
-apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
-apply (simp (no_asm) only: unfold_lesub_err Err.le_def unfold_plussub_lift2 sup_def)
-apply (auto elim: semilat_le_err_OK1 semilat_le_err_OK2
- simp add: lift2_def split: err.split)
-apply (blast dest: Semilat.orderI [OF Semilat.intro])
-apply (blast dest: Semilat.orderI [OF Semilat.intro])
-
-apply (rule OK_le_err_OK [THEN iffD1])
-apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
-apply simp
-apply simp
-apply simp
-apply simp
-apply simp
-apply simp
-
-apply (rule OK_le_err_OK [THEN iffD1])
-apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
-apply simp
-apply simp
-apply simp
-apply simp
-apply simp
-apply simp
-done
-
-end
--- a/src/HOL/MicroJava/BV/Semilat.thy Sun Nov 29 12:56:30 2009 +1100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,373 +0,0 @@
-(* Title: HOL/MicroJava/BV/Semilat.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 2000 TUM
-
-Semilattices
-*)
-
-header {*
- \chapter{Bytecode Verifier}\label{cha:bv}
- \isaheader{Semilattices}
-*}
-
-theory Semilat
-imports Main While_Combinator
-begin
-
-types 'a ord = "'a \<Rightarrow> 'a \<Rightarrow> bool"
- 'a binop = "'a \<Rightarrow> 'a \<Rightarrow> 'a"
- 'a sl = "'a set * 'a ord * 'a binop"
-
-consts
- "@lesub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /<='__ _)" [50, 1000, 51] 50)
- "@lesssub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /<'__ _)" [50, 1000, 51] 50)
-defs
-lesub_def: "x <=_r y == r x y"
-lesssub_def: "x <_r y == x <=_r y & x ~= y"
-
-syntax (xsymbols)
- "@lesub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<le>\<^sub>_ _)" [50, 1000, 51] 50)
-
-consts
- "@plussub" :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /+'__ _)" [65, 1000, 66] 65)
-defs
-plussub_def: "x +_f y == f x y"
-
-syntax (xsymbols)
- "@plussub" :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /+\<^sub>_ _)" [65, 1000, 66] 65)
-
-syntax (xsymbols)
- "@plussub" :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /\<squnion>\<^sub>_ _)" [65, 1000, 66] 65)
-
-
-constdefs
- order :: "'a ord \<Rightarrow> bool"
-"order r == (!x. x <=_r x) &
- (!x y. x <=_r y & y <=_r x \<longrightarrow> x=y) &
- (!x y z. x <=_r y & y <=_r z \<longrightarrow> x <=_r z)"
-
- acc :: "'a ord \<Rightarrow> bool"
-"acc r == wfP (\<lambda>y x. x <_r y)"
-
- top :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool"
-"top r T == !x. x <=_r T"
-
- closed :: "'a set \<Rightarrow> 'a binop \<Rightarrow> bool"
-"closed A f == !x:A. !y:A. x +_f y : A"
-
- semilat :: "'a sl \<Rightarrow> bool"
-"semilat == %(A,r,f). order r & closed A f &
- (!x:A. !y:A. x <=_r x +_f y) &
- (!x:A. !y:A. y <=_r x +_f y) &
- (!x:A. !y:A. !z:A. x <=_r z & y <=_r z \<longrightarrow> x +_f y <=_r z)"
-
- is_ub :: "'a ord \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
-"is_ub r x y u == r x u & r y u"
-
- is_lub :: "'a ord \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
-"is_lub r x y u == is_ub r x y u & (!z. is_ub r x y z \<longrightarrow> r u z)"
-
- some_lub :: "'a ord \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
-"some_lub r x y == SOME z. is_lub r x y z";
-
-locale Semilat =
- fixes A :: "'a set"
- and r :: "'a ord"
- and f :: "'a binop"
- assumes semilat: "semilat(A,r,f)"
-
-lemma order_refl [simp, intro]:
- "order r \<Longrightarrow> x <=_r x";
- by (simp add: order_def)
-
-lemma order_antisym:
- "\<lbrakk> order r; x <=_r y; y <=_r x \<rbrakk> \<Longrightarrow> x = y"
-apply (unfold order_def)
-apply (simp (no_asm_simp))
-done
-
-lemma order_trans:
- "\<lbrakk> order r; x <=_r y; y <=_r z \<rbrakk> \<Longrightarrow> x <=_r z"
-apply (unfold order_def)
-apply blast
-done
-
-lemma order_less_irrefl [intro, simp]:
- "order r \<Longrightarrow> ~ x <_r x"
-apply (unfold order_def lesssub_def)
-apply blast
-done
-
-lemma order_less_trans:
- "\<lbrakk> order r; x <_r y; y <_r z \<rbrakk> \<Longrightarrow> x <_r z"
-apply (unfold order_def lesssub_def)
-apply blast
-done
-
-lemma topD [simp, intro]:
- "top r T \<Longrightarrow> x <=_r T"
- by (simp add: top_def)
-
-lemma top_le_conv [simp]:
- "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T <=_r x) = (x = T)"
- by (blast intro: order_antisym)
-
-lemma semilat_Def:
-"semilat(A,r,f) == order r & closed A f &
- (!x:A. !y:A. x <=_r x +_f y) &
- (!x:A. !y:A. y <=_r x +_f y) &
- (!x:A. !y:A. !z:A. x <=_r z & y <=_r z \<longrightarrow> x +_f y <=_r z)"
-apply (unfold semilat_def split_conv [THEN eq_reflection])
-apply (rule refl [THEN eq_reflection])
-done
-
-lemma (in Semilat) orderI [simp, intro]:
- "order r"
- by (insert semilat) (simp add: semilat_Def)
-
-lemma (in Semilat) closedI [simp, intro]:
- "closed A f"
- by (insert semilat) (simp add: semilat_Def)
-
-lemma closedD:
- "\<lbrakk> closed A f; x:A; y:A \<rbrakk> \<Longrightarrow> x +_f y : A"
- by (unfold closed_def) blast
-
-lemma closed_UNIV [simp]: "closed UNIV f"
- by (simp add: closed_def)
-
-
-lemma (in Semilat) closed_f [simp, intro]:
- "\<lbrakk>x:A; y:A\<rbrakk> \<Longrightarrow> x +_f y : A"
- by (simp add: closedD [OF closedI])
-
-lemma (in Semilat) refl_r [intro, simp]:
- "x <=_r x"
- by simp
-
-lemma (in Semilat) antisym_r [intro?]:
- "\<lbrakk> x <=_r y; y <=_r x \<rbrakk> \<Longrightarrow> x = y"
- by (rule order_antisym) auto
-
-lemma (in Semilat) trans_r [trans, intro?]:
- "\<lbrakk>x <=_r y; y <=_r z\<rbrakk> \<Longrightarrow> x <=_r z"
- by (auto intro: order_trans)
-
-
-lemma (in Semilat) ub1 [simp, intro?]:
- "\<lbrakk> x:A; y:A \<rbrakk> \<Longrightarrow> x <=_r x +_f y"
- by (insert semilat) (unfold semilat_Def, simp)
-
-lemma (in Semilat) ub2 [simp, intro?]:
- "\<lbrakk> x:A; y:A \<rbrakk> \<Longrightarrow> y <=_r x +_f y"
- by (insert semilat) (unfold semilat_Def, simp)
-
-lemma (in Semilat) lub [simp, intro?]:
- "\<lbrakk> x <=_r z; y <=_r z; x:A; y:A; z:A \<rbrakk> \<Longrightarrow> x +_f y <=_r z";
- by (insert semilat) (unfold semilat_Def, simp)
-
-
-lemma (in Semilat) plus_le_conv [simp]:
- "\<lbrakk> x:A; y:A; z:A \<rbrakk> \<Longrightarrow> (x +_f y <=_r z) = (x <=_r z & y <=_r z)"
- by (blast intro: ub1 ub2 lub order_trans)
-
-lemma (in Semilat) le_iff_plus_unchanged:
- "\<lbrakk> x:A; y:A \<rbrakk> \<Longrightarrow> (x <=_r y) = (x +_f y = y)"
-apply (rule iffI)
- apply (blast intro: antisym_r refl_r lub ub2)
-apply (erule subst)
-apply simp
-done
-
-lemma (in Semilat) le_iff_plus_unchanged2:
- "\<lbrakk> x:A; y:A \<rbrakk> \<Longrightarrow> (x <=_r y) = (y +_f x = y)"
-apply (rule iffI)
- apply (blast intro: order_antisym lub order_refl ub1)
-apply (erule subst)
-apply simp
-done
-
-
-lemma (in Semilat) plus_assoc [simp]:
- assumes a: "a \<in> A" and b: "b \<in> A" and c: "c \<in> A"
- shows "a +_f (b +_f c) = a +_f b +_f c"
-proof -
- from a b have ab: "a +_f b \<in> A" ..
- from this c have abc: "(a +_f b) +_f c \<in> A" ..
- from b c have bc: "b +_f c \<in> A" ..
- from a this have abc': "a +_f (b +_f c) \<in> A" ..
-
- show ?thesis
- proof
- show "a +_f (b +_f c) <=_r (a +_f b) +_f c"
- proof -
- from a b have "a <=_r a +_f b" ..
- also from ab c have "\<dots> <=_r \<dots> +_f c" ..
- finally have "a<": "a <=_r (a +_f b) +_f c" .
- from a b have "b <=_r a +_f b" ..
- also from ab c have "\<dots> <=_r \<dots> +_f c" ..
- finally have "b<": "b <=_r (a +_f b) +_f c" .
- from ab c have "c<": "c <=_r (a +_f b) +_f c" ..
- from "b<" "c<" b c abc have "b +_f c <=_r (a +_f b) +_f c" ..
- from "a<" this a bc abc show ?thesis ..
- qed
- show "(a +_f b) +_f c <=_r a +_f (b +_f c)"
- proof -
- from b c have "b <=_r b +_f c" ..
- also from a bc have "\<dots> <=_r a +_f \<dots>" ..
- finally have "b<": "b <=_r a +_f (b +_f c)" .
- from b c have "c <=_r b +_f c" ..
- also from a bc have "\<dots> <=_r a +_f \<dots>" ..
- finally have "c<": "c <=_r a +_f (b +_f c)" .
- from a bc have "a<": "a <=_r a +_f (b +_f c)" ..
- from "a<" "b<" a b abc' have "a +_f b <=_r a +_f (b +_f c)" ..
- from this "c<" ab c abc' show ?thesis ..
- qed
- qed
-qed
-
-lemma (in Semilat) plus_com_lemma:
- "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a +_f b <=_r b +_f a"
-proof -
- assume a: "a \<in> A" and b: "b \<in> A"
- from b a have "a <=_r b +_f a" ..
- moreover from b a have "b <=_r b +_f a" ..
- moreover note a b
- moreover from b a have "b +_f a \<in> A" ..
- ultimately show ?thesis ..
-qed
-
-lemma (in Semilat) plus_commutative:
- "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a +_f b = b +_f a"
-by(blast intro: order_antisym plus_com_lemma)
-
-lemma is_lubD:
- "is_lub r x y u \<Longrightarrow> is_ub r x y u & (!z. is_ub r x y z \<longrightarrow> r u z)"
- by (simp add: is_lub_def)
-
-lemma is_ubI:
- "\<lbrakk> r x u; r y u \<rbrakk> \<Longrightarrow> is_ub r x y u"
- by (simp add: is_ub_def)
-
-lemma is_ubD:
- "is_ub r x y u \<Longrightarrow> r x u & r y u"
- by (simp add: is_ub_def)
-
-
-lemma is_lub_bigger1 [iff]:
- "is_lub (r^** ) x y y = r^** x y"
-apply (unfold is_lub_def is_ub_def)
-apply blast
-done
-
-lemma is_lub_bigger2 [iff]:
- "is_lub (r^** ) x y x = r^** y x"
-apply (unfold is_lub_def is_ub_def)
-apply blast
-done
-
-lemma extend_lub:
- "\<lbrakk> single_valuedP r; is_lub (r^** ) x y u; r x' x \<rbrakk>
- \<Longrightarrow> EX v. is_lub (r^** ) x' y v"
-apply (unfold is_lub_def is_ub_def)
-apply (case_tac "r^** y x")
- apply (case_tac "r^** y x'")
- apply blast
- apply (blast elim: converse_rtranclpE dest: single_valuedD)
-apply (rule exI)
-apply (rule conjI)
- apply (blast intro: converse_rtranclp_into_rtranclp dest: single_valuedD)
-apply (blast intro: rtranclp.rtrancl_into_rtrancl converse_rtranclp_into_rtranclp
- elim: converse_rtranclpE dest: single_valuedD)
-done
-
-lemma single_valued_has_lubs [rule_format]:
- "\<lbrakk> single_valuedP r; r^** x u \<rbrakk> \<Longrightarrow> (!y. r^** y u \<longrightarrow>
- (EX z. is_lub (r^** ) x y z))"
-apply (erule converse_rtranclp_induct)
- apply clarify
- apply (erule converse_rtranclp_induct)
- apply blast
- apply (blast intro: converse_rtranclp_into_rtranclp)
-apply (blast intro: extend_lub)
-done
-
-lemma some_lub_conv:
- "\<lbrakk> acyclicP r; is_lub (r^** ) x y u \<rbrakk> \<Longrightarrow> some_lub (r^** ) x y = u"
-apply (unfold some_lub_def is_lub_def)
-apply (rule someI2)
- apply assumption
-apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl [to_pred])
-done
-
-lemma is_lub_some_lub:
- "\<lbrakk> single_valuedP r; acyclicP r; r^** x u; r^** y u \<rbrakk>
- \<Longrightarrow> is_lub (r^** ) x y (some_lub (r^** ) x y)";
- by (fastsimp dest: single_valued_has_lubs simp add: some_lub_conv)
-
-subsection{*An executable lub-finder*}
-
-constdefs
- exec_lub :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a binop"
-"exec_lub r f x y == while (\<lambda>z. \<not> r\<^sup>*\<^sup>* x z) f y"
-
-
-lemma acyclic_single_valued_finite:
- "\<lbrakk>acyclicP r; single_valuedP r; r\<^sup>*\<^sup>* x y \<rbrakk>
- \<Longrightarrow> finite ({(x, y). r x y} \<inter> {a. r\<^sup>*\<^sup>* x a} \<times> {b. r\<^sup>*\<^sup>* b y})"
-apply(erule converse_rtranclp_induct)
- apply(rule_tac B = "{}" in finite_subset)
- apply(simp only:acyclic_def [to_pred])
- apply(blast intro:rtranclp_into_tranclp2 rtranclp_tranclp_tranclp)
- apply simp
-apply(rename_tac x x')
-apply(subgoal_tac "{(x, y). r x y} \<inter> {a. r\<^sup>*\<^sup>* x a} \<times> {b. r\<^sup>*\<^sup>* b y} =
- insert (x,x') ({(x, y). r x y} \<inter> {a. r\<^sup>*\<^sup>* x' a} \<times> {b. r\<^sup>*\<^sup>* b y})")
- apply simp
-apply(blast intro:converse_rtranclp_into_rtranclp
- elim:converse_rtranclpE dest:single_valuedD)
-done
-
-
-lemma exec_lub_conv:
- "\<lbrakk> acyclicP r; !x y. r x y \<longrightarrow> f x = y; is_lub (r\<^sup>*\<^sup>*) x y u \<rbrakk> \<Longrightarrow>
- exec_lub r f x y = u";
-apply(unfold exec_lub_def)
-apply(rule_tac P = "\<lambda>z. r\<^sup>*\<^sup>* y z \<and> r\<^sup>*\<^sup>* z u" and
- r = "({(x, y). r x y} \<inter> {(a,b). r\<^sup>*\<^sup>* y a \<and> r\<^sup>*\<^sup>* b u})^-1" in while_rule)
- apply(blast dest: is_lubD is_ubD)
- apply(erule conjE)
- apply(erule_tac z = u in converse_rtranclpE)
- apply(blast dest: is_lubD is_ubD)
- apply(blast dest: rtranclp.rtrancl_into_rtrancl)
- apply(rename_tac s)
- apply(subgoal_tac "is_ub (r\<^sup>*\<^sup>*) x y s")
- prefer 2; apply(simp add:is_ub_def)
- apply(subgoal_tac "r\<^sup>*\<^sup>* u s")
- prefer 2; apply(blast dest:is_lubD)
- apply(erule converse_rtranclpE)
- apply blast
- apply(simp only:acyclic_def [to_pred])
- apply(blast intro:rtranclp_into_tranclp2 rtranclp_tranclp_tranclp)
- apply(rule finite_acyclic_wf)
- apply simp
- apply(erule acyclic_single_valued_finite)
- apply(blast intro:single_valuedI)
- apply(simp add:is_lub_def is_ub_def)
- apply simp
- apply(erule acyclic_subset)
- apply blast
-apply simp
-apply(erule conjE)
-apply(erule_tac z = u in converse_rtranclpE)
- apply(blast dest: is_lubD is_ubD)
-apply blast
-done
-
-lemma is_lub_exec_lub:
- "\<lbrakk> single_valuedP r; acyclicP r; r^** x u; r^** y u; !x y. r x y \<longrightarrow> f x = y \<rbrakk>
- \<Longrightarrow> is_lub (r^** ) x y (exec_lub r f x y)"
- by (fastsimp dest: single_valued_has_lubs simp add: exec_lub_conv)
-
-end
--- a/src/HOL/MicroJava/BV/SemilatAlg.thy Sun Nov 29 12:56:30 2009 +1100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,188 +0,0 @@
-(* Title: HOL/MicroJava/BV/SemilatAlg.thy
- ID: $Id$
- Author: Gerwin Klein
- Copyright 2002 Technische Universitaet Muenchen
-*)
-
-header {* \isaheader{More on Semilattices} *}
-
-theory SemilatAlg
-imports Typing_Framework Product
-begin
-
-
-constdefs
- lesubstep_type :: "(nat \<times> 's) list \<Rightarrow> 's ord \<Rightarrow> (nat \<times> 's) list \<Rightarrow> bool"
- ("(_ /<=|_| _)" [50, 0, 51] 50)
- "x <=|r| y \<equiv> \<forall>(p,s) \<in> set x. \<exists>s'. (p,s') \<in> set y \<and> s <=_r s'"
-
-consts
- "@plusplussub" :: "'a list \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" ("(_ /++'__ _)" [65, 1000, 66] 65)
-primrec
- "[] ++_f y = y"
- "(x#xs) ++_f y = xs ++_f (x +_f y)"
-
-constdefs
- bounded :: "'s step_type \<Rightarrow> nat \<Rightarrow> bool"
-"bounded step n == !p<n. !s. !(q,t):set(step p s). q<n"
-
- pres_type :: "'s step_type \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
-"pres_type step n A == \<forall>s\<in>A. \<forall>p<n. \<forall>(q,s')\<in>set (step p s). s' \<in> A"
-
- mono :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
-"mono r step n A ==
- \<forall>s p t. s \<in> A \<and> p < n \<and> s <=_r t \<longrightarrow> step p s <=|r| step p t"
-
-
-lemma pres_typeD:
- "\<lbrakk> pres_type step n A; s\<in>A; p<n; (q,s')\<in>set (step p s) \<rbrakk> \<Longrightarrow> s' \<in> A"
- by (unfold pres_type_def, blast)
-
-lemma monoD:
- "\<lbrakk> mono r step n A; p < n; s\<in>A; s <=_r t \<rbrakk> \<Longrightarrow> step p s <=|r| step p t"
- by (unfold mono_def, blast)
-
-lemma boundedD:
- "\<lbrakk> bounded step n; p < n; (q,t) : set (step p xs) \<rbrakk> \<Longrightarrow> q < n"
- by (unfold bounded_def, blast)
-
-lemma lesubstep_type_refl [simp, intro]:
- "(\<And>x. x <=_r x) \<Longrightarrow> x <=|r| x"
- by (unfold lesubstep_type_def) auto
-
-lemma lesub_step_typeD:
- "a <=|r| b \<Longrightarrow> (x,y) \<in> set a \<Longrightarrow> \<exists>y'. (x, y') \<in> set b \<and> y <=_r y'"
- by (unfold lesubstep_type_def) blast
-
-
-lemma list_update_le_listI [rule_format]:
- "set xs <= A \<longrightarrow> set ys <= A \<longrightarrow> xs <=[r] ys \<longrightarrow> p < size xs \<longrightarrow>
- x <=_r ys!p \<longrightarrow> semilat(A,r,f) \<longrightarrow> x\<in>A \<longrightarrow>
- xs[p := x +_f xs!p] <=[r] ys"
- apply (unfold Listn.le_def lesub_def semilat_def)
- apply (simp add: list_all2_conv_all_nth nth_list_update)
- done
-
-
-lemma plusplus_closed: assumes "semilat (A, r, f)" shows
- "\<And>y. \<lbrakk> set x \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> x ++_f y \<in> A" (is "PROP ?P")
-proof -
- interpret Semilat A r f using assms by (rule Semilat.intro)
- show "PROP ?P" proof (induct x)
- show "\<And>y. y \<in> A \<Longrightarrow> [] ++_f y \<in> A" by simp
- fix y x xs
- assume y: "y \<in> A" and xs: "set (x#xs) \<subseteq> A"
- assume IH: "\<And>y. \<lbrakk> set xs \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> xs ++_f y \<in> A"
- from xs obtain x: "x \<in> A" and xs': "set xs \<subseteq> A" by simp
- from x y have "(x +_f y) \<in> A" ..
- with xs' have "xs ++_f (x +_f y) \<in> A" by (rule IH)
- thus "(x#xs) ++_f y \<in> A" by simp
- qed
-qed
-
-lemma (in Semilat) pp_ub2:
- "\<And>y. \<lbrakk> set x \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> y <=_r x ++_f y"
-proof (induct x)
- from semilat show "\<And>y. y <=_r [] ++_f y" by simp
-
- fix y a l
- assume y: "y \<in> A"
- assume "set (a#l) \<subseteq> A"
- then obtain a: "a \<in> A" and x: "set l \<subseteq> A" by simp
- assume "\<And>y. \<lbrakk>set l \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> y <=_r l ++_f y"
- hence IH: "\<And>y. y \<in> A \<Longrightarrow> y <=_r l ++_f y" using x .
-
- from a y have "y <=_r a +_f y" ..
- also from a y have "a +_f y \<in> A" ..
- hence "(a +_f y) <=_r l ++_f (a +_f y)" by (rule IH)
- finally have "y <=_r l ++_f (a +_f y)" .
- thus "y <=_r (a#l) ++_f y" by simp
-qed
-
-
-lemma (in Semilat) pp_ub1:
-shows "\<And>y. \<lbrakk>set ls \<subseteq> A; y \<in> A; x \<in> set ls\<rbrakk> \<Longrightarrow> x <=_r ls ++_f y"
-proof (induct ls)
- show "\<And>y. x \<in> set [] \<Longrightarrow> x <=_r [] ++_f y" by simp
-
- fix y s ls
- assume "set (s#ls) \<subseteq> A"
- then obtain s: "s \<in> A" and ls: "set ls \<subseteq> A" by simp
- assume y: "y \<in> A"
-
- assume
- "\<And>y. \<lbrakk>set ls \<subseteq> A; y \<in> A; x \<in> set ls\<rbrakk> \<Longrightarrow> x <=_r ls ++_f y"
- hence IH: "\<And>y. x \<in> set ls \<Longrightarrow> y \<in> A \<Longrightarrow> x <=_r ls ++_f y" using ls .
-
- assume "x \<in> set (s#ls)"
- then obtain xls: "x = s \<or> x \<in> set ls" by simp
- moreover {
- assume xs: "x = s"
- from s y have "s <=_r s +_f y" ..
- also from s y have "s +_f y \<in> A" ..
- with ls have "(s +_f y) <=_r ls ++_f (s +_f y)" by (rule pp_ub2)
- finally have "s <=_r ls ++_f (s +_f y)" .
- with xs have "x <=_r ls ++_f (s +_f y)" by simp
- }
- moreover {
- assume "x \<in> set ls"
- hence "\<And>y. y \<in> A \<Longrightarrow> x <=_r ls ++_f y" by (rule IH)
- moreover from s y have "s +_f y \<in> A" ..
- ultimately have "x <=_r ls ++_f (s +_f y)" .
- }
- ultimately
- have "x <=_r ls ++_f (s +_f y)" by blast
- thus "x <=_r (s#ls) ++_f y" by simp
-qed
-
-
-lemma (in Semilat) pp_lub:
- assumes z: "z \<in> A"
- shows
- "\<And>y. y \<in> A \<Longrightarrow> set xs \<subseteq> A \<Longrightarrow> \<forall>x \<in> set xs. x <=_r z \<Longrightarrow> y <=_r z \<Longrightarrow> xs ++_f y <=_r z"
-proof (induct xs)
- fix y assume "y <=_r z" thus "[] ++_f y <=_r z" by simp
-next
- fix y l ls assume y: "y \<in> A" and "set (l#ls) \<subseteq> A"
- then obtain l: "l \<in> A" and ls: "set ls \<subseteq> A" by auto
- assume "\<forall>x \<in> set (l#ls). x <=_r z"
- then obtain lz: "l <=_r z" and lsz: "\<forall>x \<in> set ls. x <=_r z" by auto
- assume "y <=_r z" with lz have "l +_f y <=_r z" using l y z ..
- moreover
- from l y have "l +_f y \<in> A" ..
- moreover
- assume "\<And>y. y \<in> A \<Longrightarrow> set ls \<subseteq> A \<Longrightarrow> \<forall>x \<in> set ls. x <=_r z \<Longrightarrow> y <=_r z
- \<Longrightarrow> ls ++_f y <=_r z"
- ultimately
- have "ls ++_f (l +_f y) <=_r z" using ls lsz by -
- thus "(l#ls) ++_f y <=_r z" by simp
-qed
-
-
-lemma ub1':
- assumes "semilat (A, r, f)"
- shows "\<lbrakk>\<forall>(p,s) \<in> set S. s \<in> A; y \<in> A; (a,b) \<in> set S\<rbrakk>
- \<Longrightarrow> b <=_r map snd [(p', t')\<leftarrow>S. p' = a] ++_f y"
-proof -
- interpret Semilat A r f using assms by (rule Semilat.intro)
-
- let "b <=_r ?map ++_f y" = ?thesis
-
- assume "y \<in> A"
- moreover
- assume "\<forall>(p,s) \<in> set S. s \<in> A"
- hence "set ?map \<subseteq> A" by auto
- moreover
- assume "(a,b) \<in> set S"
- hence "b \<in> set ?map" by (induct S, auto)
- ultimately
- show ?thesis by - (rule pp_ub1)
-qed
-
-
-lemma plusplus_empty:
- "\<forall>s'. (q, s') \<in> set S \<longrightarrow> s' +_f ss ! q = ss ! q \<Longrightarrow>
- (map snd [(p', t') \<leftarrow> S. p' = q] ++_f ss ! q) = ss ! q"
- by (induct S) auto
-
-end
--- a/src/HOL/MicroJava/BV/Typing_Framework.thy Sun Nov 29 12:56:30 2009 +1100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,37 +0,0 @@
-(* Title: HOL/MicroJava/BV/Typing_Framework.thy
- ID: $Id$
- Author: Tobias Nipkow
- Copyright 2000 TUM
-*)
-
-header {* \isaheader{Typing and Dataflow Analysis Framework} *}
-
-theory Typing_Framework
-imports Listn
-begin
-
-text {*
- The relationship between dataflow analysis and a welltyped-instruction predicate.
-*}
-types
- 's step_type = "nat \<Rightarrow> 's \<Rightarrow> (nat \<times> 's) list"
-
-constdefs
- stable :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> nat \<Rightarrow> bool"
-"stable r step ss p == !(q,s'):set(step p (ss!p)). s' <=_r ss!q"
-
- stables :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> bool"
-"stables r step ss == !p<size ss. stable r step ss p"
-
- wt_step ::
-"'s ord \<Rightarrow> 's \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> bool"
-"wt_step r T step ts ==
- !p<size(ts). ts!p ~= T & stable r step ts p"
-
- is_bcv :: "'s ord \<Rightarrow> 's \<Rightarrow> 's step_type
- \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> ('s list \<Rightarrow> 's list) \<Rightarrow> bool"
-"is_bcv r T step n A bcv == !ss : list n A.
- (!p<n. (bcv ss)!p ~= T) =
- (? ts: list n A. ss <=[r] ts & wt_step r T step ts)"
-
-end
--- a/src/HOL/MicroJava/BV/Typing_Framework_JVM.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/BV/Typing_Framework_JVM.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1,13 +1,13 @@
(* Title: HOL/MicroJava/BV/JVM.thy
- ID: $Id$
Author: Tobias Nipkow, Gerwin Klein
Copyright 2000 TUM
*)
header {* \isaheader{The Typing Framework for the JVM}\label{sec:JVM} *}
-theory Typing_Framework_JVM imports Typing_Framework_err JVMType EffectMono BVSpec begin
-
+theory Typing_Framework_JVM
+imports "../DFA/Abstract_BV" JVMType EffectMono BVSpec
+begin
constdefs
exec :: "jvm_prog \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> exception_table \<Rightarrow> instr list \<Rightarrow> JVMType.state step_type"
--- a/src/HOL/MicroJava/BV/Typing_Framework_err.thy Sun Nov 29 12:56:30 2009 +1100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,255 +0,0 @@
-(* Title: HOL/MicroJava/BV/Typing_Framework_err.thy
- ID: $Id$
- Author: Gerwin Klein
- Copyright 2000 TUM
-
-*)
-
-header {* \isaheader{Lifting the Typing Framework to err, app, and eff} *}
-
-theory Typing_Framework_err
-imports Typing_Framework SemilatAlg
-begin
-
-constdefs
-
-wt_err_step :: "'s ord \<Rightarrow> 's err step_type \<Rightarrow> 's err list \<Rightarrow> bool"
-"wt_err_step r step ts \<equiv> wt_step (Err.le r) Err step ts"
-
-wt_app_eff :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> bool"
-"wt_app_eff r app step ts \<equiv>
- \<forall>p < size ts. app p (ts!p) \<and> (\<forall>(q,t) \<in> set (step p (ts!p)). t <=_r ts!q)"
-
-map_snd :: "('b \<Rightarrow> 'c) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'c) list"
-"map_snd f \<equiv> map (\<lambda>(x,y). (x, f y))"
-
-error :: "nat \<Rightarrow> (nat \<times> 'a err) list"
-"error n \<equiv> map (\<lambda>x. (x,Err)) [0..<n]"
-
-err_step :: "nat \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's err step_type"
-"err_step n app step p t \<equiv>
- case t of
- Err \<Rightarrow> error n
- | OK t' \<Rightarrow> if app p t' then map_snd OK (step p t') else error n"
-
-app_mono :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
-"app_mono r app n A \<equiv>
- \<forall>s p t. s \<in> A \<and> p < n \<and> s <=_r t \<longrightarrow> app p t \<longrightarrow> app p s"
-
-
-lemmas err_step_defs = err_step_def map_snd_def error_def
-
-
-lemma bounded_err_stepD:
- "bounded (err_step n app step) n \<Longrightarrow>
- p < n \<Longrightarrow> app p a \<Longrightarrow> (q,b) \<in> set (step p a) \<Longrightarrow>
- q < n"
- apply (simp add: bounded_def err_step_def)
- apply (erule allE, erule impE, assumption)
- apply (erule_tac x = "OK a" in allE, drule bspec)
- apply (simp add: map_snd_def)
- apply fast
- apply simp
- done
-
-
-lemma in_map_sndD: "(a,b) \<in> set (map_snd f xs) \<Longrightarrow> \<exists>b'. (a,b') \<in> set xs"
- apply (induct xs)
- apply (auto simp add: map_snd_def)
- done
-
-
-lemma bounded_err_stepI:
- "\<forall>p. p < n \<longrightarrow> (\<forall>s. ap p s \<longrightarrow> (\<forall>(q,s') \<in> set (step p s). q < n))
- \<Longrightarrow> bounded (err_step n ap step) n"
-apply (clarsimp simp: bounded_def err_step_def split: err.splits)
-apply (simp add: error_def image_def)
-apply (blast dest: in_map_sndD)
-done
-
-
-lemma bounded_lift:
- "bounded step n \<Longrightarrow> bounded (err_step n app step) n"
- apply (unfold bounded_def err_step_def error_def)
- apply clarify
- apply (erule allE, erule impE, assumption)
- apply (case_tac s)
- apply (auto simp add: map_snd_def split: split_if_asm)
- done
-
-
-lemma le_list_map_OK [simp]:
- "\<And>b. map OK a <=[Err.le r] map OK b = (a <=[r] b)"
- apply (induct a)
- apply simp
- apply simp
- apply (case_tac b)
- apply simp
- apply simp
- done
-
-
-lemma map_snd_lessI:
- "x <=|r| y \<Longrightarrow> map_snd OK x <=|Err.le r| map_snd OK y"
- apply (induct x)
- apply (unfold lesubstep_type_def map_snd_def)
- apply auto
- done
-
-
-lemma mono_lift:
- "order r \<Longrightarrow> app_mono r app n A \<Longrightarrow> bounded (err_step n app step) n \<Longrightarrow>
- \<forall>s p t. s \<in> A \<and> p < n \<and> s <=_r t \<longrightarrow> app p t \<longrightarrow> step p s <=|r| step p t \<Longrightarrow>
- mono (Err.le r) (err_step n app step) n (err A)"
-apply (unfold app_mono_def mono_def err_step_def)
-apply clarify
-apply (case_tac s)
- apply simp
-apply simp
-apply (case_tac t)
- apply simp
- apply clarify
- apply (simp add: lesubstep_type_def error_def)
- apply clarify
- apply (drule in_map_sndD)
- apply clarify
- apply (drule bounded_err_stepD, assumption+)
- apply (rule exI [of _ Err])
- apply simp
-apply simp
-apply (erule allE, erule allE, erule allE, erule impE)
- apply (rule conjI, assumption)
- apply (rule conjI, assumption)
- apply assumption
-apply (rule conjI)
-apply clarify
-apply (erule allE, erule allE, erule allE, erule impE)
- apply (rule conjI, assumption)
- apply (rule conjI, assumption)
- apply assumption
-apply (erule impE, assumption)
-apply (rule map_snd_lessI, assumption)
-apply clarify
-apply (simp add: lesubstep_type_def error_def)
-apply clarify
-apply (drule in_map_sndD)
-apply clarify
-apply (drule bounded_err_stepD, assumption+)
-apply (rule exI [of _ Err])
-apply simp
-done
-
-lemma in_errorD:
- "(x,y) \<in> set (error n) \<Longrightarrow> y = Err"
- by (auto simp add: error_def)
-
-lemma pres_type_lift:
- "\<forall>s\<in>A. \<forall>p. p < n \<longrightarrow> app p s \<longrightarrow> (\<forall>(q, s')\<in>set (step p s). s' \<in> A)
- \<Longrightarrow> pres_type (err_step n app step) n (err A)"
-apply (unfold pres_type_def err_step_def)
-apply clarify
-apply (case_tac b)
- apply simp
-apply (case_tac s)
- apply simp
- apply (drule in_errorD)
- apply simp
-apply (simp add: map_snd_def split: split_if_asm)
- apply fast
-apply (drule in_errorD)
-apply simp
-done
-
-
-
-text {*
- There used to be a condition here that each instruction must have a
- successor. This is not needed any more, because the definition of
- @{term error} trivially ensures that there is a successor for
- the critical case where @{term app} does not hold.
-*}
-lemma wt_err_imp_wt_app_eff:
- assumes wt: "wt_err_step r (err_step (size ts) app step) ts"
- assumes b: "bounded (err_step (size ts) app step) (size ts)"
- shows "wt_app_eff r app step (map ok_val ts)"
-proof (unfold wt_app_eff_def, intro strip, rule conjI)
- fix p assume "p < size (map ok_val ts)"
- hence lp: "p < size ts" by simp
- hence ts: "0 < size ts" by (cases p) auto
- hence err: "(0,Err) \<in> set (error (size ts))" by (simp add: error_def)
-
- from wt lp
- have [intro?]: "\<And>p. p < size ts \<Longrightarrow> ts ! p \<noteq> Err"
- by (unfold wt_err_step_def wt_step_def) simp
-
- show app: "app p (map ok_val ts ! p)"
- proof (rule ccontr)
- from wt lp obtain s where
- OKp: "ts ! p = OK s" and
- less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
- by (unfold wt_err_step_def wt_step_def stable_def)
- (auto iff: not_Err_eq)
- assume "\<not> app p (map ok_val ts ! p)"
- with OKp lp have "\<not> app p s" by simp
- with OKp have "err_step (size ts) app step p (ts!p) = error (size ts)"
- by (simp add: err_step_def)
- with err ts obtain q where
- "(q,Err) \<in> set (err_step (size ts) app step p (ts!p))" and
- q: "q < size ts" by auto
- with less have "ts!q = Err" by auto
- moreover from q have "ts!q \<noteq> Err" ..
- ultimately show False by blast
- qed
-
- show "\<forall>(q,t)\<in>set(step p (map ok_val ts ! p)). t <=_r map ok_val ts ! q"
- proof clarify
- fix q t assume q: "(q,t) \<in> set (step p (map ok_val ts ! p))"
-
- from wt lp q
- obtain s where
- OKp: "ts ! p = OK s" and
- less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
- by (unfold wt_err_step_def wt_step_def stable_def)
- (auto iff: not_Err_eq)
-
- from b lp app q have lq: "q < size ts" by (rule bounded_err_stepD)
- hence "ts!q \<noteq> Err" ..
- then obtain s' where OKq: "ts ! q = OK s'" by (auto iff: not_Err_eq)
-
- from lp lq OKp OKq app less q
- show "t <=_r map ok_val ts ! q"
- by (auto simp add: err_step_def map_snd_def)
- qed
-qed
-
-
-lemma wt_app_eff_imp_wt_err:
- assumes app_eff: "wt_app_eff r app step ts"
- assumes bounded: "bounded (err_step (size ts) app step) (size ts)"
- shows "wt_err_step r (err_step (size ts) app step) (map OK ts)"
-proof (unfold wt_err_step_def wt_step_def, intro strip, rule conjI)
- fix p assume "p < size (map OK ts)"
- hence p: "p < size ts" by simp
- thus "map OK ts ! p \<noteq> Err" by simp
- { fix q t
- assume q: "(q,t) \<in> set (err_step (size ts) app step p (map OK ts ! p))"
- with p app_eff obtain
- "app p (ts ! p)" "\<forall>(q,t) \<in> set (step p (ts!p)). t <=_r ts!q"
- by (unfold wt_app_eff_def) blast
- moreover
- from q p bounded have "q < size ts"
- by - (rule boundedD)
- hence "map OK ts ! q = OK (ts!q)" by simp
- moreover
- have "p < size ts" by (rule p)
- moreover note q
- ultimately
- have "t <=_(Err.le r) map OK ts ! q"
- by (auto simp add: err_step_def map_snd_def)
- }
- thus "stable (Err.le r) (err_step (size ts) app step) (map OK ts) p"
- by (unfold stable_def) blast
-qed
-
-end
-
--- a/src/HOL/MicroJava/Comp/CorrCompTp.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/Comp/CorrCompTp.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1122,6 +1122,8 @@
apply simp+
done
+declare not_Err_eq [iff del]
+
lemma bc_mt_corresp_Load: "\<lbrakk> i < length LT; LT ! i \<noteq> Err; mxr = length LT \<rbrakk>
\<Longrightarrow> bc_mt_corresp [Load i]
(\<lambda>(ST, LT). pushST [ok_val (LT ! i)] (ST, LT)) (ST, LT) cG rT mxr (Suc 0)"
@@ -1138,7 +1140,7 @@
apply (frule listE_nth_in) apply assumption
apply (subgoal_tac "LT ! i \<in> {x. \<exists>y\<in>types cG. x = OK y}")
apply (drule CollectD) apply (erule bexE)
-apply (simp (no_asm_simp) )
+apply (simp (no_asm_simp))
apply blast
apply blast
done
--- a/src/HOL/MicroJava/Comp/LemmasComp.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/Comp/LemmasComp.thy Mon Nov 30 08:08:31 2009 +0100
@@ -110,7 +110,7 @@
by (case_tac "class G C", auto simp: is_class_def dest: comp_class_imp)
lemma comp_subcls1: "subcls1 (comp G) = subcls1 G"
-by (auto simp add: subcls1_def2 comp_classname comp_is_class expand_fun_eq)
+by (auto simp add: subcls1_def2 comp_classname comp_is_class)
lemma comp_widen: "widen (comp G) = widen G"
apply (simp add: expand_fun_eq)
@@ -183,17 +183,17 @@
done
-lemma comp_class_rec: " wfP ((subcls1 G)^--1) \<Longrightarrow>
+lemma comp_class_rec: " wf ((subcls1 G)^-1) \<Longrightarrow>
class_rec (comp G) C t f =
class_rec G C t (\<lambda> C' fs' ms' r'. f C' fs' (map (compMethod G C') ms') r')"
-apply (rule_tac a = C in wfP_induct) apply assumption
-apply (subgoal_tac "wfP ((subcls1 (comp G))\<inverse>\<inverse>)")
+apply (rule_tac a = C in wf_induct) apply assumption
+apply (subgoal_tac "wf ((subcls1 (comp G))^-1)")
apply (subgoal_tac "(class G x = None) \<or> (\<exists> D fs ms. (class G x = Some (D, fs, ms)))")
apply (erule disjE)
(* case class G x = None *)
apply (simp (no_asm_simp) add: class_rec_def comp_subcls1
- wfrec [to_pred, where r="(subcls1 G)^--1", simplified])
+ wfrec [where r="(subcls1 G)^-1", simplified])
apply (simp add: comp_class_None)
(* case \<exists> D fs ms. (class G x = Some (D, fs, ms)) *)
@@ -218,11 +218,11 @@
apply (simp add: comp_subcls1)
done
-lemma comp_fields: "wfP ((subcls1 G)^--1) \<Longrightarrow>
+lemma comp_fields: "wf ((subcls1 G)^-1) \<Longrightarrow>
fields (comp G,C) = fields (G,C)"
by (simp add: fields_def comp_class_rec)
-lemma comp_field: "wfP ((subcls1 G)^--1) \<Longrightarrow>
+lemma comp_field: "wf ((subcls1 G)^-1) \<Longrightarrow>
field (comp G,C) = field (G,C)"
by (simp add: TypeRel.field_def comp_fields)
@@ -234,7 +234,7 @@
\<Longrightarrow> ((class G C) \<noteq> None) \<longrightarrow>
R (class_rec G C t1 f1) (class_rec G C t2 f2)"
apply (frule wf_subcls1) (* establish wf ((subcls1 G)^-1) *)
-apply (rule_tac a = C in wfP_induct) apply assumption
+apply (rule_tac a = C in wf_induct) apply assumption
apply (intro strip)
apply (subgoal_tac "(\<exists>D rT mb. class G x = Some (D, rT, mb))")
apply (erule exE)+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/Abstract_BV.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,14 @@
+(* Title: HOL/MicroJava/BV/Semilat.thy
+ Author: Gerwin Klein
+ Copyright 2003 TUM
+*)
+
+header {* Abstract Bytecode Verifier *}
+
+(*<*)
+theory Abstract_BV
+imports Typing_Framework_err Kildall LBVCorrect LBVComplete
+begin
+
+end
+(*>*)
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/Err.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,350 @@
+(* Title: HOL/MicroJava/BV/Err.thy
+ Author: Tobias Nipkow
+ Copyright 2000 TUM
+*)
+
+header {* \isaheader{The Error Type} *}
+
+theory Err
+imports Semilat
+begin
+
+datatype 'a err = Err | OK 'a
+
+types 'a ebinop = "'a \<Rightarrow> 'a \<Rightarrow> 'a err"
+ 'a esl = "'a set * 'a ord * 'a ebinop"
+
+consts
+ ok_val :: "'a err \<Rightarrow> 'a"
+primrec
+ "ok_val (OK x) = x"
+
+constdefs
+ lift :: "('a \<Rightarrow> 'b err) \<Rightarrow> ('a err \<Rightarrow> 'b err)"
+"lift f e == case e of Err \<Rightarrow> Err | OK x \<Rightarrow> f x"
+
+ lift2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c err) \<Rightarrow> 'a err \<Rightarrow> 'b err \<Rightarrow> 'c err"
+"lift2 f e1 e2 ==
+ case e1 of Err \<Rightarrow> Err
+ | OK x \<Rightarrow> (case e2 of Err \<Rightarrow> Err | OK y \<Rightarrow> f x y)"
+
+ le :: "'a ord \<Rightarrow> 'a err ord"
+"le r e1 e2 ==
+ case e2 of Err \<Rightarrow> True |
+ OK y \<Rightarrow> (case e1 of Err \<Rightarrow> False | OK x \<Rightarrow> x <=_r y)"
+
+ sup :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a err \<Rightarrow> 'b err \<Rightarrow> 'c err)"
+"sup f == lift2(%x y. OK(x +_f y))"
+
+ err :: "'a set \<Rightarrow> 'a err set"
+"err A == insert Err {x . ? y:A. x = OK y}"
+
+ esl :: "'a sl \<Rightarrow> 'a esl"
+"esl == %(A,r,f). (A,r, %x y. OK(f x y))"
+
+ sl :: "'a esl \<Rightarrow> 'a err sl"
+"sl == %(A,r,f). (err A, le r, lift2 f)"
+
+syntax
+ err_semilat :: "'a esl \<Rightarrow> bool"
+translations
+"err_semilat L" == "semilat(Err.sl L)"
+
+
+consts
+ strict :: "('a \<Rightarrow> 'b err) \<Rightarrow> ('a err \<Rightarrow> 'b err)"
+primrec
+ "strict f Err = Err"
+ "strict f (OK x) = f x"
+
+lemma strict_Some [simp]:
+ "(strict f x = OK y) = (\<exists> z. x = OK z \<and> f z = OK y)"
+ by (cases x, auto)
+
+lemma not_Err_eq:
+ "(x \<noteq> Err) = (\<exists>a. x = OK a)"
+ by (cases x) auto
+
+lemma not_OK_eq:
+ "(\<forall>y. x \<noteq> OK y) = (x = Err)"
+ by (cases x) auto
+
+lemma unfold_lesub_err:
+ "e1 <=_(le r) e2 == le r e1 e2"
+ by (simp add: lesub_def)
+
+lemma le_err_refl:
+ "!x. x <=_r x \<Longrightarrow> e <=_(Err.le r) e"
+apply (unfold lesub_def Err.le_def)
+apply (simp split: err.split)
+done
+
+lemma le_err_trans [rule_format]:
+ "order r \<Longrightarrow> e1 <=_(le r) e2 \<longrightarrow> e2 <=_(le r) e3 \<longrightarrow> e1 <=_(le r) e3"
+apply (unfold unfold_lesub_err le_def)
+apply (simp split: err.split)
+apply (blast intro: order_trans)
+done
+
+lemma le_err_antisym [rule_format]:
+ "order r \<Longrightarrow> e1 <=_(le r) e2 \<longrightarrow> e2 <=_(le r) e1 \<longrightarrow> e1=e2"
+apply (unfold unfold_lesub_err le_def)
+apply (simp split: err.split)
+apply (blast intro: order_antisym)
+done
+
+lemma OK_le_err_OK:
+ "(OK x <=_(le r) OK y) = (x <=_r y)"
+ by (simp add: unfold_lesub_err le_def)
+
+lemma order_le_err [iff]:
+ "order(le r) = order r"
+apply (rule iffI)
+ apply (subst Semilat.order_def)
+ apply (blast dest: order_antisym OK_le_err_OK [THEN iffD2]
+ intro: order_trans OK_le_err_OK [THEN iffD1])
+apply (subst Semilat.order_def)
+apply (blast intro: le_err_refl le_err_trans le_err_antisym
+ dest: order_refl)
+done
+
+lemma le_Err [iff]: "e <=_(le r) Err"
+ by (simp add: unfold_lesub_err le_def)
+
+lemma Err_le_conv [iff]:
+ "Err <=_(le r) e = (e = Err)"
+ by (simp add: unfold_lesub_err le_def split: err.split)
+
+lemma le_OK_conv [iff]:
+ "e <=_(le r) OK x = (? y. e = OK y & y <=_r x)"
+ by (simp add: unfold_lesub_err le_def split: err.split)
+
+lemma OK_le_conv:
+ "OK x <=_(le r) e = (e = Err | (? y. e = OK y & x <=_r y))"
+ by (simp add: unfold_lesub_err le_def split: err.split)
+
+lemma top_Err [iff]: "top (le r) Err";
+ by (simp add: top_def)
+
+lemma OK_less_conv [rule_format, iff]:
+ "OK x <_(le r) e = (e=Err | (? y. e = OK y & x <_r y))"
+ by (simp add: lesssub_def lesub_def le_def split: err.split)
+
+lemma not_Err_less [rule_format, iff]:
+ "~(Err <_(le r) x)"
+ by (simp add: lesssub_def lesub_def le_def split: err.split)
+
+lemma semilat_errI [intro]:
+ assumes semilat: "semilat (A, r, f)"
+ shows "semilat(err A, Err.le r, lift2(%x y. OK(f x y)))"
+ apply(insert semilat)
+ apply (unfold semilat_Def closed_def plussub_def lesub_def
+ lift2_def Err.le_def err_def)
+ apply (simp split: err.split)
+ done
+
+lemma err_semilat_eslI_aux:
+ assumes semilat: "semilat (A, r, f)"
+ shows "err_semilat(esl(A,r,f))"
+ apply (unfold sl_def esl_def)
+ apply (simp add: semilat_errI[OF semilat])
+ done
+
+lemma err_semilat_eslI [intro, simp]:
+ "\<And>L. semilat L \<Longrightarrow> err_semilat(esl L)"
+by(simp add: err_semilat_eslI_aux split_tupled_all)
+
+lemma acc_err [simp, intro!]: "acc r \<Longrightarrow> acc(le r)"
+apply (unfold acc_def lesub_def le_def lesssub_def)
+apply (simp add: wf_eq_minimal split: err.split)
+apply clarify
+apply (case_tac "Err : Q")
+ apply blast
+apply (erule_tac x = "{a . OK a : Q}" in allE)
+apply (case_tac "x")
+ apply fast
+apply blast
+done
+
+lemma Err_in_err [iff]: "Err : err A"
+ by (simp add: err_def)
+
+lemma Ok_in_err [iff]: "(OK x : err A) = (x:A)"
+ by (auto simp add: err_def)
+
+section {* lift *}
+
+lemma lift_in_errI:
+ "\<lbrakk> e : err S; !x:S. e = OK x \<longrightarrow> f x : err S \<rbrakk> \<Longrightarrow> lift f e : err S"
+apply (unfold lift_def)
+apply (simp split: err.split)
+apply blast
+done
+
+lemma Err_lift2 [simp]:
+ "Err +_(lift2 f) x = Err"
+ by (simp add: lift2_def plussub_def)
+
+lemma lift2_Err [simp]:
+ "x +_(lift2 f) Err = Err"
+ by (simp add: lift2_def plussub_def split: err.split)
+
+lemma OK_lift2_OK [simp]:
+ "OK x +_(lift2 f) OK y = x +_f y"
+ by (simp add: lift2_def plussub_def split: err.split)
+
+
+section {* sup *}
+
+lemma Err_sup_Err [simp]:
+ "Err +_(Err.sup f) x = Err"
+ by (simp add: plussub_def Err.sup_def Err.lift2_def)
+
+lemma Err_sup_Err2 [simp]:
+ "x +_(Err.sup f) Err = Err"
+ by (simp add: plussub_def Err.sup_def Err.lift2_def split: err.split)
+
+lemma Err_sup_OK [simp]:
+ "OK x +_(Err.sup f) OK y = OK(x +_f y)"
+ by (simp add: plussub_def Err.sup_def Err.lift2_def)
+
+lemma Err_sup_eq_OK_conv [iff]:
+ "(Err.sup f ex ey = OK z) = (? x y. ex = OK x & ey = OK y & f x y = z)"
+apply (unfold Err.sup_def lift2_def plussub_def)
+apply (rule iffI)
+ apply (simp split: err.split_asm)
+apply clarify
+apply simp
+done
+
+lemma Err_sup_eq_Err [iff]:
+ "(Err.sup f ex ey = Err) = (ex=Err | ey=Err)"
+apply (unfold Err.sup_def lift2_def plussub_def)
+apply (simp split: err.split)
+done
+
+section {* semilat (err A) (le r) f *}
+
+lemma semilat_le_err_Err_plus [simp]:
+ "\<lbrakk> x: err A; semilat(err A, le r, f) \<rbrakk> \<Longrightarrow> Err +_f x = Err"
+ by (blast intro: Semilat.le_iff_plus_unchanged [OF Semilat.intro, THEN iffD1]
+ Semilat.le_iff_plus_unchanged2 [OF Semilat.intro, THEN iffD1])
+
+lemma semilat_le_err_plus_Err [simp]:
+ "\<lbrakk> x: err A; semilat(err A, le r, f) \<rbrakk> \<Longrightarrow> x +_f Err = Err"
+ by (blast intro: Semilat.le_iff_plus_unchanged [OF Semilat.intro, THEN iffD1]
+ Semilat.le_iff_plus_unchanged2 [OF Semilat.intro, THEN iffD1])
+
+lemma semilat_le_err_OK1:
+ "\<lbrakk> x:A; y:A; semilat(err A, le r, f); OK x +_f OK y = OK z \<rbrakk>
+ \<Longrightarrow> x <=_r z";
+apply (rule OK_le_err_OK [THEN iffD1])
+apply (erule subst)
+apply (simp add: Semilat.ub1 [OF Semilat.intro])
+done
+
+lemma semilat_le_err_OK2:
+ "\<lbrakk> x:A; y:A; semilat(err A, le r, f); OK x +_f OK y = OK z \<rbrakk>
+ \<Longrightarrow> y <=_r z"
+apply (rule OK_le_err_OK [THEN iffD1])
+apply (erule subst)
+apply (simp add: Semilat.ub2 [OF Semilat.intro])
+done
+
+lemma eq_order_le:
+ "\<lbrakk> x=y; order r \<rbrakk> \<Longrightarrow> x <=_r y"
+apply (unfold Semilat.order_def)
+apply blast
+done
+
+lemma OK_plus_OK_eq_Err_conv [simp]:
+ assumes "x:A" and "y:A" and "semilat(err A, le r, fe)"
+ shows "((OK x) +_fe (OK y) = Err) = (~(? z:A. x <=_r z & y <=_r z))"
+proof -
+ have plus_le_conv3: "\<And>A x y z f r.
+ \<lbrakk> semilat (A,r,f); x +_f y <=_r z; x:A; y:A; z:A \<rbrakk>
+ \<Longrightarrow> x <=_r z \<and> y <=_r z"
+ by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1])
+ from prems show ?thesis
+ apply (rule_tac iffI)
+ apply clarify
+ apply (drule OK_le_err_OK [THEN iffD2])
+ apply (drule OK_le_err_OK [THEN iffD2])
+ apply (drule Semilat.lub [OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
+ apply assumption
+ apply assumption
+ apply simp
+ apply simp
+ apply simp
+ apply simp
+ apply (case_tac "(OK x) +_fe (OK y)")
+ apply assumption
+ apply (rename_tac z)
+ apply (subgoal_tac "OK z: err A")
+ apply (drule eq_order_le)
+ apply (erule Semilat.orderI [OF Semilat.intro])
+ apply (blast dest: plus_le_conv3)
+ apply (erule subst)
+ apply (blast intro: Semilat.closedI [OF Semilat.intro] closedD)
+ done
+qed
+
+section {* semilat (err(Union AS)) *}
+
+(* FIXME? *)
+lemma all_bex_swap_lemma [iff]:
+ "(!x. (? y:A. x = f y) \<longrightarrow> P x) = (!y:A. P(f y))"
+ by blast
+
+lemma closed_err_Union_lift2I:
+ "\<lbrakk> !A:AS. closed (err A) (lift2 f); AS ~= {};
+ !A:AS.!B:AS. A~=B \<longrightarrow> (!a:A.!b:B. a +_f b = Err) \<rbrakk>
+ \<Longrightarrow> closed (err(Union AS)) (lift2 f)"
+apply (unfold closed_def err_def)
+apply simp
+apply clarify
+apply simp
+apply fast
+done
+
+text {*
+ If @{term "AS = {}"} the thm collapses to
+ @{prop "order r & closed {Err} f & Err +_f Err = Err"}
+ which may not hold
+*}
+lemma err_semilat_UnionI:
+ "\<lbrakk> !A:AS. err_semilat(A, r, f); AS ~= {};
+ !A:AS.!B:AS. A~=B \<longrightarrow> (!a:A.!b:B. ~ a <=_r b & a +_f b = Err) \<rbrakk>
+ \<Longrightarrow> err_semilat(Union AS, r, f)"
+apply (unfold semilat_def sl_def)
+apply (simp add: closed_err_Union_lift2I)
+apply (rule conjI)
+ apply blast
+apply (simp add: err_def)
+apply (rule conjI)
+ apply clarify
+ apply (rename_tac A a u B b)
+ apply (case_tac "A = B")
+ apply simp
+ apply simp
+apply (rule conjI)
+ apply clarify
+ apply (rename_tac A a u B b)
+ apply (case_tac "A = B")
+ apply simp
+ apply simp
+apply clarify
+apply (rename_tac A ya yb B yd z C c a b)
+apply (case_tac "A = B")
+ apply (case_tac "A = C")
+ apply simp
+ apply (rotate_tac -1)
+ apply simp
+apply (rotate_tac -1)
+apply (case_tac "B = C")
+ apply simp
+apply (rotate_tac -1)
+apply simp
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/Kildall.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,495 @@
+(* Title: HOL/MicroJava/BV/Kildall.thy
+ Author: Tobias Nipkow, Gerwin Klein
+ Copyright 2000 TUM
+*)
+
+header {* \isaheader{Kildall's Algorithm}\label{sec:Kildall} *}
+
+theory Kildall
+imports SemilatAlg While_Combinator
+begin
+
+
+consts
+ iter :: "'s binop \<Rightarrow> 's step_type \<Rightarrow>
+ 's list \<Rightarrow> nat set \<Rightarrow> 's list \<times> nat set"
+ propa :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> nat set \<Rightarrow> 's list * nat set"
+
+primrec
+"propa f [] ss w = (ss,w)"
+"propa f (q'#qs) ss w = (let (q,t) = q';
+ u = t +_f ss!q;
+ w' = (if u = ss!q then w else insert q w)
+ in propa f qs (ss[q := u]) w')"
+
+defs iter_def:
+"iter f step ss w ==
+ while (%(ss,w). w \<noteq> {})
+ (%(ss,w). let p = SOME p. p \<in> w
+ in propa f (step p (ss!p)) ss (w-{p}))
+ (ss,w)"
+
+constdefs
+ unstables :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> nat set"
+"unstables r step ss == {p. p < size ss \<and> \<not>stable r step ss p}"
+
+ kildall :: "'s ord \<Rightarrow> 's binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> 's list"
+"kildall r f step ss == fst(iter f step ss (unstables r step ss))"
+
+consts merges :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> 's list"
+primrec
+"merges f [] ss = ss"
+"merges f (p'#ps) ss = (let (p,s) = p' in merges f ps (ss[p := s +_f ss!p]))"
+
+
+lemmas [simp] = Let_def Semilat.le_iff_plus_unchanged [OF Semilat.intro, symmetric]
+
+
+lemma (in Semilat) nth_merges:
+ "\<And>ss. \<lbrakk>p < length ss; ss \<in> list n A; \<forall>(p,t)\<in>set ps. p<n \<and> t\<in>A \<rbrakk> \<Longrightarrow>
+ (merges f ps ss)!p = map snd [(p',t') \<leftarrow> ps. p'=p] ++_f ss!p"
+ (is "\<And>ss. \<lbrakk>_; _; ?steptype ps\<rbrakk> \<Longrightarrow> ?P ss ps")
+proof (induct ps)
+ show "\<And>ss. ?P ss []" by simp
+
+ fix ss p' ps'
+ assume ss: "ss \<in> list n A"
+ assume l: "p < length ss"
+ assume "?steptype (p'#ps')"
+ then obtain a b where
+ p': "p'=(a,b)" and ab: "a<n" "b\<in>A" and ps': "?steptype ps'"
+ by (cases p') auto
+ assume "\<And>ss. p< length ss \<Longrightarrow> ss \<in> list n A \<Longrightarrow> ?steptype ps' \<Longrightarrow> ?P ss ps'"
+ from this [OF _ _ ps'] have IH: "\<And>ss. ss \<in> list n A \<Longrightarrow> p < length ss \<Longrightarrow> ?P ss ps'" .
+
+ from ss ab
+ have "ss[a := b +_f ss!a] \<in> list n A" by (simp add: closedD)
+ moreover
+ from calculation l
+ have "p < length (ss[a := b +_f ss!a])" by simp
+ ultimately
+ have "?P (ss[a := b +_f ss!a]) ps'" by (rule IH)
+ with p' l
+ show "?P ss (p'#ps')" by simp
+qed
+
+
+(** merges **)
+
+lemma length_merges [rule_format, simp]:
+ "\<forall>ss. size(merges f ps ss) = size ss"
+ by (induct_tac ps, auto)
+
+
+lemma (in Semilat) merges_preserves_type_lemma:
+shows "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A)
+ \<longrightarrow> merges f ps xs \<in> list n A"
+apply (insert closedI)
+apply (unfold closed_def)
+apply (induct_tac ps)
+ apply simp
+apply clarsimp
+done
+
+lemma (in Semilat) merges_preserves_type [simp]:
+ "\<lbrakk> xs \<in> list n A; \<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A \<rbrakk>
+ \<Longrightarrow> merges f ps xs \<in> list n A"
+by (simp add: merges_preserves_type_lemma)
+
+lemma (in Semilat) merges_incr_lemma:
+ "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A) \<longrightarrow> xs <=[r] merges f ps xs"
+apply (induct_tac ps)
+ apply simp
+apply simp
+apply clarify
+apply (rule order_trans)
+ apply simp
+ apply (erule list_update_incr)
+ apply simp
+ apply simp
+apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
+done
+
+lemma (in Semilat) merges_incr:
+ "\<lbrakk> xs \<in> list n A; \<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A \<rbrakk>
+ \<Longrightarrow> xs <=[r] merges f ps xs"
+ by (simp add: merges_incr_lemma)
+
+
+lemma (in Semilat) merges_same_conv [rule_format]:
+ "(\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x\<in>A) \<longrightarrow>
+ (merges f ps xs = xs) = (\<forall>(p,x)\<in>set ps. x <=_r xs!p))"
+ apply (induct_tac ps)
+ apply simp
+ apply clarsimp
+ apply (rename_tac p x ps xs)
+ apply (rule iffI)
+ apply (rule context_conjI)
+ apply (subgoal_tac "xs[p := x +_f xs!p] <=[r] xs")
+ apply (drule_tac p = p in le_listD)
+ apply simp
+ apply simp
+ apply (erule subst, rule merges_incr)
+ apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
+ apply clarify
+ apply (rule conjI)
+ apply simp
+ apply (blast dest: boundedD)
+ apply blast
+ apply clarify
+ apply (erule allE)
+ apply (erule impE)
+ apply assumption
+ apply (drule bspec)
+ apply assumption
+ apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
+ apply blast
+ apply clarify
+ apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
+ done
+
+
+lemma (in Semilat) list_update_le_listI [rule_format]:
+ "set xs <= A \<longrightarrow> set ys <= A \<longrightarrow> xs <=[r] ys \<longrightarrow> p < size xs \<longrightarrow>
+ x <=_r ys!p \<longrightarrow> x\<in>A \<longrightarrow> xs[p := x +_f xs!p] <=[r] ys"
+ apply(insert semilat)
+ apply (unfold Listn.le_def lesub_def semilat_def)
+ apply (simp add: list_all2_conv_all_nth nth_list_update)
+ done
+
+lemma (in Semilat) merges_pres_le_ub:
+ assumes "set ts <= A" and "set ss <= A"
+ and "\<forall>(p,t)\<in>set ps. t <=_r ts!p \<and> t \<in> A \<and> p < size ts" and "ss <=[r] ts"
+ shows "merges f ps ss <=[r] ts"
+proof -
+ { fix t ts ps
+ have
+ "\<And>qs. \<lbrakk>set ts <= A; \<forall>(p,t)\<in>set ps. t <=_r ts!p \<and> t \<in> A \<and> p< size ts \<rbrakk> \<Longrightarrow>
+ set qs <= set ps \<longrightarrow>
+ (\<forall>ss. set ss <= A \<longrightarrow> ss <=[r] ts \<longrightarrow> merges f qs ss <=[r] ts)"
+ apply (induct_tac qs)
+ apply simp
+ apply (simp (no_asm_simp))
+ apply clarify
+ apply (rotate_tac -2)
+ apply simp
+ apply (erule allE, erule impE, erule_tac [2] mp)
+ apply (drule bspec, assumption)
+ apply (simp add: closedD)
+ apply (drule bspec, assumption)
+ apply (simp add: list_update_le_listI)
+ done
+ } note this [dest]
+
+ from prems show ?thesis by blast
+qed
+
+
+(** propa **)
+
+
+lemma decomp_propa:
+ "\<And>ss w. (\<forall>(q,t)\<in>set qs. q < size ss) \<Longrightarrow>
+ propa f qs ss w =
+ (merges f qs ss, {q. \<exists>t. (q,t)\<in>set qs \<and> t +_f ss!q \<noteq> ss!q} Un w)"
+ apply (induct qs)
+ apply simp
+ apply (simp (no_asm))
+ apply clarify
+ apply simp
+ apply (rule conjI)
+ apply blast
+ apply (simp add: nth_list_update)
+ apply blast
+ done
+
+(** iter **)
+
+lemma (in Semilat) stable_pres_lemma:
+shows "\<lbrakk>pres_type step n A; bounded step n;
+ ss \<in> list n A; p \<in> w; \<forall>q\<in>w. q < n;
+ \<forall>q. q < n \<longrightarrow> q \<notin> w \<longrightarrow> stable r step ss q; q < n;
+ \<forall>s'. (q,s') \<in> set (step p (ss ! p)) \<longrightarrow> s' +_f ss ! q = ss ! q;
+ q \<notin> w \<or> q = p \<rbrakk>
+ \<Longrightarrow> stable r step (merges f (step p (ss!p)) ss) q"
+ apply (unfold stable_def)
+ apply (subgoal_tac "\<forall>s'. (q,s') \<in> set (step p (ss!p)) \<longrightarrow> s' : A")
+ prefer 2
+ apply clarify
+ apply (erule pres_typeD)
+ prefer 3 apply assumption
+ apply (rule listE_nth_in)
+ apply assumption
+ apply simp
+ apply simp
+ apply simp
+ apply clarify
+ apply (subst nth_merges)
+ apply simp
+ apply (blast dest: boundedD)
+ apply assumption
+ apply clarify
+ apply (rule conjI)
+ apply (blast dest: boundedD)
+ apply (erule pres_typeD)
+ prefer 3 apply assumption
+ apply simp
+ apply simp
+apply(subgoal_tac "q < length ss")
+prefer 2 apply simp
+ apply (frule nth_merges [of q _ _ "step p (ss!p)"]) (* fixme: why does method subst not work?? *)
+apply assumption
+ apply clarify
+ apply (rule conjI)
+ apply (blast dest: boundedD)
+ apply (erule pres_typeD)
+ prefer 3 apply assumption
+ apply simp
+ apply simp
+ apply (drule_tac P = "\<lambda>x. (a, b) \<in> set (step q x)" in subst)
+ apply assumption
+
+ apply (simp add: plusplus_empty)
+ apply (cases "q \<in> w")
+ apply simp
+ apply (rule ub1')
+ apply (rule semilat)
+ apply clarify
+ apply (rule pres_typeD)
+ apply assumption
+ prefer 3 apply assumption
+ apply (blast intro: listE_nth_in dest: boundedD)
+ apply (blast intro: pres_typeD dest: boundedD)
+ apply (blast intro: listE_nth_in dest: boundedD)
+ apply assumption
+
+ apply simp
+ apply (erule allE, erule impE, assumption, erule impE, assumption)
+ apply (rule order_trans)
+ apply simp
+ defer
+ apply (rule pp_ub2)(*
+ apply assumption*)
+ apply simp
+ apply clarify
+ apply simp
+ apply (rule pres_typeD)
+ apply assumption
+ prefer 3 apply assumption
+ apply (blast intro: listE_nth_in dest: boundedD)
+ apply (blast intro: pres_typeD dest: boundedD)
+ apply (blast intro: listE_nth_in dest: boundedD)
+ apply blast
+ done
+
+
+lemma (in Semilat) merges_bounded_lemma:
+ "\<lbrakk> mono r step n A; bounded step n;
+ \<forall>(p',s') \<in> set (step p (ss!p)). s' \<in> A; ss \<in> list n A; ts \<in> list n A; p < n;
+ ss <=[r] ts; \<forall>p. p < n \<longrightarrow> stable r step ts p \<rbrakk>
+ \<Longrightarrow> merges f (step p (ss!p)) ss <=[r] ts"
+ apply (unfold stable_def)
+ apply (rule merges_pres_le_ub)
+ apply simp
+ apply simp
+ prefer 2 apply assumption
+
+ apply clarsimp
+ apply (drule boundedD, assumption+)
+ apply (erule allE, erule impE, assumption)
+ apply (drule bspec, assumption)
+ apply simp
+
+ apply (drule monoD [of _ _ _ _ p "ss!p" "ts!p"])
+ apply assumption
+ apply simp
+ apply (simp add: le_listD)
+
+ apply (drule lesub_step_typeD, assumption)
+ apply clarify
+ apply (drule bspec, assumption)
+ apply simp
+ apply (blast intro: order_trans)
+ done
+
+lemma termination_lemma:
+ assumes semilat: "semilat (A, r, f)"
+ shows "\<lbrakk> ss \<in> list n A; \<forall>(q,t)\<in>set qs. q<n \<and> t\<in>A; p\<in>w \<rbrakk> \<Longrightarrow>
+ ss <[r] merges f qs ss \<or>
+ merges f qs ss = ss \<and> {q. \<exists>t. (q,t)\<in>set qs \<and> t +_f ss!q \<noteq> ss!q} Un (w-{p}) < w" (is "PROP ?P")
+proof -
+ interpret Semilat A r f using assms by (rule Semilat.intro)
+ show "PROP ?P" apply(insert semilat)
+ apply (unfold lesssub_def)
+ apply (simp (no_asm_simp) add: merges_incr)
+ apply (rule impI)
+ apply (rule merges_same_conv [THEN iffD1, elim_format])
+ apply assumption+
+ defer
+ apply (rule sym, assumption)
+ defer apply simp
+ apply (subgoal_tac "\<forall>q t. \<not>((q, t) \<in> set qs \<and> t +_f ss ! q \<noteq> ss ! q)")
+ apply (blast intro!: psubsetI elim: equalityE)
+ apply clarsimp
+ apply (drule bspec, assumption)
+ apply (drule bspec, assumption)
+ apply clarsimp
+ done
+qed
+
+lemma iter_properties[rule_format]:
+ assumes semilat: "semilat (A, r, f)"
+ shows "\<lbrakk> acc r ; pres_type step n A; mono r step n A;
+ bounded step n; \<forall>p\<in>w0. p < n; ss0 \<in> list n A;
+ \<forall>p<n. p \<notin> w0 \<longrightarrow> stable r step ss0 p \<rbrakk> \<Longrightarrow>
+ iter f step ss0 w0 = (ss',w')
+ \<longrightarrow>
+ ss' \<in> list n A \<and> stables r step ss' \<and> ss0 <=[r] ss' \<and>
+ (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow> ss' <=[r] ts)"
+ (is "PROP ?P")
+proof -
+ interpret Semilat A r f using assms by (rule Semilat.intro)
+ show "PROP ?P" apply(insert semilat)
+apply (unfold iter_def stables_def)
+apply (rule_tac P = "%(ss,w).
+ ss \<in> list n A \<and> (\<forall>p<n. p \<notin> w \<longrightarrow> stable r step ss p) \<and> ss0 <=[r] ss \<and>
+ (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow> ss <=[r] ts) \<and>
+ (\<forall>p\<in>w. p < n)" and
+ r = "{(ss',ss) . ss <[r] ss'} <*lex*> finite_psubset"
+ in while_rule)
+
+-- "Invariant holds initially:"
+apply (simp add:stables_def)
+
+-- "Invariant is preserved:"
+apply(simp add: stables_def split_paired_all)
+apply(rename_tac ss w)
+apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
+ prefer 2; apply (fast intro: someI)
+apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
+ prefer 2
+ apply clarify
+ apply (rule conjI)
+ apply(clarsimp, blast dest!: boundedD)
+ apply (erule pres_typeD)
+ prefer 3
+ apply assumption
+ apply (erule listE_nth_in)
+ apply simp
+ apply simp
+apply (subst decomp_propa)
+ apply fast
+apply simp
+apply (rule conjI)
+ apply (rule merges_preserves_type)
+ apply blast
+ apply clarify
+ apply (rule conjI)
+ apply(clarsimp, fast dest!: boundedD)
+ apply (erule pres_typeD)
+ prefer 3
+ apply assumption
+ apply (erule listE_nth_in)
+ apply blast
+ apply blast
+apply (rule conjI)
+ apply clarify
+ apply (blast intro!: stable_pres_lemma)
+apply (rule conjI)
+ apply (blast intro!: merges_incr intro: le_list_trans)
+apply (rule conjI)
+ apply clarsimp
+ apply (blast intro!: merges_bounded_lemma)
+apply (blast dest!: boundedD)
+
+
+-- "Postcondition holds upon termination:"
+apply(clarsimp simp add: stables_def split_paired_all)
+
+-- "Well-foundedness of the termination relation:"
+apply (rule wf_lex_prod)
+ apply (insert orderI [THEN acc_le_listI])
+ apply (simp add: acc_def lesssub_def wfP_wf_eq [symmetric])
+apply (rule wf_finite_psubset)
+
+-- "Loop decreases along termination relation:"
+apply(simp add: stables_def split_paired_all)
+apply(rename_tac ss w)
+apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
+ prefer 2; apply (fast intro: someI)
+apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
+ prefer 2
+ apply clarify
+ apply (rule conjI)
+ apply(clarsimp, blast dest!: boundedD)
+ apply (erule pres_typeD)
+ prefer 3
+ apply assumption
+ apply (erule listE_nth_in)
+ apply blast
+ apply blast
+apply (subst decomp_propa)
+ apply blast
+apply clarify
+apply (simp del: listE_length
+ add: lex_prod_def finite_psubset_def
+ bounded_nat_set_is_finite)
+apply (rule termination_lemma)
+apply assumption+
+defer
+apply assumption
+apply clarsimp
+done
+
+qed
+
+lemma kildall_properties:
+assumes semilat: "semilat (A, r, f)"
+shows "\<lbrakk> acc r; pres_type step n A; mono r step n A;
+ bounded step n; ss0 \<in> list n A \<rbrakk> \<Longrightarrow>
+ kildall r f step ss0 \<in> list n A \<and>
+ stables r step (kildall r f step ss0) \<and>
+ ss0 <=[r] kildall r f step ss0 \<and>
+ (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow>
+ kildall r f step ss0 <=[r] ts)"
+ (is "PROP ?P")
+proof -
+ interpret Semilat A r f using assms by (rule Semilat.intro)
+ show "PROP ?P"
+apply (unfold kildall_def)
+apply(case_tac "iter f step ss0 (unstables r step ss0)")
+apply(simp)
+apply (rule iter_properties)
+apply (simp_all add: unstables_def stable_def)
+apply (rule semilat)
+done
+qed
+
+lemma is_bcv_kildall:
+assumes semilat: "semilat (A, r, f)"
+shows "\<lbrakk> acc r; top r T; pres_type step n A; bounded step n; mono r step n A \<rbrakk>
+ \<Longrightarrow> is_bcv r T step n A (kildall r f step)"
+ (is "PROP ?P")
+proof -
+ interpret Semilat A r f using assms by (rule Semilat.intro)
+ show "PROP ?P"
+apply(unfold is_bcv_def wt_step_def)
+apply(insert semilat kildall_properties[of A])
+apply(simp add:stables_def)
+apply clarify
+apply(subgoal_tac "kildall r f step ss \<in> list n A")
+ prefer 2 apply (simp(no_asm_simp))
+apply (rule iffI)
+ apply (rule_tac x = "kildall r f step ss" in bexI)
+ apply (rule conjI)
+ apply (blast)
+ apply (simp (no_asm_simp))
+ apply(assumption)
+apply clarify
+apply(subgoal_tac "kildall r f step ss!p <=_r ts!p")
+ apply simp
+apply (blast intro!: le_listD less_lengthI)
+done
+qed
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/LBVComplete.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,378 @@
+(* Title: HOL/MicroJava/BV/LBVComplete.thy
+ Author: Gerwin Klein
+ Copyright 2000 Technische Universitaet Muenchen
+*)
+
+header {* \isaheader{Completeness of the LBV} *}
+
+theory LBVComplete
+imports LBVSpec Typing_Framework
+begin
+
+constdefs
+ is_target :: "['s step_type, 's list, nat] \<Rightarrow> bool"
+ "is_target step phi pc' \<equiv>
+ \<exists>pc s'. pc' \<noteq> pc+1 \<and> pc < length phi \<and> (pc',s') \<in> set (step pc (phi!pc))"
+
+ make_cert :: "['s step_type, 's list, 's] \<Rightarrow> 's certificate"
+ "make_cert step phi B \<equiv>
+ map (\<lambda>pc. if is_target step phi pc then phi!pc else B) [0..<length phi] @ [B]"
+
+lemma [code]:
+ "is_target step phi pc' =
+ list_ex (\<lambda>pc. pc' \<noteq> pc+1 \<and> pc' mem (map fst (step pc (phi!pc)))) [0..<length phi]"
+by (force simp: list_ex_iff is_target_def mem_iff)
+
+
+locale lbvc = lbv +
+ fixes phi :: "'a list" ("\<phi>")
+ fixes c :: "'a list"
+ defines cert_def: "c \<equiv> make_cert step \<phi> \<bottom>"
+
+ assumes mono: "mono r step (length \<phi>) A"
+ assumes pres: "pres_type step (length \<phi>) A"
+ assumes phi: "\<forall>pc < length \<phi>. \<phi>!pc \<in> A \<and> \<phi>!pc \<noteq> \<top>"
+ assumes bounded: "bounded step (length \<phi>)"
+
+ assumes B_neq_T: "\<bottom> \<noteq> \<top>"
+
+
+lemma (in lbvc) cert: "cert_ok c (length \<phi>) \<top> \<bottom> A"
+proof (unfold cert_ok_def, intro strip conjI)
+ note [simp] = make_cert_def cert_def nth_append
+
+ show "c!length \<phi> = \<bottom>" by simp
+
+ fix pc assume pc: "pc < length \<phi>"
+ from pc phi B_A show "c!pc \<in> A" by simp
+ from pc phi B_neq_T show "c!pc \<noteq> \<top>" by simp
+qed
+
+lemmas [simp del] = split_paired_Ex
+
+
+lemma (in lbvc) cert_target [intro?]:
+ "\<lbrakk> (pc',s') \<in> set (step pc (\<phi>!pc));
+ pc' \<noteq> pc+1; pc < length \<phi>; pc' < length \<phi> \<rbrakk>
+ \<Longrightarrow> c!pc' = \<phi>!pc'"
+ by (auto simp add: cert_def make_cert_def nth_append is_target_def)
+
+
+lemma (in lbvc) cert_approx [intro?]:
+ "\<lbrakk> pc < length \<phi>; c!pc \<noteq> \<bottom> \<rbrakk>
+ \<Longrightarrow> c!pc = \<phi>!pc"
+ by (auto simp add: cert_def make_cert_def nth_append)
+
+
+lemma (in lbv) le_top [simp, intro]:
+ "x <=_r \<top>"
+ by (insert top) simp
+
+
+lemma (in lbv) merge_mono:
+ assumes less: "ss2 <=|r| ss1"
+ assumes x: "x \<in> A"
+ assumes ss1: "snd`set ss1 \<subseteq> A"
+ assumes ss2: "snd`set ss2 \<subseteq> A"
+ shows "merge c pc ss2 x <=_r merge c pc ss1 x" (is "?s2 <=_r ?s1")
+proof-
+ have "?s1 = \<top> \<Longrightarrow> ?thesis" by simp
+ moreover {
+ assume merge: "?s1 \<noteq> T"
+ from x ss1 have "?s1 =
+ (if \<forall>(pc', s')\<in>set ss1. pc' \<noteq> pc + 1 \<longrightarrow> s' <=_r c!pc'
+ then (map snd [(p', t') \<leftarrow> ss1 . p'=pc+1]) ++_f x
+ else \<top>)"
+ by (rule merge_def)
+ with merge obtain
+ app: "\<forall>(pc',s')\<in>set ss1. pc' \<noteq> pc+1 \<longrightarrow> s' <=_r c!pc'"
+ (is "?app ss1") and
+ sum: "(map snd [(p',t') \<leftarrow> ss1 . p' = pc+1] ++_f x) = ?s1"
+ (is "?map ss1 ++_f x = _" is "?sum ss1 = _")
+ by (simp split: split_if_asm)
+ from app less
+ have "?app ss2" by (blast dest: trans_r lesub_step_typeD)
+ moreover {
+ from ss1 have map1: "set (?map ss1) \<subseteq> A" by auto
+ with x have "?sum ss1 \<in> A" by (auto intro!: plusplus_closed semilat)
+ with sum have "?s1 \<in> A" by simp
+ moreover
+ have mapD: "\<And>x ss. x \<in> set (?map ss) \<Longrightarrow> \<exists>p. (p,x) \<in> set ss \<and> p=pc+1" by auto
+ from x map1
+ have "\<forall>x \<in> set (?map ss1). x <=_r ?sum ss1"
+ by clarify (rule pp_ub1)
+ with sum have "\<forall>x \<in> set (?map ss1). x <=_r ?s1" by simp
+ with less have "\<forall>x \<in> set (?map ss2). x <=_r ?s1"
+ by (fastsimp dest!: mapD lesub_step_typeD intro: trans_r)
+ moreover
+ from map1 x have "x <=_r (?sum ss1)" by (rule pp_ub2)
+ with sum have "x <=_r ?s1" by simp
+ moreover
+ from ss2 have "set (?map ss2) \<subseteq> A" by auto
+ ultimately
+ have "?sum ss2 <=_r ?s1" using x by - (rule pp_lub)
+ }
+ moreover
+ from x ss2 have
+ "?s2 =
+ (if \<forall>(pc', s')\<in>set ss2. pc' \<noteq> pc + 1 \<longrightarrow> s' <=_r c!pc'
+ then map snd [(p', t') \<leftarrow> ss2 . p' = pc + 1] ++_f x
+ else \<top>)"
+ by (rule merge_def)
+ ultimately have ?thesis by simp
+ }
+ ultimately show ?thesis by (cases "?s1 = \<top>") auto
+qed
+
+
+lemma (in lbvc) wti_mono:
+ assumes less: "s2 <=_r s1"
+ assumes pc: "pc < length \<phi>"
+ assumes s1: "s1 \<in> A"
+ assumes s2: "s2 \<in> A"
+ shows "wti c pc s2 <=_r wti c pc s1" (is "?s2' <=_r ?s1'")
+proof -
+ from mono pc s2 less have "step pc s2 <=|r| step pc s1" by (rule monoD)
+ moreover
+ from cert B_A pc have "c!Suc pc \<in> A" by (rule cert_okD3)
+ moreover
+ from pres s1 pc
+ have "snd`set (step pc s1) \<subseteq> A" by (rule pres_typeD2)
+ moreover
+ from pres s2 pc
+ have "snd`set (step pc s2) \<subseteq> A" by (rule pres_typeD2)
+ ultimately
+ show ?thesis by (simp add: wti merge_mono)
+qed
+
+lemma (in lbvc) wtc_mono:
+ assumes less: "s2 <=_r s1"
+ assumes pc: "pc < length \<phi>"
+ assumes s1: "s1 \<in> A"
+ assumes s2: "s2 \<in> A"
+ shows "wtc c pc s2 <=_r wtc c pc s1" (is "?s2' <=_r ?s1'")
+proof (cases "c!pc = \<bottom>")
+ case True
+ moreover from less pc s1 s2 have "wti c pc s2 <=_r wti c pc s1" by (rule wti_mono)
+ ultimately show ?thesis by (simp add: wtc)
+next
+ case False
+ have "?s1' = \<top> \<Longrightarrow> ?thesis" by simp
+ moreover {
+ assume "?s1' \<noteq> \<top>"
+ with False have c: "s1 <=_r c!pc" by (simp add: wtc split: split_if_asm)
+ with less have "s2 <=_r c!pc" ..
+ with False c have ?thesis by (simp add: wtc)
+ }
+ ultimately show ?thesis by (cases "?s1' = \<top>") auto
+qed
+
+
+lemma (in lbv) top_le_conv [simp]:
+ "\<top> <=_r x = (x = \<top>)"
+ by (insert semilat) (simp add: top top_le_conv)
+
+lemma (in lbv) neq_top [simp, elim]:
+ "\<lbrakk> x <=_r y; y \<noteq> \<top> \<rbrakk> \<Longrightarrow> x \<noteq> \<top>"
+ by (cases "x = T") auto
+
+
+lemma (in lbvc) stable_wti:
+ assumes stable: "stable r step \<phi> pc"
+ assumes pc: "pc < length \<phi>"
+ shows "wti c pc (\<phi>!pc) \<noteq> \<top>"
+proof -
+ let ?step = "step pc (\<phi>!pc)"
+ from stable
+ have less: "\<forall>(q,s')\<in>set ?step. s' <=_r \<phi>!q" by (simp add: stable_def)
+
+ from cert B_A pc
+ have cert_suc: "c!Suc pc \<in> A" by (rule cert_okD3)
+ moreover
+ from phi pc have "\<phi>!pc \<in> A" by simp
+ from pres this pc
+ have stepA: "snd`set ?step \<subseteq> A" by (rule pres_typeD2)
+ ultimately
+ have "merge c pc ?step (c!Suc pc) =
+ (if \<forall>(pc',s')\<in>set ?step. pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'
+ then map snd [(p',t') \<leftarrow> ?step.p'=pc+1] ++_f c!Suc pc
+ else \<top>)" unfolding mrg_def by (rule lbv.merge_def [OF lbvc.axioms(1), OF lbvc_axioms])
+ moreover {
+ fix pc' s' assume s': "(pc', s') \<in> set ?step" and suc_pc: "pc' \<noteq> pc+1"
+ with less have "s' <=_r \<phi>!pc'" by auto
+ also
+ from bounded pc s' have "pc' < length \<phi>" by (rule boundedD)
+ with s' suc_pc pc have "c!pc' = \<phi>!pc'" ..
+ hence "\<phi>!pc' = c!pc'" ..
+ finally have "s' <=_r c!pc'" .
+ } hence "\<forall>(pc',s')\<in>set ?step. pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'" by auto
+ moreover
+ from pc have "Suc pc = length \<phi> \<or> Suc pc < length \<phi>" by auto
+ hence "map snd [(p',t') \<leftarrow> ?step.p'=pc+1] ++_f c!Suc pc \<noteq> \<top>"
+ (is "?map ++_f _ \<noteq> _")
+ proof (rule disjE)
+ assume pc': "Suc pc = length \<phi>"
+ with cert have "c!Suc pc = \<bottom>" by (simp add: cert_okD2)
+ moreover
+ from pc' bounded pc
+ have "\<forall>(p',t')\<in>set ?step. p'\<noteq>pc+1" by clarify (drule boundedD, auto)
+ hence "[(p',t') \<leftarrow> ?step.p'=pc+1] = []" by (blast intro: filter_False)
+ hence "?map = []" by simp
+ ultimately show ?thesis by (simp add: B_neq_T)
+ next
+ assume pc': "Suc pc < length \<phi>"
+ from pc' phi have "\<phi>!Suc pc \<in> A" by simp
+ moreover note cert_suc
+ moreover from stepA
+ have "set ?map \<subseteq> A" by auto
+ moreover
+ have "\<And>s. s \<in> set ?map \<Longrightarrow> \<exists>t. (Suc pc, t) \<in> set ?step" by auto
+ with less have "\<forall>s' \<in> set ?map. s' <=_r \<phi>!Suc pc" by auto
+ moreover
+ from pc' have "c!Suc pc <=_r \<phi>!Suc pc"
+ by (cases "c!Suc pc = \<bottom>") (auto dest: cert_approx)
+ ultimately
+ have "?map ++_f c!Suc pc <=_r \<phi>!Suc pc" by (rule pp_lub)
+ moreover
+ from pc' phi have "\<phi>!Suc pc \<noteq> \<top>" by simp
+ ultimately
+ show ?thesis by auto
+ qed
+ ultimately
+ have "merge c pc ?step (c!Suc pc) \<noteq> \<top>" by simp
+ thus ?thesis by (simp add: wti)
+qed
+
+lemma (in lbvc) wti_less:
+ assumes stable: "stable r step \<phi> pc"
+ assumes suc_pc: "Suc pc < length \<phi>"
+ shows "wti c pc (\<phi>!pc) <=_r \<phi>!Suc pc" (is "?wti <=_r _")
+proof -
+ let ?step = "step pc (\<phi>!pc)"
+
+ from stable
+ have less: "\<forall>(q,s')\<in>set ?step. s' <=_r \<phi>!q" by (simp add: stable_def)
+
+ from suc_pc have pc: "pc < length \<phi>" by simp
+ with cert B_A have cert_suc: "c!Suc pc \<in> A" by (rule cert_okD3)
+ moreover
+ from phi pc have "\<phi>!pc \<in> A" by simp
+ with pres pc have stepA: "snd`set ?step \<subseteq> A" by - (rule pres_typeD2)
+ moreover
+ from stable pc have "?wti \<noteq> \<top>" by (rule stable_wti)
+ hence "merge c pc ?step (c!Suc pc) \<noteq> \<top>" by (simp add: wti)
+ ultimately
+ have "merge c pc ?step (c!Suc pc) =
+ map snd [(p',t')\<leftarrow> ?step.p'=pc+1] ++_f c!Suc pc" by (rule merge_not_top_s)
+ hence "?wti = \<dots>" (is "_ = (?map ++_f _)" is "_ = ?sum") by (simp add: wti)
+ also {
+ from suc_pc phi have "\<phi>!Suc pc \<in> A" by simp
+ moreover note cert_suc
+ moreover from stepA have "set ?map \<subseteq> A" by auto
+ moreover
+ have "\<And>s. s \<in> set ?map \<Longrightarrow> \<exists>t. (Suc pc, t) \<in> set ?step" by auto
+ with less have "\<forall>s' \<in> set ?map. s' <=_r \<phi>!Suc pc" by auto
+ moreover
+ from suc_pc have "c!Suc pc <=_r \<phi>!Suc pc"
+ by (cases "c!Suc pc = \<bottom>") (auto dest: cert_approx)
+ ultimately
+ have "?sum <=_r \<phi>!Suc pc" by (rule pp_lub)
+ }
+ finally show ?thesis .
+qed
+
+lemma (in lbvc) stable_wtc:
+ assumes stable: "stable r step phi pc"
+ assumes pc: "pc < length \<phi>"
+ shows "wtc c pc (\<phi>!pc) \<noteq> \<top>"
+proof -
+ from stable pc have wti: "wti c pc (\<phi>!pc) \<noteq> \<top>" by (rule stable_wti)
+ show ?thesis
+ proof (cases "c!pc = \<bottom>")
+ case True with wti show ?thesis by (simp add: wtc)
+ next
+ case False
+ with pc have "c!pc = \<phi>!pc" ..
+ with False wti show ?thesis by (simp add: wtc)
+ qed
+qed
+
+lemma (in lbvc) wtc_less:
+ assumes stable: "stable r step \<phi> pc"
+ assumes suc_pc: "Suc pc < length \<phi>"
+ shows "wtc c pc (\<phi>!pc) <=_r \<phi>!Suc pc" (is "?wtc <=_r _")
+proof (cases "c!pc = \<bottom>")
+ case True
+ moreover from stable suc_pc have "wti c pc (\<phi>!pc) <=_r \<phi>!Suc pc"
+ by (rule wti_less)
+ ultimately show ?thesis by (simp add: wtc)
+next
+ case False
+ from suc_pc have pc: "pc < length \<phi>" by simp
+ with stable have "?wtc \<noteq> \<top>" by (rule stable_wtc)
+ with False have "?wtc = wti c pc (c!pc)"
+ by (unfold wtc) (simp split: split_if_asm)
+ also from pc False have "c!pc = \<phi>!pc" ..
+ finally have "?wtc = wti c pc (\<phi>!pc)" .
+ also from stable suc_pc have "wti c pc (\<phi>!pc) <=_r \<phi>!Suc pc" by (rule wti_less)
+ finally show ?thesis .
+qed
+
+
+lemma (in lbvc) wt_step_wtl_lemma:
+ assumes wt_step: "wt_step r \<top> step \<phi>"
+ shows "\<And>pc s. pc+length ls = length \<phi> \<Longrightarrow> s <=_r \<phi>!pc \<Longrightarrow> s \<in> A \<Longrightarrow> s\<noteq>\<top> \<Longrightarrow>
+ wtl ls c pc s \<noteq> \<top>"
+ (is "\<And>pc s. _ \<Longrightarrow> _ \<Longrightarrow> _ \<Longrightarrow> _ \<Longrightarrow> ?wtl ls pc s \<noteq> _")
+proof (induct ls)
+ fix pc s assume "s\<noteq>\<top>" thus "?wtl [] pc s \<noteq> \<top>" by simp
+next
+ fix pc s i ls
+ assume "\<And>pc s. pc+length ls=length \<phi> \<Longrightarrow> s <=_r \<phi>!pc \<Longrightarrow> s \<in> A \<Longrightarrow> s\<noteq>\<top> \<Longrightarrow>
+ ?wtl ls pc s \<noteq> \<top>"
+ moreover
+ assume pc_l: "pc + length (i#ls) = length \<phi>"
+ hence suc_pc_l: "Suc pc + length ls = length \<phi>" by simp
+ ultimately
+ have IH: "\<And>s. s <=_r \<phi>!Suc pc \<Longrightarrow> s \<in> A \<Longrightarrow> s \<noteq> \<top> \<Longrightarrow> ?wtl ls (Suc pc) s \<noteq> \<top>" .
+
+ from pc_l obtain pc: "pc < length \<phi>" by simp
+ with wt_step have stable: "stable r step \<phi> pc" by (simp add: wt_step_def)
+ from this pc have wt_phi: "wtc c pc (\<phi>!pc) \<noteq> \<top>" by (rule stable_wtc)
+ assume s_phi: "s <=_r \<phi>!pc"
+ from phi pc have phi_pc: "\<phi>!pc \<in> A" by simp
+ assume s: "s \<in> A"
+ with s_phi pc phi_pc have wt_s_phi: "wtc c pc s <=_r wtc c pc (\<phi>!pc)" by (rule wtc_mono)
+ with wt_phi have wt_s: "wtc c pc s \<noteq> \<top>" by simp
+ moreover
+ assume s': "s \<noteq> \<top>"
+ ultimately
+ have "ls = [] \<Longrightarrow> ?wtl (i#ls) pc s \<noteq> \<top>" by simp
+ moreover {
+ assume "ls \<noteq> []"
+ with pc_l have suc_pc: "Suc pc < length \<phi>" by (auto simp add: neq_Nil_conv)
+ with stable have "wtc c pc (phi!pc) <=_r \<phi>!Suc pc" by (rule wtc_less)
+ with wt_s_phi have "wtc c pc s <=_r \<phi>!Suc pc" by (rule trans_r)
+ moreover
+ from cert suc_pc have "c!pc \<in> A" "c!(pc+1) \<in> A"
+ by (auto simp add: cert_ok_def)
+ from pres this s pc have "wtc c pc s \<in> A" by (rule wtc_pres)
+ ultimately
+ have "?wtl ls (Suc pc) (wtc c pc s) \<noteq> \<top>" using IH wt_s by blast
+ with s' wt_s have "?wtl (i#ls) pc s \<noteq> \<top>" by simp
+ }
+ ultimately show "?wtl (i#ls) pc s \<noteq> \<top>" by (cases ls) blast+
+qed
+
+
+theorem (in lbvc) wtl_complete:
+ assumes wt: "wt_step r \<top> step \<phi>"
+ and s: "s <=_r \<phi>!0" "s \<in> A" "s \<noteq> \<top>"
+ and len: "length ins = length phi"
+ shows "wtl ins c 0 s \<noteq> \<top>"
+proof -
+ from len have "0+length ins = length phi" by simp
+ from wt this s show ?thesis by (rule wt_step_wtl_lemma)
+qed
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/LBVCorrect.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,221 @@
+(* Author: Gerwin Klein
+ Copyright 1999 Technische Universitaet Muenchen
+*)
+
+header {* \isaheader{Correctness of the LBV} *}
+
+theory LBVCorrect
+imports LBVSpec Typing_Framework
+begin
+
+locale lbvs = lbv +
+ fixes s0 :: 'a ("s\<^sub>0")
+ fixes c :: "'a list"
+ fixes ins :: "'b list"
+ fixes phi :: "'a list" ("\<phi>")
+ defines phi_def:
+ "\<phi> \<equiv> map (\<lambda>pc. if c!pc = \<bottom> then wtl (take pc ins) c 0 s0 else c!pc)
+ [0..<length ins]"
+
+ assumes bounded: "bounded step (length ins)"
+ assumes cert: "cert_ok c (length ins) \<top> \<bottom> A"
+ assumes pres: "pres_type step (length ins) A"
+
+
+lemma (in lbvs) phi_None [intro?]:
+ "\<lbrakk> pc < length ins; c!pc = \<bottom> \<rbrakk> \<Longrightarrow> \<phi> ! pc = wtl (take pc ins) c 0 s0"
+ by (simp add: phi_def)
+
+lemma (in lbvs) phi_Some [intro?]:
+ "\<lbrakk> pc < length ins; c!pc \<noteq> \<bottom> \<rbrakk> \<Longrightarrow> \<phi> ! pc = c ! pc"
+ by (simp add: phi_def)
+
+lemma (in lbvs) phi_len [simp]:
+ "length \<phi> = length ins"
+ by (simp add: phi_def)
+
+
+lemma (in lbvs) wtl_suc_pc:
+ assumes all: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>"
+ assumes pc: "pc+1 < length ins"
+ shows "wtl (take (pc+1) ins) c 0 s0 \<sqsubseteq>\<^sub>r \<phi>!(pc+1)"
+proof -
+ from all pc
+ have "wtc c (pc+1) (wtl (take (pc+1) ins) c 0 s0) \<noteq> T" by (rule wtl_all)
+ with pc show ?thesis by (simp add: phi_def wtc split: split_if_asm)
+qed
+
+
+lemma (in lbvs) wtl_stable:
+ assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
+ assumes s0: "s0 \<in> A"
+ assumes pc: "pc < length ins"
+ shows "stable r step \<phi> pc"
+proof (unfold stable_def, clarify)
+ fix pc' s' assume step: "(pc',s') \<in> set (step pc (\<phi> ! pc))"
+ (is "(pc',s') \<in> set (?step pc)")
+
+ from bounded pc step have pc': "pc' < length ins" by (rule boundedD)
+
+ from wtl have tkpc: "wtl (take pc ins) c 0 s0 \<noteq> \<top>" (is "?s1 \<noteq> _") by (rule wtl_take)
+ from wtl have s2: "wtl (take (pc+1) ins) c 0 s0 \<noteq> \<top>" (is "?s2 \<noteq> _") by (rule wtl_take)
+
+ from wtl pc have wt_s1: "wtc c pc ?s1 \<noteq> \<top>" by (rule wtl_all)
+
+ have c_Some: "\<forall>pc t. pc < length ins \<longrightarrow> c!pc \<noteq> \<bottom> \<longrightarrow> \<phi>!pc = c!pc"
+ by (simp add: phi_def)
+ from pc have c_None: "c!pc = \<bottom> \<Longrightarrow> \<phi>!pc = ?s1" ..
+
+ from wt_s1 pc c_None c_Some
+ have inst: "wtc c pc ?s1 = wti c pc (\<phi>!pc)"
+ by (simp add: wtc split: split_if_asm)
+
+ from pres cert s0 wtl pc have "?s1 \<in> A" by (rule wtl_pres)
+ with pc c_Some cert c_None
+ have "\<phi>!pc \<in> A" by (cases "c!pc = \<bottom>") (auto dest: cert_okD1)
+ with pc pres
+ have step_in_A: "snd`set (?step pc) \<subseteq> A" by (auto dest: pres_typeD2)
+
+ show "s' <=_r \<phi>!pc'"
+ proof (cases "pc' = pc+1")
+ case True
+ with pc' cert
+ have cert_in_A: "c!(pc+1) \<in> A" by (auto dest: cert_okD1)
+ from True pc' have pc1: "pc+1 < length ins" by simp
+ with tkpc have "?s2 = wtc c pc ?s1" by - (rule wtl_Suc)
+ with inst
+ have merge: "?s2 = merge c pc (?step pc) (c!(pc+1))" by (simp add: wti)
+ also
+ from s2 merge have "\<dots> \<noteq> \<top>" (is "?merge \<noteq> _") by simp
+ with cert_in_A step_in_A
+ have "?merge = (map snd [(p',t') \<leftarrow> ?step pc. p'=pc+1] ++_f (c!(pc+1)))"
+ by (rule merge_not_top_s)
+ finally
+ have "s' <=_r ?s2" using step_in_A cert_in_A True step
+ by (auto intro: pp_ub1')
+ also
+ from wtl pc1 have "?s2 <=_r \<phi>!(pc+1)" by (rule wtl_suc_pc)
+ also note True [symmetric]
+ finally show ?thesis by simp
+ next
+ case False
+ from wt_s1 inst
+ have "merge c pc (?step pc) (c!(pc+1)) \<noteq> \<top>" by (simp add: wti)
+ with step_in_A
+ have "\<forall>(pc', s')\<in>set (?step pc). pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'"
+ by - (rule merge_not_top)
+ with step False
+ have ok: "s' <=_r c!pc'" by blast
+ moreover
+ from ok
+ have "c!pc' = \<bottom> \<Longrightarrow> s' = \<bottom>" by simp
+ moreover
+ from c_Some pc'
+ have "c!pc' \<noteq> \<bottom> \<Longrightarrow> \<phi>!pc' = c!pc'" by auto
+ ultimately
+ show ?thesis by (cases "c!pc' = \<bottom>") auto
+ qed
+qed
+
+
+lemma (in lbvs) phi_not_top:
+ assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
+ assumes pc: "pc < length ins"
+ shows "\<phi>!pc \<noteq> \<top>"
+proof (cases "c!pc = \<bottom>")
+ case False with pc
+ have "\<phi>!pc = c!pc" ..
+ also from cert pc have "\<dots> \<noteq> \<top>" by (rule cert_okD4)
+ finally show ?thesis .
+next
+ case True with pc
+ have "\<phi>!pc = wtl (take pc ins) c 0 s0" ..
+ also from wtl have "\<dots> \<noteq> \<top>" by (rule wtl_take)
+ finally show ?thesis .
+qed
+
+lemma (in lbvs) phi_in_A:
+ assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
+ assumes s0: "s0 \<in> A"
+ shows "\<phi> \<in> list (length ins) A"
+proof -
+ { fix x assume "x \<in> set \<phi>"
+ then obtain xs ys where "\<phi> = xs @ x # ys"
+ by (auto simp add: in_set_conv_decomp)
+ then obtain pc where pc: "pc < length \<phi>" and x: "\<phi>!pc = x"
+ by (simp add: that [of "length xs"] nth_append)
+
+ from pres cert wtl s0 pc
+ have "wtl (take pc ins) c 0 s0 \<in> A" by (auto intro!: wtl_pres)
+ moreover
+ from pc have "pc < length ins" by simp
+ with cert have "c!pc \<in> A" ..
+ ultimately
+ have "\<phi>!pc \<in> A" using pc by (simp add: phi_def)
+ hence "x \<in> A" using x by simp
+ }
+ hence "set \<phi> \<subseteq> A" ..
+ thus ?thesis by (unfold list_def) simp
+qed
+
+
+lemma (in lbvs) phi0:
+ assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
+ assumes 0: "0 < length ins"
+ shows "s0 <=_r \<phi>!0"
+proof (cases "c!0 = \<bottom>")
+ case True
+ with 0 have "\<phi>!0 = wtl (take 0 ins) c 0 s0" ..
+ moreover have "wtl (take 0 ins) c 0 s0 = s0" by simp
+ ultimately have "\<phi>!0 = s0" by simp
+ thus ?thesis by simp
+next
+ case False
+ with 0 have "phi!0 = c!0" ..
+ moreover
+ from wtl have "wtl (take 1 ins) c 0 s0 \<noteq> \<top>" by (rule wtl_take)
+ with 0 False
+ have "s0 <=_r c!0" by (auto simp add: neq_Nil_conv wtc split: split_if_asm)
+ ultimately
+ show ?thesis by simp
+qed
+
+
+theorem (in lbvs) wtl_sound:
+ assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
+ assumes s0: "s0 \<in> A"
+ shows "\<exists>ts. wt_step r \<top> step ts"
+proof -
+ have "wt_step r \<top> step \<phi>"
+ proof (unfold wt_step_def, intro strip conjI)
+ fix pc assume "pc < length \<phi>"
+ then have pc: "pc < length ins" by simp
+ with wtl show "\<phi>!pc \<noteq> \<top>" by (rule phi_not_top)
+ from wtl s0 pc show "stable r step \<phi> pc" by (rule wtl_stable)
+ qed
+ thus ?thesis ..
+qed
+
+
+theorem (in lbvs) wtl_sound_strong:
+ assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
+ assumes s0: "s0 \<in> A"
+ assumes nz: "0 < length ins"
+ shows "\<exists>ts \<in> list (length ins) A. wt_step r \<top> step ts \<and> s0 <=_r ts!0"
+proof -
+ from wtl s0 have "\<phi> \<in> list (length ins) A" by (rule phi_in_A)
+ moreover
+ have "wt_step r \<top> step \<phi>"
+ proof (unfold wt_step_def, intro strip conjI)
+ fix pc assume "pc < length \<phi>"
+ then have pc: "pc < length ins" by simp
+ with wtl show "\<phi>!pc \<noteq> \<top>" by (rule phi_not_top)
+ from wtl s0 pc show "stable r step \<phi> pc" by (rule wtl_stable)
+ qed
+ moreover
+ from wtl nz have "s0 <=_r \<phi>!0" by (rule phi0)
+ ultimately
+ show ?thesis by fast
+qed
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/LBVSpec.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,381 @@
+(* Title: HOL/MicroJava/BV/LBVSpec.thy
+ Author: Gerwin Klein
+ Copyright 1999 Technische Universitaet Muenchen
+*)
+
+header {* \isaheader{The Lightweight Bytecode Verifier} *}
+
+theory LBVSpec
+imports SemilatAlg Opt
+begin
+
+types
+ 's certificate = "'s list"
+
+consts
+merge :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> nat \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's \<Rightarrow> 's"
+primrec
+"merge cert f r T pc [] x = x"
+"merge cert f r T pc (s#ss) x = merge cert f r T pc ss (let (pc',s') = s in
+ if pc'=pc+1 then s' +_f x
+ else if s' <=_r (cert!pc') then x
+ else T)"
+
+constdefs
+wtl_inst :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow>
+ 's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's"
+"wtl_inst cert f r T step pc s \<equiv> merge cert f r T pc (step pc s) (cert!(pc+1))"
+
+wtl_cert :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow>
+ 's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's"
+"wtl_cert cert f r T B step pc s \<equiv>
+ if cert!pc = B then
+ wtl_inst cert f r T step pc s
+ else
+ if s <=_r (cert!pc) then wtl_inst cert f r T step pc (cert!pc) else T"
+
+consts
+wtl_inst_list :: "'a list \<Rightarrow> 's certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow>
+ 's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's"
+primrec
+"wtl_inst_list [] cert f r T B step pc s = s"
+"wtl_inst_list (i#is) cert f r T B step pc s =
+ (let s' = wtl_cert cert f r T B step pc s in
+ if s' = T \<or> s = T then T else wtl_inst_list is cert f r T B step (pc+1) s')"
+
+constdefs
+ cert_ok :: "'s certificate \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow> 's set \<Rightarrow> bool"
+ "cert_ok cert n T B A \<equiv> (\<forall>i < n. cert!i \<in> A \<and> cert!i \<noteq> T) \<and> (cert!n = B)"
+
+constdefs
+ bottom :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool"
+ "bottom r B \<equiv> \<forall>x. B <=_r x"
+
+
+locale lbv = Semilat +
+ fixes T :: "'a" ("\<top>")
+ fixes B :: "'a" ("\<bottom>")
+ fixes step :: "'a step_type"
+ assumes top: "top r \<top>"
+ assumes T_A: "\<top> \<in> A"
+ assumes bot: "bottom r \<bottom>"
+ assumes B_A: "\<bottom> \<in> A"
+
+ fixes merge :: "'a certificate \<Rightarrow> nat \<Rightarrow> (nat \<times> 'a) list \<Rightarrow> 'a \<Rightarrow> 'a"
+ defines mrg_def: "merge cert \<equiv> LBVSpec.merge cert f r \<top>"
+
+ fixes wti :: "'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
+ defines wti_def: "wti cert \<equiv> wtl_inst cert f r \<top> step"
+
+ fixes wtc :: "'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
+ defines wtc_def: "wtc cert \<equiv> wtl_cert cert f r \<top> \<bottom> step"
+
+ fixes wtl :: "'b list \<Rightarrow> 'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
+ defines wtl_def: "wtl ins cert \<equiv> wtl_inst_list ins cert f r \<top> \<bottom> step"
+
+
+lemma (in lbv) wti:
+ "wti c pc s \<equiv> merge c pc (step pc s) (c!(pc+1))"
+ by (simp add: wti_def mrg_def wtl_inst_def)
+
+lemma (in lbv) wtc:
+ "wtc c pc s \<equiv> if c!pc = \<bottom> then wti c pc s else if s <=_r c!pc then wti c pc (c!pc) else \<top>"
+ by (unfold wtc_def wti_def wtl_cert_def)
+
+
+lemma cert_okD1 [intro?]:
+ "cert_ok c n T B A \<Longrightarrow> pc < n \<Longrightarrow> c!pc \<in> A"
+ by (unfold cert_ok_def) fast
+
+lemma cert_okD2 [intro?]:
+ "cert_ok c n T B A \<Longrightarrow> c!n = B"
+ by (simp add: cert_ok_def)
+
+lemma cert_okD3 [intro?]:
+ "cert_ok c n T B A \<Longrightarrow> B \<in> A \<Longrightarrow> pc < n \<Longrightarrow> c!Suc pc \<in> A"
+ by (drule Suc_leI) (auto simp add: le_eq_less_or_eq dest: cert_okD1 cert_okD2)
+
+lemma cert_okD4 [intro?]:
+ "cert_ok c n T B A \<Longrightarrow> pc < n \<Longrightarrow> c!pc \<noteq> T"
+ by (simp add: cert_ok_def)
+
+declare Let_def [simp]
+
+section "more semilattice lemmas"
+
+
+lemma (in lbv) sup_top [simp, elim]:
+ assumes x: "x \<in> A"
+ shows "x +_f \<top> = \<top>"
+proof -
+ from top have "x +_f \<top> <=_r \<top>" ..
+ moreover from x T_A have "\<top> <=_r x +_f \<top>" ..
+ ultimately show ?thesis ..
+qed
+
+lemma (in lbv) plusplussup_top [simp, elim]:
+ "set xs \<subseteq> A \<Longrightarrow> xs ++_f \<top> = \<top>"
+ by (induct xs) auto
+
+
+
+lemma (in Semilat) pp_ub1':
+ assumes S: "snd`set S \<subseteq> A"
+ assumes y: "y \<in> A" and ab: "(a, b) \<in> set S"
+ shows "b <=_r map snd [(p', t') \<leftarrow> S . p' = a] ++_f y"
+proof -
+ from S have "\<forall>(x,y) \<in> set S. y \<in> A" by auto
+ with semilat y ab show ?thesis by - (rule ub1')
+qed
+
+lemma (in lbv) bottom_le [simp, intro]:
+ "\<bottom> <=_r x"
+ by (insert bot) (simp add: bottom_def)
+
+lemma (in lbv) le_bottom [simp]:
+ "x <=_r \<bottom> = (x = \<bottom>)"
+ by (blast intro: antisym_r)
+
+
+
+section "merge"
+
+lemma (in lbv) merge_Nil [simp]:
+ "merge c pc [] x = x" by (simp add: mrg_def)
+
+lemma (in lbv) merge_Cons [simp]:
+ "merge c pc (l#ls) x = merge c pc ls (if fst l=pc+1 then snd l +_f x
+ else if snd l <=_r (c!fst l) then x
+ else \<top>)"
+ by (simp add: mrg_def split_beta)
+
+lemma (in lbv) merge_Err [simp]:
+ "snd`set ss \<subseteq> A \<Longrightarrow> merge c pc ss \<top> = \<top>"
+ by (induct ss) auto
+
+lemma (in lbv) merge_not_top:
+ "\<And>x. snd`set ss \<subseteq> A \<Longrightarrow> merge c pc ss x \<noteq> \<top> \<Longrightarrow>
+ \<forall>(pc',s') \<in> set ss. (pc' \<noteq> pc+1 \<longrightarrow> s' <=_r (c!pc'))"
+ (is "\<And>x. ?set ss \<Longrightarrow> ?merge ss x \<Longrightarrow> ?P ss")
+proof (induct ss)
+ show "?P []" by simp
+next
+ fix x ls l
+ assume "?set (l#ls)" then obtain set: "snd`set ls \<subseteq> A" by simp
+ assume merge: "?merge (l#ls) x"
+ moreover
+ obtain pc' s' where l: "l = (pc',s')" by (cases l)
+ ultimately
+ obtain x' where merge': "?merge ls x'" by simp
+ assume "\<And>x. ?set ls \<Longrightarrow> ?merge ls x \<Longrightarrow> ?P ls" hence "?P ls" using set merge' .
+ moreover
+ from merge set
+ have "pc' \<noteq> pc+1 \<longrightarrow> s' <=_r (c!pc')" by (simp add: l split: split_if_asm)
+ ultimately
+ show "?P (l#ls)" by (simp add: l)
+qed
+
+
+lemma (in lbv) merge_def:
+ shows
+ "\<And>x. x \<in> A \<Longrightarrow> snd`set ss \<subseteq> A \<Longrightarrow>
+ merge c pc ss x =
+ (if \<forall>(pc',s') \<in> set ss. pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc' then
+ map snd [(p',t') \<leftarrow> ss. p'=pc+1] ++_f x
+ else \<top>)"
+ (is "\<And>x. _ \<Longrightarrow> _ \<Longrightarrow> ?merge ss x = ?if ss x" is "\<And>x. _ \<Longrightarrow> _ \<Longrightarrow> ?P ss x")
+proof (induct ss)
+ fix x show "?P [] x" by simp
+next
+ fix x assume x: "x \<in> A"
+ fix l::"nat \<times> 'a" and ls
+ assume "snd`set (l#ls) \<subseteq> A"
+ then obtain l: "snd l \<in> A" and ls: "snd`set ls \<subseteq> A" by auto
+ assume "\<And>x. x \<in> A \<Longrightarrow> snd`set ls \<subseteq> A \<Longrightarrow> ?P ls x"
+ hence IH: "\<And>x. x \<in> A \<Longrightarrow> ?P ls x" using ls by iprover
+ obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
+ hence "?merge (l#ls) x = ?merge ls
+ (if pc'=pc+1 then s' +_f x else if s' <=_r c!pc' then x else \<top>)"
+ (is "?merge (l#ls) x = ?merge ls ?if'")
+ by simp
+ also have "\<dots> = ?if ls ?if'"
+ proof -
+ from l have "s' \<in> A" by simp
+ with x have "s' +_f x \<in> A" by simp
+ with x T_A have "?if' \<in> A" by auto
+ hence "?P ls ?if'" by (rule IH) thus ?thesis by simp
+ qed
+ also have "\<dots> = ?if (l#ls) x"
+ proof (cases "\<forall>(pc', s')\<in>set (l#ls). pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'")
+ case True
+ hence "\<forall>(pc', s')\<in>set ls. pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'" by auto
+ moreover
+ from True have
+ "map snd [(p',t')\<leftarrow>ls . p'=pc+1] ++_f ?if' =
+ (map snd [(p',t')\<leftarrow>l#ls . p'=pc+1] ++_f x)"
+ by simp
+ ultimately
+ show ?thesis using True by simp
+ next
+ case False
+ moreover
+ from ls have "set (map snd [(p', t')\<leftarrow>ls . p' = Suc pc]) \<subseteq> A" by auto
+ ultimately show ?thesis by auto
+ qed
+ finally show "?P (l#ls) x" .
+qed
+
+lemma (in lbv) merge_not_top_s:
+ assumes x: "x \<in> A" and ss: "snd`set ss \<subseteq> A"
+ assumes m: "merge c pc ss x \<noteq> \<top>"
+ shows "merge c pc ss x = (map snd [(p',t') \<leftarrow> ss. p'=pc+1] ++_f x)"
+proof -
+ from ss m have "\<forall>(pc',s') \<in> set ss. (pc' \<noteq> pc+1 \<longrightarrow> s' <=_r c!pc')"
+ by (rule merge_not_top)
+ with x ss m show ?thesis by - (drule merge_def, auto split: split_if_asm)
+qed
+
+section "wtl-inst-list"
+
+lemmas [iff] = not_Err_eq
+
+lemma (in lbv) wtl_Nil [simp]: "wtl [] c pc s = s"
+ by (simp add: wtl_def)
+
+lemma (in lbv) wtl_Cons [simp]:
+ "wtl (i#is) c pc s =
+ (let s' = wtc c pc s in if s' = \<top> \<or> s = \<top> then \<top> else wtl is c (pc+1) s')"
+ by (simp add: wtl_def wtc_def)
+
+lemma (in lbv) wtl_Cons_not_top:
+ "wtl (i#is) c pc s \<noteq> \<top> =
+ (wtc c pc s \<noteq> \<top> \<and> s \<noteq> T \<and> wtl is c (pc+1) (wtc c pc s) \<noteq> \<top>)"
+ by (auto simp del: split_paired_Ex)
+
+lemma (in lbv) wtl_top [simp]: "wtl ls c pc \<top> = \<top>"
+ by (cases ls) auto
+
+lemma (in lbv) wtl_not_top:
+ "wtl ls c pc s \<noteq> \<top> \<Longrightarrow> s \<noteq> \<top>"
+ by (cases "s=\<top>") auto
+
+lemma (in lbv) wtl_append [simp]:
+ "\<And>pc s. wtl (a@b) c pc s = wtl b c (pc+length a) (wtl a c pc s)"
+ by (induct a) auto
+
+lemma (in lbv) wtl_take:
+ "wtl is c pc s \<noteq> \<top> \<Longrightarrow> wtl (take pc' is) c pc s \<noteq> \<top>"
+ (is "?wtl is \<noteq> _ \<Longrightarrow> _")
+proof -
+ assume "?wtl is \<noteq> \<top>"
+ hence "?wtl (take pc' is @ drop pc' is) \<noteq> \<top>" by simp
+ thus ?thesis by (auto dest!: wtl_not_top simp del: append_take_drop_id)
+qed
+
+lemma take_Suc:
+ "\<forall>n. n < length l \<longrightarrow> take (Suc n) l = (take n l)@[l!n]" (is "?P l")
+proof (induct l)
+ show "?P []" by simp
+next
+ fix x xs assume IH: "?P xs"
+ show "?P (x#xs)"
+ proof (intro strip)
+ fix n assume "n < length (x#xs)"
+ with IH show "take (Suc n) (x # xs) = take n (x # xs) @ [(x # xs) ! n]"
+ by (cases n, auto)
+ qed
+qed
+
+lemma (in lbv) wtl_Suc:
+ assumes suc: "pc+1 < length is"
+ assumes wtl: "wtl (take pc is) c 0 s \<noteq> \<top>"
+ shows "wtl (take (pc+1) is) c 0 s = wtc c pc (wtl (take pc is) c 0 s)"
+proof -
+ from suc have "take (pc+1) is=(take pc is)@[is!pc]" by (simp add: take_Suc)
+ with suc wtl show ?thesis by (simp add: min_max.inf_absorb2)
+qed
+
+lemma (in lbv) wtl_all:
+ assumes all: "wtl is c 0 s \<noteq> \<top>" (is "?wtl is \<noteq> _")
+ assumes pc: "pc < length is"
+ shows "wtc c pc (wtl (take pc is) c 0 s) \<noteq> \<top>"
+proof -
+ from pc have "0 < length (drop pc is)" by simp
+ then obtain i r where Cons: "drop pc is = i#r"
+ by (auto simp add: neq_Nil_conv simp del: length_drop drop_eq_Nil)
+ hence "i#r = drop pc is" ..
+ with all have take: "?wtl (take pc is@i#r) \<noteq> \<top>" by simp
+ from pc have "is!pc = drop pc is ! 0" by simp
+ with Cons have "is!pc = i" by simp
+ with take pc show ?thesis by (auto simp add: min_max.inf_absorb2)
+qed
+
+section "preserves-type"
+
+lemma (in lbv) merge_pres:
+ assumes s0: "snd`set ss \<subseteq> A" and x: "x \<in> A"
+ shows "merge c pc ss x \<in> A"
+proof -
+ from s0 have "set (map snd [(p', t')\<leftarrow>ss . p'=pc+1]) \<subseteq> A" by auto
+ with x have "(map snd [(p', t')\<leftarrow>ss . p'=pc+1] ++_f x) \<in> A"
+ by (auto intro!: plusplus_closed semilat)
+ with s0 x show ?thesis by (simp add: merge_def T_A)
+qed
+
+
+lemma pres_typeD2:
+ "pres_type step n A \<Longrightarrow> s \<in> A \<Longrightarrow> p < n \<Longrightarrow> snd`set (step p s) \<subseteq> A"
+ by auto (drule pres_typeD)
+
+
+lemma (in lbv) wti_pres [intro?]:
+ assumes pres: "pres_type step n A"
+ assumes cert: "c!(pc+1) \<in> A"
+ assumes s_pc: "s \<in> A" "pc < n"
+ shows "wti c pc s \<in> A"
+proof -
+ from pres s_pc have "snd`set (step pc s) \<subseteq> A" by (rule pres_typeD2)
+ with cert show ?thesis by (simp add: wti merge_pres)
+qed
+
+
+lemma (in lbv) wtc_pres:
+ assumes pres: "pres_type step n A"
+ assumes cert: "c!pc \<in> A" and cert': "c!(pc+1) \<in> A"
+ assumes s: "s \<in> A" and pc: "pc < n"
+ shows "wtc c pc s \<in> A"
+proof -
+ have "wti c pc s \<in> A" using pres cert' s pc ..
+ moreover have "wti c pc (c!pc) \<in> A" using pres cert' cert pc ..
+ ultimately show ?thesis using T_A by (simp add: wtc)
+qed
+
+
+lemma (in lbv) wtl_pres:
+ assumes pres: "pres_type step (length is) A"
+ assumes cert: "cert_ok c (length is) \<top> \<bottom> A"
+ assumes s: "s \<in> A"
+ assumes all: "wtl is c 0 s \<noteq> \<top>"
+ shows "pc < length is \<Longrightarrow> wtl (take pc is) c 0 s \<in> A"
+ (is "?len pc \<Longrightarrow> ?wtl pc \<in> A")
+proof (induct pc)
+ from s show "?wtl 0 \<in> A" by simp
+next
+ fix n assume IH: "Suc n < length is"
+ then have n: "n < length is" by simp
+ from IH have n1: "n+1 < length is" by simp
+ assume prem: "n < length is \<Longrightarrow> ?wtl n \<in> A"
+ have "wtc c n (?wtl n) \<in> A"
+ using pres _ _ _ n
+ proof (rule wtc_pres)
+ from prem n show "?wtl n \<in> A" .
+ from cert n show "c!n \<in> A" by (rule cert_okD1)
+ from cert n1 show "c!(n+1) \<in> A" by (rule cert_okD1)
+ qed
+ also
+ from all n have "?wtl n \<noteq> \<top>" by - (rule wtl_take)
+ with n1 have "wtc c n (?wtl n) = ?wtl (n+1)" by (rule wtl_Suc [symmetric])
+ finally show "?wtl (Suc n) \<in> A" by simp
+qed
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/Listn.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,542 @@
+(* Title: HOL/MicroJava/BV/Listn.thy
+ Author: Tobias Nipkow
+ Copyright 2000 TUM
+*)
+
+header {* \isaheader{Fixed Length Lists} *}
+
+theory Listn
+imports Err
+begin
+
+constdefs
+
+ list :: "nat \<Rightarrow> 'a set \<Rightarrow> 'a list set"
+"list n A == {xs. length xs = n & set xs <= A}"
+
+ le :: "'a ord \<Rightarrow> ('a list)ord"
+"le r == list_all2 (%x y. x <=_r y)"
+
+syntax "@lesublist" :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
+ ("(_ /<=[_] _)" [50, 0, 51] 50)
+syntax "@lesssublist" :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
+ ("(_ /<[_] _)" [50, 0, 51] 50)
+translations
+ "x <=[r] y" == "x <=_(Listn.le r) y"
+ "x <[r] y" == "x <_(Listn.le r) y"
+
+constdefs
+ map2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list"
+"map2 f == (%xs ys. map (split f) (zip xs ys))"
+
+syntax "@plussublist" :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b list \<Rightarrow> 'c list"
+ ("(_ /+[_] _)" [65, 0, 66] 65)
+translations "x +[f] y" == "x +_(map2 f) y"
+
+consts coalesce :: "'a err list \<Rightarrow> 'a list err"
+primrec
+"coalesce [] = OK[]"
+"coalesce (ex#exs) = Err.sup (op #) ex (coalesce exs)"
+
+constdefs
+ sl :: "nat \<Rightarrow> 'a sl \<Rightarrow> 'a list sl"
+"sl n == %(A,r,f). (list n A, le r, map2 f)"
+
+ sup :: "('a \<Rightarrow> 'b \<Rightarrow> 'c err) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list err"
+"sup f == %xs ys. if size xs = size ys then coalesce(xs +[f] ys) else Err"
+
+ upto_esl :: "nat \<Rightarrow> 'a esl \<Rightarrow> 'a list esl"
+"upto_esl m == %(A,r,f). (Union{list n A |n. n <= m}, le r, sup f)"
+
+lemmas [simp] = set_update_subsetI
+
+lemma unfold_lesub_list:
+ "xs <=[r] ys == Listn.le r xs ys"
+ by (simp add: lesub_def)
+
+lemma Nil_le_conv [iff]:
+ "([] <=[r] ys) = (ys = [])"
+apply (unfold lesub_def Listn.le_def)
+apply simp
+done
+
+lemma Cons_notle_Nil [iff]:
+ "~ x#xs <=[r] []"
+apply (unfold lesub_def Listn.le_def)
+apply simp
+done
+
+
+lemma Cons_le_Cons [iff]:
+ "x#xs <=[r] y#ys = (x <=_r y & xs <=[r] ys)"
+apply (unfold lesub_def Listn.le_def)
+apply simp
+done
+
+lemma Cons_less_Conss [simp]:
+ "order r \<Longrightarrow>
+ x#xs <_(Listn.le r) y#ys =
+ (x <_r y & xs <=[r] ys | x = y & xs <_(Listn.le r) ys)"
+apply (unfold lesssub_def)
+apply blast
+done
+
+lemma list_update_le_cong:
+ "\<lbrakk> i<size xs; xs <=[r] ys; x <=_r y \<rbrakk> \<Longrightarrow> xs[i:=x] <=[r] ys[i:=y]";
+apply (unfold unfold_lesub_list)
+apply (unfold Listn.le_def)
+apply (simp add: list_all2_conv_all_nth nth_list_update)
+done
+
+
+lemma le_listD:
+ "\<lbrakk> xs <=[r] ys; p < size xs \<rbrakk> \<Longrightarrow> xs!p <=_r ys!p"
+apply (unfold Listn.le_def lesub_def)
+apply (simp add: list_all2_conv_all_nth)
+done
+
+lemma le_list_refl:
+ "!x. x <=_r x \<Longrightarrow> xs <=[r] xs"
+apply (unfold unfold_lesub_list)
+apply (simp add: Listn.le_def list_all2_conv_all_nth)
+done
+
+lemma le_list_trans:
+ "\<lbrakk> order r; xs <=[r] ys; ys <=[r] zs \<rbrakk> \<Longrightarrow> xs <=[r] zs"
+apply (unfold unfold_lesub_list)
+apply (simp add: Listn.le_def list_all2_conv_all_nth)
+apply clarify
+apply simp
+apply (blast intro: order_trans)
+done
+
+lemma le_list_antisym:
+ "\<lbrakk> order r; xs <=[r] ys; ys <=[r] xs \<rbrakk> \<Longrightarrow> xs = ys"
+apply (unfold unfold_lesub_list)
+apply (simp add: Listn.le_def list_all2_conv_all_nth)
+apply (rule nth_equalityI)
+ apply blast
+apply clarify
+apply simp
+apply (blast intro: order_antisym)
+done
+
+lemma order_listI [simp, intro!]:
+ "order r \<Longrightarrow> order(Listn.le r)"
+apply (subst Semilat.order_def)
+apply (blast intro: le_list_refl le_list_trans le_list_antisym
+ dest: order_refl)
+done
+
+
+lemma lesub_list_impl_same_size [simp]:
+ "xs <=[r] ys \<Longrightarrow> size ys = size xs"
+apply (unfold Listn.le_def lesub_def)
+apply (simp add: list_all2_conv_all_nth)
+done
+
+lemma lesssub_list_impl_same_size:
+ "xs <_(Listn.le r) ys \<Longrightarrow> size ys = size xs"
+apply (unfold lesssub_def)
+apply auto
+done
+
+lemma le_list_appendI:
+ "\<And>b c d. a <=[r] b \<Longrightarrow> c <=[r] d \<Longrightarrow> a@c <=[r] b@d"
+apply (induct a)
+ apply simp
+apply (case_tac b)
+apply auto
+done
+
+lemma le_listI:
+ "length a = length b \<Longrightarrow> (\<And>n. n < length a \<Longrightarrow> a!n <=_r b!n) \<Longrightarrow> a <=[r] b"
+ apply (unfold lesub_def Listn.le_def)
+ apply (simp add: list_all2_conv_all_nth)
+ done
+
+lemma listI:
+ "\<lbrakk> length xs = n; set xs <= A \<rbrakk> \<Longrightarrow> xs : list n A"
+apply (unfold list_def)
+apply blast
+done
+
+lemma listE_length [simp]:
+ "xs : list n A \<Longrightarrow> length xs = n"
+apply (unfold list_def)
+apply blast
+done
+
+lemma less_lengthI:
+ "\<lbrakk> xs : list n A; p < n \<rbrakk> \<Longrightarrow> p < length xs"
+ by simp
+
+lemma listE_set [simp]:
+ "xs : list n A \<Longrightarrow> set xs <= A"
+apply (unfold list_def)
+apply blast
+done
+
+lemma list_0 [simp]:
+ "list 0 A = {[]}"
+apply (unfold list_def)
+apply auto
+done
+
+lemma in_list_Suc_iff:
+ "(xs : list (Suc n) A) = (\<exists>y\<in> A. \<exists>ys\<in> list n A. xs = y#ys)"
+apply (unfold list_def)
+apply (case_tac "xs")
+apply auto
+done
+
+lemma Cons_in_list_Suc [iff]:
+ "(x#xs : list (Suc n) A) = (x\<in> A & xs : list n A)";
+apply (simp add: in_list_Suc_iff)
+done
+
+lemma list_not_empty:
+ "\<exists>a. a\<in> A \<Longrightarrow> \<exists>xs. xs : list n A";
+apply (induct "n")
+ apply simp
+apply (simp add: in_list_Suc_iff)
+apply blast
+done
+
+
+lemma nth_in [rule_format, simp]:
+ "!i n. length xs = n \<longrightarrow> set xs <= A \<longrightarrow> i < n \<longrightarrow> (xs!i) : A"
+apply (induct "xs")
+ apply simp
+apply (simp add: nth_Cons split: nat.split)
+done
+
+lemma listE_nth_in:
+ "\<lbrakk> xs : list n A; i < n \<rbrakk> \<Longrightarrow> (xs!i) : A"
+ by auto
+
+
+lemma listn_Cons_Suc [elim!]:
+ "l#xs \<in> list n A \<Longrightarrow> (\<And>n'. n = Suc n' \<Longrightarrow> l \<in> A \<Longrightarrow> xs \<in> list n' A \<Longrightarrow> P) \<Longrightarrow> P"
+ by (cases n) auto
+
+lemma listn_appendE [elim!]:
+ "a@b \<in> list n A \<Longrightarrow> (\<And>n1 n2. n=n1+n2 \<Longrightarrow> a \<in> list n1 A \<Longrightarrow> b \<in> list n2 A \<Longrightarrow> P) \<Longrightarrow> P"
+proof -
+ have "\<And>n. a@b \<in> list n A \<Longrightarrow> \<exists>n1 n2. n=n1+n2 \<and> a \<in> list n1 A \<and> b \<in> list n2 A"
+ (is "\<And>n. ?list a n \<Longrightarrow> \<exists>n1 n2. ?P a n n1 n2")
+ proof (induct a)
+ fix n assume "?list [] n"
+ hence "?P [] n 0 n" by simp
+ thus "\<exists>n1 n2. ?P [] n n1 n2" by fast
+ next
+ fix n l ls
+ assume "?list (l#ls) n"
+ then obtain n' where n: "n = Suc n'" "l \<in> A" and list_n': "ls@b \<in> list n' A" by fastsimp
+ assume "\<And>n. ls @ b \<in> list n A \<Longrightarrow> \<exists>n1 n2. n = n1 + n2 \<and> ls \<in> list n1 A \<and> b \<in> list n2 A"
+ hence "\<exists>n1 n2. n' = n1 + n2 \<and> ls \<in> list n1 A \<and> b \<in> list n2 A" by this (rule list_n')
+ then obtain n1 n2 where "n' = n1 + n2" "ls \<in> list n1 A" "b \<in> list n2 A" by fast
+ with n have "?P (l#ls) n (n1+1) n2" by simp
+ thus "\<exists>n1 n2. ?P (l#ls) n n1 n2" by fastsimp
+ qed
+ moreover
+ assume "a@b \<in> list n A" "\<And>n1 n2. n=n1+n2 \<Longrightarrow> a \<in> list n1 A \<Longrightarrow> b \<in> list n2 A \<Longrightarrow> P"
+ ultimately
+ show ?thesis by blast
+qed
+
+
+lemma listt_update_in_list [simp, intro!]:
+ "\<lbrakk> xs : list n A; x\<in> A \<rbrakk> \<Longrightarrow> xs[i := x] : list n A"
+apply (unfold list_def)
+apply simp
+done
+
+lemma plus_list_Nil [simp]:
+ "[] +[f] xs = []"
+apply (unfold plussub_def map2_def)
+apply simp
+done
+
+lemma plus_list_Cons [simp]:
+ "(x#xs) +[f] ys = (case ys of [] \<Rightarrow> [] | y#ys \<Rightarrow> (x +_f y)#(xs +[f] ys))"
+ by (simp add: plussub_def map2_def split: list.split)
+
+lemma length_plus_list [rule_format, simp]:
+ "!ys. length(xs +[f] ys) = min(length xs) (length ys)"
+apply (induct xs)
+ apply simp
+apply clarify
+apply (simp (no_asm_simp) split: list.split)
+done
+
+lemma nth_plus_list [rule_format, simp]:
+ "!xs ys i. length xs = n \<longrightarrow> length ys = n \<longrightarrow> i<n \<longrightarrow>
+ (xs +[f] ys)!i = (xs!i) +_f (ys!i)"
+apply (induct n)
+ apply simp
+apply clarify
+apply (case_tac xs)
+ apply simp
+apply (force simp add: nth_Cons split: list.split nat.split)
+done
+
+
+lemma (in Semilat) plus_list_ub1 [rule_format]:
+ "\<lbrakk> set xs <= A; set ys <= A; size xs = size ys \<rbrakk>
+ \<Longrightarrow> xs <=[r] xs +[f] ys"
+apply (unfold unfold_lesub_list)
+apply (simp add: Listn.le_def list_all2_conv_all_nth)
+done
+
+lemma (in Semilat) plus_list_ub2:
+ "\<lbrakk>set xs <= A; set ys <= A; size xs = size ys \<rbrakk>
+ \<Longrightarrow> ys <=[r] xs +[f] ys"
+apply (unfold unfold_lesub_list)
+apply (simp add: Listn.le_def list_all2_conv_all_nth)
+done
+
+lemma (in Semilat) plus_list_lub [rule_format]:
+shows "!xs ys zs. set xs <= A \<longrightarrow> set ys <= A \<longrightarrow> set zs <= A
+ \<longrightarrow> size xs = n & size ys = n \<longrightarrow>
+ xs <=[r] zs & ys <=[r] zs \<longrightarrow> xs +[f] ys <=[r] zs"
+apply (unfold unfold_lesub_list)
+apply (simp add: Listn.le_def list_all2_conv_all_nth)
+done
+
+lemma (in Semilat) list_update_incr [rule_format]:
+ "x\<in> A \<Longrightarrow> set xs <= A \<longrightarrow>
+ (!i. i<size xs \<longrightarrow> xs <=[r] xs[i := x +_f xs!i])"
+apply (unfold unfold_lesub_list)
+apply (simp add: Listn.le_def list_all2_conv_all_nth)
+apply (induct xs)
+ apply simp
+apply (simp add: in_list_Suc_iff)
+apply clarify
+apply (simp add: nth_Cons split: nat.split)
+done
+
+lemma equals0I_aux:
+ "(\<And>y. A y \<Longrightarrow> False) \<Longrightarrow> A = bot_class.bot"
+ by (rule equals0I) (auto simp add: mem_def)
+
+lemma acc_le_listI [intro!]:
+ "\<lbrakk> order r; acc r \<rbrakk> \<Longrightarrow> acc(Listn.le r)"
+apply (unfold acc_def)
+apply (subgoal_tac
+ "wf(UN n. {(ys,xs). size xs = n \<and> size ys = n \<and> xs <_(Listn.le r) ys})")
+ apply (erule wf_subset)
+ apply (blast intro: lesssub_list_impl_same_size)
+apply (rule wf_UN)
+ prefer 2
+ apply clarify
+ apply (rename_tac m n)
+ apply (case_tac "m=n")
+ apply simp
+ apply (fast intro!: equals0I dest: not_sym)
+apply clarify
+apply (rename_tac n)
+apply (induct_tac n)
+ apply (simp add: lesssub_def cong: conj_cong)
+apply (rename_tac k)
+apply (simp add: wf_eq_minimal)
+apply (simp (no_asm) add: length_Suc_conv cong: conj_cong)
+apply clarify
+apply (rename_tac M m)
+apply (case_tac "\<exists>x xs. size xs = k \<and> x#xs \<in> M")
+ prefer 2
+ apply (erule thin_rl)
+ apply (erule thin_rl)
+ apply blast
+apply (erule_tac x = "{a. \<exists>xs. size xs = k \<and> a#xs:M}" in allE)
+apply (erule impE)
+ apply blast
+apply (thin_tac "\<exists>x xs. ?P x xs")
+apply clarify
+apply (rename_tac maxA xs)
+apply (erule_tac x = "{ys. size ys = size xs \<and> maxA#ys \<in> M}" in allE)
+apply (erule impE)
+ apply blast
+apply clarify
+apply (thin_tac "m \<in> M")
+apply (thin_tac "maxA#xs \<in> M")
+apply (rule bexI)
+ prefer 2
+ apply assumption
+apply clarify
+apply simp
+apply blast
+done
+
+lemma closed_listI:
+ "closed S f \<Longrightarrow> closed (list n S) (map2 f)"
+apply (unfold closed_def)
+apply (induct n)
+ apply simp
+apply clarify
+apply (simp add: in_list_Suc_iff)
+apply clarify
+apply simp
+done
+
+
+lemma Listn_sl_aux:
+assumes "semilat (A, r, f)" shows "semilat (Listn.sl n (A,r,f))"
+proof -
+ interpret Semilat A r f using assms by (rule Semilat.intro)
+show ?thesis
+apply (unfold Listn.sl_def)
+apply (simp (no_asm) only: semilat_Def split_conv)
+apply (rule conjI)
+ apply simp
+apply (rule conjI)
+ apply (simp only: closedI closed_listI)
+apply (simp (no_asm) only: list_def)
+apply (simp (no_asm_simp) add: plus_list_ub1 plus_list_ub2 plus_list_lub)
+done
+qed
+
+lemma Listn_sl: "\<And>L. semilat L \<Longrightarrow> semilat (Listn.sl n L)"
+ by(simp add: Listn_sl_aux split_tupled_all)
+
+lemma coalesce_in_err_list [rule_format]:
+ "!xes. xes : list n (err A) \<longrightarrow> coalesce xes : err(list n A)"
+apply (induct n)
+ apply simp
+apply clarify
+apply (simp add: in_list_Suc_iff)
+apply clarify
+apply (simp (no_asm) add: plussub_def Err.sup_def lift2_def split: err.split)
+apply force
+done
+
+lemma lem: "\<And>x xs. x +_(op #) xs = x#xs"
+ by (simp add: plussub_def)
+
+lemma coalesce_eq_OK1_D [rule_format]:
+ "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
+ !xs. xs : list n A \<longrightarrow> (!ys. ys : list n A \<longrightarrow>
+ (!zs. coalesce (xs +[f] ys) = OK zs \<longrightarrow> xs <=[r] zs))"
+apply (induct n)
+ apply simp
+apply clarify
+apply (simp add: in_list_Suc_iff)
+apply clarify
+apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
+apply (force simp add: semilat_le_err_OK1)
+done
+
+lemma coalesce_eq_OK2_D [rule_format]:
+ "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
+ !xs. xs : list n A \<longrightarrow> (!ys. ys : list n A \<longrightarrow>
+ (!zs. coalesce (xs +[f] ys) = OK zs \<longrightarrow> ys <=[r] zs))"
+apply (induct n)
+ apply simp
+apply clarify
+apply (simp add: in_list_Suc_iff)
+apply clarify
+apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
+apply (force simp add: semilat_le_err_OK2)
+done
+
+lemma lift2_le_ub:
+ "\<lbrakk> semilat(err A, Err.le r, lift2 f); x\<in> A; y\<in> A; x +_f y = OK z;
+ u\<in> A; x <=_r u; y <=_r u \<rbrakk> \<Longrightarrow> z <=_r u"
+apply (unfold semilat_Def plussub_def err_def)
+apply (simp add: lift2_def)
+apply clarify
+apply (rotate_tac -3)
+apply (erule thin_rl)
+apply (erule thin_rl)
+apply force
+done
+
+lemma coalesce_eq_OK_ub_D [rule_format]:
+ "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
+ !xs. xs : list n A \<longrightarrow> (!ys. ys : list n A \<longrightarrow>
+ (!zs us. coalesce (xs +[f] ys) = OK zs & xs <=[r] us & ys <=[r] us
+ & us : list n A \<longrightarrow> zs <=[r] us))"
+apply (induct n)
+ apply simp
+apply clarify
+apply (simp add: in_list_Suc_iff)
+apply clarify
+apply (simp (no_asm_use) split: err.split_asm add: lem Err.sup_def lift2_def)
+apply clarify
+apply (rule conjI)
+ apply (blast intro: lift2_le_ub)
+apply blast
+done
+
+lemma lift2_eq_ErrD:
+ "\<lbrakk> x +_f y = Err; semilat(err A, Err.le r, lift2 f); x\<in> A; y\<in> A \<rbrakk>
+ \<Longrightarrow> ~(\<exists>u\<in> A. x <=_r u & y <=_r u)"
+ by (simp add: OK_plus_OK_eq_Err_conv [THEN iffD1])
+
+
+lemma coalesce_eq_Err_D [rule_format]:
+ "\<lbrakk> semilat(err A, Err.le r, lift2 f) \<rbrakk>
+ \<Longrightarrow> !xs. xs\<in> list n A \<longrightarrow> (!ys. ys\<in> list n A \<longrightarrow>
+ coalesce (xs +[f] ys) = Err \<longrightarrow>
+ ~(\<exists>zs\<in> list n A. xs <=[r] zs & ys <=[r] zs))"
+apply (induct n)
+ apply simp
+apply clarify
+apply (simp add: in_list_Suc_iff)
+apply clarify
+apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
+ apply (blast dest: lift2_eq_ErrD)
+done
+
+lemma closed_err_lift2_conv:
+ "closed (err A) (lift2 f) = (\<forall>x\<in> A. \<forall>y\<in> A. x +_f y : err A)"
+apply (unfold closed_def)
+apply (simp add: err_def)
+done
+
+lemma closed_map2_list [rule_format]:
+ "closed (err A) (lift2 f) \<Longrightarrow>
+ \<forall>xs. xs : list n A \<longrightarrow> (\<forall>ys. ys : list n A \<longrightarrow>
+ map2 f xs ys : list n (err A))"
+apply (unfold map2_def)
+apply (induct n)
+ apply simp
+apply clarify
+apply (simp add: in_list_Suc_iff)
+apply clarify
+apply (simp add: plussub_def closed_err_lift2_conv)
+done
+
+lemma closed_lift2_sup:
+ "closed (err A) (lift2 f) \<Longrightarrow>
+ closed (err (list n A)) (lift2 (sup f))"
+ by (fastsimp simp add: closed_def plussub_def sup_def lift2_def
+ coalesce_in_err_list closed_map2_list
+ split: err.split)
+
+lemma err_semilat_sup:
+ "err_semilat (A,r,f) \<Longrightarrow>
+ err_semilat (list n A, Listn.le r, sup f)"
+apply (unfold Err.sl_def)
+apply (simp only: split_conv)
+apply (simp (no_asm) only: semilat_Def plussub_def)
+apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
+apply (rule conjI)
+ apply (drule Semilat.orderI [OF Semilat.intro])
+ apply simp
+apply (simp (no_asm) only: unfold_lesub_err Err.le_def err_def sup_def lift2_def)
+apply (simp (no_asm_simp) add: coalesce_eq_OK1_D coalesce_eq_OK2_D split: err.split)
+apply (blast intro: coalesce_eq_OK_ub_D dest: coalesce_eq_Err_D)
+done
+
+lemma err_semilat_upto_esl:
+ "\<And>L. err_semilat L \<Longrightarrow> err_semilat(upto_esl m L)"
+apply (unfold Listn.upto_esl_def)
+apply (simp (no_asm_simp) only: split_tupled_all)
+apply simp
+apply (fastsimp intro!: err_semilat_UnionI err_semilat_sup
+ dest: lesub_list_impl_same_size
+ simp add: plussub_def Listn.sup_def)
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/Opt.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,292 @@
+(* Title: HOL/MicroJava/BV/Opt.thy
+ Author: Tobias Nipkow
+ Copyright 2000 TUM
+*)
+
+header {* \isaheader{More about Options} *}
+
+theory Opt
+imports Err
+begin
+
+constdefs
+ le :: "'a ord \<Rightarrow> 'a option ord"
+"le r o1 o2 == case o2 of None \<Rightarrow> o1=None |
+ Some y \<Rightarrow> (case o1 of None \<Rightarrow> True
+ | Some x \<Rightarrow> x <=_r y)"
+
+ opt :: "'a set \<Rightarrow> 'a option set"
+"opt A == insert None {x . ? y:A. x = Some y}"
+
+ sup :: "'a ebinop \<Rightarrow> 'a option ebinop"
+"sup f o1 o2 ==
+ case o1 of None \<Rightarrow> OK o2 | Some x \<Rightarrow> (case o2 of None \<Rightarrow> OK o1
+ | Some y \<Rightarrow> (case f x y of Err \<Rightarrow> Err | OK z \<Rightarrow> OK (Some z)))"
+
+ esl :: "'a esl \<Rightarrow> 'a option esl"
+"esl == %(A,r,f). (opt A, le r, sup f)"
+
+lemma unfold_le_opt:
+ "o1 <=_(le r) o2 =
+ (case o2 of None \<Rightarrow> o1=None |
+ Some y \<Rightarrow> (case o1 of None \<Rightarrow> True | Some x \<Rightarrow> x <=_r y))"
+apply (unfold lesub_def le_def)
+apply (rule refl)
+done
+
+lemma le_opt_refl:
+ "order r \<Longrightarrow> o1 <=_(le r) o1"
+by (simp add: unfold_le_opt split: option.split)
+
+lemma le_opt_trans [rule_format]:
+ "order r \<Longrightarrow>
+ o1 <=_(le r) o2 \<longrightarrow> o2 <=_(le r) o3 \<longrightarrow> o1 <=_(le r) o3"
+apply (simp add: unfold_le_opt split: option.split)
+apply (blast intro: order_trans)
+done
+
+lemma le_opt_antisym [rule_format]:
+ "order r \<Longrightarrow> o1 <=_(le r) o2 \<longrightarrow> o2 <=_(le r) o1 \<longrightarrow> o1=o2"
+apply (simp add: unfold_le_opt split: option.split)
+apply (blast intro: order_antisym)
+done
+
+lemma order_le_opt [intro!,simp]:
+ "order r \<Longrightarrow> order(le r)"
+apply (subst Semilat.order_def)
+apply (blast intro: le_opt_refl le_opt_trans le_opt_antisym)
+done
+
+lemma None_bot [iff]:
+ "None <=_(le r) ox"
+apply (unfold lesub_def le_def)
+apply (simp split: option.split)
+done
+
+lemma Some_le [iff]:
+ "(Some x <=_(le r) ox) = (? y. ox = Some y & x <=_r y)"
+apply (unfold lesub_def le_def)
+apply (simp split: option.split)
+done
+
+lemma le_None [iff]:
+ "(ox <=_(le r) None) = (ox = None)";
+apply (unfold lesub_def le_def)
+apply (simp split: option.split)
+done
+
+
+lemma OK_None_bot [iff]:
+ "OK None <=_(Err.le (le r)) x"
+ by (simp add: lesub_def Err.le_def le_def split: option.split err.split)
+
+lemma sup_None1 [iff]:
+ "x +_(sup f) None = OK x"
+ by (simp add: plussub_def sup_def split: option.split)
+
+lemma sup_None2 [iff]:
+ "None +_(sup f) x = OK x"
+ by (simp add: plussub_def sup_def split: option.split)
+
+
+lemma None_in_opt [iff]:
+ "None : opt A"
+by (simp add: opt_def)
+
+lemma Some_in_opt [iff]:
+ "(Some x : opt A) = (x:A)"
+apply (unfold opt_def)
+apply auto
+done
+
+
+lemma semilat_opt [intro, simp]:
+ "\<And>L. err_semilat L \<Longrightarrow> err_semilat (Opt.esl L)"
+proof (unfold Opt.esl_def Err.sl_def, simp add: split_tupled_all)
+
+ fix A r f
+ assume s: "semilat (err A, Err.le r, lift2 f)"
+
+ let ?A0 = "err A"
+ let ?r0 = "Err.le r"
+ let ?f0 = "lift2 f"
+
+ from s
+ obtain
+ ord: "order ?r0" and
+ clo: "closed ?A0 ?f0" and
+ ub1: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. x <=_?r0 x +_?f0 y" and
+ ub2: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. y <=_?r0 x +_?f0 y" and
+ lub: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. \<forall>z\<in>?A0. x <=_?r0 z \<and> y <=_?r0 z \<longrightarrow> x +_?f0 y <=_?r0 z"
+ by (unfold semilat_def) simp
+
+ let ?A = "err (opt A)"
+ let ?r = "Err.le (Opt.le r)"
+ let ?f = "lift2 (Opt.sup f)"
+
+ from ord
+ have "order ?r"
+ by simp
+
+ moreover
+
+ have "closed ?A ?f"
+ proof (unfold closed_def, intro strip)
+ fix x y
+ assume x: "x : ?A"
+ assume y: "y : ?A"
+
+ { fix a b
+ assume ab: "x = OK a" "y = OK b"
+
+ with x
+ have a: "\<And>c. a = Some c \<Longrightarrow> c : A"
+ by (clarsimp simp add: opt_def)
+
+ from ab y
+ have b: "\<And>d. b = Some d \<Longrightarrow> d : A"
+ by (clarsimp simp add: opt_def)
+
+ { fix c d assume "a = Some c" "b = Some d"
+ with ab x y
+ have "c:A & d:A"
+ by (simp add: err_def opt_def Bex_def)
+ with clo
+ have "f c d : err A"
+ by (simp add: closed_def plussub_def err_def lift2_def)
+ moreover
+ fix z assume "f c d = OK z"
+ ultimately
+ have "z : A" by simp
+ } note f_closed = this
+
+ have "sup f a b : ?A"
+ proof (cases a)
+ case None
+ thus ?thesis
+ by (simp add: sup_def opt_def) (cases b, simp, simp add: b Bex_def)
+ next
+ case Some
+ thus ?thesis
+ by (auto simp add: sup_def opt_def Bex_def a b f_closed split: err.split option.split)
+ qed
+ }
+
+ thus "x +_?f y : ?A"
+ by (simp add: plussub_def lift2_def split: err.split)
+ qed
+
+ moreover
+
+ { fix a b c
+ assume "a \<in> opt A" "b \<in> opt A" "a +_(sup f) b = OK c"
+ moreover
+ from ord have "order r" by simp
+ moreover
+ { fix x y z
+ assume "x \<in> A" "y \<in> A"
+ hence "OK x \<in> err A \<and> OK y \<in> err A" by simp
+ with ub1 ub2
+ have "(OK x) <=_(Err.le r) (OK x) +_(lift2 f) (OK y) \<and>
+ (OK y) <=_(Err.le r) (OK x) +_(lift2 f) (OK y)"
+ by blast
+ moreover
+ assume "x +_f y = OK z"
+ ultimately
+ have "x <=_r z \<and> y <=_r z"
+ by (auto simp add: plussub_def lift2_def Err.le_def lesub_def)
+ }
+ ultimately
+ have "a <=_(le r) c \<and> b <=_(le r) c"
+ by (auto simp add: sup_def le_def lesub_def plussub_def
+ dest: order_refl split: option.splits err.splits)
+ }
+
+ hence "(\<forall>x\<in>?A. \<forall>y\<in>?A. x <=_?r x +_?f y) \<and> (\<forall>x\<in>?A. \<forall>y\<in>?A. y <=_?r x +_?f y)"
+ by (auto simp add: lesub_def plussub_def Err.le_def lift2_def split: err.split)
+
+ moreover
+
+ have "\<forall>x\<in>?A. \<forall>y\<in>?A. \<forall>z\<in>?A. x <=_?r z \<and> y <=_?r z \<longrightarrow> x +_?f y <=_?r z"
+ proof (intro strip, elim conjE)
+ fix x y z
+ assume xyz: "x : ?A" "y : ?A" "z : ?A"
+ assume xz: "x <=_?r z"
+ assume yz: "y <=_?r z"
+
+ { fix a b c
+ assume ok: "x = OK a" "y = OK b" "z = OK c"
+
+ { fix d e g
+ assume some: "a = Some d" "b = Some e" "c = Some g"
+
+ with ok xyz
+ obtain "OK d:err A" "OK e:err A" "OK g:err A"
+ by simp
+ with lub
+ have "\<lbrakk> (OK d) <=_(Err.le r) (OK g); (OK e) <=_(Err.le r) (OK g) \<rbrakk>
+ \<Longrightarrow> (OK d) +_(lift2 f) (OK e) <=_(Err.le r) (OK g)"
+ by blast
+ hence "\<lbrakk> d <=_r g; e <=_r g \<rbrakk> \<Longrightarrow> \<exists>y. d +_f e = OK y \<and> y <=_r g"
+ by simp
+
+ with ok some xyz xz yz
+ have "x +_?f y <=_?r z"
+ by (auto simp add: sup_def le_def lesub_def lift2_def plussub_def Err.le_def)
+ } note this [intro!]
+
+ from ok xyz xz yz
+ have "x +_?f y <=_?r z"
+ by - (cases a, simp, cases b, simp, cases c, simp, blast)
+ }
+
+ with xyz xz yz
+ show "x +_?f y <=_?r z"
+ by - (cases x, simp, cases y, simp, cases z, simp+)
+ qed
+
+ ultimately
+
+ show "semilat (?A,?r,?f)"
+ by (unfold semilat_def) simp
+qed
+
+lemma top_le_opt_Some [iff]:
+ "top (le r) (Some T) = top r T"
+apply (unfold top_def)
+apply (rule iffI)
+ apply blast
+apply (rule allI)
+apply (case_tac "x")
+apply simp+
+done
+
+lemma Top_le_conv:
+ "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T <=_r x) = (x = T)"
+apply (unfold top_def)
+apply (blast intro: order_antisym)
+done
+
+
+lemma acc_le_optI [intro!]:
+ "acc r \<Longrightarrow> acc(le r)"
+apply (unfold acc_def lesub_def le_def lesssub_def)
+apply (simp add: wf_eq_minimal split: option.split)
+apply clarify
+apply (case_tac "? a. Some a : Q")
+ apply (erule_tac x = "{a . Some a : Q}" in allE)
+ apply blast
+apply (case_tac "x")
+ apply blast
+apply blast
+done
+
+lemma option_map_in_optionI:
+ "\<lbrakk> ox : opt S; !x:S. ox = Some x \<longrightarrow> f x : S \<rbrakk>
+ \<Longrightarrow> Option.map f ox : opt S";
+apply (unfold Option.map_def)
+apply (simp split: option.split)
+apply blast
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/Product.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,141 @@
+(* Title: HOL/MicroJava/BV/Product.thy
+ Author: Tobias Nipkow
+ Copyright 2000 TUM
+*)
+
+header {* \isaheader{Products as Semilattices} *}
+
+theory Product
+imports Err
+begin
+
+constdefs
+ le :: "'a ord \<Rightarrow> 'b ord \<Rightarrow> ('a * 'b) ord"
+"le rA rB == %(a,b) (a',b'). a <=_rA a' & b <=_rB b'"
+
+ sup :: "'a ebinop \<Rightarrow> 'b ebinop \<Rightarrow> ('a * 'b)ebinop"
+"sup f g == %(a1,b1)(a2,b2). Err.sup Pair (a1 +_f a2) (b1 +_g b2)"
+
+ esl :: "'a esl \<Rightarrow> 'b esl \<Rightarrow> ('a * 'b ) esl"
+"esl == %(A,rA,fA) (B,rB,fB). (A <*> B, le rA rB, sup fA fB)"
+
+syntax "@lesubprod" :: "'a*'b \<Rightarrow> 'a ord \<Rightarrow> 'b ord \<Rightarrow> 'b \<Rightarrow> bool"
+ ("(_ /<='(_,_') _)" [50, 0, 0, 51] 50)
+translations "p <=(rA,rB) q" == "p <=_(Product.le rA rB) q"
+
+lemma unfold_lesub_prod:
+ "p <=(rA,rB) q == le rA rB p q"
+ by (simp add: lesub_def)
+
+lemma le_prod_Pair_conv [iff]:
+ "((a1,b1) <=(rA,rB) (a2,b2)) = (a1 <=_rA a2 & b1 <=_rB b2)"
+ by (simp add: lesub_def le_def)
+
+lemma less_prod_Pair_conv:
+ "((a1,b1) <_(Product.le rA rB) (a2,b2)) =
+ (a1 <_rA a2 & b1 <=_rB b2 | a1 <=_rA a2 & b1 <_rB b2)"
+apply (unfold lesssub_def)
+apply simp
+apply blast
+done
+
+lemma order_le_prod [iff]:
+ "order(Product.le rA rB) = (order rA & order rB)"
+apply (unfold Semilat.order_def)
+apply simp
+apply blast
+done
+
+lemma acc_le_prodI [intro!]:
+ "\<lbrakk> acc r\<^isub>A; acc r\<^isub>B \<rbrakk> \<Longrightarrow> acc(Product.le r\<^isub>A r\<^isub>B)"
+apply (unfold acc_def)
+apply (rule wf_subset)
+ apply (erule wf_lex_prod)
+ apply assumption
+apply (auto simp add: lesssub_def less_prod_Pair_conv lex_prod_def)
+done
+
+lemma closed_lift2_sup:
+ "\<lbrakk> closed (err A) (lift2 f); closed (err B) (lift2 g) \<rbrakk> \<Longrightarrow>
+ closed (err(A<*>B)) (lift2(sup f g))";
+apply (unfold closed_def plussub_def lift2_def err_def sup_def)
+apply (simp split: err.split)
+apply blast
+done
+
+lemma unfold_plussub_lift2:
+ "e1 +_(lift2 f) e2 == lift2 f e1 e2"
+ by (simp add: plussub_def)
+
+
+lemma plus_eq_Err_conv [simp]:
+ assumes "x:A" and "y:A"
+ and "semilat(err A, Err.le r, lift2 f)"
+ shows "(x +_f y = Err) = (~(? z:A. x <=_r z & y <=_r z))"
+proof -
+ have plus_le_conv2:
+ "\<And>r f z. \<lbrakk> z : err A; semilat (err A, r, f); OK x : err A; OK y : err A;
+ OK x +_f OK y <=_r z\<rbrakk> \<Longrightarrow> OK x <=_r z \<and> OK y <=_r z"
+ by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1])
+ from prems show ?thesis
+ apply (rule_tac iffI)
+ apply clarify
+ apply (drule OK_le_err_OK [THEN iffD2])
+ apply (drule OK_le_err_OK [THEN iffD2])
+ apply (drule Semilat.lub [OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
+ apply assumption
+ apply assumption
+ apply simp
+ apply simp
+ apply simp
+ apply simp
+ apply (case_tac "x +_f y")
+ apply assumption
+ apply (rename_tac "z")
+ apply (subgoal_tac "OK z: err A")
+ apply (frule plus_le_conv2)
+ apply assumption
+ apply simp
+ apply blast
+ apply simp
+ apply (blast dest: Semilat.orderI [OF Semilat.intro] order_refl)
+ apply blast
+ apply (erule subst)
+ apply (unfold semilat_def err_def closed_def)
+ apply simp
+ done
+qed
+
+lemma err_semilat_Product_esl:
+ "\<And>L1 L2. \<lbrakk> err_semilat L1; err_semilat L2 \<rbrakk> \<Longrightarrow> err_semilat(Product.esl L1 L2)"
+apply (unfold esl_def Err.sl_def)
+apply (simp (no_asm_simp) only: split_tupled_all)
+apply simp
+apply (simp (no_asm) only: semilat_Def)
+apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
+apply (simp (no_asm) only: unfold_lesub_err Err.le_def unfold_plussub_lift2 sup_def)
+apply (auto elim: semilat_le_err_OK1 semilat_le_err_OK2
+ simp add: lift2_def split: err.split)
+apply (blast dest: Semilat.orderI [OF Semilat.intro])
+apply (blast dest: Semilat.orderI [OF Semilat.intro])
+
+apply (rule OK_le_err_OK [THEN iffD1])
+apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
+apply simp
+apply simp
+apply simp
+apply simp
+apply simp
+apply simp
+
+apply (rule OK_le_err_OK [THEN iffD1])
+apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
+apply simp
+apply simp
+apply simp
+apply simp
+apply simp
+apply simp
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/Semilat.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,374 @@
+(* Title: HOL/MicroJava/BV/Semilat.thy
+ Author: Tobias Nipkow
+ Copyright 2000 TUM
+*)
+
+header {*
+ \chapter{Bytecode Verifier}\label{cha:bv}
+ \isaheader{Semilattices}
+*}
+
+theory Semilat
+imports Main While_Combinator
+begin
+
+types
+ 'a ord = "'a \<Rightarrow> 'a \<Rightarrow> bool"
+ 'a binop = "'a \<Rightarrow> 'a \<Rightarrow> 'a"
+ 'a sl = "'a set \<times> 'a ord \<times> 'a binop"
+
+consts
+ "lesub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
+ "lesssub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
+ "plussub" :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c"
+(*<*)
+syntax
+ "lesub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /<='__ _)" [50, 1000, 51] 50)
+ "lesssub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /<'__ _)" [50, 1000, 51] 50)
+ "plussub" :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /+'__ _)" [65, 1000, 66] 65)
+(*>*)
+syntax (xsymbols)
+ "lesub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubseteq>\<^bsub>_\<^esub> _)" [50, 0, 51] 50)
+ "lesssub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubset>\<^bsub>_\<^esub> _)" [50, 0, 51] 50)
+ "plussub" :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /\<squnion>\<^bsub>_\<^esub> _)" [65, 0, 66] 65)
+(*<*)
+ (* allow \<sub> instead of \<bsub>..\<esub> *)
+ "@lesub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubseteq>\<^sub>_ _)" [50, 1000, 51] 50)
+ "@lesssub" :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubset>\<^sub>_ _)" [50, 1000, 51] 50)
+ "@plussub" :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /\<squnion>\<^sub>_ _)" [65, 1000, 66] 65)
+
+translations
+ "x \<sqsubseteq>\<^sub>r y" => "x \<sqsubseteq>\<^bsub>r\<^esub> y"
+ "x \<sqsubset>\<^sub>r y" => "x \<sqsubset>\<^bsub>r\<^esub> y"
+ "x \<squnion>\<^sub>f y" => "x \<squnion>\<^bsub>f\<^esub> y"
+(*>*)
+
+defs
+ lesub_def: "x \<sqsubseteq>\<^sub>r y \<equiv> r x y"
+ lesssub_def: "x \<sqsubset>\<^sub>r y \<equiv> x \<sqsubseteq>\<^sub>r y \<and> x \<noteq> y"
+ plussub_def: "x \<squnion>\<^sub>f y \<equiv> f x y"
+
+constdefs
+ ord :: "('a \<times> 'a) set \<Rightarrow> 'a ord"
+ "ord r \<equiv> \<lambda>x y. (x,y) \<in> r"
+
+ order :: "'a ord \<Rightarrow> bool"
+ "order r \<equiv> (\<forall>x. x \<sqsubseteq>\<^sub>r x) \<and> (\<forall>x y. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r x \<longrightarrow> x=y) \<and> (\<forall>x y z. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<sqsubseteq>\<^sub>r z)"
+
+ top :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool"
+ "top r T \<equiv> \<forall>x. x \<sqsubseteq>\<^sub>r T"
+
+ acc :: "'a ord \<Rightarrow> bool"
+ "acc r \<equiv> wf {(y,x). x \<sqsubset>\<^sub>r y}"
+
+ closed :: "'a set \<Rightarrow> 'a binop \<Rightarrow> bool"
+ "closed A f \<equiv> \<forall>x\<in>A. \<forall>y\<in>A. x \<squnion>\<^sub>f y \<in> A"
+
+ semilat :: "'a sl \<Rightarrow> bool"
+ "semilat \<equiv> \<lambda>(A,r,f). order r \<and> closed A f \<and>
+ (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
+ (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
+ (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z)"
+
+
+ is_ub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
+ "is_ub r x y u \<equiv> (x,u)\<in>r \<and> (y,u)\<in>r"
+
+ is_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
+ "is_lub r x y u \<equiv> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z)\<in>r)"
+
+ some_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
+ "some_lub r x y \<equiv> SOME z. is_lub r x y z"
+
+locale Semilat =
+ fixes A :: "'a set"
+ fixes r :: "'a ord"
+ fixes f :: "'a binop"
+ assumes semilat: "semilat (A, r, f)"
+
+lemma order_refl [simp, intro]: "order r \<Longrightarrow> x \<sqsubseteq>\<^sub>r x"
+ (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)
+
+lemma order_antisym: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
+ (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)
+
+lemma order_trans: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
+ (*<*) by (unfold order_def) blast (*>*)
+
+lemma order_less_irrefl [intro, simp]: "order r \<Longrightarrow> \<not> x \<sqsubset>\<^sub>r x"
+ (*<*) by (unfold order_def lesssub_def) blast (*>*)
+
+lemma order_less_trans: "\<lbrakk> order r; x \<sqsubset>\<^sub>r y; y \<sqsubset>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubset>\<^sub>r z"
+ (*<*) by (unfold order_def lesssub_def) blast (*>*)
+
+lemma topD [simp, intro]: "top r T \<Longrightarrow> x \<sqsubseteq>\<^sub>r T"
+ (*<*) by (simp add: top_def) (*>*)
+
+lemma top_le_conv [simp]: "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T \<sqsubseteq>\<^sub>r x) = (x = T)"
+ (*<*) by (blast intro: order_antisym) (*>*)
+
+lemma semilat_Def:
+"semilat(A,r,f) \<equiv> order r \<and> closed A f \<and>
+ (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
+ (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
+ (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z)"
+ (*<*) by (unfold semilat_def) clarsimp (*>*)
+
+lemma (in Semilat) orderI [simp, intro]: "order r"
+ (*<*) using semilat by (simp add: semilat_Def) (*>*)
+
+lemma (in Semilat) closedI [simp, intro]: "closed A f"
+ (*<*) using semilat by (simp add: semilat_Def) (*>*)
+
+lemma closedD: "\<lbrakk> closed A f; x\<in>A; y\<in>A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
+ (*<*) by (unfold closed_def) blast (*>*)
+
+lemma closed_UNIV [simp]: "closed UNIV f"
+ (*<*) by (simp add: closed_def) (*>*)
+
+lemma (in Semilat) closed_f [simp, intro]: "\<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
+ (*<*) by (simp add: closedD [OF closedI]) (*>*)
+
+lemma (in Semilat) refl_r [intro, simp]: "x \<sqsubseteq>\<^sub>r x" by simp
+
+lemma (in Semilat) antisym_r [intro?]: "\<lbrakk> x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
+ (*<*) by (rule order_antisym) auto (*>*)
+
+lemma (in Semilat) trans_r [trans, intro?]: "\<lbrakk>x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z\<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
+ (*<*) by (auto intro: order_trans) (*>*)
+
+lemma (in Semilat) ub1 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
+ (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)
+
+lemma (in Semilat) ub2 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
+ (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)
+
+lemma (in Semilat) lub [simp, intro?]:
+ "\<lbrakk> x \<sqsubseteq>\<^sub>r z; y \<sqsubseteq>\<^sub>r z; x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z";
+ (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)
+
+lemma (in Semilat) plus_le_conv [simp]:
+ "\<lbrakk> x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> (x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z) = (x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z)"
+ (*<*) by (blast intro: ub1 ub2 lub order_trans) (*>*)
+
+lemma (in Semilat) le_iff_plus_unchanged: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> (x \<sqsubseteq>\<^sub>r y) = (x \<squnion>\<^sub>f y = y)"
+(*<*)
+apply (rule iffI)
+ apply (blast intro: antisym_r refl_r lub ub2)
+apply (erule subst)
+apply simp
+done
+(*>*)
+
+lemma (in Semilat) le_iff_plus_unchanged2: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> (x \<sqsubseteq>\<^sub>r y) = (y \<squnion>\<^sub>f x = y)"
+(*<*)
+apply (rule iffI)
+ apply (blast intro: order_antisym lub order_refl ub1)
+apply (erule subst)
+apply simp
+done
+(*>*)
+
+
+lemma (in Semilat) plus_assoc [simp]:
+ assumes a: "a \<in> A" and b: "b \<in> A" and c: "c \<in> A"
+ shows "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) = a \<squnion>\<^sub>f b \<squnion>\<^sub>f c"
+(*<*)
+proof -
+ from a b have ab: "a \<squnion>\<^sub>f b \<in> A" ..
+ from this c have abc: "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<in> A" ..
+ from b c have bc: "b \<squnion>\<^sub>f c \<in> A" ..
+ from a this have abc': "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<in> A" ..
+
+ show ?thesis
+ proof
+ show "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c"
+ proof -
+ from a b have "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
+ also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
+ finally have "a<": "a \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
+ from a b have "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
+ also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
+ finally have "b<": "b \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
+ from ab c have "c<": "c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
+ from "b<" "c<" b c abc have "b \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
+ from "a<" this a bc abc show ?thesis ..
+ qed
+ show "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)"
+ proof -
+ from b c have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
+ also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
+ finally have "b<": "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
+ from b c have "c \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
+ also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
+ finally have "c<": "c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
+ from a bc have "a<": "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
+ from "a<" "b<" a b abc' have "a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
+ from this "c<" ab c abc' show ?thesis ..
+ qed
+ qed
+qed
+(*>*)
+
+lemma (in Semilat) plus_com_lemma:
+ "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a"
+(*<*)
+proof -
+ assume a: "a \<in> A" and b: "b \<in> A"
+ from b a have "a \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
+ moreover from b a have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
+ moreover note a b
+ moreover from b a have "b \<squnion>\<^sub>f a \<in> A" ..
+ ultimately show ?thesis ..
+qed
+(*>*)
+
+lemma (in Semilat) plus_commutative:
+ "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b = b \<squnion>\<^sub>f a"
+ (*<*) by(blast intro: order_antisym plus_com_lemma) (*>*)
+
+lemma is_lubD:
+ "is_lub r x y u \<Longrightarrow> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z) \<in> r)"
+ (*<*) by (simp add: is_lub_def) (*>*)
+
+lemma is_ubI:
+ "\<lbrakk> (x,u) \<in> r; (y,u) \<in> r \<rbrakk> \<Longrightarrow> is_ub r x y u"
+ (*<*) by (simp add: is_ub_def) (*>*)
+
+lemma is_ubD:
+ "is_ub r x y u \<Longrightarrow> (x,u) \<in> r \<and> (y,u) \<in> r"
+ (*<*) by (simp add: is_ub_def) (*>*)
+
+
+lemma is_lub_bigger1 [iff]:
+ "is_lub (r^* ) x y y = ((x,y)\<in>r^* )"
+(*<*)
+apply (unfold is_lub_def is_ub_def)
+apply blast
+done
+(*>*)
+
+lemma is_lub_bigger2 [iff]:
+ "is_lub (r^* ) x y x = ((y,x)\<in>r^* )"
+(*<*)
+apply (unfold is_lub_def is_ub_def)
+apply blast
+done
+(*>*)
+
+lemma extend_lub:
+ "\<lbrakk> single_valued r; is_lub (r^* ) x y u; (x',x) \<in> r \<rbrakk>
+ \<Longrightarrow> EX v. is_lub (r^* ) x' y v"
+(*<*)
+apply (unfold is_lub_def is_ub_def)
+apply (case_tac "(y,x) \<in> r^*")
+ apply (case_tac "(y,x') \<in> r^*")
+ apply blast
+ apply (blast elim: converse_rtranclE dest: single_valuedD)
+apply (rule exI)
+apply (rule conjI)
+ apply (blast intro: converse_rtrancl_into_rtrancl dest: single_valuedD)
+apply (blast intro: rtrancl_into_rtrancl converse_rtrancl_into_rtrancl
+ elim: converse_rtranclE dest: single_valuedD)
+done
+(*>*)
+
+lemma single_valued_has_lubs [rule_format]:
+ "\<lbrakk> single_valued r; (x,u) \<in> r^* \<rbrakk> \<Longrightarrow> (\<forall>y. (y,u) \<in> r^* \<longrightarrow>
+ (EX z. is_lub (r^* ) x y z))"
+(*<*)
+apply (erule converse_rtrancl_induct)
+ apply clarify
+ apply (erule converse_rtrancl_induct)
+ apply blast
+ apply (blast intro: converse_rtrancl_into_rtrancl)
+apply (blast intro: extend_lub)
+done
+(*>*)
+
+lemma some_lub_conv:
+ "\<lbrakk> acyclic r; is_lub (r^* ) x y u \<rbrakk> \<Longrightarrow> some_lub (r^* ) x y = u"
+(*<*)
+apply (unfold some_lub_def is_lub_def)
+apply (rule someI2)
+ apply assumption
+apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl)
+done
+(*>*)
+
+lemma is_lub_some_lub:
+ "\<lbrakk> single_valued r; acyclic r; (x,u)\<in>r^*; (y,u)\<in>r^* \<rbrakk>
+ \<Longrightarrow> is_lub (r^* ) x y (some_lub (r^* ) x y)";
+ (*<*) by (fastsimp dest: single_valued_has_lubs simp add: some_lub_conv) (*>*)
+
+subsection{*An executable lub-finder*}
+
+constdefs
+ exec_lub :: "('a * 'a) set \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a binop"
+"exec_lub r f x y \<equiv> while (\<lambda>z. (x,z) \<notin> r\<^sup>*) f y"
+
+lemma exec_lub_refl: "exec_lub r f T T = T"
+by (simp add: exec_lub_def while_unfold)
+
+lemma acyclic_single_valued_finite:
+ "\<lbrakk>acyclic r; single_valued r; (x,y) \<in> r\<^sup>*\<rbrakk>
+ \<Longrightarrow> finite (r \<inter> {a. (x, a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})"
+(*<*)
+apply(erule converse_rtrancl_induct)
+ apply(rule_tac B = "{}" in finite_subset)
+ apply(simp only:acyclic_def)
+ apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
+ apply simp
+apply(rename_tac x x')
+apply(subgoal_tac "r \<inter> {a. (x,a) \<in> r\<^sup>*} \<times> {b. (b,y) \<in> r\<^sup>*} =
+ insert (x,x') (r \<inter> {a. (x', a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})")
+ apply simp
+apply(blast intro:converse_rtrancl_into_rtrancl
+ elim:converse_rtranclE dest:single_valuedD)
+done
+(*>*)
+
+
+lemma exec_lub_conv:
+ "\<lbrakk> acyclic r; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y; is_lub (r\<^sup>*) x y u \<rbrakk> \<Longrightarrow>
+ exec_lub r f x y = u";
+(*<*)
+apply(unfold exec_lub_def)
+apply(rule_tac P = "\<lambda>z. (y,z) \<in> r\<^sup>* \<and> (z,u) \<in> r\<^sup>*" and
+ r = "(r \<inter> {(a,b). (y,a) \<in> r\<^sup>* \<and> (b,u) \<in> r\<^sup>*})^-1" in while_rule)
+ apply(blast dest: is_lubD is_ubD)
+ apply(erule conjE)
+ apply(erule_tac z = u in converse_rtranclE)
+ apply(blast dest: is_lubD is_ubD)
+ apply(blast dest:rtrancl_into_rtrancl)
+ apply(rename_tac s)
+ apply(subgoal_tac "is_ub (r\<^sup>*) x y s")
+ prefer 2; apply(simp add:is_ub_def)
+ apply(subgoal_tac "(u, s) \<in> r\<^sup>*")
+ prefer 2; apply(blast dest:is_lubD)
+ apply(erule converse_rtranclE)
+ apply blast
+ apply(simp only:acyclic_def)
+ apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
+ apply(rule finite_acyclic_wf)
+ apply simp
+ apply(erule acyclic_single_valued_finite)
+ apply(blast intro:single_valuedI)
+ apply(simp add:is_lub_def is_ub_def)
+ apply simp
+ apply(erule acyclic_subset)
+ apply blast
+apply simp
+apply(erule conjE)
+apply(erule_tac z = u in converse_rtranclE)
+ apply(blast dest: is_lubD is_ubD)
+apply(blast dest:rtrancl_into_rtrancl)
+done
+(*>*)
+
+lemma is_lub_exec_lub:
+ "\<lbrakk> single_valued r; acyclic r; (x,u):r^*; (y,u):r^*; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y \<rbrakk>
+ \<Longrightarrow> is_lub (r^* ) x y (exec_lub r f x y)"
+ (*<*) by (fastsimp dest: single_valued_has_lubs simp add: exec_lub_conv) (*>*)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/SemilatAlg.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,186 @@
+(* Title: HOL/MicroJava/BV/SemilatAlg.thy
+ Author: Gerwin Klein
+ Copyright 2002 Technische Universitaet Muenchen
+*)
+
+header {* \isaheader{More on Semilattices} *}
+
+theory SemilatAlg
+imports Typing_Framework Product
+begin
+
+constdefs
+ lesubstep_type :: "(nat \<times> 's) list \<Rightarrow> 's ord \<Rightarrow> (nat \<times> 's) list \<Rightarrow> bool"
+ ("(_ /<=|_| _)" [50, 0, 51] 50)
+ "x <=|r| y \<equiv> \<forall>(p,s) \<in> set x. \<exists>s'. (p,s') \<in> set y \<and> s <=_r s'"
+
+consts
+ "@plusplussub" :: "'a list \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" ("(_ /++'__ _)" [65, 1000, 66] 65)
+primrec
+ "[] ++_f y = y"
+ "(x#xs) ++_f y = xs ++_f (x +_f y)"
+
+constdefs
+ bounded :: "'s step_type \<Rightarrow> nat \<Rightarrow> bool"
+"bounded step n == !p<n. !s. !(q,t):set(step p s). q<n"
+
+ pres_type :: "'s step_type \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
+"pres_type step n A == \<forall>s\<in>A. \<forall>p<n. \<forall>(q,s')\<in>set (step p s). s' \<in> A"
+
+ mono :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
+"mono r step n A ==
+ \<forall>s p t. s \<in> A \<and> p < n \<and> s <=_r t \<longrightarrow> step p s <=|r| step p t"
+
+
+lemma pres_typeD:
+ "\<lbrakk> pres_type step n A; s\<in>A; p<n; (q,s')\<in>set (step p s) \<rbrakk> \<Longrightarrow> s' \<in> A"
+ by (unfold pres_type_def, blast)
+
+lemma monoD:
+ "\<lbrakk> mono r step n A; p < n; s\<in>A; s <=_r t \<rbrakk> \<Longrightarrow> step p s <=|r| step p t"
+ by (unfold mono_def, blast)
+
+lemma boundedD:
+ "\<lbrakk> bounded step n; p < n; (q,t) : set (step p xs) \<rbrakk> \<Longrightarrow> q < n"
+ by (unfold bounded_def, blast)
+
+lemma lesubstep_type_refl [simp, intro]:
+ "(\<And>x. x <=_r x) \<Longrightarrow> x <=|r| x"
+ by (unfold lesubstep_type_def) auto
+
+lemma lesub_step_typeD:
+ "a <=|r| b \<Longrightarrow> (x,y) \<in> set a \<Longrightarrow> \<exists>y'. (x, y') \<in> set b \<and> y <=_r y'"
+ by (unfold lesubstep_type_def) blast
+
+
+lemma list_update_le_listI [rule_format]:
+ "set xs <= A \<longrightarrow> set ys <= A \<longrightarrow> xs <=[r] ys \<longrightarrow> p < size xs \<longrightarrow>
+ x <=_r ys!p \<longrightarrow> semilat(A,r,f) \<longrightarrow> x\<in>A \<longrightarrow>
+ xs[p := x +_f xs!p] <=[r] ys"
+ apply (unfold Listn.le_def lesub_def semilat_def)
+ apply (simp add: list_all2_conv_all_nth nth_list_update)
+ done
+
+
+lemma plusplus_closed: assumes "semilat (A, r, f)" shows
+ "\<And>y. \<lbrakk> set x \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> x ++_f y \<in> A" (is "PROP ?P")
+proof -
+ interpret Semilat A r f using assms by (rule Semilat.intro)
+ show "PROP ?P" proof (induct x)
+ show "\<And>y. y \<in> A \<Longrightarrow> [] ++_f y \<in> A" by simp
+ fix y x xs
+ assume y: "y \<in> A" and xs: "set (x#xs) \<subseteq> A"
+ assume IH: "\<And>y. \<lbrakk> set xs \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> xs ++_f y \<in> A"
+ from xs obtain x: "x \<in> A" and xs': "set xs \<subseteq> A" by simp
+ from x y have "(x +_f y) \<in> A" ..
+ with xs' have "xs ++_f (x +_f y) \<in> A" by (rule IH)
+ thus "(x#xs) ++_f y \<in> A" by simp
+ qed
+qed
+
+lemma (in Semilat) pp_ub2:
+ "\<And>y. \<lbrakk> set x \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> y <=_r x ++_f y"
+proof (induct x)
+ from semilat show "\<And>y. y <=_r [] ++_f y" by simp
+
+ fix y a l
+ assume y: "y \<in> A"
+ assume "set (a#l) \<subseteq> A"
+ then obtain a: "a \<in> A" and x: "set l \<subseteq> A" by simp
+ assume "\<And>y. \<lbrakk>set l \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> y <=_r l ++_f y"
+ hence IH: "\<And>y. y \<in> A \<Longrightarrow> y <=_r l ++_f y" using x .
+
+ from a y have "y <=_r a +_f y" ..
+ also from a y have "a +_f y \<in> A" ..
+ hence "(a +_f y) <=_r l ++_f (a +_f y)" by (rule IH)
+ finally have "y <=_r l ++_f (a +_f y)" .
+ thus "y <=_r (a#l) ++_f y" by simp
+qed
+
+
+lemma (in Semilat) pp_ub1:
+shows "\<And>y. \<lbrakk>set ls \<subseteq> A; y \<in> A; x \<in> set ls\<rbrakk> \<Longrightarrow> x <=_r ls ++_f y"
+proof (induct ls)
+ show "\<And>y. x \<in> set [] \<Longrightarrow> x <=_r [] ++_f y" by simp
+
+ fix y s ls
+ assume "set (s#ls) \<subseteq> A"
+ then obtain s: "s \<in> A" and ls: "set ls \<subseteq> A" by simp
+ assume y: "y \<in> A"
+
+ assume
+ "\<And>y. \<lbrakk>set ls \<subseteq> A; y \<in> A; x \<in> set ls\<rbrakk> \<Longrightarrow> x <=_r ls ++_f y"
+ hence IH: "\<And>y. x \<in> set ls \<Longrightarrow> y \<in> A \<Longrightarrow> x <=_r ls ++_f y" using ls .
+
+ assume "x \<in> set (s#ls)"
+ then obtain xls: "x = s \<or> x \<in> set ls" by simp
+ moreover {
+ assume xs: "x = s"
+ from s y have "s <=_r s +_f y" ..
+ also from s y have "s +_f y \<in> A" ..
+ with ls have "(s +_f y) <=_r ls ++_f (s +_f y)" by (rule pp_ub2)
+ finally have "s <=_r ls ++_f (s +_f y)" .
+ with xs have "x <=_r ls ++_f (s +_f y)" by simp
+ }
+ moreover {
+ assume "x \<in> set ls"
+ hence "\<And>y. y \<in> A \<Longrightarrow> x <=_r ls ++_f y" by (rule IH)
+ moreover from s y have "s +_f y \<in> A" ..
+ ultimately have "x <=_r ls ++_f (s +_f y)" .
+ }
+ ultimately
+ have "x <=_r ls ++_f (s +_f y)" by blast
+ thus "x <=_r (s#ls) ++_f y" by simp
+qed
+
+
+lemma (in Semilat) pp_lub:
+ assumes z: "z \<in> A"
+ shows
+ "\<And>y. y \<in> A \<Longrightarrow> set xs \<subseteq> A \<Longrightarrow> \<forall>x \<in> set xs. x <=_r z \<Longrightarrow> y <=_r z \<Longrightarrow> xs ++_f y <=_r z"
+proof (induct xs)
+ fix y assume "y <=_r z" thus "[] ++_f y <=_r z" by simp
+next
+ fix y l ls assume y: "y \<in> A" and "set (l#ls) \<subseteq> A"
+ then obtain l: "l \<in> A" and ls: "set ls \<subseteq> A" by auto
+ assume "\<forall>x \<in> set (l#ls). x <=_r z"
+ then obtain lz: "l <=_r z" and lsz: "\<forall>x \<in> set ls. x <=_r z" by auto
+ assume "y <=_r z" with lz have "l +_f y <=_r z" using l y z ..
+ moreover
+ from l y have "l +_f y \<in> A" ..
+ moreover
+ assume "\<And>y. y \<in> A \<Longrightarrow> set ls \<subseteq> A \<Longrightarrow> \<forall>x \<in> set ls. x <=_r z \<Longrightarrow> y <=_r z
+ \<Longrightarrow> ls ++_f y <=_r z"
+ ultimately
+ have "ls ++_f (l +_f y) <=_r z" using ls lsz by -
+ thus "(l#ls) ++_f y <=_r z" by simp
+qed
+
+
+lemma ub1':
+ assumes "semilat (A, r, f)"
+ shows "\<lbrakk>\<forall>(p,s) \<in> set S. s \<in> A; y \<in> A; (a,b) \<in> set S\<rbrakk>
+ \<Longrightarrow> b <=_r map snd [(p', t')\<leftarrow>S. p' = a] ++_f y"
+proof -
+ interpret Semilat A r f using assms by (rule Semilat.intro)
+
+ let "b <=_r ?map ++_f y" = ?thesis
+
+ assume "y \<in> A"
+ moreover
+ assume "\<forall>(p,s) \<in> set S. s \<in> A"
+ hence "set ?map \<subseteq> A" by auto
+ moreover
+ assume "(a,b) \<in> set S"
+ hence "b \<in> set ?map" by (induct S, auto)
+ ultimately
+ show ?thesis by - (rule pp_ub1)
+qed
+
+
+lemma plusplus_empty:
+ "\<forall>s'. (q, s') \<in> set S \<longrightarrow> s' +_f ss ! q = ss ! q \<Longrightarrow>
+ (map snd [(p', t') \<leftarrow> S. p' = q] ++_f ss ! q) = ss ! q"
+ by (induct S) auto
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/Semilattices.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,14 @@
+(* Title: HOL/MicroJava/BV/Semilat.thy
+ Author: Gerwin Klein
+ Copyright 2003 TUM
+*)
+
+header {* Semilattices *}
+
+(*<*)
+theory Semilattices
+imports Err Opt Product Listn
+begin
+
+end
+(*>*)
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/Typing_Framework.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,36 @@
+(* Title: HOL/MicroJava/BV/Typing_Framework.thy
+ Author: Tobias Nipkow
+ Copyright 2000 TUM
+*)
+
+header {* \isaheader{Typing and Dataflow Analysis Framework} *}
+
+theory Typing_Framework
+imports Listn
+begin
+
+text {*
+ The relationship between dataflow analysis and a welltyped-instruction predicate.
+*}
+types
+ 's step_type = "nat \<Rightarrow> 's \<Rightarrow> (nat \<times> 's) list"
+
+constdefs
+ stable :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> nat \<Rightarrow> bool"
+"stable r step ss p == !(q,s'):set(step p (ss!p)). s' <=_r ss!q"
+
+ stables :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> bool"
+"stables r step ss == !p<size ss. stable r step ss p"
+
+ wt_step ::
+"'s ord \<Rightarrow> 's \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> bool"
+"wt_step r T step ts ==
+ !p<size(ts). ts!p ~= T & stable r step ts p"
+
+ is_bcv :: "'s ord \<Rightarrow> 's \<Rightarrow> 's step_type
+ \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> ('s list \<Rightarrow> 's list) \<Rightarrow> bool"
+"is_bcv r T step n A bcv == !ss : list n A.
+ (!p<n. (bcv ss)!p ~= T) =
+ (? ts: list n A. ss <=[r] ts & wt_step r T step ts)"
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/MicroJava/DFA/Typing_Framework_err.thy Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,253 @@
+(* Title: HOL/MicroJava/BV/Typing_Framework_err.thy
+ Author: Gerwin Klein
+ Copyright 2000 TUM
+*)
+
+header {* \isaheader{Lifting the Typing Framework to err, app, and eff} *}
+
+theory Typing_Framework_err
+imports Typing_Framework SemilatAlg
+begin
+
+constdefs
+
+wt_err_step :: "'s ord \<Rightarrow> 's err step_type \<Rightarrow> 's err list \<Rightarrow> bool"
+"wt_err_step r step ts \<equiv> wt_step (Err.le r) Err step ts"
+
+wt_app_eff :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> bool"
+"wt_app_eff r app step ts \<equiv>
+ \<forall>p < size ts. app p (ts!p) \<and> (\<forall>(q,t) \<in> set (step p (ts!p)). t <=_r ts!q)"
+
+map_snd :: "('b \<Rightarrow> 'c) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'c) list"
+"map_snd f \<equiv> map (\<lambda>(x,y). (x, f y))"
+
+error :: "nat \<Rightarrow> (nat \<times> 'a err) list"
+"error n \<equiv> map (\<lambda>x. (x,Err)) [0..<n]"
+
+err_step :: "nat \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's err step_type"
+"err_step n app step p t \<equiv>
+ case t of
+ Err \<Rightarrow> error n
+ | OK t' \<Rightarrow> if app p t' then map_snd OK (step p t') else error n"
+
+app_mono :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
+"app_mono r app n A \<equiv>
+ \<forall>s p t. s \<in> A \<and> p < n \<and> s <=_r t \<longrightarrow> app p t \<longrightarrow> app p s"
+
+
+lemmas err_step_defs = err_step_def map_snd_def error_def
+
+
+lemma bounded_err_stepD:
+ "bounded (err_step n app step) n \<Longrightarrow>
+ p < n \<Longrightarrow> app p a \<Longrightarrow> (q,b) \<in> set (step p a) \<Longrightarrow>
+ q < n"
+ apply (simp add: bounded_def err_step_def)
+ apply (erule allE, erule impE, assumption)
+ apply (erule_tac x = "OK a" in allE, drule bspec)
+ apply (simp add: map_snd_def)
+ apply fast
+ apply simp
+ done
+
+
+lemma in_map_sndD: "(a,b) \<in> set (map_snd f xs) \<Longrightarrow> \<exists>b'. (a,b') \<in> set xs"
+ apply (induct xs)
+ apply (auto simp add: map_snd_def)
+ done
+
+
+lemma bounded_err_stepI:
+ "\<forall>p. p < n \<longrightarrow> (\<forall>s. ap p s \<longrightarrow> (\<forall>(q,s') \<in> set (step p s). q < n))
+ \<Longrightarrow> bounded (err_step n ap step) n"
+apply (clarsimp simp: bounded_def err_step_def split: err.splits)
+apply (simp add: error_def image_def)
+apply (blast dest: in_map_sndD)
+done
+
+
+lemma bounded_lift:
+ "bounded step n \<Longrightarrow> bounded (err_step n app step) n"
+ apply (unfold bounded_def err_step_def error_def)
+ apply clarify
+ apply (erule allE, erule impE, assumption)
+ apply (case_tac s)
+ apply (auto simp add: map_snd_def split: split_if_asm)
+ done
+
+
+lemma le_list_map_OK [simp]:
+ "\<And>b. map OK a <=[Err.le r] map OK b = (a <=[r] b)"
+ apply (induct a)
+ apply simp
+ apply simp
+ apply (case_tac b)
+ apply simp
+ apply simp
+ done
+
+
+lemma map_snd_lessI:
+ "x <=|r| y \<Longrightarrow> map_snd OK x <=|Err.le r| map_snd OK y"
+ apply (induct x)
+ apply (unfold lesubstep_type_def map_snd_def)
+ apply auto
+ done
+
+
+lemma mono_lift:
+ "order r \<Longrightarrow> app_mono r app n A \<Longrightarrow> bounded (err_step n app step) n \<Longrightarrow>
+ \<forall>s p t. s \<in> A \<and> p < n \<and> s <=_r t \<longrightarrow> app p t \<longrightarrow> step p s <=|r| step p t \<Longrightarrow>
+ mono (Err.le r) (err_step n app step) n (err A)"
+apply (unfold app_mono_def mono_def err_step_def)
+apply clarify
+apply (case_tac s)
+ apply simp
+apply simp
+apply (case_tac t)
+ apply simp
+ apply clarify
+ apply (simp add: lesubstep_type_def error_def)
+ apply clarify
+ apply (drule in_map_sndD)
+ apply clarify
+ apply (drule bounded_err_stepD, assumption+)
+ apply (rule exI [of _ Err])
+ apply simp
+apply simp
+apply (erule allE, erule allE, erule allE, erule impE)
+ apply (rule conjI, assumption)
+ apply (rule conjI, assumption)
+ apply assumption
+apply (rule conjI)
+apply clarify
+apply (erule allE, erule allE, erule allE, erule impE)
+ apply (rule conjI, assumption)
+ apply (rule conjI, assumption)
+ apply assumption
+apply (erule impE, assumption)
+apply (rule map_snd_lessI, assumption)
+apply clarify
+apply (simp add: lesubstep_type_def error_def)
+apply clarify
+apply (drule in_map_sndD)
+apply clarify
+apply (drule bounded_err_stepD, assumption+)
+apply (rule exI [of _ Err])
+apply simp
+done
+
+lemma in_errorD:
+ "(x,y) \<in> set (error n) \<Longrightarrow> y = Err"
+ by (auto simp add: error_def)
+
+lemma pres_type_lift:
+ "\<forall>s\<in>A. \<forall>p. p < n \<longrightarrow> app p s \<longrightarrow> (\<forall>(q, s')\<in>set (step p s). s' \<in> A)
+ \<Longrightarrow> pres_type (err_step n app step) n (err A)"
+apply (unfold pres_type_def err_step_def)
+apply clarify
+apply (case_tac b)
+ apply simp
+apply (case_tac s)
+ apply simp
+ apply (drule in_errorD)
+ apply simp
+apply (simp add: map_snd_def split: split_if_asm)
+ apply fast
+apply (drule in_errorD)
+apply simp
+done
+
+
+
+text {*
+ There used to be a condition here that each instruction must have a
+ successor. This is not needed any more, because the definition of
+ @{term error} trivially ensures that there is a successor for
+ the critical case where @{term app} does not hold.
+*}
+lemma wt_err_imp_wt_app_eff:
+ assumes wt: "wt_err_step r (err_step (size ts) app step) ts"
+ assumes b: "bounded (err_step (size ts) app step) (size ts)"
+ shows "wt_app_eff r app step (map ok_val ts)"
+proof (unfold wt_app_eff_def, intro strip, rule conjI)
+ fix p assume "p < size (map ok_val ts)"
+ hence lp: "p < size ts" by simp
+ hence ts: "0 < size ts" by (cases p) auto
+ hence err: "(0,Err) \<in> set (error (size ts))" by (simp add: error_def)
+
+ from wt lp
+ have [intro?]: "\<And>p. p < size ts \<Longrightarrow> ts ! p \<noteq> Err"
+ by (unfold wt_err_step_def wt_step_def) simp
+
+ show app: "app p (map ok_val ts ! p)"
+ proof (rule ccontr)
+ from wt lp obtain s where
+ OKp: "ts ! p = OK s" and
+ less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
+ by (unfold wt_err_step_def wt_step_def stable_def)
+ (auto iff: not_Err_eq)
+ assume "\<not> app p (map ok_val ts ! p)"
+ with OKp lp have "\<not> app p s" by simp
+ with OKp have "err_step (size ts) app step p (ts!p) = error (size ts)"
+ by (simp add: err_step_def)
+ with err ts obtain q where
+ "(q,Err) \<in> set (err_step (size ts) app step p (ts!p))" and
+ q: "q < size ts" by auto
+ with less have "ts!q = Err" by auto
+ moreover from q have "ts!q \<noteq> Err" ..
+ ultimately show False by blast
+ qed
+
+ show "\<forall>(q,t)\<in>set(step p (map ok_val ts ! p)). t <=_r map ok_val ts ! q"
+ proof clarify
+ fix q t assume q: "(q,t) \<in> set (step p (map ok_val ts ! p))"
+
+ from wt lp q
+ obtain s where
+ OKp: "ts ! p = OK s" and
+ less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
+ by (unfold wt_err_step_def wt_step_def stable_def)
+ (auto iff: not_Err_eq)
+
+ from b lp app q have lq: "q < size ts" by (rule bounded_err_stepD)
+ hence "ts!q \<noteq> Err" ..
+ then obtain s' where OKq: "ts ! q = OK s'" by (auto iff: not_Err_eq)
+
+ from lp lq OKp OKq app less q
+ show "t <=_r map ok_val ts ! q"
+ by (auto simp add: err_step_def map_snd_def)
+ qed
+qed
+
+
+lemma wt_app_eff_imp_wt_err:
+ assumes app_eff: "wt_app_eff r app step ts"
+ assumes bounded: "bounded (err_step (size ts) app step) (size ts)"
+ shows "wt_err_step r (err_step (size ts) app step) (map OK ts)"
+proof (unfold wt_err_step_def wt_step_def, intro strip, rule conjI)
+ fix p assume "p < size (map OK ts)"
+ hence p: "p < size ts" by simp
+ thus "map OK ts ! p \<noteq> Err" by simp
+ { fix q t
+ assume q: "(q,t) \<in> set (err_step (size ts) app step p (map OK ts ! p))"
+ with p app_eff obtain
+ "app p (ts ! p)" "\<forall>(q,t) \<in> set (step p (ts!p)). t <=_r ts!q"
+ by (unfold wt_app_eff_def) blast
+ moreover
+ from q p bounded have "q < size ts"
+ by - (rule boundedD)
+ hence "map OK ts ! q = OK (ts!q)" by simp
+ moreover
+ have "p < size ts" by (rule p)
+ moreover note q
+ ultimately
+ have "t <=_(Err.le r) map OK ts ! q"
+ by (auto simp add: err_step_def map_snd_def)
+ }
+ thus "stable (Err.le r) (err_step (size ts) app step) (map OK ts) p"
+ by (unfold stable_def) blast
+qed
+
+end
+
--- a/src/HOL/MicroJava/J/Example.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/J/Example.thy Mon Nov 30 08:08:31 2009 +0100
@@ -173,19 +173,19 @@
apply (simp (no_asm))
done
-lemma not_Object_subcls [elim!]: "(subcls1 tprg)^++ Object C ==> R"
-apply (auto dest!: tranclpD subcls1D)
+lemma not_Object_subcls [elim!]: "(Object, C) \<in> (subcls1 tprg)^+ ==> R"
+apply (auto dest!: tranclD subcls1D)
done
lemma subcls_ObjectD [dest!]: "tprg\<turnstile>Object\<preceq>C C ==> C = Object"
-apply (erule rtranclp_induct)
+apply (erule rtrancl_induct)
apply auto
apply (drule subcls1D)
apply auto
done
-lemma not_Base_subcls_Ext [elim!]: "(subcls1 tprg)^++ Base Ext ==> R"
-apply (auto dest!: tranclpD subcls1D)
+lemma not_Base_subcls_Ext [elim!]: "(Base, Ext) \<in> (subcls1 tprg)^+ ==> R"
+apply (auto dest!: tranclD subcls1D)
done
lemma class_tprgD:
@@ -194,11 +194,11 @@
apply (auto split add: split_if_asm simp add: map_of_Cons)
done
-lemma not_class_subcls_class [elim!]: "(subcls1 tprg)^++ C C ==> R"
-apply (auto dest!: tranclpD subcls1D)
+lemma not_class_subcls_class [elim!]: "(C, C) \<in> (subcls1 tprg)^+ ==> R"
+apply (auto dest!: tranclD subcls1D)
apply (frule class_tprgD)
apply (auto dest!:)
-apply (drule rtranclpD)
+apply (drule rtranclD)
apply auto
done
@@ -206,7 +206,7 @@
apply (simp (no_asm) add: ObjectC_def BaseC_def ExtC_def NullPointerC_def ClassCastC_def OutOfMemoryC_def)
done
-lemmas subcls_direct = subcls1I [THEN r_into_rtranclp [where r="subcls1 G"], standard]
+lemmas subcls_direct = subcls1I [THEN r_into_rtrancl [where r="subcls1 G"], standard]
lemma Ext_subcls_Base [simp]: "tprg\<turnstile>Ext\<preceq>C Base"
apply (rule subcls_direct)
@@ -220,12 +220,12 @@
declare ty_expr_ty_exprs_wt_stmt.intros [intro!]
-lemma acyclic_subcls1': "acyclicP (subcls1 tprg)"
-apply (rule acyclicI [to_pred])
+lemma acyclic_subcls1': "acyclic (subcls1 tprg)"
+apply (rule acyclicI)
apply safe
done
-lemmas wf_subcls1' = acyclic_subcls1' [THEN finite_subcls1 [THEN finite_acyclic_wf_converse [to_pred]]]
+lemmas wf_subcls1' = acyclic_subcls1' [THEN finite_subcls1 [THEN finite_acyclic_wf_converse]]
lemmas fields_rec' = wf_subcls1' [THEN [2] fields_rec_lemma]
@@ -346,7 +346,7 @@
apply (fold ExtC_def)
apply (rule mp) defer apply (rule wf_foo_Ext)
apply (auto simp add: wf_mdecl_def)
-apply (drule rtranclpD)
+apply (drule rtranclD)
apply auto
done
--- a/src/HOL/MicroJava/J/JTypeSafe.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/J/JTypeSafe.thy Mon Nov 30 08:08:31 2009 +0100
@@ -218,7 +218,7 @@
apply( rule conjI)
apply( force elim!: NewC_conforms)
apply( rule conf_obj_AddrI)
-apply( rule_tac [2] rtranclp.rtrancl_refl)
+apply( rule_tac [2] rtrancl.rtrancl_refl)
apply( simp (no_asm))
-- "for Cast"
--- a/src/HOL/MicroJava/J/TypeRel.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/J/TypeRel.thy Mon Nov 30 08:08:31 2009 +0100
@@ -9,44 +9,47 @@
theory TypeRel imports Decl begin
-- "direct subclass, cf. 8.1.3"
-inductive
- subcls1 :: "'c prog => [cname, cname] => bool" ("_ \<turnstile> _ \<prec>C1 _" [71,71,71] 70)
+
+inductive_set
+ subcls1 :: "'c prog => (cname \<times> cname) set"
+ and subcls1' :: "'c prog => cname \<Rightarrow> cname => bool" ("_ \<turnstile> _ \<prec>C1 _" [71,71,71] 70)
for G :: "'c prog"
where
- subcls1I: "\<lbrakk>class G C = Some (D,rest); C \<noteq> Object\<rbrakk> \<Longrightarrow> G\<turnstile>C\<prec>C1D"
+ "G \<turnstile> C \<prec>C1 D \<equiv> (C, D) \<in> subcls1 G"
+ | subcls1I: "\<lbrakk>class G C = Some (D,rest); C \<noteq> Object\<rbrakk> \<Longrightarrow> G \<turnstile> C \<prec>C1 D"
abbreviation
- subcls :: "'c prog => [cname, cname] => bool" ("_ \<turnstile> _ \<preceq>C _" [71,71,71] 70)
- where "G\<turnstile>C \<preceq>C D \<equiv> (subcls1 G)^** C D"
-
+ subcls :: "'c prog => cname \<Rightarrow> cname => bool" ("_ \<turnstile> _ \<preceq>C _" [71,71,71] 70)
+ where "G \<turnstile> C \<preceq>C D \<equiv> (C, D) \<in> (subcls1 G)^*"
+
lemma subcls1D:
"G\<turnstile>C\<prec>C1D \<Longrightarrow> C \<noteq> Object \<and> (\<exists>fs ms. class G C = Some (D,fs,ms))"
apply (erule subcls1.cases)
apply auto
done
-lemma subcls1_def2:
- "subcls1 G = (\<lambda>C D. (C, D) \<in>
- (SIGMA C: {C. is_class G C} . {D. C\<noteq>Object \<and> fst (the (class G C))=D}))"
- by (auto simp add: is_class_def expand_fun_eq dest: subcls1D intro: subcls1I)
+lemma subcls1_def2:
+ "subcls1 P =
+ (SIGMA C:{C. is_class P C}. {D. C\<noteq>Object \<and> fst (the (class P C))=D})"
+ by (auto simp add: is_class_def dest: subcls1D intro: subcls1I)
-lemma finite_subcls1: "finite {(C, D). subcls1 G C D}"
+lemma finite_subcls1: "finite (subcls1 G)"
apply(simp add: subcls1_def2 del: mem_Sigma_iff)
apply(rule finite_SigmaI [OF finite_is_class])
apply(rule_tac B = "{fst (the (class G C))}" in finite_subset)
apply auto
done
-lemma subcls_is_class: "(subcls1 G)^++ C D ==> is_class G C"
+lemma subcls_is_class: "(C, D) \<in> (subcls1 G)^+ ==> is_class G C"
apply (unfold is_class_def)
-apply(erule tranclp_trans_induct)
+apply(erule trancl_trans_induct)
apply (auto dest!: subcls1D)
done
lemma subcls_is_class2 [rule_format (no_asm)]:
"G\<turnstile>C\<preceq>C D \<Longrightarrow> is_class G D \<longrightarrow> is_class G C"
apply (unfold is_class_def)
-apply (erule rtranclp_induct)
+apply (erule rtrancl_induct)
apply (drule_tac [2] subcls1D)
apply auto
done
@@ -54,48 +57,28 @@
constdefs
class_rec :: "'c prog \<Rightarrow> cname \<Rightarrow> 'a \<Rightarrow>
(cname \<Rightarrow> fdecl list \<Rightarrow> 'c mdecl list \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a"
- "class_rec G == wfrec {(C, D). (subcls1 G)^--1 C D}
+ "class_rec G == wfrec ((subcls1 G)^-1)
(\<lambda>r C t f. case class G C of
None \<Rightarrow> undefined
| Some (D,fs,ms) \<Rightarrow>
f C fs ms (if C = Object then t else r D t f))"
-lemma class_rec_lemma: "wfP ((subcls1 G)^--1) \<Longrightarrow> class G C = Some (D,fs,ms) \<Longrightarrow>
- class_rec G C t f = f C fs ms (if C=Object then t else class_rec G D t f)"
- by (simp add: class_rec_def wfrec [to_pred, where r="(subcls1 G)^--1", simplified]
- cut_apply [where r="{(C, D). subcls1 G D C}", simplified, OF subcls1I])
+lemma class_rec_lemma:
+ assumes wf: "wf ((subcls1 G)^-1)"
+ and cls: "class G C = Some (D, fs, ms)"
+ shows "class_rec G C t f = f C fs ms (if C=Object then t else class_rec G D t f)"
+proof -
+ from wf have step: "\<And>H a. wfrec ((subcls1 G)\<inverse>) H a =
+ H (cut (wfrec ((subcls1 G)\<inverse>) H) ((subcls1 G)\<inverse>) a) a"
+ by (rule wfrec)
+ have cut: "\<And>f. C \<noteq> Object \<Longrightarrow> cut f ((subcls1 G)\<inverse>) C D = f D"
+ by (rule cut_apply [where r="(subcls1 G)^-1", simplified, OF subcls1I, OF cls])
+ from cls show ?thesis by (simp add: step cut class_rec_def)
+qed
definition
- "wf_class G = wfP ((subcls1 G)^--1)"
+ "wf_class G = wf ((subcls1 G)^-1)"
-lemma class_rec_func (*[code]*):
- "class_rec G C t f = (if wf_class G then
- (case class G C
- of None \<Rightarrow> undefined
- | Some (D, fs, ms) \<Rightarrow> f C fs ms (if C = Object then t else class_rec G D t f))
- else class_rec G C t f)"
-proof (cases "wf_class G")
- case False then show ?thesis by auto
-next
- case True
- from `wf_class G` have wf: "wfP ((subcls1 G)^--1)"
- unfolding wf_class_def .
- show ?thesis
- proof (cases "class G C")
- case None
- with wf show ?thesis
- by (simp add: class_rec_def wfrec [to_pred, where r="(subcls1 G)^--1", simplified]
- cut_apply [where r="{(C, D).subcls1 G D C}", simplified, OF subcls1I])
- next
- case (Some x) show ?thesis
- proof (cases x)
- case (fields D fs ms)
- then have is_some: "class G C = Some (D, fs, ms)" using Some by simp
- note class_rec = class_rec_lemma [OF wf is_some]
- show ?thesis unfolding class_rec by (simp add: is_some)
- qed
- qed
-qed
text {* Code generator setup (FIXME!) *}
@@ -115,7 +98,7 @@
defs method_def: "method \<equiv> \<lambda>(G,C). class_rec G C empty (\<lambda>C fs ms ts.
ts ++ map_of (map (\<lambda>(s,m). (s,(C,m))) ms))"
-lemma method_rec_lemma: "[|class G C = Some (D,fs,ms); wfP ((subcls1 G)^--1)|] ==>
+lemma method_rec_lemma: "[|class G C = Some (D,fs,ms); wf ((subcls1 G)^-1)|] ==>
method (G,C) = (if C = Object then empty else method (G,D)) ++
map_of (map (\<lambda>(s,m). (s,(C,m))) ms)"
apply (unfold method_def)
@@ -129,7 +112,7 @@
defs fields_def: "fields \<equiv> \<lambda>(G,C). class_rec G C [] (\<lambda>C fs ms ts.
map (\<lambda>(fn,ft). ((fn,C),ft)) fs @ ts)"
-lemma fields_rec_lemma: "[|class G C = Some (D,fs,ms); wfP ((subcls1 G)^--1)|] ==>
+lemma fields_rec_lemma: "[|class G C = Some (D,fs,ms); wf ((subcls1 G)^-1)|] ==>
fields (G,C) =
map (\<lambda>(fn,ft). ((fn,C),ft)) fs @ (if C = Object then [] else fields (G,D))"
apply (unfold fields_def)
--- a/src/HOL/MicroJava/J/WellForm.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/MicroJava/J/WellForm.thy Mon Nov 30 08:08:31 2009 +0100
@@ -5,7 +5,9 @@
header {* \isaheader{Well-formedness of Java programs} *}
-theory WellForm imports TypeRel SystemClasses begin
+theory WellForm
+imports TypeRel SystemClasses
+begin
text {*
for static checks on expressions and statements, see WellType.
@@ -133,13 +135,13 @@
apply (auto intro!: map_of_SomeI)
done
-lemma subcls1_wfD: "[|G\<turnstile>C\<prec>C1D; ws_prog G|] ==> D \<noteq> C \<and> \<not> (subcls1 G)^++ D C"
-apply( frule tranclp.r_into_trancl [where r="subcls1 G"])
+lemma subcls1_wfD: "[|G\<turnstile>C\<prec>C1D; ws_prog G|] ==> D \<noteq> C \<and> (D, C) \<notin> (subcls1 G)^+"
+apply( frule trancl.r_into_trancl [where r="subcls1 G"])
apply( drule subcls1D)
apply(clarify)
apply( drule (1) class_wf_struct)
apply( unfold ws_cdecl_def)
-apply(force simp add: reflcl_tranclp [THEN sym] simp del: reflcl_tranclp)
+apply(force simp add: reflcl_trancl [THEN sym] simp del: reflcl_trancl)
done
lemma wf_cdecl_supD:
@@ -148,47 +150,50 @@
apply (auto split add: option.split_asm)
done
-lemma subcls_asym: "[|ws_prog G; (subcls1 G)^++ C D|] ==> \<not> (subcls1 G)^++ D C"
-apply(erule tranclp.cases)
+lemma subcls_asym: "[|ws_prog G; (C, D) \<in> (subcls1 G)^+|] ==> (D, C) \<notin> (subcls1 G)^+"
+apply(erule trancl.cases)
apply(fast dest!: subcls1_wfD )
-apply(fast dest!: subcls1_wfD intro: tranclp_trans)
+apply(fast dest!: subcls1_wfD intro: trancl_trans)
done
-lemma subcls_irrefl: "[|ws_prog G; (subcls1 G)^++ C D|] ==> C \<noteq> D"
-apply (erule tranclp_trans_induct)
+lemma subcls_irrefl: "[|ws_prog G; (C, D) \<in> (subcls1 G)^+|] ==> C \<noteq> D"
+apply (erule trancl_trans_induct)
apply (auto dest: subcls1_wfD subcls_asym)
done
-lemma acyclic_subcls1: "ws_prog G ==> acyclicP (subcls1 G)"
-apply (simp add: acyclic_def [to_pred])
+lemma acyclic_subcls1: "ws_prog G ==> acyclic (subcls1 G)"
+apply (simp add: acyclic_def)
apply (fast dest: subcls_irrefl)
done
-lemma wf_subcls1: "ws_prog G ==> wfP ((subcls1 G)^--1)"
-apply (rule finite_acyclic_wf [to_pred])
-apply ( subst finite_converse [to_pred])
+lemma wf_subcls1: "ws_prog G ==> wf ((subcls1 G)^-1)"
+apply (rule finite_acyclic_wf)
+apply ( subst finite_converse)
apply ( rule finite_subcls1)
-apply (subst acyclic_converse [to_pred])
+apply (subst acyclic_converse)
apply (erule acyclic_subcls1)
done
-
-lemma subcls_induct:
-"[|wf_prog wf_mb G; !!C. \<forall>D. (subcls1 G)^++ C D --> P D ==> P C|] ==> P C"
+lemma subcls_induct_struct:
+"[|ws_prog G; !!C. \<forall>D. (C, D) \<in> (subcls1 G)^+ --> P D ==> P C|] ==> P C"
(is "?A \<Longrightarrow> PROP ?P \<Longrightarrow> _")
proof -
assume p: "PROP ?P"
assume ?A thus ?thesis apply -
-apply (drule wf_prog_ws_prog)
apply(drule wf_subcls1)
-apply(drule wfP_trancl)
-apply(simp only: tranclp_converse)
-apply(erule_tac a = C in wfP_induct)
+apply(drule wf_trancl)
+apply(simp only: trancl_converse)
+apply(erule_tac a = C in wf_induct)
apply(rule p)
apply(auto)
done
qed
+lemma subcls_induct:
+"[|wf_prog wf_mb G; !!C. \<forall>D. (C, D) \<in> (subcls1 G)^+ --> P D ==> P C|] ==> P C"
+(is "?A \<Longrightarrow> PROP ?P \<Longrightarrow> _")
+by (fact subcls_induct_struct [OF wf_prog_ws_prog])
+
lemma subcls1_induct:
"[|is_class G C; wf_prog wf_mb G; P Object;
!!C D fs ms. [|C \<noteq> Object; is_class G C; class G C = Some (D,fs,ms) \<and>
@@ -223,22 +228,6 @@
done
qed
-lemma subcls_induct_struct:
-"[|ws_prog G; !!C. \<forall>D. (subcls1 G)^++ C D --> P D ==> P C|] ==> P C"
-(is "?A \<Longrightarrow> PROP ?P \<Longrightarrow> _")
-proof -
- assume p: "PROP ?P"
- assume ?A thus ?thesis apply -
-apply(drule wf_subcls1)
-apply(drule wfP_trancl)
-apply(simp only: tranclp_converse)
-apply(erule_tac a = C in wfP_induct)
-apply(rule p)
-apply(auto)
-done
-qed
-
-
lemma subcls1_induct_struct:
"[|is_class G C; ws_prog G; P Object;
!!C D fs ms. [|C \<noteq> Object; is_class G C; class G C = Some (D,fs,ms) \<and>
@@ -337,7 +326,7 @@
apply( simp (no_asm))
apply( erule UnE)
apply( force)
-apply( erule r_into_rtranclp [THEN rtranclp_trans])
+apply( erule r_into_rtrancl [THEN rtrancl_trans])
apply auto
done
@@ -379,9 +368,9 @@
done
lemma fields_mono_lemma [rule_format (no_asm)]:
- "[|ws_prog G; (subcls1 G)^** C' C|] ==>
+ "[|ws_prog G; (C', C) \<in> (subcls1 G)^*|] ==>
x \<in> set (fields (G,C)) --> x \<in> set (fields (G,C'))"
-apply(erule converse_rtranclp_induct)
+apply(erule converse_rtrancl_induct)
apply( safe dest!: subcls1D)
apply(subst fields_rec)
apply( auto)
@@ -400,10 +389,10 @@
"[|field (G,C) fn = Some (fd, fT); G\<turnstile>D\<preceq>C C; ws_prog G|]==>
map_of (fields (G,D)) (fn, fd) = Some fT"
apply (drule field_fields)
-apply (drule rtranclpD)
+apply (drule rtranclD)
apply safe
apply (frule subcls_is_class)
-apply (drule tranclp_into_rtranclp)
+apply (drule trancl_into_rtrancl)
apply (fast dest: fields_mono)
done
@@ -435,10 +424,10 @@
apply (frule map_of_SomeD)
apply (clarsimp simp add: wf_cdecl_def)
apply( clarify)
-apply( rule rtranclp_trans)
+apply( rule rtrancl_trans)
prefer 2
apply( assumption)
-apply( rule r_into_rtranclp)
+apply( rule r_into_rtrancl)
apply( fast intro: subcls1I)
done
@@ -471,10 +460,10 @@
apply (clarsimp simp add: ws_cdecl_def)
apply blast
apply clarify
-apply( rule rtranclp_trans)
+apply( rule rtrancl_trans)
prefer 2
apply( assumption)
-apply( rule r_into_rtranclp)
+apply( rule r_into_rtrancl)
apply( fast intro: subcls1I)
done
@@ -482,15 +471,15 @@
"[|G\<turnstile>T'\<preceq>C T; wf_prog wf_mb G|] ==>
\<forall>D rT b. method (G,T) sig = Some (D,rT ,b) -->
(\<exists>D' rT' b'. method (G,T') sig = Some (D',rT',b') \<and> G\<turnstile>D'\<preceq>C D \<and> G\<turnstile>rT'\<preceq>rT)"
-apply( drule rtranclpD)
+apply( drule rtranclD)
apply( erule disjE)
apply( fast)
apply( erule conjE)
-apply( erule tranclp_trans_induct)
+apply( erule trancl_trans_induct)
prefer 2
apply( clarify)
apply( drule spec, drule spec, drule spec, erule (1) impE)
-apply( fast elim: widen_trans rtranclp_trans)
+apply( fast elim: widen_trans rtrancl_trans)
apply( clarify)
apply( drule subcls1D)
apply( clarify)
@@ -510,7 +499,7 @@
apply( unfold wf_cdecl_def)
apply( drule map_of_SomeD)
apply (auto simp add: wf_mrT_def)
-apply (rule rtranclp_trans)
+apply (rule rtrancl_trans)
defer
apply (rule method_wf_mhead [THEN conjunct1])
apply (simp only: wf_prog_def)
--- a/src/HOL/Modelcheck/MuckeSyn.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Modelcheck/MuckeSyn.thy Mon Nov 30 08:08:31 2009 +0100
@@ -130,7 +130,7 @@
fun move_mus i state =
let val sign = Thm.theory_of_thm state;
- val (subgoal::_) = Library.drop(i-1,prems_of state);
+ val subgoal = nth (prems_of state) i;
val concl = Logic.strip_imp_concl subgoal; (* recursive mu's in prems? *)
val redex = search_mu concl;
val idx = let val t = #maxidx (rep_thm state) in
@@ -222,9 +222,9 @@
(* the interface *)
fun mc_mucke_tac defs i state =
- (case Library.drop (i - 1, Thm.prems_of state) of
- [] => no_tac state
- | subgoal :: _ =>
+ (case try (nth (Thm.prems_of state)) i of
+ NONE => no_tac state
+ | SOME subgoal =>
EVERY [
REPEAT (etac thin_rl i),
cut_facts_tac (mk_lam_defs defs) i,
--- a/src/HOL/Modelcheck/mucke_oracle.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Modelcheck/mucke_oracle.ML Mon Nov 30 08:08:31 2009 +0100
@@ -95,7 +95,7 @@
fun if_full_simp_tac sset i state =
let val sign = Thm.theory_of_thm state;
- val (subgoal::_) = Library.drop(i-1,prems_of state);
+ val subgoal = nth (prems_of state) i;
val prems = Logic.strip_imp_prems subgoal;
val concl = Logic.strip_imp_concl subgoal;
val prems = prems @ [concl];
--- a/src/HOL/Nominal/nominal_datatype.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Nominal/nominal_datatype.ML Mon Nov 30 08:08:31 2009 +0100
@@ -766,8 +766,8 @@
Sign.intern_const thy7 ("Abs_" ^ s)) new_type_names;
val recTs = get_rec_types descr'' sorts;
- val newTs' = Library.take (length new_type_names, recTs');
- val newTs = Library.take (length new_type_names, recTs);
+ val newTs' = take (length new_type_names) recTs';
+ val newTs = take (length new_type_names) recTs;
val full_new_type_names = map (Sign.full_bname thy) new_type_names;
--- a/src/HOL/Nominal/nominal_induct.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Nominal/nominal_induct.ML Mon Nov 30 08:08:31 2009 +0100
@@ -46,7 +46,7 @@
val m = length vars and n = length inst;
val _ = if m >= n + 2 then () else error "Too few variables in conclusion of rule";
val P :: x :: ys = vars;
- val zs = Library.drop (m - n - 2, ys);
+ val zs = drop (m - n - 2) ys;
in
(P, tuple_fun (map #2 avoiding) (Term.dest_Var P)) ::
(x, tuple (map Free avoiding)) ::
@@ -71,7 +71,7 @@
val p = length ps;
val ys =
if p < n then []
- else map (tune o #1) (Library.take (p - n, ps)) @ xs;
+ else map (tune o #1) (take (p - n) ps) @ xs;
in Logic.list_rename_params (ys, prem) end;
fun rename_prems prop =
let val (As, C) = Logic.strip_horn (Thm.prop_of rule)
--- a/src/HOL/Product_Type.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Product_Type.thy Mon Nov 30 08:08:31 2009 +0100
@@ -6,12 +6,10 @@
header {* Cartesian products *}
theory Product_Type
-imports Inductive
+imports Typedef Inductive Fun
uses
("Tools/split_rule.ML")
("Tools/inductive_set.ML")
- ("Tools/inductive_realizer.ML")
- ("Tools/Datatype/datatype_realizer.ML")
begin
subsection {* @{typ bool} is a datatype *}
@@ -1195,16 +1193,7 @@
val unit_eq = thm "unit_eq";
*}
-
-subsection {* Further inductive packages *}
-
-use "Tools/inductive_realizer.ML"
-setup InductiveRealizer.setup
-
use "Tools/inductive_set.ML"
setup Inductive_Set.setup
-use "Tools/Datatype/datatype_realizer.ML"
-setup DatatypeRealizer.setup
-
end
--- a/src/HOL/Set.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Set.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1556,9 +1556,6 @@
lemma imp_refl: "P --> P" ..
-lemma not_mono: "Q --> P ==> ~ P --> ~ Q"
- by iprover
-
lemma ex_mono: "(!!x. P x --> Q x) ==> (EX x. P x) --> (EX x. Q x)"
by iprover
@@ -1579,6 +1576,9 @@
lemma eq_to_mono: "a = b ==> c = d ==> b --> d ==> a --> c"
by iprover
+lemma eq_to_mono2: "a = b ==> c = d ==> ~ b --> ~ d ==> ~ a --> ~ c"
+ by iprover
+
subsubsection {* Inverse image of a function *}
@@ -1724,6 +1724,7 @@
val contra_subsetD = @{thm contra_subsetD}
val distinct_lemma = @{thm distinct_lemma}
val eq_to_mono = @{thm eq_to_mono}
+val eq_to_mono2 = @{thm eq_to_mono2}
val equalityCE = @{thm equalityCE}
val equalityD1 = @{thm equalityD1}
val equalityD2 = @{thm equalityD2}
--- a/src/HOL/Sum_Type.thy Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Sum_Type.thy Mon Nov 30 08:08:31 2009 +0100
@@ -1,5 +1,4 @@
(* Title: HOL/Sum_Type.thy
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 1992 University of Cambridge
*)
@@ -7,224 +6,186 @@
header{*The Disjoint Sum of Two Types*}
theory Sum_Type
-imports Typedef Fun
+imports Typedef Inductive Fun
begin
-text{*The representations of the two injections*}
+subsection {* Construction of the sum type and its basic abstract operations *}
-constdefs
- Inl_Rep :: "['a, 'a, 'b, bool] => bool"
- "Inl_Rep == (%a. %x y p. x=a & p)"
+definition Inl_Rep :: "'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool \<Rightarrow> bool" where
+ "Inl_Rep a x y p \<longleftrightarrow> x = a \<and> p"
- Inr_Rep :: "['b, 'a, 'b, bool] => bool"
- "Inr_Rep == (%b. %x y p. y=b & ~p)"
-
+definition Inr_Rep :: "'b \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool \<Rightarrow> bool" where
+ "Inr_Rep b x y p \<longleftrightarrow> y = b \<and> \<not> p"
global
-typedef (Sum)
- ('a, 'b) "+" (infixr "+" 10)
- = "{f. (? a. f = Inl_Rep(a::'a)) | (? b. f = Inr_Rep(b::'b))}"
+typedef (Sum) ('a, 'b) "+" (infixr "+" 10) = "{f. (\<exists>a. f = Inl_Rep (a::'a)) \<or> (\<exists>b. f = Inr_Rep (b::'b))}"
by auto
local
+lemma Inl_RepI: "Inl_Rep a \<in> Sum"
+ by (auto simp add: Sum_def)
-text{*abstract constants and syntax*}
+lemma Inr_RepI: "Inr_Rep b \<in> Sum"
+ by (auto simp add: Sum_def)
+
+lemma inj_on_Abs_Sum: "A \<subseteq> Sum \<Longrightarrow> inj_on Abs_Sum A"
+ by (rule inj_on_inverseI, rule Abs_Sum_inverse) auto
+
+lemma Inl_Rep_inject: "inj_on Inl_Rep A"
+proof (rule inj_onI)
+ show "\<And>a c. Inl_Rep a = Inl_Rep c \<Longrightarrow> a = c"
+ by (auto simp add: Inl_Rep_def expand_fun_eq)
+qed
-constdefs
- Inl :: "'a => 'a + 'b"
- "Inl == (%a. Abs_Sum(Inl_Rep(a)))"
+lemma Inr_Rep_inject: "inj_on Inr_Rep A"
+proof (rule inj_onI)
+ show "\<And>b d. Inr_Rep b = Inr_Rep d \<Longrightarrow> b = d"
+ by (auto simp add: Inr_Rep_def expand_fun_eq)
+qed
+
+lemma Inl_Rep_not_Inr_Rep: "Inl_Rep a \<noteq> Inr_Rep b"
+ by (auto simp add: Inl_Rep_def Inr_Rep_def expand_fun_eq)
+
+definition Inl :: "'a \<Rightarrow> 'a + 'b" where
+ "Inl = Abs_Sum \<circ> Inl_Rep"
+
+definition Inr :: "'b \<Rightarrow> 'a + 'b" where
+ "Inr = Abs_Sum \<circ> Inr_Rep"
+
+lemma inj_Inl [simp]: "inj_on Inl A"
+by (auto simp add: Inl_def intro!: comp_inj_on Inl_Rep_inject inj_on_Abs_Sum Inl_RepI)
- Inr :: "'b => 'a + 'b"
- "Inr == (%b. Abs_Sum(Inr_Rep(b)))"
+lemma Inl_inject: "Inl x = Inl y \<Longrightarrow> x = y"
+using inj_Inl by (rule injD)
+
+lemma inj_Inr [simp]: "inj_on Inr A"
+by (auto simp add: Inr_def intro!: comp_inj_on Inr_Rep_inject inj_on_Abs_Sum Inr_RepI)
+
+lemma Inr_inject: "Inr x = Inr y \<Longrightarrow> x = y"
+using inj_Inr by (rule injD)
+
+lemma Inl_not_Inr: "Inl a \<noteq> Inr b"
+proof -
+ from Inl_RepI [of a] Inr_RepI [of b] have "{Inl_Rep a, Inr_Rep b} \<subseteq> Sum" by auto
+ with inj_on_Abs_Sum have "inj_on Abs_Sum {Inl_Rep a, Inr_Rep b}" .
+ with Inl_Rep_not_Inr_Rep [of a b] inj_on_contraD have "Abs_Sum (Inl_Rep a) \<noteq> Abs_Sum (Inr_Rep b)" by auto
+ then show ?thesis by (simp add: Inl_def Inr_def)
+qed
- Plus :: "['a set, 'b set] => ('a + 'b) set" (infixr "<+>" 65)
- "A <+> B == (Inl`A) Un (Inr`B)"
- --{*disjoint sum for sets; the operator + is overloaded with wrong type!*}
+lemma Inr_not_Inl: "Inr b \<noteq> Inl a"
+ using Inl_not_Inr by (rule not_sym)
- Part :: "['a set, 'b => 'a] => 'a set"
- "Part A h == A Int {x. ? z. x = h(z)}"
- --{*for selecting out the components of a mutually recursive definition*}
+lemma sumE:
+ assumes "\<And>x::'a. s = Inl x \<Longrightarrow> P"
+ and "\<And>y::'b. s = Inr y \<Longrightarrow> P"
+ shows P
+proof (rule Abs_Sum_cases [of s])
+ fix f
+ assume "s = Abs_Sum f" and "f \<in> Sum"
+ with assms show P by (auto simp add: Sum_def Inl_def Inr_def)
+qed
+rep_datatype (sum) Inl Inr
+proof -
+ fix P
+ fix s :: "'a + 'b"
+ assume x: "\<And>x\<Colon>'a. P (Inl x)" and y: "\<And>y\<Colon>'b. P (Inr y)"
+ then show "P s" by (auto intro: sumE [of s])
+qed (auto dest: Inl_inject Inr_inject simp add: Inl_not_Inr)
-(** Inl_Rep and Inr_Rep: Representations of the constructors **)
+subsection {* Projections *}
-(*This counts as a non-emptiness result for admitting 'a+'b as a type*)
-lemma Inl_RepI: "Inl_Rep(a) : Sum"
-by (auto simp add: Sum_def)
-
-lemma Inr_RepI: "Inr_Rep(b) : Sum"
-by (auto simp add: Sum_def)
+lemma sum_case_KK [simp]: "sum_case (\<lambda>x. a) (\<lambda>x. a) = (\<lambda>x. a)"
+ by (rule ext) (simp split: sum.split)
-lemma inj_on_Abs_Sum: "inj_on Abs_Sum Sum"
-apply (rule inj_on_inverseI)
-apply (erule Abs_Sum_inverse)
-done
-
-subsection{*Freeness Properties for @{term Inl} and @{term Inr}*}
-
-text{*Distinctness*}
+lemma surjective_sum: "sum_case (\<lambda>x::'a. f (Inl x)) (\<lambda>y::'b. f (Inr y)) = f"
+proof
+ fix s :: "'a + 'b"
+ show "(case s of Inl (x\<Colon>'a) \<Rightarrow> f (Inl x) | Inr (y\<Colon>'b) \<Rightarrow> f (Inr y)) = f s"
+ by (cases s) simp_all
+qed
-lemma Inl_Rep_not_Inr_Rep: "Inl_Rep(a) ~= Inr_Rep(b)"
-by (auto simp add: Inl_Rep_def Inr_Rep_def expand_fun_eq)
+lemma sum_case_inject:
+ assumes a: "sum_case f1 f2 = sum_case g1 g2"
+ assumes r: "f1 = g1 \<Longrightarrow> f2 = g2 \<Longrightarrow> P"
+ shows P
+proof (rule r)
+ show "f1 = g1" proof
+ fix x :: 'a
+ from a have "sum_case f1 f2 (Inl x) = sum_case g1 g2 (Inl x)" by simp
+ then show "f1 x = g1 x" by simp
+ qed
+ show "f2 = g2" proof
+ fix y :: 'b
+ from a have "sum_case f1 f2 (Inr y) = sum_case g1 g2 (Inr y)" by simp
+ then show "f2 y = g2 y" by simp
+ qed
+qed
-lemma Inl_not_Inr [iff]: "Inl(a) ~= Inr(b)"
-apply (simp add: Inl_def Inr_def)
-apply (rule inj_on_Abs_Sum [THEN inj_on_contraD])
-apply (rule Inl_Rep_not_Inr_Rep)
-apply (rule Inl_RepI)
-apply (rule Inr_RepI)
-done
-
-lemmas Inr_not_Inl = Inl_not_Inr [THEN not_sym, standard]
-declare Inr_not_Inl [iff]
-
-lemmas Inl_neq_Inr = Inl_not_Inr [THEN notE, standard]
-lemmas Inr_neq_Inl = sym [THEN Inl_neq_Inr, standard]
-
-
-text{*Injectiveness*}
+lemma sum_case_weak_cong:
+ "s = t \<Longrightarrow> sum_case f g s = sum_case f g t"
+ -- {* Prevents simplification of @{text f} and @{text g}: much faster. *}
+ by simp
-lemma Inl_Rep_inject: "Inl_Rep(a) = Inl_Rep(c) ==> a=c"
-by (auto simp add: Inl_Rep_def expand_fun_eq)
+primrec Projl :: "'a + 'b \<Rightarrow> 'a" where
+ Projl_Inl: "Projl (Inl x) = x"
-lemma Inr_Rep_inject: "Inr_Rep(b) = Inr_Rep(d) ==> b=d"
-by (auto simp add: Inr_Rep_def expand_fun_eq)
+primrec Projr :: "'a + 'b \<Rightarrow> 'b" where
+ Projr_Inr: "Projr (Inr x) = x"
-lemma inj_Inl [simp]: "inj_on Inl A"
-apply (simp add: Inl_def)
-apply (rule inj_onI)
-apply (erule inj_on_Abs_Sum [THEN inj_onD, THEN Inl_Rep_inject])
-apply (rule Inl_RepI)
-apply (rule Inl_RepI)
-done
+primrec Suml :: "('a \<Rightarrow> 'c) \<Rightarrow> 'a + 'b \<Rightarrow> 'c" where
+ "Suml f (Inl x) = f x"
-lemmas Inl_inject = inj_Inl [THEN injD, standard]
+primrec Sumr :: "('b \<Rightarrow> 'c) \<Rightarrow> 'a + 'b \<Rightarrow> 'c" where
+ "Sumr f (Inr x) = f x"
-lemma inj_Inr [simp]: "inj_on Inr A"
-apply (simp add: Inr_def)
-apply (rule inj_onI)
-apply (erule inj_on_Abs_Sum [THEN inj_onD, THEN Inr_Rep_inject])
-apply (rule Inr_RepI)
-apply (rule Inr_RepI)
-done
-
-lemmas Inr_inject = inj_Inr [THEN injD, standard]
+lemma Suml_inject:
+ assumes "Suml f = Suml g" shows "f = g"
+proof
+ fix x :: 'a
+ let ?s = "Inl x \<Colon> 'a + 'b"
+ from assms have "Suml f ?s = Suml g ?s" by simp
+ then show "f x = g x" by simp
+qed
-lemma Inl_eq [iff]: "(Inl(x)=Inl(y)) = (x=y)"
-by (blast dest!: Inl_inject)
-
-lemma Inr_eq [iff]: "(Inr(x)=Inr(y)) = (x=y)"
-by (blast dest!: Inr_inject)
+lemma Sumr_inject:
+ assumes "Sumr f = Sumr g" shows "f = g"
+proof
+ fix x :: 'b
+ let ?s = "Inr x \<Colon> 'a + 'b"
+ from assms have "Sumr f ?s = Sumr g ?s" by simp
+ then show "f x = g x" by simp
+qed
-
-subsection{*The Disjoint Sum of Sets*}
+subsection {* The Disjoint Sum of Sets *}
-(** Introduction rules for the injections **)
+definition Plus :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a + 'b) set" (infixr "<+>" 65) where
+ "A <+> B = Inl ` A \<union> Inr ` B"
-lemma InlI [intro!]: "a : A ==> Inl(a) : A <+> B"
+lemma InlI [intro!]: "a \<in> A \<Longrightarrow> Inl a \<in> A <+> B"
by (simp add: Plus_def)
-lemma InrI [intro!]: "b : B ==> Inr(b) : A <+> B"
+lemma InrI [intro!]: "b \<in> B \<Longrightarrow> Inr b \<in> A <+> B"
by (simp add: Plus_def)
-(** Elimination rules **)
+text {* Exhaustion rule for sums, a degenerate form of induction *}
lemma PlusE [elim!]:
- "[| u: A <+> B;
- !!x. [| x:A; u=Inl(x) |] ==> P;
- !!y. [| y:B; u=Inr(y) |] ==> P
- |] ==> P"
+ "u \<in> A <+> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> u = Inl x \<Longrightarrow> P) \<Longrightarrow> (\<And>y. y \<in> B \<Longrightarrow> u = Inr y \<Longrightarrow> P) \<Longrightarrow> P"
by (auto simp add: Plus_def)
-
-
-text{*Exhaustion rule for sums, a degenerate form of induction*}
-lemma sumE:
- "[| !!x::'a. s = Inl(x) ==> P; !!y::'b. s = Inr(y) ==> P
- |] ==> P"
-apply (rule Abs_Sum_cases [of s])
-apply (auto simp add: Sum_def Inl_def Inr_def)
-done
-
+lemma Plus_eq_empty_conv [simp]: "A <+> B = {} \<longleftrightarrow> A = {} \<and> B = {}"
+by auto
lemma UNIV_Plus_UNIV [simp]: "UNIV <+> UNIV = UNIV"
-apply (rule set_ext)
-apply(rename_tac s)
-apply(rule_tac s=s in sumE)
-apply auto
-done
-
-lemma Plus_eq_empty_conv[simp]: "A <+> B = {} \<longleftrightarrow> A = {} \<and> B = {}"
-by(auto)
-
-subsection{*The @{term Part} Primitive*}
-
-lemma Part_eqI [intro]: "[| a : A; a=h(b) |] ==> a : Part A h"
-by (auto simp add: Part_def)
-
-lemmas PartI = Part_eqI [OF _ refl, standard]
-
-lemma PartE [elim!]: "[| a : Part A h; !!z. [| a : A; a=h(z) |] ==> P |] ==> P"
-by (auto simp add: Part_def)
-
-
-lemma Part_subset: "Part A h <= A"
-by (auto simp add: Part_def)
-
-lemma Part_mono: "A<=B ==> Part A h <= Part B h"
-by blast
-
-lemmas basic_monos = basic_monos Part_mono
-
-lemma PartD1: "a : Part A h ==> a : A"
-by (simp add: Part_def)
-
-lemma Part_id: "Part A (%x. x) = A"
-by blast
-
-lemma Part_Int: "Part (A Int B) h = (Part A h) Int (Part B h)"
-by blast
+proof (rule set_ext)
+ fix u :: "'a + 'b"
+ show "u \<in> UNIV <+> UNIV \<longleftrightarrow> u \<in> UNIV" by (cases u) auto
+qed
-lemma Part_Collect: "Part (A Int {x. P x}) h = (Part A h) Int {x. P x}"
-by blast
-
-
-ML
-{*
-val Inl_RepI = thm "Inl_RepI";
-val Inr_RepI = thm "Inr_RepI";
-val inj_on_Abs_Sum = thm "inj_on_Abs_Sum";
-val Inl_Rep_not_Inr_Rep = thm "Inl_Rep_not_Inr_Rep";
-val Inl_not_Inr = thm "Inl_not_Inr";
-val Inr_not_Inl = thm "Inr_not_Inl";
-val Inl_neq_Inr = thm "Inl_neq_Inr";
-val Inr_neq_Inl = thm "Inr_neq_Inl";
-val Inl_Rep_inject = thm "Inl_Rep_inject";
-val Inr_Rep_inject = thm "Inr_Rep_inject";
-val inj_Inl = thm "inj_Inl";
-val Inl_inject = thm "Inl_inject";
-val inj_Inr = thm "inj_Inr";
-val Inr_inject = thm "Inr_inject";
-val Inl_eq = thm "Inl_eq";
-val Inr_eq = thm "Inr_eq";
-val InlI = thm "InlI";
-val InrI = thm "InrI";
-val PlusE = thm "PlusE";
-val sumE = thm "sumE";
-val Part_eqI = thm "Part_eqI";
-val PartI = thm "PartI";
-val PartE = thm "PartE";
-val Part_subset = thm "Part_subset";
-val Part_mono = thm "Part_mono";
-val PartD1 = thm "PartD1";
-val Part_id = thm "Part_id";
-val Part_Int = thm "Part_Int";
-val Part_Collect = thm "Part_Collect";
-
-val basic_monos = thms "basic_monos";
-*}
+hide (open) const Suml Sumr Projl Projr
end
--- a/src/HOL/Tools/Datatype/datatype.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/Datatype/datatype.ML Mon Nov 30 08:08:31 2009 +0100
@@ -1,571 +1,19 @@
(* Title: HOL/Tools/datatype.ML
Author: Stefan Berghofer, TU Muenchen
-Datatype package for Isabelle/HOL.
+Datatype package interface for Isabelle/HOL.
*)
signature DATATYPE =
sig
- include DATATYPE_COMMON
- val add_datatype : config -> string list -> (string list * binding * mixfix *
- (binding * typ list * mixfix) list) list -> theory -> string list * theory
- val datatype_cmd : string list -> (string list * binding * mixfix *
- (binding * string list * mixfix) list) list -> theory -> theory
- val rep_datatype : config -> (string list -> Proof.context -> Proof.context)
- -> string list option -> term list -> theory -> Proof.state
- val rep_datatype_cmd : string list option -> string list -> theory -> Proof.state
- val get_info : theory -> string -> info option
- val the_info : theory -> string -> info
- val the_descr : theory -> string list
- -> descr * (string * sort) list * string list
- * string * (string list * string list) * (typ list * typ list)
- val the_spec : theory -> string -> (string * sort) list * (string * typ list) list
- val all_distincts : theory -> typ list -> thm list list
- val get_constrs : theory -> string -> (string * typ) list option
- val get_all : theory -> info Symtab.table
- val info_of_constr : theory -> string * typ -> info option
- val info_of_case : theory -> string -> info option
- val interpretation : (config -> string list -> theory -> theory) -> theory -> theory
- val make_case : Proof.context -> DatatypeCase.config -> string list -> term ->
- (term * term) list -> term * (term * (int * bool)) list
- val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option
- val read_typ: theory -> string -> (string * sort) list -> typ * (string * sort) list
- val setup: theory -> theory
-end;
-
-structure Datatype : DATATYPE =
-struct
-
-open DatatypeAux;
-
-(** theory data **)
-
-(* data management *)
-
-structure DatatypesData = Theory_Data
-(
- type T =
- {types: info Symtab.table,
- constrs: (string * info) list Symtab.table,
- cases: info Symtab.table};
-
- val empty =
- {types = Symtab.empty, constrs = Symtab.empty, cases = Symtab.empty};
- val extend = I;
- fun merge
- ({types = types1, constrs = constrs1, cases = cases1},
- {types = types2, constrs = constrs2, cases = cases2}) : T =
- {types = Symtab.merge (K true) (types1, types2),
- constrs = Symtab.join (K (AList.merge (op =) (K true))) (constrs1, constrs2),
- cases = Symtab.merge (K true) (cases1, cases2)};
-);
-
-val get_all = #types o DatatypesData.get;
-val get_info = Symtab.lookup o get_all;
-
-fun the_info thy name =
- (case get_info thy name of
- SOME info => info
- | NONE => error ("Unknown datatype " ^ quote name));
-
-fun info_of_constr thy (c, T) =
- let
- val tab = Symtab.lookup_list ((#constrs o DatatypesData.get) thy) c;
- val hint = case strip_type T of (_, Type (tyco, _)) => SOME tyco | _ => NONE;
- val default = if null tab then NONE
- else SOME (snd (Library.last_elem tab))
- (*conservative wrt. overloaded constructors*);
- in case hint
- of NONE => default
- | SOME tyco => case AList.lookup (op =) tab tyco
- of NONE => default (*permissive*)
- | SOME info => SOME info
- end;
-
-val info_of_case = Symtab.lookup o #cases o DatatypesData.get;
-
-fun register (dt_infos : (string * info) list) =
- DatatypesData.map (fn {types, constrs, cases} =>
- {types = types |> fold Symtab.update dt_infos,
- constrs = constrs |> fold (fn (constr, dtname_info) =>
- Symtab.map_default (constr, []) (cons dtname_info))
- (maps (fn (dtname, info as {descr, index, ...}) =>
- map (rpair (dtname, info) o fst)
- (#3 (the (AList.lookup op = descr index)))) dt_infos),
- cases = cases |> fold Symtab.update
- (map (fn (_, info as {case_name, ...}) => (case_name, info)) dt_infos)});
-
-
-(* complex queries *)
-
-fun the_spec thy dtco =
- let
- val info as { descr, index, sorts = raw_sorts, ... } = the_info thy dtco;
- val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr index;
- val sorts = map ((fn v => (v, (the o AList.lookup (op =) raw_sorts) v))
- o DatatypeAux.dest_DtTFree) dtys;
- val cos = map
- (fn (co, tys) => (co, map (DatatypeAux.typ_of_dtyp descr sorts) tys)) raw_cos;
- in (sorts, cos) end;
-
-fun the_descr thy (raw_tycos as raw_tyco :: _) =
- let
- val info = the_info thy raw_tyco;
- val descr = #descr info;
-
- val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr (#index info);
- val vs = map ((fn v => (v, (the o AList.lookup (op =) (#sorts info)) v))
- o dest_DtTFree) dtys;
-
- fun is_DtTFree (DtTFree _) = true
- | is_DtTFree _ = false
- val k = find_index (fn (_, (_, dTs, _)) => not (forall is_DtTFree dTs)) descr;
- val protoTs as (dataTs, _) = chop k descr
- |> (pairself o map) (fn (_, (tyco, dTs, _)) => (tyco, map (typ_of_dtyp descr vs) dTs));
-
- val tycos = map fst dataTs;
- val _ = if eq_set (op =) (tycos, raw_tycos) then ()
- else error ("Type constructors " ^ commas (map quote raw_tycos)
- ^ " do not belong exhaustively to one mutual recursive datatype");
-
- val (Ts, Us) = (pairself o map) Type protoTs;
-
- val names = map Long_Name.base_name (the_default tycos (#alt_names info));
- val (auxnames, _) = Name.make_context names
- |> fold_map (yield_singleton Name.variants o name_of_typ) Us;
- val prefix = space_implode "_" names;
-
- in (descr, vs, tycos, prefix, (names, auxnames), (Ts, Us)) end;
-
-fun all_distincts thy Ts =
- let
- fun add_tycos (Type (tyco, Ts)) = insert (op =) tyco #> fold add_tycos Ts
- | add_tycos _ = I;
- val tycos = fold add_tycos Ts [];
- in map_filter (Option.map #distinct o get_info thy) tycos end;
-
-fun get_constrs thy dtco =
- case try (the_spec thy) dtco
- of SOME (sorts, cos) =>
- let
- fun subst (v, sort) = TVar ((v, 0), sort);
- fun subst_ty (TFree v) = subst v
- | subst_ty ty = ty;
- val dty = Type (dtco, map subst sorts);
- fun mk_co (co, tys) = (co, map (Term.map_atyps subst_ty) tys ---> dty);
- in SOME (map mk_co cos) end
- | NONE => NONE;
-
-
-
-(** various auxiliary **)
-
-(* prepare datatype specifications *)
-
-fun read_typ thy str sorts =
- let
- val ctxt = ProofContext.init thy
- |> fold (Variable.declare_typ o TFree) sorts;
- val T = Syntax.read_typ ctxt str;
- in (T, Term.add_tfreesT T sorts) end;
-
-fun cert_typ sign raw_T sorts =
- let
- val T = Type.no_tvars (Sign.certify_typ sign raw_T)
- handle TYPE (msg, _, _) => error msg;
- val sorts' = Term.add_tfreesT T sorts;
- val _ =
- case duplicates (op =) (map fst sorts') of
- [] => ()
- | dups => error ("Inconsistent sort constraints for " ^ commas dups)
- in (T, sorts') end;
-
-
-(* case names *)
-
-local
-
-fun dt_recs (DtTFree _) = []
- | dt_recs (DtType (_, dts)) = maps dt_recs dts
- | dt_recs (DtRec i) = [i];
-
-fun dt_cases (descr: descr) (_, args, constrs) =
- let
- fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i)));
- val bnames = map the_bname (distinct (op =) (maps dt_recs args));
- in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
-
-fun induct_cases descr =
- DatatypeProp.indexify_names (maps (dt_cases descr) (map #2 descr));
-
-fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i));
-
-in
-
-fun mk_case_names_induct descr = Rule_Cases.case_names (induct_cases descr);
-
-fun mk_case_names_exhausts descr new =
- map (Rule_Cases.case_names o exhaust_cases descr o #1)
- (filter (fn ((_, (name, _, _))) => member (op =) new name) descr);
-
+ include DATATYPE_DATA
+ include DATATYPE_REP_PROOFS
end;
-
-(* translation rules for case *)
-
-fun make_case ctxt = DatatypeCase.make_case
- (info_of_constr (ProofContext.theory_of ctxt)) ctxt;
-
-fun strip_case ctxt = DatatypeCase.strip_case
- (info_of_case (ProofContext.theory_of ctxt));
-
-fun add_case_tr' case_names thy =
- Sign.add_advanced_trfuns ([], [],
- map (fn case_name =>
- let val case_name' = Sign.const_syntax_name thy case_name
- in (case_name', DatatypeCase.case_tr' info_of_case case_name')
- end) case_names, []) thy;
-
-val trfun_setup =
- Sign.add_advanced_trfuns ([],
- [("_case_syntax", DatatypeCase.case_tr true info_of_constr)],
- [], []);
-
-
-
-(** document antiquotation **)
-
-val _ = ThyOutput.antiquotation "datatype" Args.tyname
- (fn {source = src, context = ctxt, ...} => fn dtco =>
- let
- val thy = ProofContext.theory_of ctxt;
- val (vs, cos) = the_spec thy dtco;
- val ty = Type (dtco, map TFree vs);
- fun pretty_typ_bracket (ty as Type (_, _ :: _)) =
- Pretty.enclose "(" ")" [Syntax.pretty_typ ctxt ty]
- | pretty_typ_bracket ty =
- Syntax.pretty_typ ctxt ty;
- fun pretty_constr (co, tys) =
- (Pretty.block o Pretty.breaks)
- (Syntax.pretty_term ctxt (Const (co, tys ---> ty)) ::
- map pretty_typ_bracket tys);
- val pretty_datatype =
- Pretty.block
- (Pretty.command "datatype" :: Pretty.brk 1 ::
- Syntax.pretty_typ ctxt ty ::
- Pretty.str " =" :: Pretty.brk 1 ::
- flat (separate [Pretty.brk 1, Pretty.str "| "]
- (map (single o pretty_constr) cos)));
- in ThyOutput.output (ThyOutput.maybe_pretty_source (K pretty_datatype) src [()]) end);
-
-
-
-(** abstract theory extensions relative to a datatype characterisation **)
-
-structure Datatype_Interpretation = Interpretation
- (type T = config * string list val eq: T * T -> bool = eq_snd op =);
-fun interpretation f = Datatype_Interpretation.interpretation (uncurry f);
-
-fun make_dt_info alt_names descr sorts induct inducts rec_names rec_rewrites
- (index, (((((((((((_, (tname, _, _))), inject), distinct),
- exhaust), nchotomy), case_name), case_rewrites), case_cong), weak_case_cong),
- (split, split_asm))) =
- (tname,
- {index = index,
- alt_names = alt_names,
- descr = descr,
- sorts = sorts,
- inject = inject,
- distinct = distinct,
- induct = induct,
- inducts = inducts,
- exhaust = exhaust,
- nchotomy = nchotomy,
- rec_names = rec_names,
- rec_rewrites = rec_rewrites,
- case_name = case_name,
- case_rewrites = case_rewrites,
- case_cong = case_cong,
- weak_case_cong = weak_case_cong,
- split = split,
- split_asm = split_asm});
-
-fun derive_datatype_props config dt_names alt_names descr sorts
- induct inject distinct thy1 =
- let
- val thy2 = thy1 |> Theory.checkpoint;
- val flat_descr = flat descr;
- val new_type_names = map Long_Name.base_name (the_default dt_names alt_names);
- val _ = message config ("Deriving properties for datatype(s) " ^ commas_quote new_type_names);
-
- val (exhaust, thy3) = DatatypeAbsProofs.prove_casedist_thms config new_type_names
- descr sorts induct (mk_case_names_exhausts flat_descr dt_names) thy2;
- val (nchotomys, thy4) = DatatypeAbsProofs.prove_nchotomys config new_type_names
- descr sorts exhaust thy3;
- val ((rec_names, rec_rewrites), thy5) = DatatypeAbsProofs.prove_primrec_thms
- config new_type_names descr sorts (#inject o the o Symtab.lookup (get_all thy4))
- inject (distinct, all_distincts thy2 (get_rec_types flat_descr sorts))
- induct thy4;
- val ((case_rewrites, case_names), thy6) = DatatypeAbsProofs.prove_case_thms
- config new_type_names descr sorts rec_names rec_rewrites thy5;
- val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names
- descr sorts nchotomys case_rewrites thy6;
- val (weak_case_congs, thy8) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
- descr sorts thy7;
- val (splits, thy9) = DatatypeAbsProofs.prove_split_thms
- config new_type_names descr sorts inject distinct exhaust case_rewrites thy8;
-
- val inducts = Project_Rule.projections (ProofContext.init thy2) induct;
- val dt_infos = map_index
- (make_dt_info alt_names flat_descr sorts induct inducts rec_names rec_rewrites)
- (hd descr ~~ inject ~~ distinct ~~ exhaust ~~ nchotomys ~~
- case_names ~~ case_rewrites ~~ case_congs ~~ weak_case_congs ~~ splits);
- val dt_names = map fst dt_infos;
- val prfx = Binding.qualify true (space_implode "_" new_type_names);
- val simps = flat (inject @ distinct @ case_rewrites) @ rec_rewrites;
- val named_rules = flat (map_index (fn (index, tname) =>
- [((Binding.empty, [nth inducts index]), [Induct.induct_type tname]),
- ((Binding.empty, [nth exhaust index]), [Induct.cases_type tname])]) dt_names);
- val unnamed_rules = map (fn induct =>
- ((Binding.empty, [induct]), [Rule_Cases.inner_rule, Induct.induct_type ""]))
- (Library.drop (length dt_names, inducts));
- in
- thy9
- |> PureThy.add_thmss ([((prfx (Binding.name "simps"), simps), []),
- ((prfx (Binding.name "inducts"), inducts), []),
- ((prfx (Binding.name "splits"), maps (fn (x, y) => [x, y]) splits), []),
- ((Binding.empty, flat case_rewrites @ flat distinct @ rec_rewrites),
- [Simplifier.simp_add]),
- ((Binding.empty, rec_rewrites), [Code.add_default_eqn_attribute]),
- ((Binding.empty, flat inject), [iff_add]),
- ((Binding.empty, map (fn th => th RS notE) (flat distinct)),
- [Classical.safe_elim NONE]),
- ((Binding.empty, weak_case_congs), [Simplifier.attrib (op addcongs)])]
- @ named_rules @ unnamed_rules)
- |> snd
- |> add_case_tr' case_names
- |> register dt_infos
- |> Datatype_Interpretation.data (config, dt_names)
- |> pair dt_names
- end;
-
-
-
-(** declare existing type as datatype **)
-
-fun prove_rep_datatype config dt_names alt_names descr sorts
- raw_inject half_distinct raw_induct thy1 =
- let
- val raw_distinct = (map o maps) (fn thm => [thm, thm RS not_sym]) half_distinct;
- val new_type_names = map Long_Name.base_name (the_default dt_names alt_names);
- val (((inject, distinct), [induct]), thy2) =
- thy1
- |> store_thmss "inject" new_type_names raw_inject
- ||>> store_thmss "distinct" new_type_names raw_distinct
- ||> Sign.add_path (space_implode "_" new_type_names)
- ||>> PureThy.add_thms [((Binding.name "induct", raw_induct), [mk_case_names_induct descr])]
- ||> Sign.restore_naming thy1;
- in
- thy2
- |> derive_datatype_props config dt_names alt_names [descr] sorts
- induct inject distinct
- end;
-
-fun gen_rep_datatype prep_term config after_qed alt_names raw_ts thy =
- let
- fun constr_of_term (Const (c, T)) = (c, T)
- | constr_of_term t =
- error ("Not a constant: " ^ Syntax.string_of_term_global thy t);
- fun no_constr (c, T) = error ("Bad constructor: "
- ^ Sign.extern_const thy c ^ "::"
- ^ Syntax.string_of_typ_global thy T);
- fun type_of_constr (cT as (_, T)) =
- let
- val frees = OldTerm.typ_tfrees T;
- val (tyco, vs) = ((apsnd o map) (dest_TFree) o dest_Type o snd o strip_type) T
- handle TYPE _ => no_constr cT
- val _ = if has_duplicates (eq_fst (op =)) vs then no_constr cT else ();
- val _ = if length frees <> length vs then no_constr cT else ();
- in (tyco, (vs, cT)) end;
+structure Datatype =
+struct
- val raw_cs = AList.group (op =) (map (type_of_constr o constr_of_term o prep_term thy) raw_ts);
- val _ = case map_filter (fn (tyco, _) =>
- if Symtab.defined (get_all thy) tyco then SOME tyco else NONE) raw_cs
- of [] => ()
- | tycos => error ("Type(s) " ^ commas (map quote tycos)
- ^ " already represented inductivly");
- val raw_vss = maps (map (map snd o fst) o snd) raw_cs;
- val ms = case distinct (op =) (map length raw_vss)
- of [n] => 0 upto n - 1
- | _ => error ("Different types in given constructors");
- fun inter_sort m = map (fn xs => nth xs m) raw_vss
- |> Library.foldr1 (Sorts.inter_sort (Sign.classes_of thy))
- val sorts = map inter_sort ms;
- val vs = Name.names Name.context Name.aT sorts;
-
- fun norm_constr (raw_vs, (c, T)) = (c, map_atyps
- (TFree o (the o AList.lookup (op =) (map fst raw_vs ~~ vs)) o fst o dest_TFree) T);
-
- val cs = map (apsnd (map norm_constr)) raw_cs;
- val dtyps_of_typ = map (dtyp_of_typ (map (rpair (map fst vs) o fst) cs))
- o fst o strip_type;
- val dt_names = map fst cs;
-
- fun mk_spec (i, (tyco, constr)) = (i, (tyco,
- map (DtTFree o fst) vs,
- (map o apsnd) dtyps_of_typ constr))
- val descr = map_index mk_spec cs;
- val injs = DatatypeProp.make_injs [descr] vs;
- val half_distincts = map snd (DatatypeProp.make_distincts [descr] vs);
- val ind = DatatypeProp.make_ind [descr] vs;
- val rules = (map o map o map) Logic.close_form [[[ind]], injs, half_distincts];
-
- fun after_qed' raw_thms =
- let
- val [[[raw_induct]], raw_inject, half_distinct] =
- unflat rules (map Drule.zero_var_indexes_list raw_thms);
- (*FIXME somehow dubious*)
- in
- ProofContext.theory_result
- (prove_rep_datatype config dt_names alt_names descr vs
- raw_inject half_distinct raw_induct)
- #-> after_qed
- end;
- in
- thy
- |> ProofContext.init
- |> Proof.theorem_i NONE after_qed' ((map o map) (rpair []) (flat rules))
- end;
-
-val rep_datatype = gen_rep_datatype Sign.cert_term;
-val rep_datatype_cmd = gen_rep_datatype Syntax.read_term_global default_config (K I);
-
-
-
-(** definitional introduction of datatypes **)
-
-fun gen_add_datatype prep_typ config new_type_names dts thy =
- let
- val _ = Theory.requires thy "Datatype" "datatype definitions";
-
- (* this theory is used just for parsing *)
- val tmp_thy = thy |>
- Theory.copy |>
- Sign.add_types (map (fn (tvs, tname, mx, _) =>
- (tname, length tvs, mx)) dts);
-
- val (tyvars, _, _, _)::_ = dts;
- val (new_dts, types_syntax) = ListPair.unzip (map (fn (tvs, tname, mx, _) =>
- let val full_tname = Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname)
- in
- (case duplicates (op =) tvs of
- [] =>
- if eq_set (op =) (tyvars, tvs) then ((full_tname, tvs), (tname, mx))
- else error ("Mutually recursive datatypes must have same type parameters")
- | dups => error ("Duplicate parameter(s) for datatype " ^ quote (Binding.str_of tname) ^
- " : " ^ commas dups))
- end) dts);
- val dt_names = map fst new_dts;
-
- val _ =
- (case duplicates (op =) (map fst new_dts) @ duplicates (op =) new_type_names of
- [] => ()
- | dups => error ("Duplicate datatypes: " ^ commas dups));
-
- fun prep_dt_spec ((tvs, tname, mx, constrs), tname') (dts', constr_syntax, sorts, i) =
- let
- fun prep_constr (cname, cargs, mx') (constrs, constr_syntax', sorts') =
- let
- val (cargs', sorts'') = fold_map (prep_typ tmp_thy) cargs sorts';
- val _ =
- (case subtract (op =) tvs (fold (curry OldTerm.add_typ_tfree_names) cargs' []) of
- [] => ()
- | vs => error ("Extra type variables on rhs: " ^ commas vs))
- in (constrs @ [(Sign.full_name_path tmp_thy tname'
- (Binding.map_name (Syntax.const_name mx') cname),
- map (dtyp_of_typ new_dts) cargs')],
- constr_syntax' @ [(cname, mx')], sorts'')
- end handle ERROR msg => cat_error msg
- ("The error above occured in constructor " ^ quote (Binding.str_of cname) ^
- " of datatype " ^ quote (Binding.str_of tname));
-
- val (constrs', constr_syntax', sorts') =
- fold prep_constr constrs ([], [], sorts)
-
- in
- case duplicates (op =) (map fst constrs') of
- [] =>
- (dts' @ [(i, (Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname),
- map DtTFree tvs, constrs'))],
- constr_syntax @ [constr_syntax'], sorts', i + 1)
- | dups => error ("Duplicate constructors " ^ commas dups ^
- " in datatype " ^ quote (Binding.str_of tname))
- end;
-
- val (dts', constr_syntax, sorts', i) =
- fold prep_dt_spec (dts ~~ new_type_names) ([], [], [], 0);
- val sorts = sorts' @ (map (rpair (Sign.defaultS tmp_thy)) (subtract (op =) (map fst sorts') tyvars));
- val dt_info = get_all thy;
- val (descr, _) = unfold_datatypes tmp_thy dts' sorts dt_info dts' i;
- val _ = check_nonempty descr handle (exn as Datatype_Empty s) =>
- if #strict config then error ("Nonemptiness check failed for datatype " ^ s)
- else raise exn;
-
- val _ = message config ("Constructing datatype(s) " ^ commas_quote new_type_names);
- val ((inject, distinct, induct), thy') = thy |>
- DatatypeRepProofs.representation_proofs config dt_info new_type_names descr sorts
- types_syntax constr_syntax (mk_case_names_induct (flat descr));
- in
- derive_datatype_props config dt_names (SOME new_type_names) descr sorts
- induct inject distinct thy'
- end;
-
-val add_datatype = gen_add_datatype cert_typ;
-val datatype_cmd = snd ooo gen_add_datatype read_typ default_config;
-
-
-
-(** package setup **)
-
-(* setup theory *)
-
-val setup =
- trfun_setup #>
- Datatype_Interpretation.init;
-
-
-(* outer syntax *)
-
-local
-
-structure P = OuterParse and K = OuterKeyword
-
-fun prep_datatype_decls args =
- let
- val names = map
- (fn ((((NONE, _), t), _), _) => Binding.name_of t | ((((SOME t, _), _), _), _) => t) args;
- val specs = map (fn ((((_, vs), t), mx), cons) =>
- (vs, t, mx, map (fn ((x, y), z) => (x, y, z)) cons)) args;
- in (names, specs) end;
-
-val parse_datatype_decl =
- (Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.type_args -- P.binding -- P.opt_infix --
- (P.$$$ "=" |-- P.enum1 "|" (P.binding -- Scan.repeat P.typ -- P.opt_mixfix)));
-
-val parse_datatype_decls = P.and_list1 parse_datatype_decl >> prep_datatype_decls;
-
-in
-
-val _ =
- OuterSyntax.command "datatype" "define inductive datatypes" K.thy_decl
- (parse_datatype_decls >> (fn (names, specs) => Toplevel.theory (datatype_cmd names specs)));
-
-val _ =
- OuterSyntax.command "rep_datatype" "represent existing types inductively" K.thy_goal
- (Scan.option (P.$$$ "(" |-- Scan.repeat1 P.name --| P.$$$ ")") -- Scan.repeat1 P.term
- >> (fn (alt_names, ts) => Toplevel.print
- o Toplevel.theory_to_proof (rep_datatype_cmd alt_names ts)));
+open Datatype_Data;
+open DatatypeRepProofs;
end;
-
-end;
--- a/src/HOL/Tools/Datatype/datatype_abs_proofs.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/Datatype/datatype_abs_proofs.ML Mon Nov 30 08:08:31 2009 +0100
@@ -51,7 +51,7 @@
val descr' = flat descr;
val recTs = get_rec_types descr' sorts;
- val newTs = Library.take (length (hd descr), recTs);
+ val newTs = take (length (hd descr)) recTs;
val {maxidx, ...} = rep_thm induct;
val induct_Ps = map head_of (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct)));
@@ -62,7 +62,7 @@
Abs ("z", T', Const ("True", T''))) induct_Ps;
val P = Abs ("z", T, HOLogic.imp $ HOLogic.mk_eq (Var (("a", maxidx+1), T), Bound 0) $
Var (("P", 0), HOLogic.boolT))
- val insts = Library.take (i, dummyPs) @ (P::(Library.drop (i + 1, dummyPs)));
+ val insts = take i dummyPs @ (P::(drop (i + 1) dummyPs));
val cert = cterm_of thy;
val insts' = (map cert induct_Ps) ~~ (map cert insts);
val induct' = refl RS ((nth
@@ -98,7 +98,7 @@
val descr' = flat descr;
val recTs = get_rec_types descr' sorts;
val used = List.foldr OldTerm.add_typ_tfree_names [] recTs;
- val newTs = Library.take (length (hd descr), recTs);
+ val newTs = take (length (hd descr)) recTs;
val induct_Ps = map head_of (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct)));
@@ -283,7 +283,7 @@
val descr' = flat descr;
val recTs = get_rec_types descr' sorts;
val used = List.foldr OldTerm.add_typ_tfree_names [] recTs;
- val newTs = Library.take (length (hd descr), recTs);
+ val newTs = take (length (hd descr)) recTs;
val T' = TFree (Name.variant used "'t", HOLogic.typeS);
fun mk_dummyT dt = binder_types (typ_of_dtyp descr' sorts dt) ---> T';
@@ -305,8 +305,8 @@
let
val Ts = map (typ_of_dtyp descr' sorts) cargs;
val Ts' = Ts @ map mk_dummyT (filter is_rec_type cargs);
- val frees' = map (uncurry (mk_Free "x")) (Ts' ~~ (1 upto length Ts'));
- val frees = Library.take (length cargs, frees');
+ val frees' = map2 (mk_Free "x") Ts' (1 upto length Ts');
+ val frees = take (length cargs) frees';
val free = mk_Free "f" (Ts ---> T') j
in
(free, list_abs_free (map dest_Free frees',
@@ -314,14 +314,14 @@
end) (constrs ~~ (1 upto length constrs)));
val caseT = (map (snd o dest_Free) fns1) @ [T] ---> T';
- val fns = flat (Library.take (i, case_dummy_fns)) @
- fns2 @ flat (Library.drop (i + 1, case_dummy_fns));
+ val fns = flat (take i case_dummy_fns) @
+ fns2 @ flat (drop (i + 1) case_dummy_fns);
val reccomb = Const (recname, (map fastype_of fns) @ [T] ---> T');
val decl = ((Binding.name (Long_Name.base_name name), caseT), NoSyn);
val def = (Binding.name (Long_Name.base_name name ^ "_def"),
Logic.mk_equals (list_comb (Const (name, caseT), fns1),
- list_comb (reccomb, (flat (Library.take (i, case_dummy_fns))) @
- fns2 @ (flat (Library.drop (i + 1, case_dummy_fns))) )));
+ list_comb (reccomb, (flat (take i case_dummy_fns)) @
+ fns2 @ (flat (drop (i + 1) case_dummy_fns)))));
val ([def_thm], thy') =
thy
|> Sign.declare_const decl |> snd
@@ -329,7 +329,7 @@
in (defs @ [def_thm], thy')
end) (hd descr ~~ newTs ~~ case_names ~~
- Library.take (length newTs, reccomb_names)) ([], thy1)
+ take (length newTs) reccomb_names) ([], thy1)
||> Theory.checkpoint;
val case_thms = map (map (fn t => Skip_Proof.prove_global thy2 [] [] t
@@ -353,7 +353,7 @@
val descr' = flat descr;
val recTs = get_rec_types descr' sorts;
- val newTs = Library.take (length (hd descr), recTs);
+ val newTs = take (length (hd descr)) recTs;
fun prove_split_thms ((((((t1, t2), inject), dist_rewrites'),
exhaustion), case_thms'), T) =
--- a/src/HOL/Tools/Datatype/datatype_codegen.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/Datatype/datatype_codegen.ML Mon Nov 30 08:08:31 2009 +0100
@@ -6,16 +6,19 @@
signature DATATYPE_CODEGEN =
sig
- val find_shortest_path: Datatype.descr -> int -> (string * int) option
+ include DATATYPE_COMMON
+ val find_shortest_path: descr -> int -> (string * int) option
val setup: theory -> theory
end;
structure DatatypeCodegen : DATATYPE_CODEGEN =
struct
+open DatatypeAux
+
(** find shortest path to constructor with no recursive arguments **)
-fun find_nonempty (descr: Datatype.descr) is i =
+fun find_nonempty (descr: descr) is i =
let
val (_, _, constrs) = the (AList.lookup (op =) descr i);
fun arg_nonempty (_, DatatypeAux.DtRec i) = if member (op =) is i
@@ -40,7 +43,7 @@
(* datatype definition *)
-fun add_dt_defs thy defs dep module (descr: Datatype.descr) sorts gr =
+fun add_dt_defs thy defs dep module (descr: descr) sorts gr =
let
val descr' = filter (can (map DatatypeAux.dest_DtTFree o #2 o snd)) descr;
val rtnames = map (#1 o snd) (filter (fn (_, (_, _, cs)) =>
@@ -217,19 +220,19 @@
invoke_codegen thy defs dep module brack (eta_expand c ts (i+1)) gr
else
let
- val ts1 = Library.take (i, ts);
- val t :: ts2 = Library.drop (i, ts);
+ val ts1 = take i ts;
+ val t :: ts2 = drop i ts;
val names = List.foldr OldTerm.add_term_names
(map (fst o fst o dest_Var) (List.foldr OldTerm.add_term_vars [] ts1)) ts1;
- val (Ts, dT) = split_last (Library.take (i+1, fst (strip_type T)));
+ val (Ts, dT) = split_last (take (i+1) (fst (strip_type T)));
fun pcase [] [] [] gr = ([], gr)
| pcase ((cname, cargs)::cs) (t::ts) (U::Us) gr =
let
val j = length cargs;
val xs = Name.variant_list names (replicate j "x");
- val Us' = Library.take (j, fst (strip_type U));
- val frees = map Free (xs ~~ Us');
+ val Us' = take j (fst (strip_type U));
+ val frees = map2 (curry Free) xs Us';
val (cp, gr0) = invoke_codegen thy defs dep module false
(list_comb (Const (cname, Us' ---> dT), frees)) gr;
val t' = Envir.beta_norm (list_comb (t, frees));
@@ -274,12 +277,12 @@
fun datatype_codegen thy defs dep module brack t gr = (case strip_comb t of
(c as Const (s, T), ts) =>
- (case Datatype.info_of_case thy s of
+ (case Datatype_Data.info_of_case thy s of
SOME {index, descr, ...} =>
if is_some (get_assoc_code thy (s, T)) then NONE else
SOME (pretty_case thy defs dep module brack
(#3 (the (AList.lookup op = descr index))) c ts gr )
- | NONE => case (Datatype.info_of_constr thy (s, T), strip_type T) of
+ | NONE => case (Datatype_Data.info_of_constr thy (s, T), strip_type T) of
(SOME {index, descr, ...}, (_, U as Type (tyname, _))) =>
if is_some (get_assoc_code thy (s, T)) then NONE else
let
@@ -294,7 +297,7 @@
| _ => NONE);
fun datatype_tycodegen thy defs dep module brack (Type (s, Ts)) gr =
- (case Datatype.get_info thy s of
+ (case Datatype_Data.get_info thy s of
NONE => NONE
| SOME {descr, sorts, ...} =>
if is_some (get_assoc_type thy s) then NONE else
@@ -329,7 +332,7 @@
fun mk_case_cert thy tyco =
let
val raw_thms =
- (#case_rewrites o Datatype.the_info thy) tyco;
+ (#case_rewrites o Datatype_Data.the_info thy) tyco;
val thms as hd_thm :: _ = raw_thms
|> Conjunction.intr_balanced
|> Thm.unvarify
@@ -362,9 +365,9 @@
fun mk_eq_eqns thy dtco =
let
- val (vs, cos) = Datatype.the_spec thy dtco;
+ val (vs, cos) = Datatype_Data.the_spec thy dtco;
val { descr, index, inject = inject_thms, distinct = distinct_thms, ... } =
- Datatype.the_info thy dtco;
+ Datatype_Data.the_info thy dtco;
val ty = Type (dtco, map TFree vs);
fun mk_eq (t1, t2) = Const (@{const_name eq_class.eq}, ty --> ty --> HOLogic.boolT)
$ t1 $ t2;
@@ -424,11 +427,11 @@
fun add_all_code config dtcos thy =
let
- val (vs :: _, coss) = (split_list o map (Datatype.the_spec thy)) dtcos;
+ val (vs :: _, coss) = (split_list o map (Datatype_Data.the_spec thy)) dtcos;
val any_css = map2 (mk_constr_consts thy vs) dtcos coss;
val css = if exists is_none any_css then []
else map_filter I any_css;
- val case_rewrites = maps (#case_rewrites o Datatype.the_info thy) dtcos;
+ val case_rewrites = maps (#case_rewrites o Datatype_Data.the_info thy) dtcos;
val certs = map (mk_case_cert thy) dtcos;
in
if null css then thy
@@ -446,6 +449,6 @@
val setup =
add_codegen "datatype" datatype_codegen
#> add_tycodegen "datatype" datatype_tycodegen
- #> Datatype.interpretation add_all_code
+ #> Datatype_Data.interpretation add_all_code
end;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Datatype/datatype_data.ML Mon Nov 30 08:08:31 2009 +0100
@@ -0,0 +1,471 @@
+(* Title: HOL/Tools/datatype.ML
+ Author: Stefan Berghofer, TU Muenchen
+
+Datatype package for Isabelle/HOL.
+*)
+
+signature DATATYPE_DATA =
+sig
+ include DATATYPE_COMMON
+ val derive_datatype_props : config -> string list -> string list option
+ -> descr list -> (string * sort) list -> thm -> thm list list -> thm list list
+ -> theory -> string list * theory
+ val rep_datatype : config -> (string list -> Proof.context -> Proof.context)
+ -> string list option -> term list -> theory -> Proof.state
+ val rep_datatype_cmd : string list option -> string list -> theory -> Proof.state
+ val get_info : theory -> string -> info option
+ val the_info : theory -> string -> info
+ val the_descr : theory -> string list
+ -> descr * (string * sort) list * string list
+ * string * (string list * string list) * (typ list * typ list)
+ val the_spec : theory -> string -> (string * sort) list * (string * typ list) list
+ val all_distincts : theory -> typ list -> thm list list
+ val get_constrs : theory -> string -> (string * typ) list option
+ val get_all : theory -> info Symtab.table
+ val info_of_constr : theory -> string * typ -> info option
+ val info_of_case : theory -> string -> info option
+ val interpretation : (config -> string list -> theory -> theory) -> theory -> theory
+ val make_case : Proof.context -> DatatypeCase.config -> string list -> term ->
+ (term * term) list -> term * (term * (int * bool)) list
+ val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option
+ val read_typ: theory -> string -> (string * sort) list -> typ * (string * sort) list
+ val cert_typ: theory -> typ -> (string * sort) list -> typ * (string * sort) list
+ val mk_case_names_induct: descr -> attribute
+ val setup: theory -> theory
+end;
+
+structure Datatype_Data: DATATYPE_DATA =
+struct
+
+open DatatypeAux;
+
+(** theory data **)
+
+(* data management *)
+
+structure DatatypesData = Theory_Data
+(
+ type T =
+ {types: info Symtab.table,
+ constrs: (string * info) list Symtab.table,
+ cases: info Symtab.table};
+
+ val empty =
+ {types = Symtab.empty, constrs = Symtab.empty, cases = Symtab.empty};
+ val extend = I;
+ fun merge
+ ({types = types1, constrs = constrs1, cases = cases1},
+ {types = types2, constrs = constrs2, cases = cases2}) : T =
+ {types = Symtab.merge (K true) (types1, types2),
+ constrs = Symtab.join (K (AList.merge (op =) (K true))) (constrs1, constrs2),
+ cases = Symtab.merge (K true) (cases1, cases2)};
+);
+
+val get_all = #types o DatatypesData.get;
+val get_info = Symtab.lookup o get_all;
+
+fun the_info thy name =
+ (case get_info thy name of
+ SOME info => info
+ | NONE => error ("Unknown datatype " ^ quote name));
+
+fun info_of_constr thy (c, T) =
+ let
+ val tab = Symtab.lookup_list ((#constrs o DatatypesData.get) thy) c;
+ val hint = case strip_type T of (_, Type (tyco, _)) => SOME tyco | _ => NONE;
+ val default = if null tab then NONE
+ else SOME (snd (Library.last_elem tab))
+ (*conservative wrt. overloaded constructors*);
+ in case hint
+ of NONE => default
+ | SOME tyco => case AList.lookup (op =) tab tyco
+ of NONE => default (*permissive*)
+ | SOME info => SOME info
+ end;
+
+val info_of_case = Symtab.lookup o #cases o DatatypesData.get;
+
+fun register (dt_infos : (string * info) list) =
+ DatatypesData.map (fn {types, constrs, cases} =>
+ {types = types |> fold Symtab.update dt_infos,
+ constrs = constrs |> fold (fn (constr, dtname_info) =>
+ Symtab.map_default (constr, []) (cons dtname_info))
+ (maps (fn (dtname, info as {descr, index, ...}) =>
+ map (rpair (dtname, info) o fst)
+ (#3 (the (AList.lookup op = descr index)))) dt_infos),
+ cases = cases |> fold Symtab.update
+ (map (fn (_, info as {case_name, ...}) => (case_name, info)) dt_infos)});
+
+
+(* complex queries *)
+
+fun the_spec thy dtco =
+ let
+ val info as { descr, index, sorts = raw_sorts, ... } = the_info thy dtco;
+ val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr index;
+ val sorts = map ((fn v => (v, (the o AList.lookup (op =) raw_sorts) v))
+ o DatatypeAux.dest_DtTFree) dtys;
+ val cos = map
+ (fn (co, tys) => (co, map (DatatypeAux.typ_of_dtyp descr sorts) tys)) raw_cos;
+ in (sorts, cos) end;
+
+fun the_descr thy (raw_tycos as raw_tyco :: _) =
+ let
+ val info = the_info thy raw_tyco;
+ val descr = #descr info;
+
+ val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr (#index info);
+ val vs = map ((fn v => (v, (the o AList.lookup (op =) (#sorts info)) v))
+ o dest_DtTFree) dtys;
+
+ fun is_DtTFree (DtTFree _) = true
+ | is_DtTFree _ = false
+ val k = find_index (fn (_, (_, dTs, _)) => not (forall is_DtTFree dTs)) descr;
+ val protoTs as (dataTs, _) = chop k descr
+ |> (pairself o map) (fn (_, (tyco, dTs, _)) => (tyco, map (typ_of_dtyp descr vs) dTs));
+
+ val tycos = map fst dataTs;
+ val _ = if eq_set (op =) (tycos, raw_tycos) then ()
+ else error ("Type constructors " ^ commas (map quote raw_tycos)
+ ^ " do not belong exhaustively to one mutual recursive datatype");
+
+ val (Ts, Us) = (pairself o map) Type protoTs;
+
+ val names = map Long_Name.base_name (the_default tycos (#alt_names info));
+ val (auxnames, _) = Name.make_context names
+ |> fold_map (yield_singleton Name.variants o name_of_typ) Us;
+ val prefix = space_implode "_" names;
+
+ in (descr, vs, tycos, prefix, (names, auxnames), (Ts, Us)) end;
+
+fun all_distincts thy Ts =
+ let
+ fun add_tycos (Type (tyco, Ts)) = insert (op =) tyco #> fold add_tycos Ts
+ | add_tycos _ = I;
+ val tycos = fold add_tycos Ts [];
+ in map_filter (Option.map #distinct o get_info thy) tycos end;
+
+fun get_constrs thy dtco =
+ case try (the_spec thy) dtco
+ of SOME (sorts, cos) =>
+ let
+ fun subst (v, sort) = TVar ((v, 0), sort);
+ fun subst_ty (TFree v) = subst v
+ | subst_ty ty = ty;
+ val dty = Type (dtco, map subst sorts);
+ fun mk_co (co, tys) = (co, map (Term.map_atyps subst_ty) tys ---> dty);
+ in SOME (map mk_co cos) end
+ | NONE => NONE;
+
+
+
+(** various auxiliary **)
+
+(* prepare datatype specifications *)
+
+fun read_typ thy str sorts =
+ let
+ val ctxt = ProofContext.init thy
+ |> fold (Variable.declare_typ o TFree) sorts;
+ val T = Syntax.read_typ ctxt str;
+ in (T, Term.add_tfreesT T sorts) end;
+
+fun cert_typ sign raw_T sorts =
+ let
+ val T = Type.no_tvars (Sign.certify_typ sign raw_T)
+ handle TYPE (msg, _, _) => error msg;
+ val sorts' = Term.add_tfreesT T sorts;
+ val _ =
+ case duplicates (op =) (map fst sorts') of
+ [] => ()
+ | dups => error ("Inconsistent sort constraints for " ^ commas dups)
+ in (T, sorts') end;
+
+
+(* case names *)
+
+local
+
+fun dt_recs (DtTFree _) = []
+ | dt_recs (DtType (_, dts)) = maps dt_recs dts
+ | dt_recs (DtRec i) = [i];
+
+fun dt_cases (descr: descr) (_, args, constrs) =
+ let
+ fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i)));
+ val bnames = map the_bname (distinct (op =) (maps dt_recs args));
+ in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
+
+fun induct_cases descr =
+ DatatypeProp.indexify_names (maps (dt_cases descr) (map #2 descr));
+
+fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i));
+
+in
+
+fun mk_case_names_induct descr = Rule_Cases.case_names (induct_cases descr);
+
+fun mk_case_names_exhausts descr new =
+ map (Rule_Cases.case_names o exhaust_cases descr o #1)
+ (filter (fn ((_, (name, _, _))) => member (op =) new name) descr);
+
+end;
+
+
+(* translation rules for case *)
+
+fun make_case ctxt = DatatypeCase.make_case
+ (info_of_constr (ProofContext.theory_of ctxt)) ctxt;
+
+fun strip_case ctxt = DatatypeCase.strip_case
+ (info_of_case (ProofContext.theory_of ctxt));
+
+fun add_case_tr' case_names thy =
+ Sign.add_advanced_trfuns ([], [],
+ map (fn case_name =>
+ let val case_name' = Sign.const_syntax_name thy case_name
+ in (case_name', DatatypeCase.case_tr' info_of_case case_name')
+ end) case_names, []) thy;
+
+val trfun_setup =
+ Sign.add_advanced_trfuns ([],
+ [("_case_syntax", DatatypeCase.case_tr true info_of_constr)],
+ [], []);
+
+
+
+(** document antiquotation **)
+
+val _ = ThyOutput.antiquotation "datatype" Args.tyname
+ (fn {source = src, context = ctxt, ...} => fn dtco =>
+ let
+ val thy = ProofContext.theory_of ctxt;
+ val (vs, cos) = the_spec thy dtco;
+ val ty = Type (dtco, map TFree vs);
+ fun pretty_typ_bracket (ty as Type (_, _ :: _)) =
+ Pretty.enclose "(" ")" [Syntax.pretty_typ ctxt ty]
+ | pretty_typ_bracket ty =
+ Syntax.pretty_typ ctxt ty;
+ fun pretty_constr (co, tys) =
+ (Pretty.block o Pretty.breaks)
+ (Syntax.pretty_term ctxt (Const (co, tys ---> ty)) ::
+ map pretty_typ_bracket tys);
+ val pretty_datatype =
+ Pretty.block
+ (Pretty.command "datatype" :: Pretty.brk 1 ::
+ Syntax.pretty_typ ctxt ty ::
+ Pretty.str " =" :: Pretty.brk 1 ::
+ flat (separate [Pretty.brk 1, Pretty.str "| "]
+ (map (single o pretty_constr) cos)));
+ in ThyOutput.output (ThyOutput.maybe_pretty_source (K pretty_datatype) src [()]) end);
+
+
+
+(** abstract theory extensions relative to a datatype characterisation **)
+
+structure Datatype_Interpretation = Interpretation
+ (type T = config * string list val eq: T * T -> bool = eq_snd op =);
+fun interpretation f = Datatype_Interpretation.interpretation (uncurry f);
+
+fun make_dt_info alt_names descr sorts induct inducts rec_names rec_rewrites
+ (index, (((((((((((_, (tname, _, _))), inject), distinct),
+ exhaust), nchotomy), case_name), case_rewrites), case_cong), weak_case_cong),
+ (split, split_asm))) =
+ (tname,
+ {index = index,
+ alt_names = alt_names,
+ descr = descr,
+ sorts = sorts,
+ inject = inject,
+ distinct = distinct,
+ induct = induct,
+ inducts = inducts,
+ exhaust = exhaust,
+ nchotomy = nchotomy,
+ rec_names = rec_names,
+ rec_rewrites = rec_rewrites,
+ case_name = case_name,
+ case_rewrites = case_rewrites,
+ case_cong = case_cong,
+ weak_case_cong = weak_case_cong,
+ split = split,
+ split_asm = split_asm});
+
+fun derive_datatype_props config dt_names alt_names descr sorts
+ induct inject distinct thy1 =
+ let
+ val thy2 = thy1 |> Theory.checkpoint;
+ val flat_descr = flat descr;
+ val new_type_names = map Long_Name.base_name (the_default dt_names alt_names);
+ val _ = message config ("Deriving properties for datatype(s) " ^ commas_quote new_type_names);
+
+ val (exhaust, thy3) = DatatypeAbsProofs.prove_casedist_thms config new_type_names
+ descr sorts induct (mk_case_names_exhausts flat_descr dt_names) thy2;
+ val (nchotomys, thy4) = DatatypeAbsProofs.prove_nchotomys config new_type_names
+ descr sorts exhaust thy3;
+ val ((rec_names, rec_rewrites), thy5) = DatatypeAbsProofs.prove_primrec_thms
+ config new_type_names descr sorts (#inject o the o Symtab.lookup (get_all thy4))
+ inject (distinct, all_distincts thy2 (get_rec_types flat_descr sorts))
+ induct thy4;
+ val ((case_rewrites, case_names), thy6) = DatatypeAbsProofs.prove_case_thms
+ config new_type_names descr sorts rec_names rec_rewrites thy5;
+ val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names
+ descr sorts nchotomys case_rewrites thy6;
+ val (weak_case_congs, thy8) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
+ descr sorts thy7;
+ val (splits, thy9) = DatatypeAbsProofs.prove_split_thms
+ config new_type_names descr sorts inject distinct exhaust case_rewrites thy8;
+
+ val inducts = Project_Rule.projections (ProofContext.init thy2) induct;
+ val dt_infos = map_index
+ (make_dt_info alt_names flat_descr sorts induct inducts rec_names rec_rewrites)
+ (hd descr ~~ inject ~~ distinct ~~ exhaust ~~ nchotomys ~~
+ case_names ~~ case_rewrites ~~ case_congs ~~ weak_case_congs ~~ splits);
+ val dt_names = map fst dt_infos;
+ val prfx = Binding.qualify true (space_implode "_" new_type_names);
+ val simps = flat (inject @ distinct @ case_rewrites) @ rec_rewrites;
+ val named_rules = flat (map_index (fn (index, tname) =>
+ [((Binding.empty, [nth inducts index]), [Induct.induct_type tname]),
+ ((Binding.empty, [nth exhaust index]), [Induct.cases_type tname])]) dt_names);
+ val unnamed_rules = map (fn induct =>
+ ((Binding.empty, [induct]), [Rule_Cases.inner_rule, Induct.induct_type ""]))
+ (drop (length dt_names) inducts);
+ in
+ thy9
+ |> PureThy.add_thmss ([((prfx (Binding.name "simps"), simps), []),
+ ((prfx (Binding.name "inducts"), inducts), []),
+ ((prfx (Binding.name "splits"), maps (fn (x, y) => [x, y]) splits), []),
+ ((Binding.empty, flat case_rewrites @ flat distinct @ rec_rewrites),
+ [Simplifier.simp_add]),
+ ((Binding.empty, rec_rewrites), [Code.add_default_eqn_attribute]),
+ ((Binding.empty, flat inject), [iff_add]),
+ ((Binding.empty, map (fn th => th RS notE) (flat distinct)),
+ [Classical.safe_elim NONE]),
+ ((Binding.empty, weak_case_congs), [Simplifier.attrib (op addcongs)])]
+ @ named_rules @ unnamed_rules)
+ |> snd
+ |> add_case_tr' case_names
+ |> register dt_infos
+ |> Datatype_Interpretation.data (config, dt_names)
+ |> pair dt_names
+ end;
+
+
+
+(** declare existing type as datatype **)
+
+fun prove_rep_datatype config dt_names alt_names descr sorts
+ raw_inject half_distinct raw_induct thy1 =
+ let
+ val raw_distinct = (map o maps) (fn thm => [thm, thm RS not_sym]) half_distinct;
+ val new_type_names = map Long_Name.base_name (the_default dt_names alt_names);
+ val (((inject, distinct), [induct]), thy2) =
+ thy1
+ |> store_thmss "inject" new_type_names raw_inject
+ ||>> store_thmss "distinct" new_type_names raw_distinct
+ ||> Sign.add_path (space_implode "_" new_type_names)
+ ||>> PureThy.add_thms [((Binding.name "induct", raw_induct), [mk_case_names_induct descr])]
+ ||> Sign.restore_naming thy1;
+ in
+ thy2
+ |> derive_datatype_props config dt_names alt_names [descr] sorts
+ induct inject distinct
+ end;
+
+fun gen_rep_datatype prep_term config after_qed alt_names raw_ts thy =
+ let
+ fun constr_of_term (Const (c, T)) = (c, T)
+ | constr_of_term t =
+ error ("Not a constant: " ^ Syntax.string_of_term_global thy t);
+ fun no_constr (c, T) = error ("Bad constructor: "
+ ^ Sign.extern_const thy c ^ "::"
+ ^ Syntax.string_of_typ_global thy T);
+ fun type_of_constr (cT as (_, T)) =
+ let
+ val frees = OldTerm.typ_tfrees T;
+ val (tyco, vs) = ((apsnd o map) (dest_TFree) o dest_Type o snd o strip_type) T
+ handle TYPE _ => no_constr cT
+ val _ = if has_duplicates (eq_fst (op =)) vs then no_constr cT else ();
+ val _ = if length frees <> length vs then no_constr cT else ();
+ in (tyco, (vs, cT)) end;
+
+ val raw_cs = AList.group (op =) (map (type_of_constr o constr_of_term o prep_term thy) raw_ts);
+ val _ = case map_filter (fn (tyco, _) =>
+ if Symtab.defined (get_all thy) tyco then SOME tyco else NONE) raw_cs
+ of [] => ()
+ | tycos => error ("Type(s) " ^ commas (map quote tycos)
+ ^ " already represented inductivly");
+ val raw_vss = maps (map (map snd o fst) o snd) raw_cs;
+ val ms = case distinct (op =) (map length raw_vss)
+ of [n] => 0 upto n - 1
+ | _ => error ("Different types in given constructors");
+ fun inter_sort m = map (fn xs => nth xs m) raw_vss
+ |> Library.foldr1 (Sorts.inter_sort (Sign.classes_of thy))
+ val sorts = map inter_sort ms;
+ val vs = Name.names Name.context Name.aT sorts;
+
+ fun norm_constr (raw_vs, (c, T)) = (c, map_atyps
+ (TFree o (the o AList.lookup (op =) (map fst raw_vs ~~ vs)) o fst o dest_TFree) T);
+
+ val cs = map (apsnd (map norm_constr)) raw_cs;
+ val dtyps_of_typ = map (dtyp_of_typ (map (rpair (map fst vs) o fst) cs))
+ o fst o strip_type;
+ val dt_names = map fst cs;
+
+ fun mk_spec (i, (tyco, constr)) = (i, (tyco,
+ map (DtTFree o fst) vs,
+ (map o apsnd) dtyps_of_typ constr))
+ val descr = map_index mk_spec cs;
+ val injs = DatatypeProp.make_injs [descr] vs;
+ val half_distincts = map snd (DatatypeProp.make_distincts [descr] vs);
+ val ind = DatatypeProp.make_ind [descr] vs;
+ val rules = (map o map o map) Logic.close_form [[[ind]], injs, half_distincts];
+
+ fun after_qed' raw_thms =
+ let
+ val [[[raw_induct]], raw_inject, half_distinct] =
+ unflat rules (map Drule.zero_var_indexes_list raw_thms);
+ (*FIXME somehow dubious*)
+ in
+ ProofContext.theory_result
+ (prove_rep_datatype config dt_names alt_names descr vs
+ raw_inject half_distinct raw_induct)
+ #-> after_qed
+ end;
+ in
+ thy
+ |> ProofContext.init
+ |> Proof.theorem_i NONE after_qed' ((map o map) (rpair []) (flat rules))
+ end;
+
+val rep_datatype = gen_rep_datatype Sign.cert_term;
+val rep_datatype_cmd = gen_rep_datatype Syntax.read_term_global default_config (K I);
+
+
+
+(** package setup **)
+
+(* setup theory *)
+
+val setup =
+ trfun_setup #>
+ Datatype_Interpretation.init;
+
+
+(* outer syntax *)
+
+local
+
+structure P = OuterParse and K = OuterKeyword
+
+in
+
+val _ =
+ OuterSyntax.command "rep_datatype" "represent existing types inductively" K.thy_goal
+ (Scan.option (P.$$$ "(" |-- Scan.repeat1 P.name --| P.$$$ ")") -- Scan.repeat1 P.term
+ >> (fn (alt_names, ts) => Toplevel.print
+ o Toplevel.theory_to_proof (rep_datatype_cmd alt_names ts)));
+
+end;
+
+end;
--- a/src/HOL/Tools/Datatype/datatype_prop.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/Datatype/datatype_prop.ML Mon Nov 30 08:08:31 2009 +0100
@@ -72,7 +72,7 @@
end;
in
map2 (fn d => fn T => fold_rev (make_inj T) (#3 (snd d)) [])
- (hd descr) (Library.take (length (hd descr), get_rec_types descr' sorts))
+ (hd descr) (take (length (hd descr)) (get_rec_types descr' sorts))
end;
@@ -82,7 +82,7 @@
let
val descr' = flat descr;
val recTs = get_rec_types descr' sorts;
- val newTs = Library.take (length (hd descr), recTs);
+ val newTs = take (length (hd descr)) recTs;
fun prep_constr (cname, cargs) = (cname, map (typ_of_dtyp descr' sorts) cargs);
@@ -168,14 +168,12 @@
HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT))))
end;
- fun make_casedist ((_, (_, _, constrs)), T) =
+ fun make_casedist ((_, (_, _, constrs))) T =
let val prems = map (make_casedist_prem T) constrs
in Logic.list_implies (prems, HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT)))
end
- in map make_casedist
- ((hd descr) ~~ Library.take (length (hd descr), get_rec_types descr' sorts))
- end;
+ in map2 make_casedist (hd descr) (take (length (hd descr)) (get_rec_types descr' sorts)) end;
(*************** characteristic equations for primrec combinator **************)
@@ -257,7 +255,7 @@
val descr' = flat descr;
val recTs = get_rec_types descr' sorts;
val used = List.foldr OldTerm.add_typ_tfree_names [] recTs;
- val newTs = Library.take (length (hd descr), recTs);
+ val newTs = take (length (hd descr)) recTs;
val T' = TFree (Name.variant used "'t", HOLogic.typeS);
val case_fn_Ts = map (fn (i, (_, _, constrs)) =>
@@ -280,7 +278,7 @@
let
val descr' = flat descr;
val recTs = get_rec_types descr' sorts;
- val newTs = Library.take (length (hd descr), recTs);
+ val newTs = take (length (hd descr)) recTs;
fun make_case T comb_t ((cname, cargs), f) =
let
@@ -304,7 +302,7 @@
val descr' = flat descr;
val recTs = get_rec_types descr' sorts;
val used' = List.foldr OldTerm.add_typ_tfree_names [] recTs;
- val newTs = Library.take (length (hd descr), recTs);
+ val newTs = take (length (hd descr)) recTs;
val T' = TFree (Name.variant used' "'t", HOLogic.typeS);
val P = Free ("P", T' --> HOLogic.boolT);
@@ -415,7 +413,7 @@
let
val descr' = flat descr;
val recTs = get_rec_types descr' sorts;
- val newTs = Library.take (length (hd descr), recTs);
+ val newTs = take (length (hd descr)) recTs;
fun mk_eqn T (cname, cargs) =
let
--- a/src/HOL/Tools/Datatype/datatype_rep_proofs.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/Datatype/datatype_rep_proofs.ML Mon Nov 30 08:08:31 2009 +0100
@@ -1,8 +1,7 @@
(* Title: HOL/Tools/datatype_rep_proofs.ML
Author: Stefan Berghofer, TU Muenchen
-Definitional introduction of datatypes
-Proof of characteristic theorems:
+Definitional introduction of datatypes with proof of characteristic theorems:
- injectivity of constructors
- distinctness of constructors
@@ -11,53 +10,58 @@
signature DATATYPE_REP_PROOFS =
sig
- include DATATYPE_COMMON
- val representation_proofs : config -> info Symtab.table ->
- string list -> descr list -> (string * sort) list ->
- (binding * mixfix) list -> (binding * mixfix) list list -> attribute
- -> theory -> (thm list list * thm list list * thm) * theory
+ val add_datatype : DatatypeAux.config -> string list -> (string list * binding * mixfix *
+ (binding * typ list * mixfix) list) list -> theory -> string list * theory
+ val datatype_cmd : string list -> (string list * binding * mixfix *
+ (binding * string list * mixfix) list) list -> theory -> theory
end;
structure DatatypeRepProofs : DATATYPE_REP_PROOFS =
struct
+(** auxiliary **)
+
open DatatypeAux;
val (_ $ (_ $ (_ $ (distinct_f $ _) $ _))) = hd (prems_of distinct_lemma);
val collect_simp = rewrite_rule [mk_meta_eq mem_Collect_eq];
-
-(** theory context references **)
-
fun exh_thm_of (dt_info : info Symtab.table) tname =
#exhaust (the (Symtab.lookup dt_info tname));
-(******************************************************************************)
+val node_name = @{type_name "Datatype.node"};
+val In0_name = @{const_name "Datatype.In0"};
+val In1_name = @{const_name "Datatype.In1"};
+val Scons_name = @{const_name "Datatype.Scons"};
+val Leaf_name = @{const_name "Datatype.Leaf"};
+val Numb_name = @{const_name "Datatype.Numb"};
+val Lim_name = @{const_name "Datatype.Lim"};
+val Suml_name = @{const_name "Sum_Type.Suml"};
+val Sumr_name = @{const_name "Sum_Type.Sumr"};
+
+val In0_inject = @{thm In0_inject};
+val In1_inject = @{thm In1_inject};
+val Scons_inject = @{thm Scons_inject};
+val Leaf_inject = @{thm Leaf_inject};
+val In0_eq = @{thm In0_eq};
+val In1_eq = @{thm In1_eq};
+val In0_not_In1 = @{thm In0_not_In1};
+val In1_not_In0 = @{thm In1_not_In0};
+val Lim_inject = @{thm Lim_inject};
+val Inl_inject = @{thm Inl_inject};
+val Inr_inject = @{thm Inr_inject};
+val Suml_inject = @{thm Suml_inject};
+val Sumr_inject = @{thm Sumr_inject};
+
+
+
+(** proof of characteristic theorems **)
fun representation_proofs (config : config) (dt_info : info Symtab.table)
new_type_names descr sorts types_syntax constr_syntax case_names_induct thy =
let
- val Datatype_thy = ThyInfo.the_theory "Datatype" thy;
- val node_name = "Datatype.node";
- val In0_name = "Datatype.In0";
- val In1_name = "Datatype.In1";
- val Scons_name = "Datatype.Scons";
- val Leaf_name = "Datatype.Leaf";
- val Numb_name = "Datatype.Numb";
- val Lim_name = "Datatype.Lim";
- val Suml_name = "Datatype.Suml";
- val Sumr_name = "Datatype.Sumr";
-
- val [In0_inject, In1_inject, Scons_inject, Leaf_inject,
- In0_eq, In1_eq, In0_not_In1, In1_not_In0,
- Lim_inject, Suml_inject, Sumr_inject] = map (PureThy.get_thm Datatype_thy)
- ["In0_inject", "In1_inject", "Scons_inject", "Leaf_inject",
- "In0_eq", "In1_eq", "In0_not_In1", "In1_not_In0",
- "Lim_inject", "Suml_inject", "Sumr_inject"];
-
val descr' = flat descr;
-
val big_name = space_implode "_" new_type_names;
val thy1 = Sign.add_path big_name thy;
val big_rec_name = big_name ^ "_rep_set";
@@ -77,14 +81,13 @@
subtract (op =) (List.foldr OldTerm.add_typ_tfree_names [] (leafTs' @ branchTs)) (hd tyvars);
val leafTs = leafTs' @ map (fn n => TFree (n, (the o AList.lookup (op =) sorts) n)) unneeded_vars;
val recTs = get_rec_types descr' sorts;
- val newTs = Library.take (length (hd descr), recTs);
- val oldTs = Library.drop (length (hd descr), recTs);
+ val (newTs, oldTs) = chop (length (hd descr)) recTs;
val sumT = if null leafTs then HOLogic.unitT
else Balanced_Tree.make (fn (T, U) => Type ("+", [T, U])) leafTs;
val Univ_elT = HOLogic.mk_setT (Type (node_name, [sumT, branchT]));
val UnivT = HOLogic.mk_setT Univ_elT;
val UnivT' = Univ_elT --> HOLogic.boolT;
- val Collect = Const ("Collect", UnivT' --> UnivT);
+ val Collect = Const (@{const_name Collect}, UnivT' --> UnivT);
val In0 = Const (In0_name, Univ_elT --> Univ_elT);
val In1 = Const (In1_name, Univ_elT --> Univ_elT);
@@ -101,9 +104,9 @@
val Type (_, [T1, T2]) = T
in
if i <= n2 then
- Const ("Sum_Type.Inl", T1 --> T) $ (mk_inj' T1 n2 i)
+ Const (@{const_name "Sum_Type.Inl"}, T1 --> T) $ (mk_inj' T1 n2 i)
else
- Const ("Sum_Type.Inr", T2 --> T) $ (mk_inj' T2 (n - n2) (i - n2))
+ Const (@{const_name "Sum_Type.Inr"}, T2 --> T) $ (mk_inj' T2 (n - n2) (i - n2))
end
in mk_inj' sumT (length leafTs) (1 + find_index (fn T'' => T'' = T') leafTs)
end;
@@ -193,7 +196,7 @@
QUIET_BREADTH_FIRST (has_fewer_prems 1)
(resolve_tac rep_intrs 1)))
(types_syntax ~~ tyvars ~~
- (Library.take (length newTs, rep_set_names)) ~~ new_type_names) ||>
+ (take (length newTs) rep_set_names) ~~ new_type_names) ||>
Sign.add_path big_name;
(*********************** definition of constructors ***********************)
@@ -472,7 +475,7 @@
iso_inj_thms_unfolded;
val iso_thms = if length descr = 1 then [] else
- Library.drop (length newTs, split_conj_thm
+ drop (length newTs) (split_conj_thm
(Skip_Proof.prove_global thy5 [] [] iso_t (fn _ => EVERY
[(indtac rep_induct [] THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1,
REPEAT (rtac TrueI 1),
@@ -630,4 +633,115 @@
((constr_inject', distinct_thms', dt_induct'), thy7)
end;
+
+
+(** definitional introduction of datatypes **)
+
+fun gen_add_datatype prep_typ config new_type_names dts thy =
+ let
+ val _ = Theory.requires thy "Datatype" "datatype definitions";
+
+ (* this theory is used just for parsing *)
+ val tmp_thy = thy |>
+ Theory.copy |>
+ Sign.add_types (map (fn (tvs, tname, mx, _) =>
+ (tname, length tvs, mx)) dts);
+
+ val (tyvars, _, _, _)::_ = dts;
+ val (new_dts, types_syntax) = ListPair.unzip (map (fn (tvs, tname, mx, _) =>
+ let val full_tname = Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname)
+ in
+ (case duplicates (op =) tvs of
+ [] =>
+ if eq_set (op =) (tyvars, tvs) then ((full_tname, tvs), (tname, mx))
+ else error ("Mutually recursive datatypes must have same type parameters")
+ | dups => error ("Duplicate parameter(s) for datatype " ^ quote (Binding.str_of tname) ^
+ " : " ^ commas dups))
+ end) dts);
+ val dt_names = map fst new_dts;
+
+ val _ =
+ (case duplicates (op =) (map fst new_dts) @ duplicates (op =) new_type_names of
+ [] => ()
+ | dups => error ("Duplicate datatypes: " ^ commas dups));
+
+ fun prep_dt_spec (tvs, tname, mx, constrs) tname' (dts', constr_syntax, sorts, i) =
+ let
+ fun prep_constr (cname, cargs, mx') (constrs, constr_syntax', sorts') =
+ let
+ val (cargs', sorts'') = fold_map (prep_typ tmp_thy) cargs sorts';
+ val _ =
+ (case subtract (op =) tvs (fold (curry OldTerm.add_typ_tfree_names) cargs' []) of
+ [] => ()
+ | vs => error ("Extra type variables on rhs: " ^ commas vs))
+ in (constrs @ [(Sign.full_name_path tmp_thy tname'
+ (Binding.map_name (Syntax.const_name mx') cname),
+ map (dtyp_of_typ new_dts) cargs')],
+ constr_syntax' @ [(cname, mx')], sorts'')
+ end handle ERROR msg => cat_error msg
+ ("The error above occured in constructor " ^ quote (Binding.str_of cname) ^
+ " of datatype " ^ quote (Binding.str_of tname));
+
+ val (constrs', constr_syntax', sorts') =
+ fold prep_constr constrs ([], [], sorts)
+
+ in
+ case duplicates (op =) (map fst constrs') of
+ [] =>
+ (dts' @ [(i, (Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname),
+ map DtTFree tvs, constrs'))],
+ constr_syntax @ [constr_syntax'], sorts', i + 1)
+ | dups => error ("Duplicate constructors " ^ commas dups ^
+ " in datatype " ^ quote (Binding.str_of tname))
+ end;
+
+ val (dts', constr_syntax, sorts', i) =
+ fold2 prep_dt_spec dts new_type_names ([], [], [], 0);
+ val sorts = sorts' @ map (rpair (Sign.defaultS tmp_thy)) (subtract (op =) (map fst sorts') tyvars);
+ val dt_info = Datatype_Data.get_all thy;
+ val (descr, _) = unfold_datatypes tmp_thy dts' sorts dt_info dts' i;
+ val _ = check_nonempty descr handle (exn as Datatype_Empty s) =>
+ if #strict config then error ("Nonemptiness check failed for datatype " ^ s)
+ else raise exn;
+
+ val _ = message config ("Constructing datatype(s) " ^ commas_quote new_type_names);
+
+ in
+ thy
+ |> representation_proofs config dt_info new_type_names descr sorts
+ types_syntax constr_syntax (Datatype_Data.mk_case_names_induct (flat descr))
+ |-> (fn (inject, distinct, induct) => Datatype_Data.derive_datatype_props
+ config dt_names (SOME new_type_names) descr sorts
+ induct inject distinct)
+ end;
+
+val add_datatype = gen_add_datatype Datatype_Data.cert_typ;
+val datatype_cmd = snd ooo gen_add_datatype Datatype_Data.read_typ default_config;
+
+local
+
+structure P = OuterParse and K = OuterKeyword
+
+fun prep_datatype_decls args =
+ let
+ val names = map
+ (fn ((((NONE, _), t), _), _) => Binding.name_of t | ((((SOME t, _), _), _), _) => t) args;
+ val specs = map (fn ((((_, vs), t), mx), cons) =>
+ (vs, t, mx, map (fn ((x, y), z) => (x, y, z)) cons)) args;
+ in (names, specs) end;
+
+val parse_datatype_decl =
+ (Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.type_args -- P.binding -- P.opt_infix --
+ (P.$$$ "=" |-- P.enum1 "|" (P.binding -- Scan.repeat P.typ -- P.opt_mixfix)));
+
+val parse_datatype_decls = P.and_list1 parse_datatype_decl >> prep_datatype_decls;
+
+in
+
+val _ =
+ OuterSyntax.command "datatype" "define inductive datatypes" K.thy_decl
+ (parse_datatype_decls >> (fn (names, specs) => Toplevel.theory (datatype_cmd names specs)));
+
end;
+
+end;
--- a/src/HOL/Tools/Function/fun.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/Function/fun.ML Mon Nov 30 08:08:31 2009 +0100
@@ -121,9 +121,9 @@
(Function_Split.split_all_equations ctxt compleqs)
fun restore_spec thms =
- bnds ~~ Library.take (length bnds, Library.unflat spliteqs thms)
+ bnds ~~ take (length bnds) (unflat spliteqs thms)
- val spliteqs' = flat (Library.take (length bnds, spliteqs))
+ val spliteqs' = flat (take (length bnds) spliteqs)
val fnames = map (fst o fst) fixes
val indices = map (fn eq => find_index (curry op = (fname_of eq)) fnames) spliteqs'
--- a/src/HOL/Tools/Function/sum_tree.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/Function/sum_tree.ML Mon Nov 30 08:08:31 2009 +0100
@@ -8,8 +8,8 @@
struct
(* Theory dependencies *)
-val proj_in_rules = [@{thm "Datatype.Projl_Inl"}, @{thm "Datatype.Projr_Inr"}]
-val sumcase_split_ss = HOL_basic_ss addsimps (@{thm "Product_Type.split"} :: @{thms "sum.cases"})
+val proj_in_rules = [@{thm Projl_Inl}, @{thm Projr_Inr}]
+val sumcase_split_ss = HOL_basic_ss addsimps (@{thm Product_Type.split} :: @{thms sum.cases})
(* top-down access in balanced tree *)
fun access_top_down {left, right, init} len i =
@@ -31,8 +31,8 @@
fun mk_proj ST n i =
access_top_down
{ init = (ST, I : term -> term),
- left = (fn (T as Type ("+", [LT, RT]), proj) => (LT, App (Const (@{const_name Datatype.Projl}, T --> LT)) o proj)),
- right =(fn (T as Type ("+", [LT, RT]), proj) => (RT, App (Const (@{const_name Datatype.Projr}, T --> RT)) o proj))} n i
+ left = (fn (T as Type ("+", [LT, RT]), proj) => (LT, App (Const (@{const_name Sum_Type.Projl}, T --> LT)) o proj)),
+ right =(fn (T as Type ("+", [LT, RT]), proj) => (RT, App (Const (@{const_name Sum_Type.Projr}, T --> RT)) o proj))} n i
|> snd
fun mk_sumcases T fs =
--- a/src/HOL/Tools/Groebner_Basis/groebner.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/Groebner_Basis/groebner.ML Mon Nov 30 08:08:31 2009 +0100
@@ -899,7 +899,7 @@
val (qs,p) = isolate_monomials vars eq
val rs = ideal (qs @ ps) p
(fn (s,t) => TermOrd.term_ord (term_of s, term_of t))
- in (eq,Library.take (length qs, rs) ~~ vars)
+ in (eq, take (length qs) rs ~~ vars)
end;
fun subst_in_poly i p = Thm.rhs_of (ring_normalize_conv (vsubst i p));
in
--- a/src/HOL/Tools/Nitpick/nitpick.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/Nitpick/nitpick.ML Mon Nov 30 08:08:31 2009 +0100
@@ -655,7 +655,7 @@
update_checked_problems problems (unsat_js @ map fst lib_ps);
if null con_ps then
let
- val num_genuine = Library.take (max_potential, lib_ps)
+ val num_genuine = take max_potential lib_ps
|> map (print_and_check false)
|> filter (equal (SOME true)) |> length
val max_genuine = max_genuine - num_genuine
@@ -689,7 +689,7 @@
end
else
let
- val _ = Library.take (max_genuine, con_ps)
+ val _ = take max_genuine con_ps
|> List.app (ignore o print_and_check true)
val max_genuine = max_genuine - length con_ps
in
--- a/src/HOL/Tools/Nitpick/nitpick_scope.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/Nitpick/nitpick_scope.ML Mon Nov 30 08:08:31 2009 +0100
@@ -496,7 +496,7 @@
bisim_depths mono_Ts nonmono_Ts
val ranks = map rank_of_block blocks
val all = all_combinations_ordered_smartly (map (rpair 0) ranks)
- val head = Library.take (max_scopes, all)
+ val head = take max_scopes all
val descs = map_filter (scope_descriptor_from_combination ext_ctxt blocks)
head
in
--- a/src/HOL/Tools/TFL/tfl.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/TFL/tfl.ML Mon Nov 30 08:08:31 2009 +0100
@@ -193,8 +193,7 @@
fun mk_pat (c,l) =
let val L = length (binder_types (type_of c))
fun build (prfx,tag,plist) =
- let val args = Library.take (L,plist)
- and plist' = Library.drop(L,plist)
+ let val (args, plist') = chop L plist
in (prfx,tag,list_comb(c,args)::plist') end
in map build l end;
--- a/src/HOL/Tools/inductive.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/inductive.ML Mon Nov 30 08:08:31 2009 +0100
@@ -213,7 +213,7 @@
fun make_bool_args' xs =
make_bool_args (K HOLogic.false_const) (K HOLogic.true_const) xs;
-fun arg_types_of k c = Library.drop (k, binder_types (fastype_of c));
+fun arg_types_of k c = drop k (binder_types (fastype_of c));
fun find_arg T x [] = sys_error "find_arg"
| find_arg T x ((p as (_, (SOME _, _))) :: ps) =
--- a/src/HOL/Tools/inductive_codegen.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/inductive_codegen.ML Mon Nov 30 08:08:31 2009 +0100
@@ -104,7 +104,7 @@
let
val cnstrs = flat (maps
(map (fn (_, (_, _, cs)) => map (apsnd length) cs) o #descr o snd)
- (Symtab.dest (Datatype.get_all thy)));
+ (Symtab.dest (Datatype_Data.get_all thy)));
fun check t = (case strip_comb t of
(Var _, []) => true
| (Const (s, _), ts) => (case AList.lookup (op =) cnstrs s of
--- a/src/HOL/Tools/inductive_realizer.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/inductive_realizer.ML Mon Nov 30 08:08:31 2009 +0100
@@ -67,7 +67,7 @@
val Tvs = map TVar iTs;
val (Const (s, _), ts) = strip_comb (HOLogic.dest_Trueprop
(Logic.strip_imp_concl (prop_of (hd intrs))));
- val params = map dest_Var (Library.take (nparms, ts));
+ val params = map dest_Var (take nparms ts);
val tname = Binding.name (space_implode "_" (Long_Name.base_name s ^ "T" :: vs));
fun constr_of_intr intr = (Binding.name (Long_Name.base_name (name_of_thm intr)),
map (Logic.unvarifyT o snd) (subtract (op =) params (rev (Term.add_vars (prop_of intr) []))) @
--- a/src/HOL/Tools/old_primrec.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/old_primrec.ML Mon Nov 30 08:08:31 2009 +0100
@@ -124,8 +124,8 @@
let
val fnameT' as (fname', _) = dest_Const f;
val (_, rpos, _) = the (AList.lookup (op =) rec_eqns fnameT');
- val ls = Library.take (rpos, ts);
- val rest = Library.drop (rpos, ts);
+ val ls = take rpos ts;
+ val rest = drop rpos ts;
val (x', rs) = (hd rest, tl rest)
handle Empty => raise RecError ("not enough arguments\
\ in recursive application\nof function " ^ quote fname' ^ " on rhs");
@@ -246,7 +246,7 @@
fun gen_primrec_i note def alt_name eqns_atts thy =
let
val (eqns, atts) = split_list eqns_atts;
- val dt_info = Datatype.get_all thy;
+ val dt_info = Datatype_Data.get_all thy;
val rec_eqns = fold_rev (process_eqn thy o snd) eqns [] ;
val tnames = distinct (op =) (map (#1 o snd) rec_eqns);
val dts = find_dts dt_info tnames tnames;
--- a/src/HOL/Tools/primrec.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/primrec.ML Mon Nov 30 08:08:31 2009 +0100
@@ -220,7 +220,7 @@
val eqns = fold_rev (process_eqn (fn v => Variable.is_fixed lthy v
orelse exists (fn ((w, _), _) => v = Binding.name_of w) fixes)) eqs [];
val tnames = distinct (op =) (map (#1 o snd) eqns);
- val dts = find_dts (Datatype.get_all (ProofContext.theory_of lthy)) tnames tnames;
+ val dts = find_dts (Datatype_Data.get_all (ProofContext.theory_of lthy)) tnames tnames;
val main_fns = map (fn (tname, {index, ...}) =>
(index, (fst o the o find_first (fn (_, x) => #1 x = tname)) eqns)) dts;
val {descr, rec_names, rec_rewrites, ...} =
--- a/src/HOL/Tools/record.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/record.ML Mon Nov 30 08:08:31 2009 +0100
@@ -321,7 +321,7 @@
fun rec_id i T =
let
val rTs = dest_recTs T;
- val rTs' = if i < 0 then rTs else Library.take (i, rTs);
+ val rTs' = if i < 0 then rTs else take i rTs;
in implode (map #1 rTs') end;
@@ -1582,7 +1582,7 @@
(Logic.strip_assums_concl (prop_of rule')));
(*ca indicates if rule is a case analysis or induction rule*)
val (x, ca) =
- (case rev (Library.drop (length params, ys)) of
+ (case rev (drop (length params) ys) of
[] => (head_of (fst (HOLogic.dest_eq (HOLogic.dest_Trueprop
(hd (rev (Logic.strip_assums_hyp (hd (prems_of rule')))))))), true)
| [x] => (head_of x, false));
@@ -1635,7 +1635,7 @@
else if len > 16 then
let
fun group16 [] = []
- | group16 xs = Library.take (16, xs) :: group16 (Library.drop (16, xs));
+ | group16 xs = take 16 xs :: group16 (drop 16 xs);
val vars' = group16 vars;
val (composites, (thy', i')) = fold_map mk_even_istuple vars' (thy, i);
in
@@ -1772,7 +1772,7 @@
fun chunks [] [] = []
| chunks [] xs = [xs]
- | chunks (l :: ls) xs = Library.take (l, xs) :: chunks ls (Library.drop (l, xs));
+ | chunks (l :: ls) xs = take l xs :: chunks ls (drop l xs);
fun chop_last [] = error "chop_last: list should not be empty"
| chop_last [x] = ([], x)
@@ -1881,12 +1881,12 @@
val extension_names = map (unsuffix ext_typeN o fst o #extension) parents @ [extN];
val extension_id = implode extension_names;
- fun rec_schemeT n = mk_recordT (map #extension (Library.drop (n, parents))) extT;
+ fun rec_schemeT n = mk_recordT (map #extension (drop n parents)) extT;
val rec_schemeT0 = rec_schemeT 0;
fun recT n =
let val (c, Ts) = extension in
- mk_recordT (map #extension (Library.drop (n, parents)))
+ mk_recordT (map #extension (drop n parents))
(Type (c, subst_last HOLogic.unitT Ts))
end;
val recT0 = recT 0;
@@ -1896,7 +1896,7 @@
val (args', more) = chop_last args;
fun mk_ext' ((name, T), args) more = mk_ext (name, T) (args @ [more]);
fun build Ts =
- fold_rev mk_ext' (Library.drop (n, (extension_names ~~ Ts) ~~ chunks parent_chunks args'))
+ fold_rev mk_ext' (drop n ((extension_names ~~ Ts) ~~ chunks parent_chunks args'))
more;
in
if more = HOLogic.unit
@@ -1989,7 +1989,7 @@
val (accessor_thms, updator_thms, upd_acc_cong_assists) =
timeit_msg "record getting tree access/updates:" get_access_update_thms;
- fun lastN xs = Library.drop (parent_fields_len, xs);
+ fun lastN xs = drop parent_fields_len xs;
(*selectors*)
fun mk_sel_spec ((c, T), thm) =
--- a/src/HOL/Tools/refute.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/refute.ML Mon Nov 30 08:08:31 2009 +0100
@@ -2889,7 +2889,7 @@
(* go back up the stack until we find a level where we can go *)
(* to the next sibling node *)
let
- val offsets' = Library.dropwhile
+ val offsets' = dropwhile
(fn off' => off' mod size_elem = size_elem - 1) offsets
in
case offsets' of
--- a/src/HOL/Tools/split_rule.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOL/Tools/split_rule.ML Mon Nov 30 08:08:31 2009 +0100
@@ -74,8 +74,8 @@
let
val cterm = Thm.cterm_of (Thm.theory_of_thm rl)
val (Us', U') = strip_type T;
- val Us = Library.take (length ts, Us');
- val U = Library.drop (length ts, Us') ---> U';
+ val Us = take (length ts) Us';
+ val U = drop (length ts) Us' ---> U';
val T' = maps HOLogic.flatten_tupleT Us ---> U;
fun mk_tuple (v as Var ((a, _), T)) (xs, insts) =
let
--- a/src/HOLCF/Tools/Domain/domain_extender.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/HOLCF/Tools/Domain/domain_extender.ML Mon Nov 30 08:08:31 2009 +0100
@@ -153,7 +153,7 @@
val thy' = thy'' |> Domain_Syntax.add_syntax false comp_dnam eqs';
val dts = map (Type o fst) eqs';
val new_dts = map (fn ((s,Ts),_) => (s, map (fst o dest_TFree) Ts)) eqs';
- fun strip ss = Library.drop (find_index (fn s => s = "'") ss + 1, ss);
+ fun strip ss = drop (find_index (fn s => s = "'") ss + 1) ss;
fun typid (Type (id,_)) =
let val c = hd (Symbol.explode (Long_Name.base_name id))
in if Symbol.is_letter c then c else "t" end
@@ -228,7 +228,7 @@
val thy' = thy'' |> Domain_Syntax.add_syntax true comp_dnam eqs';
val dts = map (Type o fst) eqs';
val new_dts = map (fn ((s,Ts),_) => (s, map (fst o dest_TFree) Ts)) eqs';
- fun strip ss = Library.drop (find_index (fn s => s = "'") ss + 1, ss);
+ fun strip ss = drop (find_index (fn s => s = "'") ss + 1) ss;
fun typid (Type (id,_)) =
let val c = hd (Symbol.explode (Long_Name.base_name id))
in if Symbol.is_letter c then c else "t" end
--- a/src/Provers/splitter.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Provers/splitter.ML Mon Nov 30 08:08:31 2009 +0100
@@ -122,8 +122,8 @@
fun down [] t i = Bound 0
| down (p::ps) t i =
let val (h,ts) = strip_comb t
- val v1 = ListPair.map var (Library.take(p,ts), i upto (i+p-1))
- val u::us = Library.drop(p,ts)
+ val v1 = ListPair.map var (take p ts, i upto (i+p-1))
+ val u::us = drop p ts
val v2 = ListPair.map var (us, (i+p) upto (i+length(ts)-2))
in list_comb(h,v1@[down ps u (i+length ts)]@v2) end;
in Abs("", T, down (rev pos) t maxi) end;
@@ -191,7 +191,7 @@
fun mk_split_pack (thm, T: typ, T', n, ts, apsns, pos, TB, t) =
if n > length ts then []
else let val lev = length apsns
- val lbnos = fold add_lbnos (Library.take (n, ts)) []
+ val lbnos = fold add_lbnos (take n ts) []
val flbnos = filter (fn i => i < lev) lbnos
val tt = incr_boundvars (~lev) t
in if null flbnos then
@@ -259,7 +259,7 @@
Const(c, cT) =>
let fun find [] = []
| find ((gcT, pat, thm, T, n)::tups) =
- let val t2 = list_comb (h, Library.take (n, ts))
+ let val t2 = list_comb (h, take n ts)
in if Sign.typ_instance sg (cT, gcT)
andalso fomatch sg (Ts,pat,t2)
then mk_split_pack(thm,T,T',n,ts,apsns,pos,type_of1(Ts,t2),t2)
--- a/src/Pure/General/path.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/General/path.ML Mon Nov 30 08:08:31 2009 +0100
@@ -139,7 +139,7 @@
val split_ext = split_path (fn (prfx, s) => apfst (append (Path prfx))
(case take_suffix (fn c => c <> ".") (explode s) of
([], _) => (Path [Basic s], "")
- | (cs, e) => (Path [Basic (implode (Library.take (length cs - 1, cs)))], implode e)));
+ | (cs, e) => (Path [Basic (implode (take (length cs - 1) cs))], implode e)));
(* expand variables *)
--- a/src/Pure/General/scan.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/General/scan.ML Mon Nov 30 08:08:31 2009 +0100
@@ -221,7 +221,7 @@
fun trace scan xs =
let val (y, xs') = scan xs
- in ((y, Library.take (length xs - length xs', xs)), xs') end;
+ in ((y, take (length xs - length xs') xs), xs') end;
(* stopper *)
--- a/src/Pure/General/symbol.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/General/symbol.ML Mon Nov 30 08:08:31 2009 +0100
@@ -183,7 +183,7 @@
val raw1 = raw0 o implode;
val raw2 = enclose "\\<^raw" ">" o string_of_int o ord;
- fun encode cs = enc (Library.take_prefix raw_chr cs)
+ fun encode cs = enc (take_prefix raw_chr cs)
and enc ([], []) = []
| enc (cs, []) = [raw1 cs]
| enc ([], d :: ds) = raw2 d :: encode ds
@@ -198,11 +198,11 @@
fun beginning n cs =
let
- val drop_blanks = #1 o Library.take_suffix is_ascii_blank;
+ val drop_blanks = #1 o take_suffix is_ascii_blank;
val all_cs = drop_blanks cs;
val dots = if length all_cs > n then " ..." else "";
in
- (drop_blanks (Library.take (n, all_cs))
+ (drop_blanks (take n all_cs)
|> map (fn c => if is_ascii_blank c then space else c)
|> implode) ^ dots
end;
@@ -491,8 +491,8 @@
fun strip_blanks s =
sym_explode s
- |> Library.take_prefix is_blank |> #2
- |> Library.take_suffix is_blank |> #1
+ |> take_prefix is_blank |> #2
+ |> take_suffix is_blank |> #1
|> implode;
@@ -516,7 +516,7 @@
then chr (ord s + 1) :: ss
else "a" :: s :: ss;
- val (ss, qs) = apfst rev (Library.take_suffix is_quasi (sym_explode str));
+ val (ss, qs) = apfst rev (take_suffix is_quasi (sym_explode str));
val ss' = if symbolic_end ss then "'" :: ss else bump ss;
in implode (rev ss' @ qs) end;
--- a/src/Pure/Isar/code.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/Isar/code.ML Mon Nov 30 08:08:31 2009 +0100
@@ -128,7 +128,7 @@
val args = args_of thm;
val incr_idx = Logic.incr_indexes ([], Thm.maxidx_of thm + 1);
fun matches_args args' = length args <= length args' andalso
- Pattern.matchess thy (args, (map incr_idx o curry Library.take (length args)) args');
+ Pattern.matchess thy (args, (map incr_idx o take (length args)) args');
fun drop (thm', proper') = if (proper orelse not proper')
andalso matches_args (args_of thm') then
(warning ("Code generator: dropping redundant code equation\n" ^
--- a/src/Pure/Isar/obtain.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/Isar/obtain.ML Mon Nov 30 08:08:31 2009 +0100
@@ -232,12 +232,12 @@
err ("Failed to unify variable " ^
string_of_term (Free (x, Envir.norm_type tyenv T)) ^ " against parameter " ^
string_of_term (Syntax.mark_boundT (y, Envir.norm_type tyenv U)) ^ " in") rule;
- val (tyenv, _) = fold unify (map #1 vars ~~ Library.take (m, params))
+ val (tyenv, _) = fold unify (map #1 vars ~~ take m params)
(Vartab.empty, Int.max (maxidx, Thm.maxidx_of rule));
val norm_type = Envir.norm_type tyenv;
val xs = map (apsnd norm_type o fst) vars;
- val ys = map (apsnd norm_type) (Library.drop (m, params));
+ val ys = map (apsnd norm_type) (drop m params);
val ys' = map Name.internal (Name.variant_list (map fst xs) (map fst ys)) ~~ map #2 ys;
val terms = map (Drule.mk_term o cert o Free) (xs @ ys');
--- a/src/Pure/Isar/proof_context.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/Isar/proof_context.ML Mon Nov 30 08:08:31 2009 +0100
@@ -1340,7 +1340,7 @@
val suppressed = len - ! prems_limit;
val prt_prems = if null prems then []
else [Pretty.big_list "prems:" ((if suppressed <= 0 then [] else [Pretty.str "..."]) @
- map (Display.pretty_thm ctxt) (Library.drop (suppressed, prems)))];
+ map (Display.pretty_thm ctxt) (drop suppressed prems))];
in prt_structs @ prt_fixes @ prt_prems end;
--- a/src/Pure/Isar/rule_cases.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/Isar/rule_cases.ML Mon Nov 30 08:08:31 2009 +0100
@@ -144,7 +144,7 @@
(Option.map (curry Logic.nth_prem i) rule_struct, Logic.nth_prem (i, prop))) () of
NONE => (name, NONE)
| SOME p => (name, extract_case is_open thy p name concls)) :: cs, i - 1);
- in fold_rev add_case (Library.drop (n - nprems, cases)) ([], n) |> #1 end;
+ in fold_rev add_case (drop (n - nprems) cases) ([], n) |> #1 end;
in
@@ -205,8 +205,8 @@
th
|> unfold_prems n defs
|> unfold_prems_concls defs
- |> Drule.multi_resolve (Library.take (m, facts))
- |> Seq.map (pair (xx, (n - m, Library.drop (m, facts))))
+ |> Drule.multi_resolve (take m facts)
+ |> Seq.map (pair (xx, (n - m, drop m facts)))
end;
end;
@@ -345,7 +345,7 @@
fun prep_rule n th =
let
val th' = Thm.permute_prems 0 n th;
- val prems = Library.take (Thm.nprems_of th' - n, Drule.cprems_of th');
+ val prems = take (Thm.nprems_of th' - n) (Drule.cprems_of th');
val th'' = Drule.implies_elim_list th' (map Thm.assume prems);
in (prems, (n, th'')) end;
--- a/src/Pure/Proof/extraction.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/Proof/extraction.ML Mon Nov 30 08:08:31 2009 +0100
@@ -461,7 +461,7 @@
end
else (vs', tye)
- in fold_rev add_args (Library.take (n, vars) ~~ Library.take (n, ts)) ([], []) end;
+ in fold_rev add_args (take n vars ~~ take n ts) ([], []) end;
fun find (vs: string list) = Option.map snd o find_first (curry (eq_set (op =)) vs o fst);
fun find' (s: string) = map_filter (fn (s', x) => if s = s' then SOME x else NONE);
--- a/src/Pure/Syntax/ast.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/Syntax/ast.ML Mon Nov 30 08:08:31 2009 +0100
@@ -158,7 +158,7 @@
(case (ast, pat) of
(Appl asts, Appl pats) =>
let val a = length asts and p = length pats in
- if a > p then (Appl (Library.take (p, asts)), Library.drop (p, asts))
+ if a > p then (Appl (take p asts), drop p asts)
else (ast, [])
end
| _ => (ast, []));
--- a/src/Pure/Syntax/syntax.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/Syntax/syntax.ML Mon Nov 30 08:08:31 2009 +0100
@@ -496,10 +496,10 @@
else if ! ambiguity_is_error then error (ambiguity_msg pos)
else
(warning (cat_lines
- (("Ambiguous input " ^ Position.str_of pos ^
+ (("Ambiguous input" ^ Position.str_of pos ^
"\nproduces " ^ string_of_int len ^ " parse trees" ^
(if len <= limit then "" else " (" ^ string_of_int limit ^ " displayed)") ^ ":") ::
- map show_pt (Library.take (limit, pts)))));
+ map show_pt (take limit pts))));
SynTrans.pts_to_asts ctxt (lookup_tr parse_ast_trtab) pts
end;
@@ -545,7 +545,7 @@
else cat_error (ambig_msg ()) (cat_lines
(("Ambiguous input, " ^ string_of_int len ^ " terms are type correct" ^
(if len <= limit then "" else " (" ^ string_of_int limit ^ " displayed)") ^ ":") ::
- map (Pretty.string_of_term pp) (Library.take (limit, results))))
+ map (Pretty.string_of_term pp) (take limit results)))
end;
fun standard_parse_term pp check get_sort map_const map_free map_type map_sort
--- a/src/Pure/Thy/present.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/Thy/present.ML Mon Nov 30 08:08:31 2009 +0100
@@ -285,7 +285,7 @@
(browser_info := empty_browser_info; session_info := NONE)
else
let
- val parent_name = name_of_session (Library.take (length path - 1, path));
+ val parent_name = name_of_session (take (length path - 1) path);
val session_name = name_of_session path;
val sess_prefix = Path.make path;
val html_prefix = Path.append (Path.expand output_path) sess_prefix;
--- a/src/Pure/Thy/thy_output.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/Thy/thy_output.ML Mon Nov 30 08:08:31 2009 +0100
@@ -265,7 +265,7 @@
if nesting = 0 andalso not (Toplevel.is_proof state) then tag_stack
else if nesting >= 0 then (tag', replicate nesting tag @ tags)
else
- (case Library.drop (~ nesting - 1, tags) of
+ (case drop (~ nesting - 1) tags of
tgs :: tgss => (tgs, tgss)
| [] => err_bad_nesting (Position.str_of cmd_pos));
--- a/src/Pure/Tools/find_theorems.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/Tools/find_theorems.ML Mon Nov 30 08:08:31 2009 +0100
@@ -409,7 +409,7 @@
val len = length matches;
val lim = the_default (! limit) opt_limit;
- in (SOME len, Library.drop (len - lim, matches)) end;
+ in (SOME len, drop (len - lim) matches) end;
val find =
if rem_dups orelse is_none opt_limit
--- a/src/Pure/assumption.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/assumption.ML Mon Nov 30 08:08:31 2009 +0100
@@ -88,12 +88,12 @@
(* local assumptions *)
fun local_assumptions_of inner outer =
- Library.drop (length (all_assumptions_of outer), all_assumptions_of inner);
+ drop (length (all_assumptions_of outer)) (all_assumptions_of inner);
val local_assms_of = maps #2 oo local_assumptions_of;
fun local_prems_of inner outer =
- Library.drop (length (all_prems_of outer), all_prems_of inner);
+ drop (length (all_prems_of outer)) (all_prems_of inner);
(* add assumptions *)
--- a/src/Pure/codegen.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/codegen.ML Mon Nov 30 08:08:31 2009 +0100
@@ -579,11 +579,11 @@
fun eta_expand t ts i =
let
val k = length ts;
- val Ts = Library.drop (k, binder_types (fastype_of t));
+ val Ts = drop k (binder_types (fastype_of t));
val j = i - k
in
List.foldr (fn (T, t) => Abs ("x", T, t))
- (list_comb (t, ts @ map Bound (j-1 downto 0))) (Library.take (j, Ts))
+ (list_comb (t, ts @ map Bound (j-1 downto 0))) (take j Ts)
end;
fun mk_app _ p [] = p
--- a/src/Pure/goal_display.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/goal_display.ML Mon Nov 30 08:08:31 2009 +0100
@@ -99,7 +99,7 @@
(if main then [prt_term B] else []) @
(if ngoals = 0 then [Pretty.str "No subgoals!"]
else if ngoals > maxgoals then
- pretty_subgoals (Library.take (maxgoals, As)) @
+ pretty_subgoals (take maxgoals As) @
(if total then [Pretty.str ("A total of " ^ string_of_int ngoals ^ " subgoals...")]
else [])
else pretty_subgoals As) @
--- a/src/Pure/library.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/library.ML Mon Nov 30 08:08:31 2009 +0100
@@ -81,6 +81,8 @@
val filter: ('a -> bool) -> 'a list -> 'a list
val filter_out: ('a -> bool) -> 'a list -> 'a list
val map_filter: ('a -> 'b option) -> 'a list -> 'b list
+ val take: int -> 'a list -> 'a list
+ val drop: int -> 'a list -> 'a list
val chop: int -> 'a list -> 'a list * 'a list
val dropwhile: ('a -> bool) -> 'a list -> 'a list
val nth: 'a list -> int -> 'a
@@ -224,8 +226,6 @@
val foldl: ('a * 'b -> 'a) -> 'a * 'b list -> 'a
val foldr: ('a * 'b -> 'b) -> 'a list * 'b -> 'b
val foldl_map: ('a * 'b -> 'a * 'c) -> 'a * 'b list -> 'a * 'c list
- val take: int * 'a list -> 'a list
- val drop: int * 'a list -> 'a list
val last_elem: 'a list -> 'a
end;
@@ -423,20 +423,20 @@
fun filter_out f = filter (not o f);
val map_filter = List.mapPartial;
+fun take (0: int) xs = []
+ | take _ [] = []
+ | take n (x :: xs) =
+ if n > 0 then x :: take (n - 1) xs else [];
+
+fun drop (0: int) xs = xs
+ | drop _ [] = []
+ | drop n (x :: xs) =
+ if n > 0 then drop (n - 1) xs else x :: xs;
+
fun chop (0: int) xs = ([], xs)
| chop _ [] = ([], [])
| chop n (x :: xs) = chop (n - 1) xs |>> cons x;
-(*take the first n elements from a list*)
-fun take (n: int, []) = []
- | take (n, x :: xs) =
- if n > 0 then x :: take (n - 1, xs) else [];
-
-(*drop the first n elements from a list*)
-fun drop (n: int, []) = []
- | drop (n, x :: xs) =
- if n > 0 then drop (n - 1, xs) else x :: xs;
-
fun dropwhile P [] = []
| dropwhile P (ys as x::xs) = if P x then dropwhile P xs else ys;
--- a/src/Pure/meta_simplifier.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/meta_simplifier.ML Mon Nov 30 08:08:31 2009 +0100
@@ -1163,9 +1163,9 @@
val (rrs', asm') = rules_of_prem ss prem'
in mut_impc prems concl rrss asms (prem' :: prems')
(rrs' :: rrss') (asm' :: asms') (SOME (fold_rev (disch true)
- (Library.take (i, prems))
+ (take i prems)
(Drule.imp_cong_rule eqn (reflexive (Drule.list_implies
- (Library.drop (i, prems), concl))))) :: eqns)
+ (drop i prems, concl))))) :: eqns)
ss (length prems') ~1
end
--- a/src/Pure/proofterm.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/proofterm.ML Mon Nov 30 08:08:31 2009 +0100
@@ -1003,7 +1003,7 @@
| _ => error "shrink: proof not in normal form");
val vs = vars_of prop;
val (ts', ts'') = chop (length vs) ts;
- val insts = Library.take (length ts', map (fst o dest_Var) vs) ~~ ts';
+ val insts = take (length ts') (map (fst o dest_Var) vs) ~~ ts';
val nvs = Library.foldl (fn (ixns', (ixn, ixns)) =>
insert (op =) ixn (case AList.lookup (op =) insts ixn of
SOME (SOME t) => if is_proj t then union (op =) ixns ixns' else ixns'
--- a/src/Pure/pure_setup.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/pure_setup.ML Mon Nov 30 08:08:31 2009 +0100
@@ -39,6 +39,11 @@
then use "ML-Systems/install_pp_polyml.ML"
else ();
+if ml_system = "polyml-5.0" orelse ml_system = "polyml-5.1" then
+ Secure.use_text ML_Parse.global_context (0, "") false
+ "PolyML.Compiler.maxInlineSize := 20"
+else ();
+
(* ML toplevel use commands *)
--- a/src/Pure/tactic.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/tactic.ML Mon Nov 30 08:08:31 2009 +0100
@@ -173,7 +173,7 @@
perm_tac 0 (1 - i);
fun distinct_subgoal_tac i st =
- (case Library.drop (i - 1, Thm.prems_of st) of
+ (case drop (i - 1) (Thm.prems_of st) of
[] => no_tac st
| A :: Bs =>
st |> EVERY (fold (fn (B, k) =>
--- a/src/Pure/thm.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/thm.ML Mon Nov 30 08:08:31 2009 +0100
@@ -1457,7 +1457,7 @@
val short = length iparams - length cs;
val newnames =
if short < 0 then error "More names than abstractions!"
- else Name.variant_list cs (Library.take (short, iparams)) @ cs;
+ else Name.variant_list cs (take short iparams) @ cs;
val freenames = Term.fold_aterms (fn Free (x, _) => insert (op =) x | _ => I) Bi [];
val newBi = Logic.list_rename_params (newnames, Bi);
in
--- a/src/Pure/variable.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Pure/variable.ML Mon Nov 30 08:08:31 2009 +0100
@@ -345,7 +345,7 @@
val fixes_inner = fixes_of inner;
val fixes_outer = fixes_of outer;
- val gen_fixes = map #2 (Library.take (length fixes_inner - length fixes_outer, fixes_inner));
+ val gen_fixes = map #2 (take (length fixes_inner - length fixes_outer) fixes_inner);
val still_fixed = not o member (op =) gen_fixes;
val type_occs_inner = type_occs_of inner;
--- a/src/Tools/Code/code_haskell.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Tools/Code/code_haskell.ML Mon Nov 30 08:08:31 2009 +0100
@@ -78,7 +78,7 @@
and pr_app' tyvars thm vars ((c, (_, tys)), ts) = case contr_classparam_typs c
of [] => (str o deresolve) c :: map (pr_term tyvars thm vars BR) ts
| fingerprint => let
- val ts_fingerprint = ts ~~ curry Library.take (length ts) fingerprint;
+ val ts_fingerprint = ts ~~ take (length ts) fingerprint;
val needs_annotation = forall (fn (_, NONE) => true | (t, SOME _) =>
(not o Code_Thingol.locally_monomorphic) t) ts_fingerprint;
fun pr_term_anno (t, NONE) _ = pr_term tyvars thm vars BR t
@@ -86,7 +86,7 @@
brackets [pr_term tyvars thm vars NOBR t, str "::", pr_typ tyvars NOBR ty];
in
if needs_annotation then
- (str o deresolve) c :: map2 pr_term_anno ts_fingerprint (curry Library.take (length ts) tys)
+ (str o deresolve) c :: map2 pr_term_anno ts_fingerprint (take (length ts) tys)
else (str o deresolve) c :: map (pr_term tyvars thm vars BR) ts
end
and pr_app tyvars = gen_pr_app (pr_app' tyvars) (pr_term tyvars) syntax_const
--- a/src/Tools/Code/code_printer.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Tools/Code/code_printer.ML Mon Nov 30 08:08:31 2009 +0100
@@ -231,7 +231,7 @@
of NONE => brackify fxy (pr_app thm vars app)
| SOME (k, pr) =>
let
- fun pr' fxy ts = pr (pr_term thm) thm vars fxy (ts ~~ curry Library.take k tys);
+ fun pr' fxy ts = pr (pr_term thm) thm vars fxy (ts ~~ take k tys);
in if k = length ts
then pr' fxy ts
else if k < length ts
--- a/src/Tools/Code/code_thingol.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Tools/Code/code_thingol.ML Mon Nov 30 08:08:31 2009 +0100
@@ -226,7 +226,7 @@
val l = k - j;
val ctxt = (fold o fold_varnames) Name.declare ts Name.context;
val vs_tys = (map o apfst) SOME
- (Name.names ctxt "a" ((curry Library.take l o curry Library.drop j) tys));
+ (Name.names ctxt "a" ((take l o drop j) tys));
in vs_tys `|==> IConst c `$$ ts @ map (IVar o fst) vs_tys end;
fun contains_dictvar t =
@@ -773,7 +773,7 @@
val clauses = if null case_pats
then mk_clause (fn ([t], body) => (t, body)) [ty] (the_single ts_clause)
else maps (fn ((constr as IConst (_, (_, tys)), n), t) =>
- mk_clause (fn (ts, body) => (constr `$$ ts, body)) (curry Library.take n tys) t)
+ mk_clause (fn (ts, body) => (constr `$$ ts, body)) (take n tys) t)
(constrs ~~ ts_clause);
in ((t, ty), clauses) end;
in
@@ -788,7 +788,7 @@
if length ts < num_args then
let
val k = length ts;
- val tys = (curry Library.take (num_args - k) o curry Library.drop k o fst o strip_type) ty;
+ val tys = (take (num_args - k) o drop k o fst o strip_type) ty;
val ctxt = (fold o fold_aterms) Term.declare_term_frees ts Name.context;
val vs = Name.names ctxt "a" tys;
in
@@ -797,8 +797,8 @@
#>> (fn (tys, t) => map2 (fn (v, _) => pair (SOME v)) vs tys `|==> t)
end
else if length ts > num_args then
- translate_case thy algbr eqngr thm case_scheme ((c, ty), Library.take (num_args, ts))
- ##>> fold_map (translate_term thy algbr eqngr thm) (Library.drop (num_args, ts))
+ translate_case thy algbr eqngr thm case_scheme ((c, ty), take num_args ts)
+ ##>> fold_map (translate_term thy algbr eqngr thm) (drop num_args ts)
#>> (fn (t, ts) => t `$$ ts)
else
translate_case thy algbr eqngr thm case_scheme ((c, ty), ts)
--- a/src/Tools/induct.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Tools/induct.ML Mon Nov 30 08:08:31 2009 +0100
@@ -280,11 +280,11 @@
fun align_left msg xs ys =
let val m = length xs and n = length ys
- in if m < n then error msg else (Library.take (n, xs) ~~ ys) end;
+ in if m < n then error msg else (take n xs ~~ ys) end;
fun align_right msg xs ys =
let val m = length xs and n = length ys
- in if m < n then error msg else (Library.drop (m - n, xs) ~~ ys) end;
+ in if m < n then error msg else (drop (m - n) xs ~~ ys) end;
(* prep_inst *)
--- a/src/Tools/induct_tacs.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/Tools/induct_tacs.ML Mon Nov 30 08:08:31 2009 +0100
@@ -59,7 +59,7 @@
fun prep_inst (concl, xs) =
let val vs = Induct.vars_of concl
- in map_filter prep_var (Library.drop (length vs - length xs, vs) ~~ xs) end;
+ in map_filter prep_var (drop (length vs - length xs) vs ~~ xs) end;
in
--- a/src/ZF/Tools/cartprod.ML Sun Nov 29 12:56:30 2009 +1100
+++ b/src/ZF/Tools/cartprod.ML Mon Nov 30 08:08:31 2009 +0100
@@ -96,8 +96,8 @@
(*Makes a nested tuple from a list, following the product type structure*)
fun mk_tuple pair (Type("*", [T1,T2])) tms =
- pair $ (mk_tuple pair T1 tms)
- $ (mk_tuple pair T2 (Library.drop (length (factors T1), tms)))
+ pair $ mk_tuple pair T1 tms
+ $ mk_tuple pair T2 (drop (length (factors T1)) tms)
| mk_tuple pair T (t::_) = t;
(*Attempts to remove occurrences of split, and pair-valued parameters*)