# HG changeset patch # User haftmann # Date 1249892700 -7200 # Node ID 96f9e6402403c5d1e9e50ec5bc4be5b6b0e58e0b # Parent 5ef633275b15a096a21f35a3ec650876f627717b# Parent e88b295aae351f732d56b51105b347d7dfc0d8d5 merged diff -r 5ef633275b15 -r 96f9e6402403 Admin/isatest/isatest-makeall --- a/Admin/isatest/isatest-makeall Mon Aug 10 08:37:37 2009 +0200 +++ b/Admin/isatest/isatest-makeall Mon Aug 10 10:25:00 2009 +0200 @@ -80,6 +80,11 @@ NICE="" ;; + macbroy21) + MFLAGS="-k" + NICE="" + ;; + macbroy23) MFLAGS="-k -j 2" NICE="nice" diff -r 5ef633275b15 -r 96f9e6402403 Admin/isatest/isatest-makedist --- a/Admin/isatest/isatest-makedist Mon Aug 10 08:37:37 2009 +0200 +++ b/Admin/isatest/isatest-makedist Mon Aug 10 10:25:00 2009 +0200 @@ -106,7 +106,7 @@ sleep 15 $SSH atbroy101 "$MAKEALL $HOME/settings/at64-poly" sleep 15 -$SSH macbroy2 "$MAKEALL $HOME/settings/mac-poly-M4; $MAKEALL $HOME/settings/mac-poly-M8; $MAKEALL $HOME/settings/mac-poly64-M4" +$SSH macbroy2 "$MAKEALL $HOME/settings/mac-poly-M4; $MAKEALL $HOME/settings/mac-poly-M8; $MAKEALL $HOME/settings/mac-poly64-M4; $MAKEALL $HOME/settings/mac-poly64-M8" sleep 15 $SSH macbroy5 "$MAKEALL $HOME/settings/mac-poly" sleep 15 diff -r 5ef633275b15 -r 96f9e6402403 Admin/isatest/isatest-stats --- a/Admin/isatest/isatest-stats Mon Aug 10 08:37:37 2009 +0200 +++ b/Admin/isatest/isatest-stats Mon Aug 10 10:25:00 2009 +0200 @@ -6,7 +6,7 @@ THIS=$(cd "$(dirname "$0")"; pwd -P) -PLATFORMS="at-poly at64-poly mac-poly-M4 mac-poly-M8 at-poly-5.1-para-e at64-poly-5.1-para at-mac-poly-5.1-para afp at-sml-dev" +PLATFORMS="at-poly at64-poly mac-poly-M4 mac-poly64-M4 mac-poly-M8 at-poly-5.1-para-e at64-poly-5.1-para at-mac-poly-5.1-para afp at-sml-dev" ISABELLE_SESSIONS="\ HOL-Plain \ diff -r 5ef633275b15 -r 96f9e6402403 Admin/isatest/settings/at-poly --- a/Admin/isatest/settings/at-poly Mon Aug 10 08:37:37 2009 +0200 +++ b/Admin/isatest/settings/at-poly Mon Aug 10 10:25:00 2009 +0200 @@ -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" +ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -t true" HOL_USEDIR_OPTIONS="-p 2" diff -r 5ef633275b15 -r 96f9e6402403 Admin/isatest/settings/mac-poly64-M4 --- a/Admin/isatest/settings/mac-poly64-M4 Mon Aug 10 08:37:37 2009 +0200 +++ b/Admin/isatest/settings/mac-poly64-M4 Mon Aug 10 10:25:00 2009 +0200 @@ -4,7 +4,7 @@ ML_SYSTEM="polyml-experimental" ML_PLATFORM="x86_64-darwin" ML_HOME="$POLYML_HOME/$ML_PLATFORM" - ML_OPTIONS="--mutable 2000 --immutable 2000" + ML_OPTIONS="--mutable 5000 --immutable 2000" ISABELLE_HOME_USER=~/isabelle-mac-poly64-M4 @@ -23,6 +23,6 @@ ISABELLE_OUTPUT="$ISABELLE_HOME_USER/heaps" ISABELLE_BROWSER_INFO="$ISABELLE_HOME_USER/browser_info" -ISABELLE_USEDIR_OPTIONS="-i false -d false -M 4" +ISABELLE_USEDIR_OPTIONS="-i false -d false -M 4 -q 2 -t true" -HOL_USEDIR_OPTIONS="-p 2 -q 1" +HOL_USEDIR_OPTIONS="-p 2 -q 2" diff -r 5ef633275b15 -r 96f9e6402403 Admin/isatest/settings/mac-poly64-M8 --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Admin/isatest/settings/mac-poly64-M8 Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,28 @@ +# -*- shell-script -*- :mode=shellscript: + + POLYML_HOME="/home/polyml/polyml-svn" + ML_SYSTEM="polyml-experimental" + ML_PLATFORM="x86_64-darwin" + ML_HOME="$POLYML_HOME/$ML_PLATFORM" + ML_OPTIONS="--mutable 5000 --immutable 2000" + + +ISABELLE_HOME_USER=~/isabelle-mac-poly64-M8 + +# Where to look for isabelle tools (multiple dirs separated by ':'). +ISABELLE_TOOLS="$ISABELLE_HOME/lib/Tools" + +# Location for temporary files (should be on a local file system). +ISABELLE_TMP_PREFIX="/tmp/isabelle-$USER" + + +# Heap input locations. ML system identifier is included in lookup. +ISABELLE_PATH="$ISABELLE_HOME_USER/heaps:$ISABELLE_HOME/heaps" + +# Heap output location. ML system identifier is appended automatically later on. +ISABELLE_OUTPUT="$ISABELLE_HOME_USER/heaps" +ISABELLE_BROWSER_INFO="$ISABELLE_HOME_USER/browser_info" + +ISABELLE_USEDIR_OPTIONS="-i false -d false -M 8 -q 2 -t true" + +HOL_USEDIR_OPTIONS="-p 2 -q 2" diff -r 5ef633275b15 -r 96f9e6402403 NEWS --- a/NEWS Mon Aug 10 08:37:37 2009 +0200 +++ b/NEWS Mon Aug 10 10:25:00 2009 +0200 @@ -175,6 +175,12 @@ *** System *** +* Support for additional "Isabelle components" via etc/components, see +also the system manual. + +* The isabelle makeall tool now operates on all components with +IsaMakefile, not just hardwired "logics". + * Discontinued support for Poly/ML 4.x versions. * Removed "compress" option from isabelle-process and isabelle usedir; diff -r 5ef633275b15 -r 96f9e6402403 bin/isabelle --- a/bin/isabelle Mon Aug 10 08:37:37 2009 +0200 +++ b/bin/isabelle Mon Aug 10 10:25:00 2009 +0200 @@ -17,6 +17,8 @@ ISABELLE_HOME="$(cd "$(dirname "$0")"; cd "$(pwd -P)"; cd ..; pwd)" source "$ISABELLE_HOME/lib/scripts/getsettings" || exit 2 +ORIG_IFS="$IFS"; IFS=":"; declare -a TOOLS=($ISABELLE_TOOLS); IFS="$ORIG_IFS" + ## diagnostics @@ -28,24 +30,19 @@ echo " Start Isabelle tool NAME with ARGS; pass \"-?\" for tool specific help." echo echo " Available tools are:" - ( - ORIG_IFS="$IFS" - IFS=":" - for DIR in $ISABELLE_TOOLS - do - if [ -d "$DIR" ]; then - cd "$DIR" - for T in * - do - if [ -f "$T" -a -x "$T" ]; then - DESCRLINE=$(fgrep DESCRIPTION: "$T" | sed -e 's/^.*DESCRIPTION: *//') - echo " $T - $DESCRLINE" - fi - done - fi - done - IFS="$ORIG_IFS" - ) + for DIR in ${TOOLS[@]} + do + if [ -d "$DIR" ]; then + for TOOL in "$DIR"/* + do + if [ -f "$TOOL" -a -x "$TOOL" ]; then + NAME="$(basename "$TOOL")" + DESCRLINE="$(fgrep DESCRIPTION: "$TOOL" | sed -e 's/^.*DESCRIPTION: *//')" + echo " $NAME - $DESCRLINE" + fi + done + fi + done exit 1 } @@ -66,13 +63,10 @@ ## main -ORIG_IFS="$IFS" -IFS=":" -for DIR in $ISABELLE_TOOLS +for DIR in "${TOOLS[@]}" do TOOL="$DIR/$TOOLNAME" [ -f "$TOOL" -a -x "$TOOL" ] && exec "$TOOL" "$@" done -IFS="$ORIG_IFS" fail "Unknown Isabelle tool: $TOOLNAME" diff -r 5ef633275b15 -r 96f9e6402403 bin/isabelle-process --- a/bin/isabelle-process Mon Aug 10 08:37:37 2009 +0200 +++ b/bin/isabelle-process Mon Aug 10 10:25:00 2009 +0200 @@ -160,15 +160,13 @@ INFILE="" ISA_PATH="" - ORIG_IFS="$IFS" - IFS=":" - for DIR in $ISABELLE_PATH + ORIG_IFS="$IFS"; IFS=":"; declare -a PATHS=($ISABELLE_PATH); IFS="$ORIG_IFS" + for DIR in "${PATHS[@]}" do DIR="$DIR/$ML_IDENTIFIER" ISA_PATH="$ISA_PATH $DIR\n" [ -z "$INFILE" -a -f "$DIR/$INPUT" ] && INFILE="$DIR/$INPUT" done - IFS="$ORIG_IFS" if [ -z "$INFILE" ]; then echo "Unknown logic \"$INPUT\" -- no heap file found in:" >&2 diff -r 5ef633275b15 -r 96f9e6402403 doc-src/IsarImplementation/Thy/Proof.thy --- a/doc-src/IsarImplementation/Thy/Proof.thy Mon Aug 10 08:37:37 2009 +0200 +++ b/doc-src/IsarImplementation/Thy/Proof.thy Mon Aug 10 10:25:00 2009 +0200 @@ -94,7 +94,7 @@ @{index_ML Variable.export: "Proof.context -> Proof.context -> thm list -> thm list"} \\ @{index_ML Variable.polymorphic: "Proof.context -> term list -> term list"} \\ @{index_ML Variable.import: "bool -> thm list -> Proof.context -> - ((ctyp list * cterm list) * thm list) * Proof.context"} \\ + (((ctyp * ctyp) list * (cterm * cterm) list) * thm list) * Proof.context"} \\ @{index_ML Variable.focus: "cterm -> Proof.context -> ((string * cterm) list * cterm) * Proof.context"} \\ \end{mldecls} diff -r 5ef633275b15 -r 96f9e6402403 doc-src/IsarImplementation/Thy/document/Proof.tex --- a/doc-src/IsarImplementation/Thy/document/Proof.tex Mon Aug 10 08:37:37 2009 +0200 +++ b/doc-src/IsarImplementation/Thy/document/Proof.tex Mon Aug 10 10:25:00 2009 +0200 @@ -112,7 +112,7 @@ \indexdef{}{ML}{Variable.export}\verb|Variable.export: Proof.context -> Proof.context -> thm list -> thm list| \\ \indexdef{}{ML}{Variable.polymorphic}\verb|Variable.polymorphic: Proof.context -> term list -> term list| \\ \indexdef{}{ML}{Variable.import}\verb|Variable.import: bool -> thm list -> Proof.context ->|\isasep\isanewline% -\verb| ((ctyp list * cterm list) * thm list) * Proof.context| \\ +\verb| (((ctyp * ctyp) list * (cterm * cterm) list) * thm list) * Proof.context| \\ \indexdef{}{ML}{Variable.focus}\verb|Variable.focus: cterm -> Proof.context -> ((string * cterm) list * cterm) * Proof.context| \\ \end{mldecls} diff -r 5ef633275b15 -r 96f9e6402403 doc-src/System/Thy/Basics.thy --- a/doc-src/System/Thy/Basics.thy Mon Aug 10 08:37:37 2009 +0200 +++ b/doc-src/System/Thy/Basics.thy Mon Aug 10 10:25:00 2009 +0200 @@ -59,11 +59,14 @@ *} -subsection {* Building the environment *} +subsection {* Bootstrapping the environment \label{sec:boot} *} -text {* - Whenever any of the Isabelle executables is run, their settings - environment is put together as follows. +text {* Isabelle executables need to be run within a proper settings + environment. This is bootstrapped as described below, on the first + invocation of one of the outer wrapper scripts (such as + @{executable_ref isabelle}). This happens only once for each + process tree, i.e.\ the environment is passed to subprocesses + according to regular Unix conventions. \begin{enumerate} @@ -78,7 +81,7 @@ links are admissible, but a plain copy of the @{"file" "$ISABELLE_HOME/bin"} files will not work! - \item The file @{"file" "$ISABELLE_HOME/etc/settings"} ist run as a + \item The file @{"file" "$ISABELLE_HOME/etc/settings"} is run as a @{executable_ref bash} shell script with the auto-export option for variables enabled. @@ -252,6 +255,52 @@ *} +subsection {* Additional components \label{sec:components} *} + +text {* Any directory may be registered as an explicit \emph{Isabelle + component}. The general layout conventions are that of the main + Isabelle distribution itself, and the following two files (both + optional) have a special meaning: + + \begin{itemize} + + \item @{verbatim "etc/settings"} holds additional settings that are + initialized when bootstrapping the overall Isabelle environment, + cf.\ \secref{sec:boot}. As usual, the content is interpreted as a + @{verbatim bash} script. It may refer to the component's enclosing + directory via the @{verbatim "COMPONENT"} shell variable. + + For example, the following setting allows to refer to files within + the component later on, without having to hardwire absolute paths: + + \begin{ttbox} + MY_COMPONENT_HOME="$COMPONENT" + \end{ttbox} + + Components can also add to existing Isabelle settings such as + @{setting_def ISABELLE_TOOLS}, in order to provide + component-specific tools that can be invoked by end-users. For + example: + + \begin{ttbox} + ISABELLE_TOOLS="$ISABELLE_TOOLS:$COMPONENT/lib/Tools" + \end{ttbox} + + \item @{verbatim "etc/components"} holds a list of further + sub-components of the same structure. The directory specifications + given here can be either absolute (with leading @{verbatim "/"}) or + relative to the component's main directory. + + \end{itemize} + + The root of component initialization is @{setting ISABELLE_HOME} + itself. After initializing all of its sub-components recursively, + @{setting ISABELLE_HOME_USER} is included in the same manner (if + that directory exists). Thus users can easily add private + components to @{verbatim "$ISABELLE_HOME_USER/etc/components"}. +*} + + section {* The raw Isabelle process *} text {* diff -r 5ef633275b15 -r 96f9e6402403 doc-src/System/Thy/Misc.thy --- a/doc-src/System/Thy/Misc.thy Mon Aug 10 08:37:37 2009 +0200 +++ b/doc-src/System/Thy/Misc.thy Mon Aug 10 10:25:00 2009 +0200 @@ -225,13 +225,13 @@ section {* Make all logics *} -text {* - The @{tool_def makeall} utility applies Isabelle make to all logic - directories of the distribution: +text {* The @{tool_def makeall} utility applies Isabelle make to any + Isabelle component (cf.\ \secref{sec:components}) that contains an + @{verbatim IsaMakefile}: \begin{ttbox} Usage: makeall [ARGS ...] - Apply isabelle make to all logics (passing ARGS). + Apply isabelle make to all components with IsaMakefile (passing ARGS). \end{ttbox} The arguments @{verbatim ARGS} are just passed verbatim to each diff -r 5ef633275b15 -r 96f9e6402403 doc-src/System/Thy/document/Basics.tex --- a/doc-src/System/Thy/document/Basics.tex Mon Aug 10 08:37:37 2009 +0200 +++ b/doc-src/System/Thy/document/Basics.tex Mon Aug 10 10:25:00 2009 +0200 @@ -76,13 +76,17 @@ \end{isamarkuptext}% \isamarkuptrue% % -\isamarkupsubsection{Building the environment% +\isamarkupsubsection{Bootstrapping the environment \label{sec:boot}% } \isamarkuptrue% % \begin{isamarkuptext}% -Whenever any of the Isabelle executables is run, their settings - environment is put together as follows. +Isabelle executables need to be run within a proper settings + environment. This is bootstrapped as described below, on the first + invocation of one of the outer wrapper scripts (such as + \indexref{}{executable}{isabelle}\hyperlink{executable.isabelle}{\mbox{\isa{\isatt{isabelle}}}}). This happens only once for each + process tree, i.e.\ the environment is passed to subprocesses + according to regular Unix conventions. \begin{enumerate} @@ -96,7 +100,7 @@ executable objects created by the \hyperlink{tool.install}{\mbox{\isa{\isatt{install}}}} utility. Symbolic links are admissible, but a plain copy of the \hyperlink{file.$ISABELLE-HOME/bin}{\mbox{\isa{\isatt{{\isachardollar}ISABELLE{\isacharunderscore}HOME{\isacharslash}bin}}}} files will not work! - \item The file \hyperlink{file.$ISABELLE-HOME/etc/settings}{\mbox{\isa{\isatt{{\isachardollar}ISABELLE{\isacharunderscore}HOME{\isacharslash}etc{\isacharslash}settings}}}} ist run as a + \item The file \hyperlink{file.$ISABELLE-HOME/etc/settings}{\mbox{\isa{\isatt{{\isachardollar}ISABELLE{\isacharunderscore}HOME{\isacharslash}etc{\isacharslash}settings}}}} is run as a \indexref{}{executable}{bash}\hyperlink{executable.bash}{\mbox{\isa{\isatt{bash}}}} shell script with the auto-export option for variables enabled. @@ -259,6 +263,55 @@ \end{isamarkuptext}% \isamarkuptrue% % +\isamarkupsubsection{Additional components \label{sec:components}% +} +\isamarkuptrue% +% +\begin{isamarkuptext}% +Any directory may be registered as an explicit \emph{Isabelle + component}. The general layout conventions are that of the main + Isabelle distribution itself, and the following two files (both + optional) have a special meaning: + + \begin{itemize} + + \item \verb|etc/settings| holds additional settings that are + initialized when bootstrapping the overall Isabelle environment, + cf.\ \secref{sec:boot}. As usual, the content is interpreted as a + \verb|bash| script. It may refer to the component's enclosing + directory via the \verb|COMPONENT| shell variable. + + For example, the following setting allows to refer to files within + the component later on, without having to hardwire absolute paths: + + \begin{ttbox} + MY_COMPONENT_HOME="$COMPONENT" + \end{ttbox} + + Components can also add to existing Isabelle settings such as + \indexdef{}{setting}{ISABELLE\_TOOLS}\hypertarget{setting.ISABELLE-TOOLS}{\hyperlink{setting.ISABELLE-TOOLS}{\mbox{\isa{\isatt{ISABELLE{\isacharunderscore}TOOLS}}}}}, in order to provide + component-specific tools that can be invoked by end-users. For + example: + + \begin{ttbox} + ISABELLE_TOOLS="$ISABELLE_TOOLS:$COMPONENT/lib/Tools" + \end{ttbox} + + \item \verb|etc/components| holds a list of further + sub-components of the same structure. The directory specifications + given here can be either absolute (with leading \verb|/|) or + relative to the component's main directory. + + \end{itemize} + + The root of component initialization is \hyperlink{setting.ISABELLE-HOME}{\mbox{\isa{\isatt{ISABELLE{\isacharunderscore}HOME}}}} + itself. After initializing all of its sub-components recursively, + \hyperlink{setting.ISABELLE-HOME-USER}{\mbox{\isa{\isatt{ISABELLE{\isacharunderscore}HOME{\isacharunderscore}USER}}}} is included in the same manner (if + that directory exists). Thus users can easily add private + components to \verb|$ISABELLE_HOME_USER/etc/components|.% +\end{isamarkuptext}% +\isamarkuptrue% +% \isamarkupsection{The raw Isabelle process% } \isamarkuptrue% diff -r 5ef633275b15 -r 96f9e6402403 doc-src/System/Thy/document/Misc.tex --- a/doc-src/System/Thy/document/Misc.tex Mon Aug 10 08:37:37 2009 +0200 +++ b/doc-src/System/Thy/document/Misc.tex Mon Aug 10 10:25:00 2009 +0200 @@ -259,12 +259,13 @@ \isamarkuptrue% % \begin{isamarkuptext}% -The \indexdef{}{tool}{makeall}\hypertarget{tool.makeall}{\hyperlink{tool.makeall}{\mbox{\isa{\isatt{makeall}}}}} utility applies Isabelle make to all logic - directories of the distribution: +The \indexdef{}{tool}{makeall}\hypertarget{tool.makeall}{\hyperlink{tool.makeall}{\mbox{\isa{\isatt{makeall}}}}} utility applies Isabelle make to any + Isabelle component (cf.\ \secref{sec:components}) that contains an + \verb|IsaMakefile|: \begin{ttbox} Usage: makeall [ARGS ...] - Apply isabelle make to all logics (passing ARGS). + Apply isabelle make to all components with IsaMakefile (passing ARGS). \end{ttbox} The arguments \verb|ARGS| are just passed verbatim to each diff -r 5ef633275b15 -r 96f9e6402403 etc/components --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/components Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,16 @@ +#main object logics +src/Pure +src/FOL +src/HOL +src/ZF +src/CCL +src/CTT +src/Cube +src/FOLP +src/HOLCF +src/LCF +src/Sequents +#misc components +src/HOL/Tools/ATP_Manager +src/HOL/Library/Sum_Of_Squares + diff -r 5ef633275b15 -r 96f9e6402403 etc/settings --- a/etc/settings Mon Aug 10 08:37:37 2009 +0200 +++ b/etc/settings Mon Aug 10 10:25:00 2009 +0200 @@ -144,6 +144,7 @@ # Site settings check -- just to make it a little bit harder to copy this file verbatim! [ -n "$ISABELLE_SITE_SETTINGS_PRESENT" ] && \ { echo >&2 "### Isabelle site settings already present! Maybe copied etc/settings in full?"; } +ISABELLE_SITE_SETTINGS_PRESENT=true ### @@ -221,7 +222,6 @@ #JEDIT_JAVA_OPTIONS="-server -Xms128m -Xmx512m" JEDIT_OPTIONS="-reuseview -noserver -nobackground" - ### ### External reasoning tools ### @@ -273,6 +273,9 @@ # Jerusat 1.3 (SAT Solver, cf. Isabelle/src/HOL/Tools/sat_solver.ML) #JERUSAT_HOME=/usr/local/bin +# CSDP (SDP Solver, cf. Isabelle/src/HOL/Library/Sum_of_Squares/sos_wrapper.ML) +#CSDP_EXE=csdp + # For configuring HOL/Matrix/cplex # LP_SOLVER is the default solver. It can be changed during runtime via Cplex.set_solver. # First option: use the commercial cplex solver diff -r 5ef633275b15 -r 96f9e6402403 lib/Tools/doc --- a/lib/Tools/doc Mon Aug 10 08:37:37 2009 +0200 +++ b/lib/Tools/doc Mon Aug 10 10:25:00 2009 +0200 @@ -34,28 +34,23 @@ ## main +ORIG_IFS="$IFS"; IFS=":"; declare -a DOCS=($ISABELLE_DOCS); IFS="$ORIG_IFS" + if [ -z "$DOC" ]; then - ORIG_IFS="$IFS" - IFS=":" - for DIR in $ISABELLE_DOCS + for DIR in "${DOCS[@]}" do [ -d "$DIR" ] || fail "Bad document directory: $DIR" [ -f "$DIR/Contents" ] && grep -v "^>>" "$DIR/Contents" done - IFS="$ORIG_IFS" else - ORIG_IFS="$IFS" - IFS=":" - for DIR in $ISABELLE_DOCS + for DIR in "${DOCS[@]}" do - IFS="$ORIG_IFS" [ -d "$DIR" ] || fail "Bad document directory: $DIR" for FMT in "$ISABELLE_DOC_FORMAT" dvi do [ -f "$DIR/$DOC.$FMT" ] && { cd "$DIR"; exec "$ISABELLE_TOOL" display "$DOC.$FMT"; } done done - IFS="$ORIG_IFS" fail "Unknown Isabelle document: $DOC" fi diff -r 5ef633275b15 -r 96f9e6402403 lib/Tools/document --- a/lib/Tools/document Mon Aug 10 08:37:37 2009 +0200 +++ b/lib/Tools/document Mon Aug 10 10:25:00 2009 +0200 @@ -38,7 +38,7 @@ CLEAN="" NAME="document" OUTFORMAT=dvi -TAGS="" +declare -a TAGS=() while getopts "cn:o:t:" OPT do @@ -53,7 +53,7 @@ OUTFORMAT="$OPTARG" ;; t) - TAGS="$OPTARG" + ORIG_IFS="$IFS"; IFS=","; TAGS=($OPTARG); IFS="$ORIG_IFS" ;; \?) usage @@ -90,21 +90,20 @@ function prep_tags () { ( - IFS="," - for TAG in $TAGS + for TAG in "${TAGS[@]}" do case "$TAG" in /*) - echo "\\isafoldtag{${TAG:1}}" + echo "\\isafoldtag{${TAG:1}}" ;; -*) - echo "\\isadroptag{${TAG:1}}" + echo "\\isadroptag{${TAG:1}}" ;; +*) - echo "\\isakeeptag{${TAG:1}}" + echo "\\isakeeptag{${TAG:1}}" ;; *) - echo "\\isakeeptag{${TAG}}" + echo "\\isakeeptag{${TAG}}" ;; esac done diff -r 5ef633275b15 -r 96f9e6402403 lib/Tools/findlogics --- a/lib/Tools/findlogics Mon Aug 10 08:37:37 2009 +0200 +++ b/lib/Tools/findlogics Mon Aug 10 10:25:00 2009 +0200 @@ -22,22 +22,21 @@ [ "$#" -ne 0 ] && usage - -LOGICS="" +declare -a LOGICS=() +declare -a ISABELLE_PATHS=() -ORIG_IFS="$IFS" -IFS=":" -for DIR in $ISABELLE_PATH +ORIG_IFS="$IFS"; IFS=":"; ISABELLE_PATHS=($ISABELLE_PATH); IFS=$ORIG_IFS + +for DIR in "${ISABELLE_PATHS[@]}" do DIR="$DIR/$ML_IDENTIFIER" for FILE in "$DIR"/* do if [ -f "$FILE" ]; then NAME=$(basename "$FILE") - LOGICS="$LOGICS $NAME" + LOGICS+=("$NAME") fi done done -IFS="$ORIG_IFS" -echo $({ for L in $LOGICS; do echo "$L"; done; } | sort | uniq) +echo $({ for L in ${LOGICS[@]}; do echo "$L"; done; } | sort | uniq) diff -r 5ef633275b15 -r 96f9e6402403 lib/Tools/makeall --- a/lib/Tools/makeall Mon Aug 10 08:37:37 2009 +0200 +++ b/lib/Tools/makeall Mon Aug 10 10:25:00 2009 +0200 @@ -4,11 +4,6 @@ # # DESCRIPTION: apply make utility to all logics -## global settings - -ALL_LOGICS="Pure FOL HOL ZF CCL CTT Cube FOLP HOLCF LCF Sequents" - - ## diagnostics PRG="$(basename "$0")" @@ -18,7 +13,7 @@ echo echo "Usage: isabelle $PRG [ARGS ...]" echo - echo " Apply isabelle make to all logics (passing ARGS)." + echo " Apply isabelle make to all components with IsaMakefile (passing ARGS)." echo exit 1 } @@ -29,6 +24,7 @@ exit 2 } + ## main [ "$1" = "-?" ] && usage @@ -38,9 +34,14 @@ echo "Started at $(date) ($ML_IDENTIFIER on $(hostname))" . "$ISABELLE_HOME/lib/scripts/timestart.bash" -for L in $ALL_LOGICS +ORIG_IFS="$IFS"; IFS=":"; declare -a COMPONENTS=($ISABELLE_COMPONENTS); IFS="$ORIG_IFS" + +for DIR in "${COMPONENTS[@]}" do - ( cd "$ISABELLE_HOME/src/$L"; "$ISABELLE_TOOL" make "$@" ) || FAIL="$FAIL$L " + if [ -f "$DIR/IsaMakefile" ]; then + NAME="$(basename "$DIR")" + ( cd "$DIR"; "$ISABELLE_TOOL" make "$@" ) || FAIL="$FAIL$NAME " + fi done echo -n "Finished at "; date diff -r 5ef633275b15 -r 96f9e6402403 lib/Tools/mkdir --- a/lib/Tools/mkdir Mon Aug 10 08:37:37 2009 +0200 +++ b/lib/Tools/mkdir Mon Aug 10 10:25:00 2009 +0200 @@ -187,8 +187,8 @@ [ -z "$QUIET" ] && echo "creating $PREFIX/ROOT.ML" >&2 cat >ROOT.ML < 1, - "QuietFlag" => "-q01", - "SubmitButton" => "RunSelectedSystems", - "ProblemSource" => "UPLOAD", - ); - -#----Get format and transform options if specified -my %Options; -getopts("hwxs:t:c:",\%Options); - -#----Usage -sub usage() { - print("Usage: remote [] \n"); - print(" are ...\n"); - print(" -h - print this help\n"); - print(" -w - list available ATP systems\n"); - print(" -x - use X2TPTP to convert output of prover\n"); - print(" -s - specified system to use\n"); - print(" -t - CPU time limit for system\n"); - print(" -c - custom command for system\n"); - print(" - TPTP problem file\n"); - exit(0); -} -if (exists($Options{'h'})) { - usage(); -} - -#----What systems flag -if (exists($Options{'w'})) { - $URLParameters{"SubmitButton"} = "ListSystems"; - delete($URLParameters{"ProblemSource"}); -} - -#----X2TPTP -if (exists($Options{'x'})) { - $URLParameters{"X2TPTP"} = "-S"; -} - -#----Selected system -my $System; -if (exists($Options{'s'})) { - $System = $Options{'s'}; -} else { - # use Vampire as default - $System = "Vampire---9.0"; -} -$URLParameters{"System___$System"} = $System; - -#----Time limit -if (exists($Options{'t'})) { - $URLParameters{"TimeLimit___$System"} = $Options{'t'}; -} -#----Custom command -if (exists($Options{'c'})) { - $URLParameters{"Command___$System"} = $Options{'c'}; -} - -#----Get single file name -if (exists($URLParameters{"ProblemSource"})) { - if (scalar(@ARGV) >= 1) { - $URLParameters{"UPLOADProblem"} = [shift(@ARGV)]; - } else { - print("Missing problem file\n"); - usage(); - die; - } -} - -# Query Server -my $Agent = LWP::UserAgent->new; -if (exists($Options{'t'})) { - # give server more time to respond - $Agent->timeout($Options{'t'} + 10); -} -my $Request = POST($SystemOnTPTPFormReplyURL, - Content_Type => 'form-data',Content => \%URLParameters); -my $Response = $Agent->request($Request); - -#catch errors / failure -if(!$Response->is_success) { - print "HTTP-Error: " . $Response->message . "\n"; - exit(-1); -} elsif (exists($Options{'w'})) { - print $Response->content; - exit (0); -} elsif ($Response->content =~ /WARNING: (\S*) does not exist/) { - print "Specified System $1 does not exist\n"; - exit(-1); -} elsif (exists($Options{'x'}) && - $Response->content =~ - /%\s*Result\s*:\s*Unsatisfiable.*\n%\s*Output\s*:\s*(CNF)?Refutation.*\n%/ && - $Response->content !~ /ERROR: Could not form TPTP format derivation/ ) -{ - # converted output: extract proof - my @lines = split( /\n/, $Response->content); - my $extract = ""; - foreach my $line (@lines){ - #ignore comments - if ($line !~ /^%/ && !($line eq "")) { - $extract .= "$line"; - } - } - # insert newlines after ').' - $extract =~ s/\s//g; - $extract =~ s/\)\.cnf/\)\.\ncnf/g; - - print "========== ~~/lib/scripts/SystemOnTPTP extracted proof: ==========\n"; - # orientation for res_reconstruct.ML - print "# SZS output start CNFRefutation.\n"; - print "$extract\n"; - print "# SZS output end CNFRefutation.\n"; - # can be useful for debugging; Isabelle ignores this - print "============== original response from SystemOnTPTP: ==============\n"; - print $Response->content; - exit(0); -} elsif (!exists($Options{'x'})) { - # pass output directly to Isabelle - print $Response->content; - exit(0); -}else { - print "Remote-script could not extract proof:\n".$Response->content; - exit(-1); -} - diff -r 5ef633275b15 -r 96f9e6402403 lib/scripts/getsettings --- a/lib/scripts/getsettings Mon Aug 10 08:37:37 2009 +0200 +++ b/lib/scripts/getsettings Mon Aug 10 10:25:00 2009 +0200 @@ -68,14 +68,42 @@ done } -#get actual settings -source "$ISABELLE_HOME/etc/settings" || exit 2 -ISABELLE_SITE_SETTINGS_PRESENT=true +#nested components +ISABELLE_COMPONENTS="" +function init_component () +{ + local COMPONENT="$1" + + if [ ! -d "$COMPONENT" ]; then + echo >&2 "Bad Isabelle component: $COMPONENT" + exit 2 + elif [ -z "$ISABELLE_COMPONENTS" ]; then + ISABELLE_COMPONENTS="$COMPONENT" + else + ISABELLE_COMPONENTS="$ISABELLE_COMPONENTS:$COMPONENT" + fi + if [ -f "$COMPONENT/etc/settings" ]; then + source "$COMPONENT/etc/settings" || exit 2 + fi + if [ -f "$COMPONENT/etc/components" ]; then + { + while read; do + case "$REPLY" in + \#* | "") ;; + /*) init_component "$REPLY" ;; + *) init_component "$COMPONENT/$REPLY" ;; + esac + done + } < "$COMPONENT/etc/components" + fi +} + +#main components +init_component "$ISABELLE_HOME" [ "$ISABELLE_HOME" -ef "$ISABELLE_HOME_USER" ] && \ - { echo >&2 "### ISABELLE_HOME and ISABELLE_HOME_USER should not be the same directory!"; } -[ -z "$ISABELLE_IGNORE_USER_SETTINGS" -a -f "$ISABELLE_HOME_USER/etc/settings" ] && \ - { source "$ISABELLE_HOME_USER/etc/settings" || exit 2; } + { echo >&2 "### ISABELLE_HOME and ISABELLE_HOME_USER must not be the same directory!"; } +[ -d "$ISABELLE_HOME_USER" ] && init_component "$ISABELLE_HOME_USER" #ML system identifier if [ -z "$ML_PLATFORM" ]; then diff -r 5ef633275b15 -r 96f9e6402403 lib/scripts/mirabelle --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/scripts/mirabelle Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,129 @@ +#!/usr/bin/perl -w + +use strict; +use File::Basename; + +# Taken from http://www.skywayradio.com/tech/perl/trim_blanks.html +sub trim { + my @out = @_; + for (@out) { + s/^\s+//; + s/\s+$//; + } + return wantarray ? @out : $out[0]; +} + +sub quote { + my $str = pop; + return "\"" . $str . "\""; +} + +sub print_usage_and_quit { + print STDERR "Usage: mirabelle actions file1.thy...\n" . + " actions: action1:...:actionN\n" . + " action: name or name[key1=value1,...,keyM=valueM]\n"; + exit 1; +} + +my $num_args = $#ARGV + 1; +if ($num_args < 2) { + print_usage_and_quit(); +} + +my @action_names; +my @action_settings; + +foreach (split(/:/, $ARGV[0])) { + my %settings; + + $_ =~ /([^[]*)(?:\[(.*)\])?/; + my ($name, $settings_str) = ($1, $2 || ""); + my @setting_strs = split(/,/, $settings_str); + foreach (@setting_strs) { + $_ =~ /(.*)=(.*)/; + my $key = $1; + my $value = $2; + $settings{trim($key)} = trim($value); + } + + push @action_names, trim($name); + push @action_settings, \%settings; +} + +my $output_path = "/tmp/mirabelle"; # FIXME: generate path +my $mirabellesetup_thy_name = $output_path . "/MirabelleSetup"; +my $mirabellesetup_file = $mirabellesetup_thy_name . ".thy"; +my $mirabelle_log_file = $output_path . "/mirabelle.log"; + +mkdir $output_path, 0755; + +open(FILE, ">$mirabellesetup_file") + || die "Could not create file '$mirabellesetup_file'"; + +my $invoke_lines; + +for my $i (0 .. $#action_names) { + my $settings_str = ""; + my $settings = $action_settings[$i]; + my $key; + my $value; + + while (($key, $value) = each(%$settings)) { + $settings_str .= "(" . quote ($key) . ", " . quote ($value) . "), "; + } + $settings_str =~ s/, $//; + + $invoke_lines .= "setup {* Mirabelle.invoke \"$action_names[$i]\" "; + $invoke_lines .= "[$settings_str] *}\n" +} + +print FILE <; + close(OLD_FILE); + + my $thy_text = join("", @lines); + my $old_len = length($thy_text); + $thy_text =~ s/\btheory\b[^\n]*\s*\bimports\s/theory $new_thy_name\nimports "$mirabellesetup_thy_name" /gm; + die "No 'imports' found" if length($thy_text) == $old_len; + + open(NEW_FILE, ">$new_thy_file"); + print NEW_FILE $thy_text; + close(NEW_FILE); + + $root_text .= "use_thy \"" . $dir . $new_thy_name . "\";\n"; + + push @new_thy_files, $new_thy_file; +} + +my $root_file = "ROOT_mirabelle.ML"; +open(ROOT_FILE, ">$root_file") || die "Cannot open file $root_file"; +print ROOT_FILE $root_text; +close(ROOT_FILE); + +system "isabelle-process -e 'use \"ROOT_mirabelle.ML\";' -f -q HOL"; + +# unlink $mirabellesetup_file; +unlink $root_file; +unlink @new_thy_files; diff -r 5ef633275b15 -r 96f9e6402403 lib/scripts/neos/NeosCSDPClient.py --- a/lib/scripts/neos/NeosCSDPClient.py Mon Aug 10 08:37:37 2009 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,56 +0,0 @@ -#!/usr/bin/env python -import sys -import xmlrpclib -import time -import re - -from config import Variables - -if len(sys.argv) < 3 or len(sys.argv) > 3: - sys.stderr.write("Usage: NeosCSDPClient \n") - sys.exit(1) - -neos=xmlrpclib.Server("http://%s:%d" % (Variables.NEOS_HOST, Variables.NEOS_PORT)) - -xmlfile = open(sys.argv[1],"r") -xml_pre = "\nsdp\ncsdp\nSPARSE_SDPA\n\n\n" -xml = xml_pre -buffer = 1 -while buffer: - buffer = xmlfile.read() - xml += buffer -xmlfile.close() -xml += xml_post - -(jobNumber,password) = neos.submitJob(xml) - -if jobNumber == 0: - sys.stdout.write("error submitting job: %s" % password) - sys.exit(-1) -else: - sys.stdout.write("jobNumber = %d\tpassword = %s\n" % (jobNumber,password)) - -offset=0 -status="Waiting" -while status == "Running" or status=="Waiting": - time.sleep(1) - (msg,offset) = neos.getIntermediateResults(jobNumber,password,offset) - sys.stdout.write(msg.data) - status = neos.getJobStatus(jobNumber, password) - -msg = neos.getFinalResults(jobNumber, password).data -result = msg.split("Solution:") - -sys.stdout.write(result[0]) -if len(result) > 1: - plain_msg = result[1].strip() - if plain_msg != "": - output = open(sys.argv[2],"w") - output.write(plain_msg) - output.close() - sys.exit(0) - -sys.exit(2) - - diff -r 5ef633275b15 -r 96f9e6402403 lib/scripts/neos/config.py --- a/lib/scripts/neos/config.py Mon Aug 10 08:37:37 2009 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3 +0,0 @@ -class Variables: - NEOS_HOST="neos.mcs.anl.gov" - NEOS_PORT=3332 diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/ATP_Linkup.thy --- a/src/HOL/ATP_Linkup.thy Mon Aug 10 08:37:37 2009 +0200 +++ b/src/HOL/ATP_Linkup.thy Mon Aug 10 10:25:00 2009 +0200 @@ -15,9 +15,9 @@ ("Tools/res_hol_clause.ML") ("Tools/res_reconstruct.ML") ("Tools/res_atp.ML") - ("Tools/atp_manager.ML") - ("Tools/atp_wrapper.ML") - ("Tools/atp_minimal.ML") + ("Tools/ATP_Manager/atp_manager.ML") + ("Tools/ATP_Manager/atp_wrapper.ML") + ("Tools/ATP_Manager/atp_minimal.ML") "~~/src/Tools/Metis/metis.ML" ("Tools/metis_tools.ML") begin @@ -96,10 +96,9 @@ use "Tools/res_reconstruct.ML" setup ResReconstruct.setup use "Tools/res_atp.ML" -use "Tools/atp_manager.ML" -use "Tools/atp_wrapper.ML" - -use "Tools/atp_minimal.ML" +use "Tools/ATP_Manager/atp_manager.ML" +use "Tools/ATP_Manager/atp_wrapper.ML" +use "Tools/ATP_Manager/atp_minimal.ML" text {* basic provers *} setup {* AtpManager.add_prover "spass" AtpWrapper.spass *} diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/IsaMakefile --- a/src/HOL/IsaMakefile Mon Aug 10 08:37:37 2009 +0200 +++ b/src/HOL/IsaMakefile Mon Aug 10 10:25:00 2009 +0200 @@ -231,12 +231,13 @@ $(SRC)/Provers/Arith/combine_numerals.ML \ $(SRC)/Provers/Arith/extract_common_term.ML \ $(SRC)/Tools/Metis/metis.ML \ + Tools/ATP_Manager/atp_manager.ML \ + Tools/ATP_Manager/atp_minimal.ML \ + Tools/ATP_Manager/atp_wrapper.ML \ Tools/Groebner_Basis/groebner.ML \ Tools/Groebner_Basis/misc.ML \ + Tools/Groebner_Basis/normalizer.ML \ Tools/Groebner_Basis/normalizer_data.ML \ - Tools/Groebner_Basis/normalizer.ML \ - Tools/atp_manager.ML \ - Tools/atp_wrapper.ML \ Tools/int_arith.ML \ Tools/list_code.ML \ Tools/meson.ML \ @@ -315,49 +316,45 @@ HOL-Library: HOL $(LOG)/HOL-Library.gz - $(LOG)/HOL-Library.gz: $(OUT)/HOL Library/SetsAndFunctions.thy \ - Library/Abstract_Rat.thy \ - Library/BigO.thy Library/ContNotDenum.thy Library/Efficient_Nat.thy \ - Library/Euclidean_Space.thy Library/Sum_Of_Squares.thy Library/positivstellensatz.ML \ - Library/Fset.thy Library/Convex_Euclidean_Space.thy \ - Library/sum_of_squares.ML Library/Glbs.thy Library/normarith.ML \ - Library/Executable_Set.thy Library/Infinite_Set.thy \ - Library/FuncSet.thy Library/Permutations.thy Library/Determinants.thy\ - Library/Bit.thy Library/Topology_Euclidean_Space.thy \ - Library/Finite_Cartesian_Product.thy \ - Library/FrechetDeriv.thy Library/Fraction_Field.thy\ - Library/Fundamental_Theorem_Algebra.thy \ - Library/Inner_Product.thy Library/Kleene_Algebra.thy Library/Lattice_Syntax.thy \ - Library/Legacy_GCD.thy \ - Library/Library.thy Library/List_Prefix.thy Library/List_Set.thy Library/State_Monad.thy \ - Library/Nat_Int_Bij.thy Library/Multiset.thy Library/Permutation.thy \ - Library/Primes.thy Library/Pocklington.thy Library/Quotient.thy \ - Library/Quicksort.thy Library/Nat_Infinity.thy Library/Word.thy \ - Library/README.html Library/Continuity.thy Library/Order_Relation.thy \ - Library/Nested_Environment.thy Library/Ramsey.thy Library/Zorn.thy \ - Library/Library/ROOT.ML Library/Library/document/root.tex \ - Library/Library/document/root.bib Library/While_Combinator.thy \ - Library/Product_ord.thy Library/Char_nat.thy Library/Char_ord.thy \ - Library/Option_ord.thy Library/Sublist_Order.thy \ - Library/List_lexord.thy Library/Commutative_Ring.thy \ - Library/comm_ring.ML Library/Coinductive_List.thy \ - Library/AssocList.thy Library/Formal_Power_Series.thy \ - Library/Binomial.thy Library/Eval_Witness.thy \ - Library/Code_Char.thy \ + Library/Abstract_Rat.thy Library/BigO.thy Library/ContNotDenum.thy \ + Library/Efficient_Nat.thy Library/Euclidean_Space.thy \ + Library/Sum_Of_Squares.thy Library/Sum_Of_Squares/sos_wrapper.ML \ + Library/Sum_Of_Squares/sum_of_squares.ML Library/Fset.thy \ + Library/Convex_Euclidean_Space.thy Library/Glbs.thy \ + Library/normarith.ML Library/Executable_Set.thy \ + Library/Infinite_Set.thy Library/FuncSet.thy \ + Library/Permutations.thy Library/Determinants.thy Library/Bit.thy \ + Library/Topology_Euclidean_Space.thy \ + Library/Finite_Cartesian_Product.thy Library/FrechetDeriv.thy \ + Library/Fraction_Field.thy Library/Fundamental_Theorem_Algebra.thy \ + Library/Inner_Product.thy Library/Kleene_Algebra.thy \ + Library/Lattice_Syntax.thy Library/Legacy_GCD.thy \ + Library/Library.thy Library/List_Prefix.thy Library/List_Set.thy \ + Library/State_Monad.thy Library/Nat_Int_Bij.thy Library/Multiset.thy \ + Library/Permutation.thy Library/Primes.thy Library/Pocklington.thy \ + Library/Quotient.thy Library/Quicksort.thy Library/Nat_Infinity.thy \ + Library/Word.thy Library/README.html Library/Continuity.thy \ + Library/Order_Relation.thy Library/Nested_Environment.thy \ + Library/Ramsey.thy Library/Zorn.thy Library/Library/ROOT.ML \ + Library/Library/document/root.tex Library/Library/document/root.bib \ + Library/While_Combinator.thy Library/Product_ord.thy \ + Library/Char_nat.thy Library/Char_ord.thy Library/Option_ord.thy \ + Library/Sublist_Order.thy Library/List_lexord.thy \ + Library/Commutative_Ring.thy Library/comm_ring.ML \ + Library/Coinductive_List.thy Library/AssocList.thy \ + Library/Formal_Power_Series.thy Library/Binomial.thy \ + Library/Eval_Witness.thy Library/Code_Char.thy \ Library/Code_Char_chr.thy Library/Code_Integer.thy \ Library/Mapping.thy Library/Numeral_Type.thy Library/Reflection.thy \ Library/Boolean_Algebra.thy Library/Countable.thy \ Library/Diagonalize.thy Library/RBT.thy Library/Univ_Poly.thy \ - Library/Poly_Deriv.thy \ - Library/Polynomial.thy \ - Library/Preorder.thy \ - Library/Product_plus.thy \ - Library/Product_Vector.thy \ - Library/Tree.thy \ - Library/Enum.thy Library/Float.thy $(SRC)/Tools/float.ML $(SRC)/HOL/Tools/float_arith.ML \ - Library/reify_data.ML Library/reflection.ML \ - Library/LaTeXsugar.thy Library/OptionalSugar.thy + Library/Poly_Deriv.thy Library/Polynomial.thy Library/Preorder.thy \ + Library/Product_plus.thy Library/Product_Vector.thy Library/Tree.thy \ + Library/Enum.thy Library/Float.thy $(SRC)/Tools/float.ML \ + $(SRC)/HOL/Tools/float_arith.ML Library/positivstellensatz.ML \ + Library/reify_data.ML Library/reflection.ML Library/LaTeXsugar.thy \ + Library/OptionalSugar.thy @cd Library; $(ISABELLE_TOOL) usedir $(OUT)/HOL Library @@ -903,7 +900,8 @@ ex/Sudoku.thy ex/Tarski.thy \ ex/Termination.thy ex/Unification.thy ex/document/root.bib \ ex/document/root.tex ex/set.thy ex/svc_funcs.ML ex/svc_test.thy \ - ex/Predicate_Compile.thy ex/predicate_compile.ML ex/Predicate_Compile_ex.thy + ex/Predicate_Compile.thy ex/predicate_compile.ML ex/Predicate_Compile_ex.thy \ + ex/Mirabelle.thy ex/mirabelle.ML @$(ISABELLE_TOOL) usedir $(OUT)/HOL ex diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Library/Sum_Of_Squares.thy --- a/src/HOL/Library/Sum_Of_Squares.thy Mon Aug 10 08:37:37 2009 +0200 +++ b/src/HOL/Library/Sum_Of_Squares.thy Mon Aug 10 10:25:00 2009 +0200 @@ -1,26 +1,39 @@ -(* Title: Library/Sum_Of_Squares +(* Title: HOL/Library/Sum_Of_Squares.thy Author: Amine Chaieb, University of Cambridge - -In order to use the method sos, call it with (sos remote_csdp) to use the remote solver -or install CSDP (https://projects.coin-or.org/Csdp/), put the executable csdp on your path, -and call it with (sos csdp). By default, sos calls remote_csdp. This can take of the order -of a minute for one sos call, because sos calls CSDP repeatedly. -If you install CSDP locally, sos calls typically takes only a few seconds. - *) header {* A decision method for universal multivariate real arithmetic with addition, - multiplication and ordering using semidefinite programming*} + multiplication and ordering using semidefinite programming *} theory Sum_Of_Squares - imports Complex_Main (* "~~/src/HOL/Decision_Procs/Dense_Linear_Order" *) - uses "positivstellensatz.ML" "sum_of_squares.ML" "sos_wrapper.ML" - begin +imports Complex_Main (* "~~/src/HOL/Decision_Procs/Dense_Linear_Order" *) +uses + ("positivstellensatz.ML") (* duplicate use!? -- cf. Euclidian_Space.thy *) + ("Sum_Of_Squares/sum_of_squares.ML") + ("Sum_Of_Squares/sos_wrapper.ML") +begin -(* setup sos tactic *) +text {* + In order to use the method sos, call it with @{text "(sos + remote_csdp)"} to use the remote solver. Or install CSDP + (https://projects.coin-or.org/Csdp), configure the Isabelle setting + @{text CSDP_EXE}, and call it with @{text "(sos csdp)"}. By + default, sos calls @{text remote_csdp}. This can take of the order + of a minute for one sos call, because sos calls CSDP repeatedly. If + you install CSDP locally, sos calls typically takes only a few + seconds. +*} + +text {* setup sos tactic *} + +use "positivstellensatz.ML" +use "Sum_Of_Squares/sum_of_squares.ML" +use "Sum_Of_Squares/sos_wrapper.ML" + setup SosWrapper.setup -text{* Tests -- commented since they work only when csdp is installed or take too long with remote csdps *} +text {* Tests -- commented since they work only when csdp is installed + or take too long with remote csdps *} (* lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x \ a < 0" by sos diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Library/Sum_Of_Squares/etc/settings --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Library/Sum_Of_Squares/etc/settings Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,1 @@ +ISABELLE_SUM_OF_SQUARES="$COMPONENT" diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Library/Sum_Of_Squares/neos_csdp_client --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Library/Sum_Of_Squares/neos_csdp_client Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,65 @@ +#!/usr/bin/env python +import sys +import xmlrpclib +import time +import re + +# Neos server config +NEOS_HOST="neos.mcs.anl.gov" +NEOS_PORT=3332 + +if len(sys.argv) < 3 or len(sys.argv) > 3: + sys.stderr.write("Usage: NeosCSDPClient \n") + sys.exit(1) + +neos=xmlrpclib.Server("http://%s:%d" % (NEOS_HOST, NEOS_PORT)) + +inputfile = open(sys.argv[1],"r") +xml_pre = "\nsdp\ncsdp\nSPARSE_SDPA\n\n\n" +xml = xml_pre +buffer = 1 +while buffer: + buffer = inputfile.read() + xml += buffer +inputfile.close() +xml += xml_post + +(jobNumber,password) = neos.submitJob(xml) + +if jobNumber == 0: + sys.stdout.write("error submitting job: %s" % password) + sys.exit(20) +else: + sys.stdout.write("jobNumber = %d\tpassword = %s\n" % (jobNumber,password)) + +offset=0 +messages = "" +status="Waiting" +while status == "Running" or status=="Waiting": + time.sleep(1) + (msg,offset) = neos.getIntermediateResults(jobNumber,password,offset) + messages += msg.data + sys.stdout.write(msg.data) + status = neos.getJobStatus(jobNumber, password) + +msg = neos.getFinalResults(jobNumber, password).data +sys.stdout.write("---------- Begin CSDP Output -------------\n"); +sys.stdout.write(msg) + +# extract solution +result = msg.split("Solution:") +if len(result) > 1: + output = open(sys.argv[2],"w") + output.write(result[1].strip()) + output.close() + +# extract return code +p = re.compile(r"^Error: Command exited with non-zero status (\d+)$", re.MULTILINE) +m = p.search(messages) +if m: + sys.exit(int(m.group(1))) +else: + sys.exit(0) + + diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Library/Sum_Of_Squares/sos_wrapper.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Library/Sum_Of_Squares/sos_wrapper.ML Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,140 @@ +(* Title: sos_wrapper.ML + Author: Philipp Meyer, TU Muenchen + +Added functionality for sums of squares, e.g. calling a remote prover +*) + +signature SOS_WRAPPER = +sig + + datatype prover_result = Success | Failure | Error + + val setup: theory -> theory + val destdir: string ref +end + +structure SosWrapper : SOS_WRAPPER= +struct + +datatype prover_result = Success | Failure | Error +fun str_of_result Success = "Success" + | str_of_result Failure = "Failure" + | str_of_result Error = "Error" + +(*** output control ***) + +fun debug s = if ! Sos.debugging then Output.writeln s else () +val write = Output.priority + +(*** calling provers ***) + +val destdir = ref "" + +fun filename dir name = + let + val probfile = Path.basic (name ^ serial_string ()) + val dir_path = Path.explode dir + in + if dir = "" then + File.tmp_path probfile + else + if File.exists dir_path then + Path.append dir_path probfile + else + error ("No such directory: " ^ dir) + end + +fun run_solver name cmd find_failure input = + let + val _ = write ("Calling solver: " ^ name) + + (* create input file *) + val dir = ! destdir + val input_file = filename dir "sos_in" + val _ = File.write input_file input + + (* call solver *) + val output_file = filename dir "sos_out" + val (output, rv) = system_out ( + if File.exists cmd then space_implode " " + [File.shell_path cmd, File.platform_path input_file, File.platform_path output_file] + else error ("Bad executable: " ^ File.shell_path cmd)) + + (* read and analysize output *) + val (res, res_msg) = find_failure rv + val result = if File.exists output_file then File.read output_file else "" + + (* remove temporary files *) + val _ = if dir = "" then + (File.rm input_file ; if File.exists output_file then File.rm output_file else ()) + else () + + val _ = debug ("Solver output:\n" ^ output) + + val _ = write (str_of_result res ^ ": " ^ res_msg) + in + case res of + Success => result + | Failure => raise Sos.Failure res_msg + | Error => error ("Prover failed: " ^ res_msg) + end + +(*** various provers ***) + +(* local csdp client *) + +fun find_csdp_failure rv = + case rv of + 0 => (Success, "SDP solved") + | 1 => (Failure, "SDP is primal infeasible") + | 2 => (Failure, "SDP is dual infeasible") + | 3 => (Success, "SDP solved with reduced accuracy") + | 4 => (Failure, "Maximum iterations reached") + | 5 => (Failure, "Stuck at edge of primal feasibility") + | 6 => (Failure, "Stuck at edge of dual infeasibility") + | 7 => (Failure, "Lack of progress") + | 8 => (Failure, "X, Z, or O was singular") + | 9 => (Failure, "Detected NaN or Inf values") + | _ => (Error, "return code is " ^ string_of_int rv) + +val csdp = ("$CSDP_EXE", find_csdp_failure) + +(* remote neos server *) + +fun find_neos_failure rv = + case rv of + 20 => (Error, "error submitting job") + | 21 => (Error, "no solution") + | _ => find_csdp_failure rv + +val neos_csdp = ("$ISABELLE_SUM_OF_SQUARES/neos_csdp_client", find_neos_failure) + +(* save provers in table *) + +val provers = + Symtab.make [("remote_csdp", neos_csdp),("csdp", csdp)] + +fun get_prover name = + case Symtab.lookup provers name of + SOME prover => prover + | NONE => error ("unknown prover: " ^ name) + +fun call_solver name = + let + val (cmd, find_failure) = get_prover name + in + run_solver name (Path.explode cmd) find_failure + end + +(* setup tactic *) + +val def_solver = "remote_csdp" + +fun sos_solver name = (SIMPLE_METHOD' o (Sos.sos_tac (call_solver name))) + +val sos_method = Scan.optional (Scan.lift OuterParse.xname) def_solver >> sos_solver + +val setup = Method.setup @{binding sos} sos_method + "Prove universal problems over the reals using sums of squares" + +end diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Library/Sum_Of_Squares/sum_of_squares.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Library/Sum_Of_Squares/sum_of_squares.ML Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,1512 @@ +(* Title: sum_of_squares.ML + Authors: Amine Chaieb, University of Cambridge + Philipp Meyer, TU Muenchen + +A tactic for proving nonlinear inequalities +*) + +signature SOS = +sig + + val sos_tac : (string -> string) -> Proof.context -> int -> Tactical.tactic + + val debugging : bool ref; + + exception Failure of string; +end + +structure Sos : SOS = +struct + +val rat_0 = Rat.zero; +val rat_1 = Rat.one; +val rat_2 = Rat.two; +val rat_10 = Rat.rat_of_int 10; +val rat_1_2 = rat_1 // rat_2; +val max = curry IntInf.max; +val min = curry IntInf.min; + +val denominator_rat = Rat.quotient_of_rat #> snd #> Rat.rat_of_int; +val numerator_rat = Rat.quotient_of_rat #> fst #> Rat.rat_of_int; +fun int_of_rat a = + case Rat.quotient_of_rat a of (i,1) => i | _ => error "int_of_rat: not an int"; +fun lcm_rat x y = Rat.rat_of_int (Integer.lcm (int_of_rat x) (int_of_rat y)); + +fun rat_pow r i = + let fun pow r i = + if i = 0 then rat_1 else + let val d = pow r (i div 2) + in d */ d */ (if i mod 2 = 0 then rat_1 else r) + end + in if i < 0 then pow (Rat.inv r) (~ i) else pow r i end; + +fun round_rat r = + let val (a,b) = Rat.quotient_of_rat (Rat.abs r) + val d = a div b + val s = if r = b then d + 1 else d) end + +val abs_rat = Rat.abs; +val pow2 = rat_pow rat_2; +val pow10 = rat_pow rat_10; + +val debugging = ref false; + +exception Sanity; + +exception Unsolvable; + +exception Failure of string; + +(* Turn a rational into a decimal string with d sig digits. *) + +local +fun normalize y = + if abs_rat y =/ rat_1 then normalize (y // rat_10) + 1 + else 0 + in +fun decimalize d x = + if x =/ rat_0 then "0.0" else + let + val y = Rat.abs x + val e = normalize y + val z = pow10(~ e) */ y +/ rat_1 + val k = int_of_rat (round_rat(pow10 d */ z)) + in (if x a + | h::t => itern (k + 1) t f (f h k a); + +fun iter (m,n) f a = + if n < m then a + else iter (m+1,n) f (f m a); + +(* The main types. *) + +fun strict_ord ord (x,y) = case ord (x,y) of LESS => LESS | _ => GREATER + +structure Intpairfunc = FuncFun(type key = int*int val ord = prod_ord int_ord int_ord); + +type vector = int* Rat.rat Intfunc.T; + +type matrix = (int*int)*(Rat.rat Intpairfunc.T); + +type monomial = int Ctermfunc.T; + +val cterm_ord = (fn (s,t) => TermOrd.fast_term_ord(term_of s, term_of t)) + fun monomial_ord (m1,m2) = list_ord (prod_ord cterm_ord int_ord) (Ctermfunc.graph m1, Ctermfunc.graph m2) +structure Monomialfunc = FuncFun(type key = monomial val ord = monomial_ord) + +type poly = Rat.rat Monomialfunc.T; + + fun iszero (k,r) = r =/ rat_0; + +fun fold_rev2 f l1 l2 b = + case (l1,l2) of + ([],[]) => b + | (h1::t1,h2::t2) => f h1 h2 (fold_rev2 f t1 t2 b) + | _ => error "fold_rev2"; + +(* Vectors. Conventionally indexed 1..n. *) + +fun vector_0 n = (n,Intfunc.undefined):vector; + +fun dim (v:vector) = fst v; + +fun vector_const c n = + if c =/ rat_0 then vector_0 n + else (n,fold_rev (fn k => Intfunc.update (k,c)) (1 upto n) Intfunc.undefined) :vector; + +val vector_1 = vector_const rat_1; + +fun vector_cmul c (v:vector) = + let val n = dim v + in if c =/ rat_0 then vector_0 n + else (n,Intfunc.mapf (fn x => c */ x) (snd v)) + end; + +fun vector_neg (v:vector) = (fst v,Intfunc.mapf Rat.neg (snd v)) :vector; + +fun vector_add (v1:vector) (v2:vector) = + let val m = dim v1 + val n = dim v2 + in if m <> n then error "vector_add: incompatible dimensions" + else (n,Intfunc.combine (curry op +/) (fn x => x =/ rat_0) (snd v1) (snd v2)) :vector + end; + +fun vector_sub v1 v2 = vector_add v1 (vector_neg v2); + +fun vector_dot (v1:vector) (v2:vector) = + let val m = dim v1 + val n = dim v2 + in if m <> n then error "vector_dot: incompatible dimensions" + else Intfunc.fold (fn (i,x) => fn a => x +/ a) + (Intfunc.combine (curry op */) (fn x => x =/ rat_0) (snd v1) (snd v2)) rat_0 + end; + +fun vector_of_list l = + let val n = length l + in (n,fold_rev2 (curry Intfunc.update) (1 upto n) l Intfunc.undefined) :vector + end; + +(* Matrices; again rows and columns indexed from 1. *) + +fun matrix_0 (m,n) = ((m,n),Intpairfunc.undefined):matrix; + +fun dimensions (m:matrix) = fst m; + +fun matrix_const c (mn as (m,n)) = + if m <> n then error "matrix_const: needs to be square" + else if c =/ rat_0 then matrix_0 mn + else (mn,fold_rev (fn k => Intpairfunc.update ((k,k), c)) (1 upto n) Intpairfunc.undefined) :matrix;; + +val matrix_1 = matrix_const rat_1; + +fun matrix_cmul c (m:matrix) = + let val (i,j) = dimensions m + in if c =/ rat_0 then matrix_0 (i,j) + else ((i,j),Intpairfunc.mapf (fn x => c */ x) (snd m)) + end; + +fun matrix_neg (m:matrix) = + (dimensions m, Intpairfunc.mapf Rat.neg (snd m)) :matrix; + +fun matrix_add (m1:matrix) (m2:matrix) = + let val d1 = dimensions m1 + val d2 = dimensions m2 + in if d1 <> d2 + then error "matrix_add: incompatible dimensions" + else (d1,Intpairfunc.combine (curry op +/) (fn x => x =/ rat_0) (snd m1) (snd m2)) :matrix + end;; + +fun matrix_sub m1 m2 = matrix_add m1 (matrix_neg m2); + +fun row k (m:matrix) = + let val (i,j) = dimensions m + in (j, + Intpairfunc.fold (fn ((i,j), c) => fn a => if i = k then Intfunc.update (j,c) a else a) (snd m) Intfunc.undefined ) : vector + end; + +fun column k (m:matrix) = + let val (i,j) = dimensions m + in (i, + Intpairfunc.fold (fn ((i,j), c) => fn a => if j = k then Intfunc.update (i,c) a else a) (snd m) Intfunc.undefined) + : vector + end; + +fun transp (m:matrix) = + let val (i,j) = dimensions m + in + ((j,i),Intpairfunc.fold (fn ((i,j), c) => fn a => Intpairfunc.update ((j,i), c) a) (snd m) Intpairfunc.undefined) :matrix + end; + +fun diagonal (v:vector) = + let val n = dim v + in ((n,n),Intfunc.fold (fn (i, c) => fn a => Intpairfunc.update ((i,i), c) a) (snd v) Intpairfunc.undefined) : matrix + end; + +fun matrix_of_list l = + let val m = length l + in if m = 0 then matrix_0 (0,0) else + let val n = length (hd l) + in ((m,n),itern 1 l (fn v => fn i => itern 1 v (fn c => fn j => Intpairfunc.update ((i,j), c))) Intpairfunc.undefined) + end + end; + +(* Monomials. *) + +fun monomial_eval assig (m:monomial) = + Ctermfunc.fold (fn (x, k) => fn a => a */ rat_pow (Ctermfunc.apply assig x) k) + m rat_1; +val monomial_1 = (Ctermfunc.undefined:monomial); + +fun monomial_var x = Ctermfunc.onefunc (x, 1) :monomial; + +val (monomial_mul:monomial->monomial->monomial) = + Ctermfunc.combine (curry op +) (K false); + +fun monomial_pow (m:monomial) k = + if k = 0 then monomial_1 + else Ctermfunc.mapf (fn x => k * x) m; + +fun monomial_divides (m1:monomial) (m2:monomial) = + Ctermfunc.fold (fn (x, k) => fn a => Ctermfunc.tryapplyd m2 x 0 >= k andalso a) m1 true;; + +fun monomial_div (m1:monomial) (m2:monomial) = + let val m = Ctermfunc.combine (curry op +) + (fn x => x = 0) m1 (Ctermfunc.mapf (fn x => ~ x) m2) + in if Ctermfunc.fold (fn (x, k) => fn a => k >= 0 andalso a) m true then m + else error "monomial_div: non-divisible" + end; + +fun monomial_degree x (m:monomial) = + Ctermfunc.tryapplyd m x 0;; + +fun monomial_lcm (m1:monomial) (m2:monomial) = + fold_rev (fn x => Ctermfunc.update (x, max (monomial_degree x m1) (monomial_degree x m2))) + (gen_union (is_equal o cterm_ord) (Ctermfunc.dom m1, Ctermfunc.dom m2)) (Ctermfunc.undefined :monomial); + +fun monomial_multidegree (m:monomial) = + Ctermfunc.fold (fn (x, k) => fn a => k + a) m 0;; + +fun monomial_variables m = Ctermfunc.dom m;; + +(* Polynomials. *) + +fun eval assig (p:poly) = + Monomialfunc.fold (fn (m, c) => fn a => a +/ c */ monomial_eval assig m) p rat_0; + +val poly_0 = (Monomialfunc.undefined:poly); + +fun poly_isconst (p:poly) = + Monomialfunc.fold (fn (m, c) => fn a => Ctermfunc.is_undefined m andalso a) p true; + +fun poly_var x = Monomialfunc.onefunc (monomial_var x,rat_1) :poly; + +fun poly_const c = + if c =/ rat_0 then poly_0 else Monomialfunc.onefunc(monomial_1, c); + +fun poly_cmul c (p:poly) = + if c =/ rat_0 then poly_0 + else Monomialfunc.mapf (fn x => c */ x) p; + +fun poly_neg (p:poly) = (Monomialfunc.mapf Rat.neg p :poly);; + +fun poly_add (p1:poly) (p2:poly) = + (Monomialfunc.combine (curry op +/) (fn x => x =/ rat_0) p1 p2 :poly); + +fun poly_sub p1 p2 = poly_add p1 (poly_neg p2); + +fun poly_cmmul (c,m) (p:poly) = + if c =/ rat_0 then poly_0 + else if Ctermfunc.is_undefined m + then Monomialfunc.mapf (fn d => c */ d) p + else Monomialfunc.fold (fn (m', d) => fn a => (Monomialfunc.update (monomial_mul m m', c */ d) a)) p poly_0; + +fun poly_mul (p1:poly) (p2:poly) = + Monomialfunc.fold (fn (m, c) => fn a => poly_add (poly_cmmul (c,m) p2) a) p1 poly_0; + +fun poly_div (p1:poly) (p2:poly) = + if not(poly_isconst p2) + then error "poly_div: non-constant" else + let val c = eval Ctermfunc.undefined p2 + in if c =/ rat_0 then error "poly_div: division by zero" + else poly_cmul (Rat.inv c) p1 + end; + +fun poly_square p = poly_mul p p; + +fun poly_pow p k = + if k = 0 then poly_const rat_1 + else if k = 1 then p + else let val q = poly_square(poly_pow p (k div 2)) in + if k mod 2 = 1 then poly_mul p q else q end; + +fun poly_exp p1 p2 = + if not(poly_isconst p2) + then error "poly_exp: not a constant" + else poly_pow p1 (int_of_rat (eval Ctermfunc.undefined p2)); + +fun degree x (p:poly) = + Monomialfunc.fold (fn (m,c) => fn a => max (monomial_degree x m) a) p 0; + +fun multidegree (p:poly) = + Monomialfunc.fold (fn (m, c) => fn a => max (monomial_multidegree m) a) p 0; + +fun poly_variables (p:poly) = + sort cterm_ord (Monomialfunc.fold_rev (fn (m, c) => curry (gen_union (is_equal o cterm_ord)) (monomial_variables m)) p []);; + +(* Order monomials for human presentation. *) + +fun cterm_ord (t,t') = TermOrd.fast_term_ord (term_of t, term_of t'); + +val humanorder_varpow = prod_ord cterm_ord (rev_order o int_ord); + +local + fun ord (l1,l2) = case (l1,l2) of + (_,[]) => LESS + | ([],_) => GREATER + | (h1::t1,h2::t2) => + (case humanorder_varpow (h1, h2) of + LESS => LESS + | EQUAL => ord (t1,t2) + | GREATER => GREATER) +in fun humanorder_monomial m1 m2 = + ord (sort humanorder_varpow (Ctermfunc.graph m1), + sort humanorder_varpow (Ctermfunc.graph m2)) +end; + +fun fold1 f l = case l of + [] => error "fold1" + | [x] => x + | (h::t) => f h (fold1 f t); + +(* Conversions to strings. *) + +fun string_of_vector min_size max_size (v:vector) = + let val n_raw = dim v + in if n_raw = 0 then "[]" else + let + val n = max min_size (min n_raw max_size) + val xs = map (Rat.string_of_rat o (fn i => Intfunc.tryapplyd (snd v) i rat_0)) (1 upto n) + in "[" ^ fold1 (fn s => fn t => s ^ ", " ^ t) xs ^ + (if n_raw > max_size then ", ...]" else "]") + end + end; + +fun string_of_matrix max_size (m:matrix) = + let + val (i_raw,j_raw) = dimensions m + val i = min max_size i_raw + val j = min max_size j_raw + val rstr = map (fn k => string_of_vector j j (row k m)) (1 upto i) + in "["^ fold1 (fn s => fn t => s^";\n "^t) rstr ^ + (if j > max_size then "\n ...]" else "]") + end; + +fun string_of_term t = + case t of + a$b => "("^(string_of_term a)^" "^(string_of_term b)^")" + | Abs x => + let val (xn, b) = Term.dest_abs x + in "(\\"^xn^"."^(string_of_term b)^")" + end + | Const(s,_) => s + | Free (s,_) => s + | Var((s,_),_) => s + | _ => error "string_of_term"; + +val string_of_cterm = string_of_term o term_of; + +fun string_of_varpow x k = + if k = 1 then string_of_cterm x + else string_of_cterm x^"^"^string_of_int k; + +fun string_of_monomial m = + if Ctermfunc.is_undefined m then "1" else + let val vps = fold_rev (fn (x,k) => fn a => string_of_varpow x k :: a) + (sort humanorder_varpow (Ctermfunc.graph m)) [] + in fold1 (fn s => fn t => s^"*"^t) vps + end; + +fun string_of_cmonomial (c,m) = + if Ctermfunc.is_undefined m then Rat.string_of_rat c + else if c =/ rat_1 then string_of_monomial m + else Rat.string_of_rat c ^ "*" ^ string_of_monomial m;; + +fun string_of_poly (p:poly) = + if Monomialfunc.is_undefined p then "<<0>>" else + let + val cms = sort (fn ((m1,_),(m2,_)) => humanorder_monomial m1 m2) (Monomialfunc.graph p) + val s = fold (fn (m,c) => fn a => + if c >" + end; + +(* Conversion from HOL term. *) + +local + val neg_tm = @{cterm "uminus :: real => _"} + val add_tm = @{cterm "op + :: real => _"} + val sub_tm = @{cterm "op - :: real => _"} + val mul_tm = @{cterm "op * :: real => _"} + val inv_tm = @{cterm "inverse :: real => _"} + val div_tm = @{cterm "op / :: real => _"} + val pow_tm = @{cterm "op ^ :: real => _"} + val zero_tm = @{cterm "0:: real"} + val is_numeral = can (HOLogic.dest_number o term_of) + fun is_comb t = case t of _$_ => true | _ => false + fun poly_of_term tm = + if tm aconvc zero_tm then poly_0 + else if RealArith.is_ratconst tm + then poly_const(RealArith.dest_ratconst tm) + else + (let val (lop,r) = Thm.dest_comb tm + in if lop aconvc neg_tm then poly_neg(poly_of_term r) + else if lop aconvc inv_tm then + let val p = poly_of_term r + in if poly_isconst p + then poly_const(Rat.inv (eval Ctermfunc.undefined p)) + else error "poly_of_term: inverse of non-constant polyomial" + end + else (let val (opr,l) = Thm.dest_comb lop + in + if opr aconvc pow_tm andalso is_numeral r + then poly_pow (poly_of_term l) ((snd o HOLogic.dest_number o term_of) r) + else if opr aconvc add_tm + then poly_add (poly_of_term l) (poly_of_term r) + else if opr aconvc sub_tm + then poly_sub (poly_of_term l) (poly_of_term r) + else if opr aconvc mul_tm + then poly_mul (poly_of_term l) (poly_of_term r) + else if opr aconvc div_tm + then let + val p = poly_of_term l + val q = poly_of_term r + in if poly_isconst q then poly_cmul (Rat.inv (eval Ctermfunc.undefined q)) p + else error "poly_of_term: division by non-constant polynomial" + end + else poly_var tm + + end + handle CTERM ("dest_comb",_) => poly_var tm) + end + handle CTERM ("dest_comb",_) => poly_var tm) +in +val poly_of_term = fn tm => + if type_of (term_of tm) = @{typ real} then poly_of_term tm + else error "poly_of_term: term does not have real type" +end; + +(* String of vector (just a list of space-separated numbers). *) + +fun sdpa_of_vector (v:vector) = + let + val n = dim v + val strs = map (decimalize 20 o (fn i => Intfunc.tryapplyd (snd v) i rat_0)) (1 upto n) + in fold1 (fn x => fn y => x ^ " " ^ y) strs ^ "\n" + end; + +fun increasing f ord (x,y) = ord (f x, f y); +fun triple_int_ord ((a,b,c),(a',b',c')) = + prod_ord int_ord (prod_ord int_ord int_ord) + ((a,(b,c)),(a',(b',c'))); +structure Inttriplefunc = FuncFun(type key = int*int*int val ord = triple_int_ord); + +(* String for block diagonal matrix numbered k. *) + +fun sdpa_of_blockdiagonal k m = + let + val pfx = string_of_int k ^" " + val ents = + Inttriplefunc.fold (fn ((b,i,j), c) => fn a => if i > j then a else ((b,i,j),c)::a) m [] + val entss = sort (increasing fst triple_int_ord ) ents + in fold_rev (fn ((b,i,j),c) => fn a => + pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ + " " ^ decimalize 20 c ^ "\n" ^ a) entss "" + end; + +(* String for a matrix numbered k, in SDPA sparse format. *) + +fun sdpa_of_matrix k (m:matrix) = + let + val pfx = string_of_int k ^ " 1 " + val ms = Intpairfunc.fold (fn ((i,j), c) => fn a => if i > j then a else ((i,j),c)::a) (snd m) [] + val mss = sort (increasing fst (prod_ord int_ord int_ord)) ms + in fold_rev (fn ((i,j),c) => fn a => + pfx ^ string_of_int i ^ " " ^ string_of_int j ^ + " " ^ decimalize 20 c ^ "\n" ^ a) mss "" + end;; + +(* ------------------------------------------------------------------------- *) +(* String in SDPA sparse format for standard SDP problem: *) +(* *) +(* X = v_1 * [M_1] + ... + v_m * [M_m] - [M_0] must be PSD *) +(* Minimize obj_1 * v_1 + ... obj_m * v_m *) +(* ------------------------------------------------------------------------- *) + +fun sdpa_of_problem obj mats = + let + val m = length mats - 1 + val (n,_) = dimensions (hd mats) + in + string_of_int m ^ "\n" ^ + "1\n" ^ + string_of_int n ^ "\n" ^ + sdpa_of_vector obj ^ + fold_rev2 (fn k => fn m => fn a => sdpa_of_matrix (k - 1) m ^ a) (1 upto length mats) mats "" + end; + +fun index_char str chr pos = + if pos >= String.size str then ~1 + else if String.sub(str,pos) = chr then pos + else index_char str chr (pos + 1); +fun rat_of_quotient (a,b) = if b = 0 then rat_0 else Rat.rat_of_quotient (a,b); +fun rat_of_string s = + let val n = index_char s #"/" 0 in + if n = ~1 then s |> IntInf.fromString |> valOf |> Rat.rat_of_int + else + let val SOME numer = IntInf.fromString(String.substring(s,0,n)) + val SOME den = IntInf.fromString (String.substring(s,n+1,String.size s - n - 1)) + in rat_of_quotient(numer, den) + end + end; + +fun isspace x = x = " " ; +fun isnum x = x mem_string ["0","1","2","3","4","5","6","7","8","9"] + +(* More parser basics. *) + +local + open Scan +in + val word = this_string + fun token s = + repeat ($$ " ") |-- word s --| repeat ($$ " ") + val numeral = one isnum + val decimalint = bulk numeral >> (rat_of_string o implode) + val decimalfrac = bulk numeral + >> (fn s => rat_of_string(implode s) // pow10 (length s)) + val decimalsig = + decimalint -- option (Scan.$$ "." |-- decimalfrac) + >> (fn (h,NONE) => h | (h,SOME x) => h +/ x) + fun signed prs = + $$ "-" |-- prs >> Rat.neg + || $$ "+" |-- prs + || prs; + +fun emptyin def xs = if null xs then (def,xs) else Scan.fail xs + + val exponent = ($$ "e" || $$ "E") |-- signed decimalint; + + val decimal = signed decimalsig -- (emptyin rat_0|| exponent) + >> (fn (h, x) => h */ pow10 (int_of_rat x)); +end; + + fun mkparser p s = + let val (x,rst) = p (explode s) + in if null rst then x + else error "mkparser: unparsed input" + end;; + +(* Parse back csdp output. *) + + fun ignore inp = ((),[]) + fun csdpoutput inp = ((decimal -- Scan.bulk (Scan.$$ " " |-- Scan.option decimal) >> (fn (h,to) => map_filter I ((SOME h)::to))) --| ignore >> vector_of_list) inp + val parse_csdpoutput = mkparser csdpoutput + +(* Run prover on a problem in linear form. *) + +fun run_problem prover obj mats = + parse_csdpoutput (prover (sdpa_of_problem obj mats)) + +(* Try some apparently sensible scaling first. Note that this is purely to *) +(* get a cleaner translation to floating-point, and doesn't affect any of *) +(* the results, in principle. In practice it seems a lot better when there *) +(* are extreme numbers in the original problem. *) + + (* Version for (int*int) keys *) +local + fun max_rat x y = if x fn a => lcm_rat (denominator_rat c) a) amat acc + fun maximal_element fld amat acc = + fld (fn (m,c) => fn maxa => max_rat maxa (abs_rat c)) amat acc +fun float_of_rat x = let val (a,b) = Rat.quotient_of_rat x + in Real.fromLargeInt a / Real.fromLargeInt b end; +in + +fun pi_scale_then solver (obj:vector) mats = + let + val cd1 = fold_rev (common_denominator Intpairfunc.fold) mats (rat_1) + val cd2 = common_denominator Intfunc.fold (snd obj) (rat_1) + val mats' = map (Intpairfunc.mapf (fn x => cd1 */ x)) mats + val obj' = vector_cmul cd2 obj + val max1 = fold_rev (maximal_element Intpairfunc.fold) mats' (rat_0) + val max2 = maximal_element Intfunc.fold (snd obj') (rat_0) + val scal1 = pow2 (20 - trunc(Math.ln (float_of_rat max1) / Math.ln 2.0)) + val scal2 = pow2 (20 - trunc(Math.ln (float_of_rat max2) / Math.ln 2.0)) + val mats'' = map (Intpairfunc.mapf (fn x => x */ scal1)) mats' + val obj'' = vector_cmul scal2 obj' + in solver obj'' mats'' + end +end; + +(* Try some apparently sensible scaling first. Note that this is purely to *) +(* get a cleaner translation to floating-point, and doesn't affect any of *) +(* the results, in principle. In practice it seems a lot better when there *) +(* are extreme numbers in the original problem. *) + + (* Version for (int*int*int) keys *) +local + fun max_rat x y = if x fn a => lcm_rat (denominator_rat c) a) amat acc + fun maximal_element fld amat acc = + fld (fn (m,c) => fn maxa => max_rat maxa (abs_rat c)) amat acc +fun float_of_rat x = let val (a,b) = Rat.quotient_of_rat x + in Real.fromLargeInt a / Real.fromLargeInt b end; +fun int_of_float x = (trunc x handle Overflow => 0 | Domain => 0) +in + +fun tri_scale_then solver (obj:vector) mats = + let + val cd1 = fold_rev (common_denominator Inttriplefunc.fold) mats (rat_1) + val cd2 = common_denominator Intfunc.fold (snd obj) (rat_1) + val mats' = map (Inttriplefunc.mapf (fn x => cd1 */ x)) mats + val obj' = vector_cmul cd2 obj + val max1 = fold_rev (maximal_element Inttriplefunc.fold) mats' (rat_0) + val max2 = maximal_element Intfunc.fold (snd obj') (rat_0) + val scal1 = pow2 (20 - int_of_float(Math.ln (float_of_rat max1) / Math.ln 2.0)) + val scal2 = pow2 (20 - int_of_float(Math.ln (float_of_rat max2) / Math.ln 2.0)) + val mats'' = map (Inttriplefunc.mapf (fn x => x */ scal1)) mats' + val obj'' = vector_cmul scal2 obj' + in solver obj'' mats'' + end +end; + +(* Round a vector to "nice" rationals. *) + +fun nice_rational n x = round_rat (n */ x) // n;; +fun nice_vector n ((d,v) : vector) = + (d, Intfunc.fold (fn (i,c) => fn a => + let val y = nice_rational n c + in if c =/ rat_0 then a + else Intfunc.update (i,y) a end) v Intfunc.undefined):vector + +fun dest_ord f x = is_equal (f x); + +(* Stuff for "equations" ((int*int*int)->num functions). *) + +fun tri_equation_cmul c eq = + if c =/ rat_0 then Inttriplefunc.undefined else Inttriplefunc.mapf (fn d => c */ d) eq; + +fun tri_equation_add eq1 eq2 = Inttriplefunc.combine (curry op +/) (fn x => x =/ rat_0) eq1 eq2; + +fun tri_equation_eval assig eq = + let fun value v = Inttriplefunc.apply assig v + in Inttriplefunc.fold (fn (v, c) => fn a => a +/ value v */ c) eq rat_0 + end; + +(* Eliminate among linear equations: return unconstrained variables and *) +(* assignments for the others in terms of them. We give one pseudo-variable *) +(* "one" that's used for a constant term. *) + +local + fun extract_first p l = case l of (* FIXME : use find_first instead *) + [] => error "extract_first" + | h::t => if p h then (h,t) else + let val (k,s) = extract_first p t in (k,h::s) end +fun eliminate vars dun eqs = case vars of + [] => if forall Inttriplefunc.is_undefined eqs then dun + else raise Unsolvable + | v::vs => + ((let + val (eq,oeqs) = extract_first (fn e => Inttriplefunc.defined e v) eqs + val a = Inttriplefunc.apply eq v + val eq' = tri_equation_cmul ((Rat.neg rat_1) // a) (Inttriplefunc.undefine v eq) + fun elim e = + let val b = Inttriplefunc.tryapplyd e v rat_0 + in if b =/ rat_0 then e else + tri_equation_add e (tri_equation_cmul (Rat.neg b // a) eq) + end + in eliminate vs (Inttriplefunc.update (v,eq') (Inttriplefunc.mapf elim dun)) (map elim oeqs) + end) + handle Failure _ => eliminate vs dun eqs) +in +fun tri_eliminate_equations one vars eqs = + let + val assig = eliminate vars Inttriplefunc.undefined eqs + val vs = Inttriplefunc.fold (fn (x, f) => fn a => remove (dest_ord triple_int_ord) one (Inttriplefunc.dom f) @ a) assig [] + in (distinct (dest_ord triple_int_ord) vs, assig) + end +end; + +(* Eliminate all variables, in an essentially arbitrary order. *) + +fun tri_eliminate_all_equations one = + let + fun choose_variable eq = + let val (v,_) = Inttriplefunc.choose eq + in if is_equal (triple_int_ord(v,one)) then + let val eq' = Inttriplefunc.undefine v eq + in if Inttriplefunc.is_undefined eq' then error "choose_variable" + else fst (Inttriplefunc.choose eq') + end + else v + end + fun eliminate dun eqs = case eqs of + [] => dun + | eq::oeqs => + if Inttriplefunc.is_undefined eq then eliminate dun oeqs else + let val v = choose_variable eq + val a = Inttriplefunc.apply eq v + val eq' = tri_equation_cmul ((Rat.rat_of_int ~1) // a) + (Inttriplefunc.undefine v eq) + fun elim e = + let val b = Inttriplefunc.tryapplyd e v rat_0 + in if b =/ rat_0 then e + else tri_equation_add e (tri_equation_cmul (Rat.neg b // a) eq) + end + in eliminate (Inttriplefunc.update(v, eq') (Inttriplefunc.mapf elim dun)) + (map elim oeqs) + end +in fn eqs => + let + val assig = eliminate Inttriplefunc.undefined eqs + val vs = Inttriplefunc.fold (fn (x, f) => fn a => remove (dest_ord triple_int_ord) one (Inttriplefunc.dom f) @ a) assig [] + in (distinct (dest_ord triple_int_ord) vs,assig) + end +end; + +(* Solve equations by assigning arbitrary numbers. *) + +fun tri_solve_equations one eqs = + let + val (vars,assigs) = tri_eliminate_all_equations one eqs + val vfn = fold_rev (fn v => Inttriplefunc.update(v,rat_0)) vars + (Inttriplefunc.onefunc(one, Rat.rat_of_int ~1)) + val ass = + Inttriplefunc.combine (curry op +/) (K false) + (Inttriplefunc.mapf (tri_equation_eval vfn) assigs) vfn + in if forall (fn e => tri_equation_eval ass e =/ rat_0) eqs + then Inttriplefunc.undefine one ass else raise Sanity + end; + +(* Multiply equation-parametrized poly by regular poly and add accumulator. *) + +fun tri_epoly_pmul p q acc = + Monomialfunc.fold (fn (m1, c) => fn a => + Monomialfunc.fold (fn (m2,e) => fn b => + let val m = monomial_mul m1 m2 + val es = Monomialfunc.tryapplyd b m Inttriplefunc.undefined + in Monomialfunc.update (m,tri_equation_add (tri_equation_cmul c e) es) b + end) q a) p acc ; + +(* Usual operations on equation-parametrized poly. *) + +fun tri_epoly_cmul c l = + if c =/ rat_0 then Inttriplefunc.undefined else Inttriplefunc.mapf (tri_equation_cmul c) l;; + +val tri_epoly_neg = tri_epoly_cmul (Rat.rat_of_int ~1); + +val tri_epoly_add = Inttriplefunc.combine tri_equation_add Inttriplefunc.is_undefined; + +fun tri_epoly_sub p q = tri_epoly_add p (tri_epoly_neg q);; + +(* Stuff for "equations" ((int*int)->num functions). *) + +fun pi_equation_cmul c eq = + if c =/ rat_0 then Inttriplefunc.undefined else Inttriplefunc.mapf (fn d => c */ d) eq; + +fun pi_equation_add eq1 eq2 = Inttriplefunc.combine (curry op +/) (fn x => x =/ rat_0) eq1 eq2; + +fun pi_equation_eval assig eq = + let fun value v = Inttriplefunc.apply assig v + in Inttriplefunc.fold (fn (v, c) => fn a => a +/ value v */ c) eq rat_0 + end; + +(* Eliminate among linear equations: return unconstrained variables and *) +(* assignments for the others in terms of them. We give one pseudo-variable *) +(* "one" that's used for a constant term. *) + +local +fun extract_first p l = case l of + [] => error "extract_first" + | h::t => if p h then (h,t) else + let val (k,s) = extract_first p t in (k,h::s) end +fun eliminate vars dun eqs = case vars of + [] => if forall Inttriplefunc.is_undefined eqs then dun + else raise Unsolvable + | v::vs => + let + val (eq,oeqs) = extract_first (fn e => Inttriplefunc.defined e v) eqs + val a = Inttriplefunc.apply eq v + val eq' = pi_equation_cmul ((Rat.neg rat_1) // a) (Inttriplefunc.undefine v eq) + fun elim e = + let val b = Inttriplefunc.tryapplyd e v rat_0 + in if b =/ rat_0 then e else + pi_equation_add e (pi_equation_cmul (Rat.neg b // a) eq) + end + in eliminate vs (Inttriplefunc.update (v,eq') (Inttriplefunc.mapf elim dun)) (map elim oeqs) + end + handle Failure _ => eliminate vs dun eqs +in +fun pi_eliminate_equations one vars eqs = + let + val assig = eliminate vars Inttriplefunc.undefined eqs + val vs = Inttriplefunc.fold (fn (x, f) => fn a => remove (dest_ord triple_int_ord) one (Inttriplefunc.dom f) @ a) assig [] + in (distinct (dest_ord triple_int_ord) vs, assig) + end +end; + +(* Eliminate all variables, in an essentially arbitrary order. *) + +fun pi_eliminate_all_equations one = + let + fun choose_variable eq = + let val (v,_) = Inttriplefunc.choose eq + in if is_equal (triple_int_ord(v,one)) then + let val eq' = Inttriplefunc.undefine v eq + in if Inttriplefunc.is_undefined eq' then error "choose_variable" + else fst (Inttriplefunc.choose eq') + end + else v + end + fun eliminate dun eqs = case eqs of + [] => dun + | eq::oeqs => + if Inttriplefunc.is_undefined eq then eliminate dun oeqs else + let val v = choose_variable eq + val a = Inttriplefunc.apply eq v + val eq' = pi_equation_cmul ((Rat.rat_of_int ~1) // a) + (Inttriplefunc.undefine v eq) + fun elim e = + let val b = Inttriplefunc.tryapplyd e v rat_0 + in if b =/ rat_0 then e + else pi_equation_add e (pi_equation_cmul (Rat.neg b // a) eq) + end + in eliminate (Inttriplefunc.update(v, eq') (Inttriplefunc.mapf elim dun)) + (map elim oeqs) + end +in fn eqs => + let + val assig = eliminate Inttriplefunc.undefined eqs + val vs = Inttriplefunc.fold (fn (x, f) => fn a => remove (dest_ord triple_int_ord) one (Inttriplefunc.dom f) @ a) assig [] + in (distinct (dest_ord triple_int_ord) vs,assig) + end +end; + +(* Solve equations by assigning arbitrary numbers. *) + +fun pi_solve_equations one eqs = + let + val (vars,assigs) = pi_eliminate_all_equations one eqs + val vfn = fold_rev (fn v => Inttriplefunc.update(v,rat_0)) vars + (Inttriplefunc.onefunc(one, Rat.rat_of_int ~1)) + val ass = + Inttriplefunc.combine (curry op +/) (K false) + (Inttriplefunc.mapf (pi_equation_eval vfn) assigs) vfn + in if forall (fn e => pi_equation_eval ass e =/ rat_0) eqs + then Inttriplefunc.undefine one ass else raise Sanity + end; + +(* Multiply equation-parametrized poly by regular poly and add accumulator. *) + +fun pi_epoly_pmul p q acc = + Monomialfunc.fold (fn (m1, c) => fn a => + Monomialfunc.fold (fn (m2,e) => fn b => + let val m = monomial_mul m1 m2 + val es = Monomialfunc.tryapplyd b m Inttriplefunc.undefined + in Monomialfunc.update (m,pi_equation_add (pi_equation_cmul c e) es) b + end) q a) p acc ; + +(* Usual operations on equation-parametrized poly. *) + +fun pi_epoly_cmul c l = + if c =/ rat_0 then Inttriplefunc.undefined else Inttriplefunc.mapf (pi_equation_cmul c) l;; + +val pi_epoly_neg = pi_epoly_cmul (Rat.rat_of_int ~1); + +val pi_epoly_add = Inttriplefunc.combine pi_equation_add Inttriplefunc.is_undefined; + +fun pi_epoly_sub p q = pi_epoly_add p (pi_epoly_neg q);; + +fun allpairs f l1 l2 = fold_rev (fn x => (curry (op @)) (map (f x) l2)) l1 []; + +(* Hence produce the "relevant" monomials: those whose squares lie in the *) +(* Newton polytope of the monomials in the input. (This is enough according *) +(* to Reznik: "Extremal PSD forms with few terms", Duke Math. Journal, *) +(* vol 45, pp. 363--374, 1978. *) +(* *) +(* These are ordered in sort of decreasing degree. In particular the *) +(* constant monomial is last; this gives an order in diagonalization of the *) +(* quadratic form that will tend to display constants. *) + +(* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form. *) + +local +fun diagonalize n i m = + if Intpairfunc.is_undefined (snd m) then [] + else + let val a11 = Intpairfunc.tryapplyd (snd m) (i,i) rat_0 + in if a11 fn a => + let val y = c // a11 + in if y = rat_0 then a else Intfunc.update (i,y) a + end) (snd v) Intfunc.undefined) + fun upt0 x y a = if y = rat_0 then a else Intpairfunc.update (x,y) a + val m' = + ((n,n), + iter (i+1,n) (fn j => + iter (i+1,n) (fn k => + (upt0 (j,k) (Intpairfunc.tryapplyd (snd m) (j,k) rat_0 -/ Intfunc.tryapplyd (snd v) j rat_0 */ Intfunc.tryapplyd (snd v') k rat_0)))) + Intpairfunc.undefined) + in (a11,v')::diagonalize n (i + 1) m' + end + end +in +fun diag m = + let + val nn = dimensions m + val n = fst nn + in if snd nn <> n then error "diagonalize: non-square matrix" + else diagonalize n 1 m + end +end; + +fun gcd_rat a b = Rat.rat_of_int (Integer.gcd (int_of_rat a) (int_of_rat b)); + +(* Adjust a diagonalization to collect rationals at the start. *) + (* FIXME : Potentially polymorphic keys, but here only: integers!! *) +local + fun upd0 x y a = if y =/ rat_0 then a else Intfunc.update(x,y) a; + fun mapa f (d,v) = + (d, Intfunc.fold (fn (i,c) => fn a => upd0 i (f c) a) v Intfunc.undefined) + fun adj (c,l) = + let val a = + Intfunc.fold (fn (i,c) => fn a => lcm_rat a (denominator_rat c)) + (snd l) rat_1 // + Intfunc.fold (fn (i,c) => fn a => gcd_rat a (numerator_rat c)) + (snd l) rat_0 + in ((c // (a */ a)),mapa (fn x => a */ x) l) + end +in +fun deration d = if null d then (rat_0,d) else + let val d' = map adj d + val a = fold (lcm_rat o denominator_rat o fst) d' rat_1 // + fold (gcd_rat o numerator_rat o fst) d' rat_0 + in ((rat_1 // a),map (fn (c,l) => (a */ c,l)) d') + end +end; + +(* Enumeration of monomials with given multidegree bound. *) + +fun enumerate_monomials d vars = + if d < 0 then [] + else if d = 0 then [Ctermfunc.undefined] + else if null vars then [monomial_1] else + let val alts = + map (fn k => let val oths = enumerate_monomials (d - k) (tl vars) + in map (fn ks => if k = 0 then ks else Ctermfunc.update (hd vars, k) ks) oths end) (0 upto d) + in fold1 (curry op @) alts + end; + +(* Enumerate products of distinct input polys with degree <= d. *) +(* We ignore any constant input polynomials. *) +(* Give the output polynomial and a record of how it was derived. *) + +local + open RealArith +in +fun enumerate_products d pols = +if d = 0 then [(poly_const rat_1,Rational_lt rat_1)] +else if d < 0 then [] else +case pols of + [] => [(poly_const rat_1,Rational_lt rat_1)] + | (p,b)::ps => + let val e = multidegree p + in if e = 0 then enumerate_products d ps else + enumerate_products d ps @ + map (fn (q,c) => (poly_mul p q,Product(b,c))) + (enumerate_products (d - e) ps) + end +end; + +(* Convert regular polynomial. Note that we treat (0,0,0) as -1. *) + +fun epoly_of_poly p = + Monomialfunc.fold (fn (m,c) => fn a => Monomialfunc.update (m, Inttriplefunc.onefunc ((0,0,0), Rat.neg c)) a) p Monomialfunc.undefined; + +(* String for block diagonal matrix numbered k. *) + +fun sdpa_of_blockdiagonal k m = + let + val pfx = string_of_int k ^" " + val ents = + Inttriplefunc.fold + (fn ((b,i,j),c) => fn a => if i > j then a else ((b,i,j),c)::a) + m [] + val entss = sort (increasing fst triple_int_ord) ents + in fold_rev (fn ((b,i,j),c) => fn a => + pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ + " " ^ decimalize 20 c ^ "\n" ^ a) entss "" + end; + +(* SDPA for problem using block diagonal (i.e. multiple SDPs) *) + +fun sdpa_of_blockproblem nblocks blocksizes obj mats = + let val m = length mats - 1 + in + string_of_int m ^ "\n" ^ + string_of_int nblocks ^ "\n" ^ + (fold1 (fn s => fn t => s^" "^t) (map string_of_int blocksizes)) ^ + "\n" ^ + sdpa_of_vector obj ^ + fold_rev2 (fn k => fn m => fn a => sdpa_of_blockdiagonal (k - 1) m ^ a) + (1 upto length mats) mats "" + end; + +(* Run prover on a problem in block diagonal form. *) + +fun run_blockproblem prover nblocks blocksizes obj mats= + parse_csdpoutput (prover (sdpa_of_blockproblem nblocks blocksizes obj mats)) + +(* 3D versions of matrix operations to consider blocks separately. *) + +val bmatrix_add = Inttriplefunc.combine (curry op +/) (fn x => x =/ rat_0); +fun bmatrix_cmul c bm = + if c =/ rat_0 then Inttriplefunc.undefined + else Inttriplefunc.mapf (fn x => c */ x) bm; + +val bmatrix_neg = bmatrix_cmul (Rat.rat_of_int ~1); +fun bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);; + +(* Smash a block matrix into components. *) + +fun blocks blocksizes bm = + map (fn (bs,b0) => + let val m = Inttriplefunc.fold + (fn ((b,i,j),c) => fn a => if b = b0 then Intpairfunc.update ((i,j),c) a else a) bm Intpairfunc.undefined + val d = Intpairfunc.fold (fn ((i,j),c) => fn a => max a (max i j)) m 0 + in (((bs,bs),m):matrix) end) + (blocksizes ~~ (1 upto length blocksizes));; + +(* FIXME : Get rid of this !!!*) +local + fun tryfind_with msg f [] = raise Failure msg + | tryfind_with msg f (x::xs) = (f x handle Failure s => tryfind_with s f xs); +in + fun tryfind f = tryfind_with "tryfind" f +end + +(* +fun tryfind f [] = error "tryfind" + | tryfind f (x::xs) = (f x handle ERROR _ => tryfind f xs); +*) + +(* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *) + + +local + open RealArith +in +fun real_positivnullstellensatz_general prover linf d eqs leqs pol = +let + val vars = fold_rev (curry (gen_union (op aconvc)) o poly_variables) + (pol::eqs @ map fst leqs) [] + val monoid = if linf then + (poly_const rat_1,Rational_lt rat_1):: + (filter (fn (p,c) => multidegree p <= d) leqs) + else enumerate_products d leqs + val nblocks = length monoid + fun mk_idmultiplier k p = + let + val e = d - multidegree p + val mons = enumerate_monomials e vars + val nons = mons ~~ (1 upto length mons) + in (mons, + fold_rev (fn (m,n) => Monomialfunc.update(m,Inttriplefunc.onefunc((~k,~n,n),rat_1))) nons Monomialfunc.undefined) + end + + fun mk_sqmultiplier k (p,c) = + let + val e = (d - multidegree p) div 2 + val mons = enumerate_monomials e vars + val nons = mons ~~ (1 upto length mons) + in (mons, + fold_rev (fn (m1,n1) => + fold_rev (fn (m2,n2) => fn a => + let val m = monomial_mul m1 m2 + in if n1 > n2 then a else + let val c = if n1 = n2 then rat_1 else rat_2 + val e = Monomialfunc.tryapplyd a m Inttriplefunc.undefined + in Monomialfunc.update(m, tri_equation_add (Inttriplefunc.onefunc((k,n1,n2), c)) e) a + end + end) nons) + nons Monomialfunc.undefined) + end + + val (sqmonlist,sqs) = split_list (map2 mk_sqmultiplier (1 upto length monoid) monoid) + val (idmonlist,ids) = split_list(map2 mk_idmultiplier (1 upto length eqs) eqs) + val blocksizes = map length sqmonlist + val bigsum = + fold_rev2 (fn p => fn q => fn a => tri_epoly_pmul p q a) eqs ids + (fold_rev2 (fn (p,c) => fn s => fn a => tri_epoly_pmul p s a) monoid sqs + (epoly_of_poly(poly_neg pol))) + val eqns = Monomialfunc.fold (fn (m,e) => fn a => e::a) bigsum [] + val (pvs,assig) = tri_eliminate_all_equations (0,0,0) eqns + val qvars = (0,0,0)::pvs + val allassig = fold_rev (fn v => Inttriplefunc.update(v,(Inttriplefunc.onefunc(v,rat_1)))) pvs assig + fun mk_matrix v = + Inttriplefunc.fold (fn ((b,i,j), ass) => fn m => + if b < 0 then m else + let val c = Inttriplefunc.tryapplyd ass v rat_0 + in if c = rat_0 then m else + Inttriplefunc.update ((b,j,i), c) (Inttriplefunc.update ((b,i,j), c) m) + end) + allassig Inttriplefunc.undefined + val diagents = Inttriplefunc.fold + (fn ((b,i,j), e) => fn a => if b > 0 andalso i = j then tri_equation_add e a else a) + allassig Inttriplefunc.undefined + + val mats = map mk_matrix qvars + val obj = (length pvs, + itern 1 pvs (fn v => fn i => Intfunc.updatep iszero (i,Inttriplefunc.tryapplyd diagents v rat_0)) + Intfunc.undefined) + val raw_vec = if null pvs then vector_0 0 + else tri_scale_then (run_blockproblem prover nblocks blocksizes) obj mats + fun int_element (d,v) i = Intfunc.tryapplyd v i rat_0 + fun cterm_element (d,v) i = Ctermfunc.tryapplyd v i rat_0 + + fun find_rounding d = + let + val _ = if !debugging + then writeln ("Trying rounding with limit "^Rat.string_of_rat d ^ "\n") + else () + val vec = nice_vector d raw_vec + val blockmat = iter (1,dim vec) + (fn i => fn a => bmatrix_add (bmatrix_cmul (int_element vec i) (nth mats i)) a) + (bmatrix_neg (nth mats 0)) + val allmats = blocks blocksizes blockmat + in (vec,map diag allmats) + end + val (vec,ratdias) = + if null pvs then find_rounding rat_1 + else tryfind find_rounding (map Rat.rat_of_int (1 upto 31) @ + map pow2 (5 upto 66)) + val newassigs = + fold_rev (fn k => Inttriplefunc.update (nth pvs (k - 1), int_element vec k)) + (1 upto dim vec) (Inttriplefunc.onefunc ((0,0,0), Rat.rat_of_int ~1)) + val finalassigs = + Inttriplefunc.fold (fn (v,e) => fn a => Inttriplefunc.update(v, tri_equation_eval newassigs e) a) allassig newassigs + fun poly_of_epoly p = + Monomialfunc.fold (fn (v,e) => fn a => Monomialfunc.updatep iszero (v,tri_equation_eval finalassigs e) a) + p Monomialfunc.undefined + fun mk_sos mons = + let fun mk_sq (c,m) = + (c,fold_rev (fn k=> fn a => Monomialfunc.updatep iszero (nth mons (k - 1), int_element m k) a) + (1 upto length mons) Monomialfunc.undefined) + in map mk_sq + end + val sqs = map2 mk_sos sqmonlist ratdias + val cfs = map poly_of_epoly ids + val msq = filter (fn (a,b) => not (null b)) (map2 pair monoid sqs) + fun eval_sq sqs = fold_rev (fn (c,q) => poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 + val sanity = + fold_rev (fn ((p,c),s) => poly_add (poly_mul p (eval_sq s))) msq + (fold_rev2 (fn p => fn q => poly_add (poly_mul p q)) cfs eqs + (poly_neg pol)) + +in if not(Monomialfunc.is_undefined sanity) then raise Sanity else + (cfs,map (fn (a,b) => (snd a,b)) msq) + end + + +end; + +(* Iterative deepening. *) + +fun deepen f n = + (writeln ("Searching with depth limit " ^ string_of_int n) ; (f n handle Failure s => (writeln ("failed with message: " ^ s) ; deepen f (n+1)))) + +(* The ordering so we can create canonical HOL polynomials. *) + +fun dest_monomial mon = sort (increasing fst cterm_ord) (Ctermfunc.graph mon); + +fun monomial_order (m1,m2) = + if Ctermfunc.is_undefined m2 then LESS + else if Ctermfunc.is_undefined m1 then GREATER + else + let val mon1 = dest_monomial m1 + val mon2 = dest_monomial m2 + val deg1 = fold (curry op + o snd) mon1 0 + val deg2 = fold (curry op + o snd) mon2 0 + in if deg1 < deg2 then GREATER else if deg1 > deg2 then LESS + else list_ord (prod_ord cterm_ord int_ord) (mon1,mon2) + end; + +fun dest_poly p = + map (fn (m,c) => (c,dest_monomial m)) + (sort (prod_ord monomial_order (K EQUAL)) (Monomialfunc.graph p)); + +(* Map back polynomials and their composites to HOL. *) + +local + open Thm Numeral RealArith +in + +fun cterm_of_varpow x k = if k = 1 then x else capply (capply @{cterm "op ^ :: real => _"} x) + (mk_cnumber @{ctyp nat} k) + +fun cterm_of_monomial m = + if Ctermfunc.is_undefined m then @{cterm "1::real"} + else + let + val m' = dest_monomial m + val vps = fold_rev (fn (x,k) => cons (cterm_of_varpow x k)) m' [] + in fold1 (fn s => fn t => capply (capply @{cterm "op * :: real => _"} s) t) vps + end + +fun cterm_of_cmonomial (m,c) = if Ctermfunc.is_undefined m then cterm_of_rat c + else if c = Rat.one then cterm_of_monomial m + else capply (capply @{cterm "op *::real => _"} (cterm_of_rat c)) (cterm_of_monomial m); + +fun cterm_of_poly p = + if Monomialfunc.is_undefined p then @{cterm "0::real"} + else + let + val cms = map cterm_of_cmonomial + (sort (prod_ord monomial_order (K EQUAL)) (Monomialfunc.graph p)) + in fold1 (fn t1 => fn t2 => capply(capply @{cterm "op + :: real => _"} t1) t2) cms + end; + +fun cterm_of_sqterm (c,p) = Product(Rational_lt c,Square(cterm_of_poly p)); + +fun cterm_of_sos (pr,sqs) = if null sqs then pr + else Product(pr,fold1 (fn a => fn b => Sum(a,b)) (map cterm_of_sqterm sqs)); + +end + +(* Interface to HOL. *) +local + open Thm Conv RealArith + val concl = dest_arg o cprop_of + fun simple_cterm_ord t u = TermOrd.fast_term_ord (term_of t, term_of u) = LESS +in + (* FIXME: Replace tryfind by get_first !! *) +fun real_nonlinear_prover prover ctxt = + let + val {add,mul,neg,pow,sub,main} = Normalizer.semiring_normalizers_ord_wrapper ctxt + (valOf (NormalizerData.match ctxt @{cterm "(0::real) + 1"})) + simple_cterm_ord + val (real_poly_add_conv,real_poly_mul_conv,real_poly_neg_conv, + real_poly_pow_conv,real_poly_sub_conv,real_poly_conv) = (add,mul,neg,pow,sub,main) + fun mainf translator (eqs,les,lts) = + let + val eq0 = map (poly_of_term o dest_arg1 o concl) eqs + val le0 = map (poly_of_term o dest_arg o concl) les + val lt0 = map (poly_of_term o dest_arg o concl) lts + val eqp0 = map (fn (t,i) => (t,Axiom_eq i)) (eq0 ~~ (0 upto (length eq0 - 1))) + val lep0 = map (fn (t,i) => (t,Axiom_le i)) (le0 ~~ (0 upto (length le0 - 1))) + val ltp0 = map (fn (t,i) => (t,Axiom_lt i)) (lt0 ~~ (0 upto (length lt0 - 1))) + val (keq,eq) = List.partition (fn (p,_) => multidegree p = 0) eqp0 + val (klep,lep) = List.partition (fn (p,_) => multidegree p = 0) lep0 + val (kltp,ltp) = List.partition (fn (p,_) => multidegree p = 0) ltp0 + fun trivial_axiom (p,ax) = + case ax of + Axiom_eq n => if eval Ctermfunc.undefined p <>/ Rat.zero then nth eqs n + else raise Failure "trivial_axiom: Not a trivial axiom" + | Axiom_le n => if eval Ctermfunc.undefined p if eval Ctermfunc.undefined p <=/ Rat.zero then nth lts n + else raise Failure "trivial_axiom: Not a trivial axiom" + | _ => error "trivial_axiom: Not a trivial axiom" + in + ((let val th = tryfind trivial_axiom (keq @ klep @ kltp) + in fconv_rule (arg_conv (arg1_conv real_poly_conv) then_conv field_comp_conv) th end) + handle Failure _ => ( + let + val pol = fold_rev poly_mul (map fst ltp) (poly_const Rat.one) + val leq = lep @ ltp + fun tryall d = + let val e = multidegree pol + val k = if e = 0 then 0 else d div e + val eq' = map fst eq + in tryfind (fn i => (d,i,real_positivnullstellensatz_general prover false d eq' leq + (poly_neg(poly_pow pol i)))) + (0 upto k) + end + val (d,i,(cert_ideal,cert_cone)) = deepen tryall 0 + val proofs_ideal = + map2 (fn q => fn (p,ax) => Eqmul(cterm_of_poly q,ax)) cert_ideal eq + val proofs_cone = map cterm_of_sos cert_cone + val proof_ne = if null ltp then Rational_lt Rat.one else + let val p = fold1 (fn s => fn t => Product(s,t)) (map snd ltp) + in funpow i (fn q => Product(p,q)) (Rational_lt Rat.one) + end + val proof = fold1 (fn s => fn t => Sum(s,t)) + (proof_ne :: proofs_ideal @ proofs_cone) + in writeln "Translating proof certificate to HOL"; + translator (eqs,les,lts) proof + end)) + end + in mainf end +end + +fun C f x y = f y x; + (* FIXME : This is very bad!!!*) +fun subst_conv eqs t = + let + val t' = fold (Thm.cabs o Thm.lhs_of) eqs t + in Conv.fconv_rule (Thm.beta_conversion true) (fold (C combination) eqs (reflexive t')) + end + +(* A wrapper that tries to substitute away variables first. *) + +local + open Thm Conv RealArith + fun simple_cterm_ord t u = TermOrd.fast_term_ord (term_of t, term_of u) = LESS + val concl = dest_arg o cprop_of + val shuffle1 = + fconv_rule (rewr_conv @{lemma "(a + x == y) == (x == y - (a::real))" by (atomize (full)) (simp add: ring_simps) }) + val shuffle2 = + fconv_rule (rewr_conv @{lemma "(x + a == y) == (x == y - (a::real))" by (atomize (full)) (simp add: ring_simps)}) + fun substitutable_monomial fvs tm = case term_of tm of + Free(_,@{typ real}) => if not (member (op aconvc) fvs tm) then (Rat.one,tm) + else raise Failure "substitutable_monomial" + | @{term "op * :: real => _"}$c$(t as Free _ ) => + if is_ratconst (dest_arg1 tm) andalso not (member (op aconvc) fvs (dest_arg tm)) + then (dest_ratconst (dest_arg1 tm),dest_arg tm) else raise Failure "substitutable_monomial" + | @{term "op + :: real => _"}$s$t => + (substitutable_monomial (add_cterm_frees (dest_arg tm) fvs) (dest_arg1 tm) + handle Failure _ => substitutable_monomial (add_cterm_frees (dest_arg1 tm) fvs) (dest_arg tm)) + | _ => raise Failure "substitutable_monomial" + + fun isolate_variable v th = + let val w = dest_arg1 (cprop_of th) + in if v aconvc w then th + else case term_of w of + @{term "op + :: real => _"}$s$t => + if dest_arg1 w aconvc v then shuffle2 th + else isolate_variable v (shuffle1 th) + | _ => error "isolate variable : This should not happen?" + end +in + +fun real_nonlinear_subst_prover prover ctxt = + let + val {add,mul,neg,pow,sub,main} = Normalizer.semiring_normalizers_ord_wrapper ctxt + (valOf (NormalizerData.match ctxt @{cterm "(0::real) + 1"})) + simple_cterm_ord + + val (real_poly_add_conv,real_poly_mul_conv,real_poly_neg_conv, + real_poly_pow_conv,real_poly_sub_conv,real_poly_conv) = (add,mul,neg,pow,sub,main) + + fun make_substitution th = + let + val (c,v) = substitutable_monomial [] (dest_arg1(concl th)) + val th1 = Drule.arg_cong_rule (capply @{cterm "op * :: real => _"} (cterm_of_rat (Rat.inv c))) (mk_meta_eq th) + val th2 = fconv_rule (binop_conv real_poly_mul_conv) th1 + in fconv_rule (arg_conv real_poly_conv) (isolate_variable v th2) + end + fun oprconv cv ct = + let val g = Thm.dest_fun2 ct + in if g aconvc @{cterm "op <= :: real => _"} + orelse g aconvc @{cterm "op < :: real => _"} + then arg_conv cv ct else arg1_conv cv ct + end + fun mainf translator = + let + fun substfirst(eqs,les,lts) = + ((let + val eth = tryfind make_substitution eqs + val modify = fconv_rule (arg_conv (oprconv(subst_conv [eth] then_conv real_poly_conv))) + in substfirst + (filter_out (fn t => (Thm.dest_arg1 o Thm.dest_arg o cprop_of) t + aconvc @{cterm "0::real"}) (map modify eqs), + map modify les,map modify lts) + end) + handle Failure _ => real_nonlinear_prover prover ctxt translator (rev eqs, rev les, rev lts)) + in substfirst + end + + + in mainf + end + +(* Overall function. *) + +fun real_sos prover ctxt t = gen_prover_real_arith ctxt (real_nonlinear_subst_prover prover ctxt) t; +end; + +(* A tactic *) +fun strip_all ct = + case term_of ct of + Const("all",_) $ Abs (xn,xT,p) => + let val (a,(v,t')) = (apsnd (Thm.dest_abs (SOME xn)) o Thm.dest_comb) ct + in apfst (cons v) (strip_all t') + end +| _ => ([],ct) + +fun core_sos_conv prover ctxt t = Drule.arg_cong_rule @{cterm Trueprop} (real_sos prover ctxt (Thm.dest_arg t) RS @{thm Eq_TrueI}) + +val known_sos_constants = + [@{term "op ==>"}, @{term "Trueprop"}, + @{term "op -->"}, @{term "op &"}, @{term "op |"}, + @{term "Not"}, @{term "op = :: bool => _"}, + @{term "All :: (real => _) => _"}, @{term "Ex :: (real => _) => _"}, + @{term "op = :: real => _"}, @{term "op < :: real => _"}, + @{term "op <= :: real => _"}, + @{term "op + :: real => _"}, @{term "op - :: real => _"}, + @{term "op * :: real => _"}, @{term "uminus :: real => _"}, + @{term "op / :: real => _"}, @{term "inverse :: real => _"}, + @{term "op ^ :: real => _"}, @{term "abs :: real => _"}, + @{term "min :: real => _"}, @{term "max :: real => _"}, + @{term "0::real"}, @{term "1::real"}, @{term "number_of :: int => real"}, + @{term "number_of :: int => nat"}, + @{term "Int.Bit0"}, @{term "Int.Bit1"}, + @{term "Int.Pls"}, @{term "Int.Min"}]; + +fun check_sos kcts ct = + let + val t = term_of ct + val _ = if not (null (Term.add_tfrees t []) + andalso null (Term.add_tvars t [])) + then error "SOS: not sos. Additional type varables" else () + val fs = Term.add_frees t [] + val _ = if exists (fn ((_,T)) => not (T = @{typ "real"})) fs + then error "SOS: not sos. Variables with type not real" else () + val vs = Term.add_vars t [] + val _ = if exists (fn ((_,T)) => not (T = @{typ "real"})) fs + then error "SOS: not sos. Variables with type not real" else () + val ukcs = subtract (fn (t,p) => Const p aconv t) kcts (Term.add_consts t []) + val _ = if null ukcs then () + else error ("SOSO: Unknown constants in Subgoal:" ^ commas (map fst ukcs)) +in () end + +fun core_sos_tac prover ctxt = CSUBGOAL (fn (ct, i) => + let val _ = check_sos known_sos_constants ct + val (avs, p) = strip_all ct + val th = standard (fold_rev forall_intr avs (real_sos prover ctxt (Thm.dest_arg p))) + in rtac th i end); + +fun default_SOME f NONE v = SOME v + | default_SOME f (SOME v) _ = SOME v; + +fun lift_SOME f NONE a = f a + | lift_SOME f (SOME a) _ = SOME a; + + +local + val is_numeral = can (HOLogic.dest_number o term_of) +in +fun get_denom b ct = case term_of ct of + @{term "op / :: real => _"} $ _ $ _ => + if is_numeral (Thm.dest_arg ct) then get_denom b (Thm.dest_arg1 ct) + else default_SOME (get_denom b) (get_denom b (Thm.dest_arg ct)) (Thm.dest_arg ct, b) + | @{term "op < :: real => _"} $ _ $ _ => lift_SOME (get_denom true) (get_denom true (Thm.dest_arg ct)) (Thm.dest_arg1 ct) + | @{term "op <= :: real => _"} $ _ $ _ => lift_SOME (get_denom true) (get_denom true (Thm.dest_arg ct)) (Thm.dest_arg1 ct) + | _ $ _ => lift_SOME (get_denom b) (get_denom b (Thm.dest_fun ct)) (Thm.dest_arg ct) + | _ => NONE +end; + +fun elim_one_denom_tac ctxt = +CSUBGOAL (fn (P,i) => + case get_denom false P of + NONE => no_tac + | SOME (d,ord) => + let + val ss = simpset_of ctxt addsimps @{thms field_simps} + addsimps [@{thm nonzero_power_divide}, @{thm power_divide}] + val th = instantiate' [] [SOME d, SOME (Thm.dest_arg P)] + (if ord then @{lemma "(d=0 --> P) & (d>0 --> P) & (d<(0::real) --> P) ==> P" by auto} + else @{lemma "(d=0 --> P) & (d ~= (0::real) --> P) ==> P" by blast}) + in (rtac th i THEN Simplifier.asm_full_simp_tac ss i) end); + +fun elim_denom_tac ctxt i = REPEAT (elim_one_denom_tac ctxt i); + +fun sos_tac prover ctxt = ObjectLogic.full_atomize_tac THEN' elim_denom_tac ctxt THEN' core_sos_tac prover ctxt + + +end; diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Library/sos_wrapper.ML --- a/src/HOL/Library/sos_wrapper.ML Mon Aug 10 08:37:37 2009 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,158 +0,0 @@ -(* Title: sos_wrapper.ML - Author: Philipp Meyer, TU Muenchen - -Added functionality for sums of squares, e.g. calling a remote prover -*) - -signature SOS_WRAPPER = -sig - - datatype prover_result = Success | PartialSuccess | Failure | Error - type prover = string * (int -> string -> prover_result * string) - - val setup: theory -> theory -end - -structure SosWrapper : SOS_WRAPPER= -struct - -datatype prover_result = Success | PartialSuccess | Failure | Error -type prover = - string * (* command name *) - (int -> string ->prover_result * string) (* function to find failure from return value and output *) - - -(*** output control ***) - -fun debug s = Output.debug (fn () => s) -val answer = Output.priority -val write = Output.writeln - -(*** calling provers ***) - -val destdir = ref "" - -fun filename dir name = - let - val probfile = Path.basic (name ^ serial_string ()) - in - if dir = "" then - File.tmp_path probfile - else - if File.exists (Path.explode dir) then - Path.append (Path.explode dir) probfile - else - error ("No such directory: " ^ dir) - end - -fun is_success Success = true - | is_success PartialSuccess = true - | is_success _ = false -fun str_of_status Success = "Success" - | str_of_status PartialSuccess = "Partial Success" - | str_of_status Failure= "Failure" - | str_of_status Error= "Error" - -fun run_solver name (cmd, find_failure) input = - let - val _ = answer ("Calling solver: " ^ name) - - (* create input file *) - val dir = ! destdir - val input_file = filename dir "sos_in" - val _ = File.write input_file input - - val _ = debug "Solver input:" - val _ = debug input - - (* call solver *) - val output_file = filename dir "sos_out" - val (output, rv) = system_out (cmd ^ " " ^ (Path.implode input_file) ^ - " " ^ (Path.implode output_file)) - - (* read and analysize output *) - val (res, res_msg) = find_failure rv output - val result = if is_success res then File.read output_file else "" - - (* remove temporary files *) - val _ = if dir = "" then (File.rm input_file ; if File.exists output_file then File.rm output_file else ()) else () - - val _ = debug "Solver output:" - val _ = debug output - val _ = debug "Solver result:" - val _ = debug result - - val _ = answer (str_of_status res ^ ": " ^ res_msg) - - in - if is_success res then - result - else - error ("Prover failed: " ^ res_msg) - end - -(*** various provers ***) - -(* local csdp client *) - -fun find_csdp_run_failure rv _ = - case rv of - 0 => (Success, "SDP solved") - | 1 => (Failure, "SDP is primal infeasible") - | 2 => (Failure, "SDP is dual infeasible") - | 3 => (PartialSuccess, "SDP solved with reduced accuracy") - | _ => (Failure, "return code is " ^ string_of_int rv) - -val csdp = ("csdp", find_csdp_run_failure) - -(* remote neos server *) - -fun find_neos_failure rv output = - if rv = 2 then (Failure, "no solution") else - if rv <> 0 then (Error, "return code is " ^ string_of_int rv) else - let - fun find_success str = - if String.isPrefix "Success: " str then - SOME (Success, unprefix "Success: " str) - else if String.isPrefix "Partial Success: " str then - SOME (PartialSuccess, unprefix "Partial Success: " str) - else if String.isPrefix "Failure: " str then - SOME (Failure, unprefix "Failure: " str) - else - NONE - val exit_line = get_first find_success (split_lines output) - in - case exit_line of - SOME (status, msg) => - if String.isPrefix "SDP solved" msg then - (status, msg) - else (Failure, msg) - | NONE => (Failure, "no success") - end - -val neos_csdp = ("$ISABELLE_HOME/lib/scripts/neos/NeosCSDPClient.py", find_neos_failure) - -(* save provers in table *) - -val provers = - Symtab.make [("remote_csdp", neos_csdp),("csdp", csdp)] - -fun get_prover name = - case Symtab.lookup provers name of - SOME prover => prover - | NONE => error ("unknown prover: " ^ name) - -fun call_solver name = - run_solver name (get_prover name) - -(* setup tactic *) - -val def_solver = "remote_csdp" - -fun sos_solver name = (SIMPLE_METHOD' o (Sos.sos_tac (call_solver name))) - -val sos_method = Scan.optional (Scan.lift OuterParse.xname) def_solver >> sos_solver - -val setup = Method.setup @{binding sos} sos_method "Prove universal problems over the reals using sums of squares" - -end diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Library/sum_of_squares.ML --- a/src/HOL/Library/sum_of_squares.ML Mon Aug 10 08:37:37 2009 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1754 +0,0 @@ -(* Title: sum_of_squares.ML - Authors: Amine Chaieb, University of Cambridge - Philipp Meyer, TU Muenchen - -A tactic for proving nonlinear inequalities -*) - -signature SOS = -sig - - val sos_tac : (string -> string) -> Proof.context -> int -> Tactical.tactic - -end - -structure Sos : SOS = -struct - - -val rat_0 = Rat.zero; -val rat_1 = Rat.one; -val rat_2 = Rat.two; -val rat_10 = Rat.rat_of_int 10; -val rat_1_2 = rat_1 // rat_2; -val max = curry IntInf.max; -val min = curry IntInf.min; - -val denominator_rat = Rat.quotient_of_rat #> snd #> Rat.rat_of_int; -val numerator_rat = Rat.quotient_of_rat #> fst #> Rat.rat_of_int; -fun int_of_rat a = - case Rat.quotient_of_rat a of (i,1) => i | _ => error "int_of_rat: not an int"; -fun lcm_rat x y = Rat.rat_of_int (Integer.lcm (int_of_rat x) (int_of_rat y)); - -fun rat_pow r i = - let fun pow r i = - if i = 0 then rat_1 else - let val d = pow r (i div 2) - in d */ d */ (if i mod 2 = 0 then rat_1 else r) - end - in if i < 0 then pow (Rat.inv r) (~ i) else pow r i end; - -fun round_rat r = - let val (a,b) = Rat.quotient_of_rat (Rat.abs r) - val d = a div b - val s = if r = b then d + 1 else d) end - -val abs_rat = Rat.abs; -val pow2 = rat_pow rat_2; -val pow10 = rat_pow rat_10; - -val debugging = ref false; - -exception Sanity; - -exception Unsolvable; - -(* Turn a rational into a decimal string with d sig digits. *) - -local -fun normalize y = - if abs_rat y =/ rat_1 then normalize (y // rat_10) + 1 - else 0 - in -fun decimalize d x = - if x =/ rat_0 then "0.0" else - let - val y = Rat.abs x - val e = normalize y - val z = pow10(~ e) */ y +/ rat_1 - val k = int_of_rat (round_rat(pow10 d */ z)) - in (if x a - | h::t => itern (k + 1) t f (f h k a); - -fun iter (m,n) f a = - if n < m then a - else iter (m+1,n) f (f m a); - -(* The main types. *) - -fun strict_ord ord (x,y) = case ord (x,y) of LESS => LESS | _ => GREATER - -structure Intpairfunc = FuncFun(type key = int*int val ord = prod_ord int_ord int_ord); - -type vector = int* Rat.rat Intfunc.T; - -type matrix = (int*int)*(Rat.rat Intpairfunc.T); - -type monomial = int Ctermfunc.T; - -val cterm_ord = (fn (s,t) => TermOrd.fast_term_ord(term_of s, term_of t)) - fun monomial_ord (m1,m2) = list_ord (prod_ord cterm_ord int_ord) (Ctermfunc.graph m1, Ctermfunc.graph m2) -structure Monomialfunc = FuncFun(type key = monomial val ord = monomial_ord) - -type poly = Rat.rat Monomialfunc.T; - - fun iszero (k,r) = r =/ rat_0; - -fun fold_rev2 f l1 l2 b = - case (l1,l2) of - ([],[]) => b - | (h1::t1,h2::t2) => f h1 h2 (fold_rev2 f t1 t2 b) - | _ => error "fold_rev2"; - -(* Vectors. Conventionally indexed 1..n. *) - -fun vector_0 n = (n,Intfunc.undefined):vector; - -fun dim (v:vector) = fst v; - -fun vector_const c n = - if c =/ rat_0 then vector_0 n - else (n,fold_rev (fn k => Intfunc.update (k,c)) (1 upto n) Intfunc.undefined) :vector; - -val vector_1 = vector_const rat_1; - -fun vector_cmul c (v:vector) = - let val n = dim v - in if c =/ rat_0 then vector_0 n - else (n,Intfunc.mapf (fn x => c */ x) (snd v)) - end; - -fun vector_neg (v:vector) = (fst v,Intfunc.mapf Rat.neg (snd v)) :vector; - -fun vector_add (v1:vector) (v2:vector) = - let val m = dim v1 - val n = dim v2 - in if m <> n then error "vector_add: incompatible dimensions" - else (n,Intfunc.combine (curry op +/) (fn x => x =/ rat_0) (snd v1) (snd v2)) :vector - end; - -fun vector_sub v1 v2 = vector_add v1 (vector_neg v2); - -fun vector_dot (v1:vector) (v2:vector) = - let val m = dim v1 - val n = dim v2 - in if m <> n then error "vector_dot: incompatible dimensions" - else Intfunc.fold (fn (i,x) => fn a => x +/ a) - (Intfunc.combine (curry op */) (fn x => x =/ rat_0) (snd v1) (snd v2)) rat_0 - end; - -fun vector_of_list l = - let val n = length l - in (n,fold_rev2 (curry Intfunc.update) (1 upto n) l Intfunc.undefined) :vector - end; - -(* Matrices; again rows and columns indexed from 1. *) - -fun matrix_0 (m,n) = ((m,n),Intpairfunc.undefined):matrix; - -fun dimensions (m:matrix) = fst m; - -fun matrix_const c (mn as (m,n)) = - if m <> n then error "matrix_const: needs to be square" - else if c =/ rat_0 then matrix_0 mn - else (mn,fold_rev (fn k => Intpairfunc.update ((k,k), c)) (1 upto n) Intpairfunc.undefined) :matrix;; - -val matrix_1 = matrix_const rat_1; - -fun matrix_cmul c (m:matrix) = - let val (i,j) = dimensions m - in if c =/ rat_0 then matrix_0 (i,j) - else ((i,j),Intpairfunc.mapf (fn x => c */ x) (snd m)) - end; - -fun matrix_neg (m:matrix) = - (dimensions m, Intpairfunc.mapf Rat.neg (snd m)) :matrix; - -fun matrix_add (m1:matrix) (m2:matrix) = - let val d1 = dimensions m1 - val d2 = dimensions m2 - in if d1 <> d2 - then error "matrix_add: incompatible dimensions" - else (d1,Intpairfunc.combine (curry op +/) (fn x => x =/ rat_0) (snd m1) (snd m2)) :matrix - end;; - -fun matrix_sub m1 m2 = matrix_add m1 (matrix_neg m2); - -fun row k (m:matrix) = - let val (i,j) = dimensions m - in (j, - Intpairfunc.fold (fn ((i,j), c) => fn a => if i = k then Intfunc.update (j,c) a else a) (snd m) Intfunc.undefined ) : vector - end; - -fun column k (m:matrix) = - let val (i,j) = dimensions m - in (i, - Intpairfunc.fold (fn ((i,j), c) => fn a => if j = k then Intfunc.update (i,c) a else a) (snd m) Intfunc.undefined) - : vector - end; - -fun transp (m:matrix) = - let val (i,j) = dimensions m - in - ((j,i),Intpairfunc.fold (fn ((i,j), c) => fn a => Intpairfunc.update ((j,i), c) a) (snd m) Intpairfunc.undefined) :matrix - end; - -fun diagonal (v:vector) = - let val n = dim v - in ((n,n),Intfunc.fold (fn (i, c) => fn a => Intpairfunc.update ((i,i), c) a) (snd v) Intpairfunc.undefined) : matrix - end; - -fun matrix_of_list l = - let val m = length l - in if m = 0 then matrix_0 (0,0) else - let val n = length (hd l) - in ((m,n),itern 1 l (fn v => fn i => itern 1 v (fn c => fn j => Intpairfunc.update ((i,j), c))) Intpairfunc.undefined) - end - end; - -(* Monomials. *) - -fun monomial_eval assig (m:monomial) = - Ctermfunc.fold (fn (x, k) => fn a => a */ rat_pow (Ctermfunc.apply assig x) k) - m rat_1; -val monomial_1 = (Ctermfunc.undefined:monomial); - -fun monomial_var x = Ctermfunc.onefunc (x, 1) :monomial; - -val (monomial_mul:monomial->monomial->monomial) = - Ctermfunc.combine (curry op +) (K false); - -fun monomial_pow (m:monomial) k = - if k = 0 then monomial_1 - else Ctermfunc.mapf (fn x => k * x) m; - -fun monomial_divides (m1:monomial) (m2:monomial) = - Ctermfunc.fold (fn (x, k) => fn a => Ctermfunc.tryapplyd m2 x 0 >= k andalso a) m1 true;; - -fun monomial_div (m1:monomial) (m2:monomial) = - let val m = Ctermfunc.combine (curry op +) - (fn x => x = 0) m1 (Ctermfunc.mapf (fn x => ~ x) m2) - in if Ctermfunc.fold (fn (x, k) => fn a => k >= 0 andalso a) m true then m - else error "monomial_div: non-divisible" - end; - -fun monomial_degree x (m:monomial) = - Ctermfunc.tryapplyd m x 0;; - -fun monomial_lcm (m1:monomial) (m2:monomial) = - fold_rev (fn x => Ctermfunc.update (x, max (monomial_degree x m1) (monomial_degree x m2))) - (gen_union (is_equal o cterm_ord) (Ctermfunc.dom m1, Ctermfunc.dom m2)) (Ctermfunc.undefined :monomial); - -fun monomial_multidegree (m:monomial) = - Ctermfunc.fold (fn (x, k) => fn a => k + a) m 0;; - -fun monomial_variables m = Ctermfunc.dom m;; - -(* Polynomials. *) - -fun eval assig (p:poly) = - Monomialfunc.fold (fn (m, c) => fn a => a +/ c */ monomial_eval assig m) p rat_0; - -val poly_0 = (Monomialfunc.undefined:poly); - -fun poly_isconst (p:poly) = - Monomialfunc.fold (fn (m, c) => fn a => Ctermfunc.is_undefined m andalso a) p true; - -fun poly_var x = Monomialfunc.onefunc (monomial_var x,rat_1) :poly; - -fun poly_const c = - if c =/ rat_0 then poly_0 else Monomialfunc.onefunc(monomial_1, c); - -fun poly_cmul c (p:poly) = - if c =/ rat_0 then poly_0 - else Monomialfunc.mapf (fn x => c */ x) p; - -fun poly_neg (p:poly) = (Monomialfunc.mapf Rat.neg p :poly);; - -fun poly_add (p1:poly) (p2:poly) = - (Monomialfunc.combine (curry op +/) (fn x => x =/ rat_0) p1 p2 :poly); - -fun poly_sub p1 p2 = poly_add p1 (poly_neg p2); - -fun poly_cmmul (c,m) (p:poly) = - if c =/ rat_0 then poly_0 - else if Ctermfunc.is_undefined m - then Monomialfunc.mapf (fn d => c */ d) p - else Monomialfunc.fold (fn (m', d) => fn a => (Monomialfunc.update (monomial_mul m m', c */ d) a)) p poly_0; - -fun poly_mul (p1:poly) (p2:poly) = - Monomialfunc.fold (fn (m, c) => fn a => poly_add (poly_cmmul (c,m) p2) a) p1 poly_0; - -fun poly_div (p1:poly) (p2:poly) = - if not(poly_isconst p2) - then error "poly_div: non-constant" else - let val c = eval Ctermfunc.undefined p2 - in if c =/ rat_0 then error "poly_div: division by zero" - else poly_cmul (Rat.inv c) p1 - end; - -fun poly_square p = poly_mul p p; - -fun poly_pow p k = - if k = 0 then poly_const rat_1 - else if k = 1 then p - else let val q = poly_square(poly_pow p (k div 2)) in - if k mod 2 = 1 then poly_mul p q else q end; - -fun poly_exp p1 p2 = - if not(poly_isconst p2) - then error "poly_exp: not a constant" - else poly_pow p1 (int_of_rat (eval Ctermfunc.undefined p2)); - -fun degree x (p:poly) = - Monomialfunc.fold (fn (m,c) => fn a => max (monomial_degree x m) a) p 0; - -fun multidegree (p:poly) = - Monomialfunc.fold (fn (m, c) => fn a => max (monomial_multidegree m) a) p 0; - -fun poly_variables (p:poly) = - sort cterm_ord (Monomialfunc.fold_rev (fn (m, c) => curry (gen_union (is_equal o cterm_ord)) (monomial_variables m)) p []);; - -(* Order monomials for human presentation. *) - -fun cterm_ord (t,t') = TermOrd.fast_term_ord (term_of t, term_of t'); - -val humanorder_varpow = prod_ord cterm_ord (rev_order o int_ord); - -local - fun ord (l1,l2) = case (l1,l2) of - (_,[]) => LESS - | ([],_) => GREATER - | (h1::t1,h2::t2) => - (case humanorder_varpow (h1, h2) of - LESS => LESS - | EQUAL => ord (t1,t2) - | GREATER => GREATER) -in fun humanorder_monomial m1 m2 = - ord (sort humanorder_varpow (Ctermfunc.graph m1), - sort humanorder_varpow (Ctermfunc.graph m2)) -end; - -fun fold1 f l = case l of - [] => error "fold1" - | [x] => x - | (h::t) => f h (fold1 f t); - -(* Conversions to strings. *) - -fun string_of_vector min_size max_size (v:vector) = - let val n_raw = dim v - in if n_raw = 0 then "[]" else - let - val n = max min_size (min n_raw max_size) - val xs = map (Rat.string_of_rat o (fn i => Intfunc.tryapplyd (snd v) i rat_0)) (1 upto n) - in "[" ^ fold1 (fn s => fn t => s ^ ", " ^ t) xs ^ - (if n_raw > max_size then ", ...]" else "]") - end - end; - -fun string_of_matrix max_size (m:matrix) = - let - val (i_raw,j_raw) = dimensions m - val i = min max_size i_raw - val j = min max_size j_raw - val rstr = map (fn k => string_of_vector j j (row k m)) (1 upto i) - in "["^ fold1 (fn s => fn t => s^";\n "^t) rstr ^ - (if j > max_size then "\n ...]" else "]") - end; - -fun string_of_term t = - case t of - a$b => "("^(string_of_term a)^" "^(string_of_term b)^")" - | Abs x => - let val (xn, b) = Term.dest_abs x - in "(\\"^xn^"."^(string_of_term b)^")" - end - | Const(s,_) => s - | Free (s,_) => s - | Var((s,_),_) => s - | _ => error "string_of_term"; - -val string_of_cterm = string_of_term o term_of; - -fun string_of_varpow x k = - if k = 1 then string_of_cterm x - else string_of_cterm x^"^"^string_of_int k; - -fun string_of_monomial m = - if Ctermfunc.is_undefined m then "1" else - let val vps = fold_rev (fn (x,k) => fn a => string_of_varpow x k :: a) - (sort humanorder_varpow (Ctermfunc.graph m)) [] - in fold1 (fn s => fn t => s^"*"^t) vps - end; - -fun string_of_cmonomial (c,m) = - if Ctermfunc.is_undefined m then Rat.string_of_rat c - else if c =/ rat_1 then string_of_monomial m - else Rat.string_of_rat c ^ "*" ^ string_of_monomial m;; - -fun string_of_poly (p:poly) = - if Monomialfunc.is_undefined p then "<<0>>" else - let - val cms = sort (fn ((m1,_),(m2,_)) => humanorder_monomial m1 m2) (Monomialfunc.graph p) - val s = fold (fn (m,c) => fn a => - if c >" - end; - -(* Conversion from HOL term. *) - -local - val neg_tm = @{cterm "uminus :: real => _"} - val add_tm = @{cterm "op + :: real => _"} - val sub_tm = @{cterm "op - :: real => _"} - val mul_tm = @{cterm "op * :: real => _"} - val inv_tm = @{cterm "inverse :: real => _"} - val div_tm = @{cterm "op / :: real => _"} - val pow_tm = @{cterm "op ^ :: real => _"} - val zero_tm = @{cterm "0:: real"} - val is_numeral = can (HOLogic.dest_number o term_of) - fun is_comb t = case t of _$_ => true | _ => false - fun poly_of_term tm = - if tm aconvc zero_tm then poly_0 - else if RealArith.is_ratconst tm - then poly_const(RealArith.dest_ratconst tm) - else - (let val (lop,r) = Thm.dest_comb tm - in if lop aconvc neg_tm then poly_neg(poly_of_term r) - else if lop aconvc inv_tm then - let val p = poly_of_term r - in if poly_isconst p - then poly_const(Rat.inv (eval Ctermfunc.undefined p)) - else error "poly_of_term: inverse of non-constant polyomial" - end - else (let val (opr,l) = Thm.dest_comb lop - in - if opr aconvc pow_tm andalso is_numeral r - then poly_pow (poly_of_term l) ((snd o HOLogic.dest_number o term_of) r) - else if opr aconvc add_tm - then poly_add (poly_of_term l) (poly_of_term r) - else if opr aconvc sub_tm - then poly_sub (poly_of_term l) (poly_of_term r) - else if opr aconvc mul_tm - then poly_mul (poly_of_term l) (poly_of_term r) - else if opr aconvc div_tm - then let - val p = poly_of_term l - val q = poly_of_term r - in if poly_isconst q then poly_cmul (Rat.inv (eval Ctermfunc.undefined q)) p - else error "poly_of_term: division by non-constant polynomial" - end - else poly_var tm - - end - handle CTERM ("dest_comb",_) => poly_var tm) - end - handle CTERM ("dest_comb",_) => poly_var tm) -in -val poly_of_term = fn tm => - if type_of (term_of tm) = @{typ real} then poly_of_term tm - else error "poly_of_term: term does not have real type" -end; - -(* String of vector (just a list of space-separated numbers). *) - -fun sdpa_of_vector (v:vector) = - let - val n = dim v - val strs = map (decimalize 20 o (fn i => Intfunc.tryapplyd (snd v) i rat_0)) (1 upto n) - in fold1 (fn x => fn y => x ^ " " ^ y) strs ^ "\n" - end; - -fun increasing f ord (x,y) = ord (f x, f y); -fun triple_int_ord ((a,b,c),(a',b',c')) = - prod_ord int_ord (prod_ord int_ord int_ord) - ((a,(b,c)),(a',(b',c'))); -structure Inttriplefunc = FuncFun(type key = int*int*int val ord = triple_int_ord); - -(* String for block diagonal matrix numbered k. *) - -fun sdpa_of_blockdiagonal k m = - let - val pfx = string_of_int k ^" " - val ents = - Inttriplefunc.fold (fn ((b,i,j), c) => fn a => if i > j then a else ((b,i,j),c)::a) m [] - val entss = sort (increasing fst triple_int_ord ) ents - in fold_rev (fn ((b,i,j),c) => fn a => - pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ - " " ^ decimalize 20 c ^ "\n" ^ a) entss "" - end; - -(* String for a matrix numbered k, in SDPA sparse format. *) - -fun sdpa_of_matrix k (m:matrix) = - let - val pfx = string_of_int k ^ " 1 " - val ms = Intpairfunc.fold (fn ((i,j), c) => fn a => if i > j then a else ((i,j),c)::a) (snd m) [] - val mss = sort (increasing fst (prod_ord int_ord int_ord)) ms - in fold_rev (fn ((i,j),c) => fn a => - pfx ^ string_of_int i ^ " " ^ string_of_int j ^ - " " ^ decimalize 20 c ^ "\n" ^ a) mss "" - end;; - -(* ------------------------------------------------------------------------- *) -(* String in SDPA sparse format for standard SDP problem: *) -(* *) -(* X = v_1 * [M_1] + ... + v_m * [M_m] - [M_0] must be PSD *) -(* Minimize obj_1 * v_1 + ... obj_m * v_m *) -(* ------------------------------------------------------------------------- *) - -fun sdpa_of_problem obj mats = - let - val m = length mats - 1 - val (n,_) = dimensions (hd mats) - in - string_of_int m ^ "\n" ^ - "1\n" ^ - string_of_int n ^ "\n" ^ - sdpa_of_vector obj ^ - fold_rev2 (fn k => fn m => fn a => sdpa_of_matrix (k - 1) m ^ a) (1 upto length mats) mats "" - end; - -fun index_char str chr pos = - if pos >= String.size str then ~1 - else if String.sub(str,pos) = chr then pos - else index_char str chr (pos + 1); -fun rat_of_quotient (a,b) = if b = 0 then rat_0 else Rat.rat_of_quotient (a,b); -fun rat_of_string s = - let val n = index_char s #"/" 0 in - if n = ~1 then s |> IntInf.fromString |> valOf |> Rat.rat_of_int - else - let val SOME numer = IntInf.fromString(String.substring(s,0,n)) - val SOME den = IntInf.fromString (String.substring(s,n+1,String.size s - n - 1)) - in rat_of_quotient(numer, den) - end - end; - -fun isspace x = x = " " ; -fun isnum x = x mem_string ["0","1","2","3","4","5","6","7","8","9"] - -(* More parser basics. *) - -local - open Scan -in - val word = this_string - fun token s = - repeat ($$ " ") |-- word s --| repeat ($$ " ") - val numeral = one isnum - val decimalint = bulk numeral >> (rat_of_string o implode) - val decimalfrac = bulk numeral - >> (fn s => rat_of_string(implode s) // pow10 (length s)) - val decimalsig = - decimalint -- option (Scan.$$ "." |-- decimalfrac) - >> (fn (h,NONE) => h | (h,SOME x) => h +/ x) - fun signed prs = - $$ "-" |-- prs >> Rat.neg - || $$ "+" |-- prs - || prs; - -fun emptyin def xs = if null xs then (def,xs) else Scan.fail xs - - val exponent = ($$ "e" || $$ "E") |-- signed decimalint; - - val decimal = signed decimalsig -- (emptyin rat_0|| exponent) - >> (fn (h, x) => h */ pow10 (int_of_rat x)); -end; - - fun mkparser p s = - let val (x,rst) = p (explode s) - in if null rst then x - else error "mkparser: unparsed input" - end;; -val parse_decimal = mkparser decimal; - -fun fix err prs = - prs || (fn x=> error err); - -fun listof prs sep err = - prs -- Scan.bulk (sep |-- fix err prs) >> uncurry cons; - -(* Parse back a vector. *) - - val vector = - token "{" |-- listof decimal (token ",") "decimal" --| token "}" - >> vector_of_list - val parse_vector = mkparser vector - fun skipupto dscr prs inp = - (dscr |-- prs - || Scan.one (K true) |-- skipupto dscr prs) inp - fun ignore inp = ((),[]) - fun sdpaoutput inp = skipupto (word "xVec" -- token "=") - (vector --| ignore) inp - fun csdpoutput inp = ((decimal -- Scan.bulk (Scan.$$ " " |-- Scan.option decimal) >> (fn (h,to) => map_filter I ((SOME h)::to))) --| ignore >> vector_of_list) inp - val parse_sdpaoutput = mkparser sdpaoutput - val parse_csdpoutput = mkparser csdpoutput - -(* Run prover on a problem in linear form. *) - -fun run_problem prover obj mats = - parse_csdpoutput (prover (sdpa_of_problem obj mats)) - -(* -UNUSED - -(* Also parse the SDPA output to test success (CSDP yields a return code). *) - -local - val prs = - skipupto (word "phase.value" -- token "=") - (Scan.option (Scan.$$ "p") -- Scan.option (Scan.$$ "d") - -- (word "OPT" || word "FEAS")) -in - fun sdpa_run_succeeded s = - (prs (explode s); true) handle _ => false -end; - -(* The default parameters. Unfortunately this goes to a fixed file. *) - -val sdpa_default_parameters = -"100 unsigned int maxIteration; \n1.0E-7 double 0.0 < epsilonStar;\n1.0E2 double 0.0 < lambdaStar;\n2.0 double 1.0 < omegaStar;\n-1.0E5 double lowerBound;\n1.0E5 double upperBound;\n0.1 double 0.0 <= betaStar < 1.0;\n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\n0.9 double 0.0 < gammaStar < 1.0;\n1.0E-7 double 0.0 < epsilonDash;\n";; - -(* These were suggested by Makoto Yamashita for problems where we are *) -(* right at the edge of the semidefinite cone, as sometimes happens. *) - -val sdpa_alt_parameters = -"1000 unsigned int maxIteration;\n1.0E-7 double 0.0 < epsilonStar;\n1.0E4 double 0.0 < lambdaStar;\n2.0 double 1.0 < omegaStar;\n-1.0E5 double lowerBound;\n1.0E5 double upperBound;\n0.1 double 0.0 <= betaStar < 1.0;\n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\n0.9 double 0.0 < gammaStar < 1.0;\n1.0E-7 double 0.0 < epsilonDash;\n";; - -val sdpa_params = sdpa_alt_parameters;; - -(* CSDP parameters; so far I'm sticking with the defaults. *) - -val csdp_default_parameters = -"axtol=1.0e-8\natytol=1.0e-8\nobjtol=1.0e-8\npinftol=1.0e8\ndinftol=1.0e8\nmaxiter=100\nminstepfrac=0.9\nmaxstepfrac=0.97\nminstepp=1.0e-8\nminstepd=1.0e-8\nusexzgap=1\ntweakgap=0\naffine=0\nprintlevel=1\n";; - -val csdp_params = csdp_default_parameters;; - -fun tmp_file pre suf = - let val i = string_of_int (round (random())) - val name = Path.append (Path.variable "ISABELLE_TMP") (Path.explode (pre ^ i ^ suf)) - in - if File.exists name then tmp_file pre suf - else name - end; - -(* Now call SDPA on a problem and parse back the output. *) - -fun run_sdpa dbg obj mats = - let - val input_file = tmp_file "sos" ".dat-s" - val output_file = tmp_file "sos" ".out" - val params_file = tmp_file "param" ".sdpa" - val current_dir = File.pwd() - val _ = File.write input_file - (sdpa_of_problem "" obj mats) - val _ = File.write params_file sdpa_params - val _ = File.cd (Path.variable "ISABELLE_TMP") - val _ = File.system_command ("sdpa "^ (Path.implode input_file) ^ " " ^ - (Path.implode output_file) ^ - (if dbg then "" else "> /dev/null")) - val opr = File.read output_file - in if not(sdpa_run_succeeded opr) then error "sdpa: call failed" - else - let val res = parse_sdpaoutput opr - in ((if dbg then () - else (File.rm input_file; File.rm output_file ; File.cd current_dir)); - res) - end - end; - -fun sdpa obj mats = run_sdpa (!debugging) obj mats; - -(* The same thing with CSDP. *) - -fun run_csdp dbg obj mats = - let - val input_file = tmp_file "sos" ".dat-s" - val output_file = tmp_file "sos" ".out" - val params_file = tmp_file "param" ".csdp" - val current_dir = File.pwd() - val _ = File.write input_file (sdpa_of_problem "" obj mats) - val _ = File.write params_file csdp_params - val _ = File.cd (Path.variable "ISABELLE_TMP") - val rv = system ("csdp "^(Path.implode input_file) ^ " " - ^ (Path.implode output_file) ^ - (if dbg then "" else "> /dev/null")) - val opr = File.read output_file - val res = parse_csdpoutput opr - in - ((if dbg then () - else (File.rm input_file; File.rm output_file ; File.cd current_dir)); - (rv,res)) - end; - -fun csdp obj mats = - let - val (rv,res) = run_csdp (!debugging) obj mats - in - ((if rv = 1 orelse rv = 2 then error "csdp: Problem is infeasible" - else if rv = 3 then writeln "csdp warning: Reduced accuracy" - else if rv <> 0 then error ("csdp: error "^string_of_int rv) - else ()); - res) - end; - -*) - -(* Try some apparently sensible scaling first. Note that this is purely to *) -(* get a cleaner translation to floating-point, and doesn't affect any of *) -(* the results, in principle. In practice it seems a lot better when there *) -(* are extreme numbers in the original problem. *) - - (* Version for (int*int) keys *) -local - fun max_rat x y = if x fn a => lcm_rat (denominator_rat c) a) amat acc - fun maximal_element fld amat acc = - fld (fn (m,c) => fn maxa => max_rat maxa (abs_rat c)) amat acc -fun float_of_rat x = let val (a,b) = Rat.quotient_of_rat x - in Real.fromLargeInt a / Real.fromLargeInt b end; -in - -fun pi_scale_then solver (obj:vector) mats = - let - val cd1 = fold_rev (common_denominator Intpairfunc.fold) mats (rat_1) - val cd2 = common_denominator Intfunc.fold (snd obj) (rat_1) - val mats' = map (Intpairfunc.mapf (fn x => cd1 */ x)) mats - val obj' = vector_cmul cd2 obj - val max1 = fold_rev (maximal_element Intpairfunc.fold) mats' (rat_0) - val max2 = maximal_element Intfunc.fold (snd obj') (rat_0) - val scal1 = pow2 (20 - trunc(Math.ln (float_of_rat max1) / Math.ln 2.0)) - val scal2 = pow2 (20 - trunc(Math.ln (float_of_rat max2) / Math.ln 2.0)) - val mats'' = map (Intpairfunc.mapf (fn x => x */ scal1)) mats' - val obj'' = vector_cmul scal2 obj' - in solver obj'' mats'' - end -end; - -(* Try some apparently sensible scaling first. Note that this is purely to *) -(* get a cleaner translation to floating-point, and doesn't affect any of *) -(* the results, in principle. In practice it seems a lot better when there *) -(* are extreme numbers in the original problem. *) - - (* Version for (int*int*int) keys *) -local - fun max_rat x y = if x fn a => lcm_rat (denominator_rat c) a) amat acc - fun maximal_element fld amat acc = - fld (fn (m,c) => fn maxa => max_rat maxa (abs_rat c)) amat acc -fun float_of_rat x = let val (a,b) = Rat.quotient_of_rat x - in Real.fromLargeInt a / Real.fromLargeInt b end; -fun int_of_float x = (trunc x handle Overflow => 0 | Domain => 0) -in - -fun tri_scale_then solver (obj:vector) mats = - let - val cd1 = fold_rev (common_denominator Inttriplefunc.fold) mats (rat_1) - val cd2 = common_denominator Intfunc.fold (snd obj) (rat_1) - val mats' = map (Inttriplefunc.mapf (fn x => cd1 */ x)) mats - val obj' = vector_cmul cd2 obj - val max1 = fold_rev (maximal_element Inttriplefunc.fold) mats' (rat_0) - val max2 = maximal_element Intfunc.fold (snd obj') (rat_0) - val scal1 = pow2 (20 - int_of_float(Math.ln (float_of_rat max1) / Math.ln 2.0)) - val scal2 = pow2 (20 - int_of_float(Math.ln (float_of_rat max2) / Math.ln 2.0)) - val mats'' = map (Inttriplefunc.mapf (fn x => x */ scal1)) mats' - val obj'' = vector_cmul scal2 obj' - in solver obj'' mats'' - end -end; - -(* Round a vector to "nice" rationals. *) - -fun nice_rational n x = round_rat (n */ x) // n;; -fun nice_vector n ((d,v) : vector) = - (d, Intfunc.fold (fn (i,c) => fn a => - let val y = nice_rational n c - in if c =/ rat_0 then a - else Intfunc.update (i,y) a end) v Intfunc.undefined):vector - -(* -UNUSED - -(* Reduce linear program to SDP (diagonal matrices) and test with CSDP. This *) -(* one tests A [-1;x1;..;xn] >= 0 (i.e. left column is negated constants). *) - -fun linear_program_basic a = - let - val (m,n) = dimensions a - val mats = map (fn j => diagonal (column j a)) (1 upto n) - val obj = vector_const rat_1 m - val (rv,res) = run_csdp false obj mats - in if rv = 1 orelse rv = 2 then false - else if rv = 0 then true - else error "linear_program: An error occurred in the SDP solver" - end; - -(* Alternative interface testing A x >= b for matrix A, vector b. *) - -fun linear_program a b = - let val (m,n) = dimensions a - in if dim b <> m then error "linear_program: incompatible dimensions" - else - let - val mats = diagonal b :: map (fn j => diagonal (column j a)) (1 upto n) - val obj = vector_const rat_1 m - val (rv,res) = run_csdp false obj mats - in if rv = 1 orelse rv = 2 then false - else if rv = 0 then true - else error "linear_program: An error occurred in the SDP solver" - end - end; - -(* Test whether a point is in the convex hull of others. Rather than use *) -(* computational geometry, express as linear inequalities and call CSDP. *) -(* This is a bit lazy of me, but it's easy and not such a bottleneck so far. *) - -fun in_convex_hull pts pt = - let - val pts1 = (1::pt) :: map (fn x => 1::x) pts - val pts2 = map (fn p => map (fn x => ~x) p @ p) pts1 - val n = length pts + 1 - val v = 2 * (length pt + 1) - val m = v + n - 1 - val mat = ((m,n), - itern 1 pts2 (fn pts => fn j => itern 1 pts - (fn x => fn i => Intpairfunc.update ((i,j), Rat.rat_of_int x))) - (iter (1,n) (fn i => Intpairfunc.update((v + i,i+1), rat_1)) - Intpairfunc.undefined)) - in linear_program_basic mat - end; - -(* Filter down a set of points to a minimal set with the same convex hull. *) - -local - fun augment1 (m::ms) = if in_convex_hull ms m then ms else ms@[m] - fun augment m ms = funpow 3 augment1 (m::ms) -in -fun minimal_convex_hull mons = - let val mons' = fold_rev augment (tl mons) [hd mons] - in funpow (length mons') augment1 mons' - end -end; - -*) - -fun dest_ord f x = is_equal (f x); - - - -(* Stuff for "equations" ((int*int*int)->num functions). *) - -fun tri_equation_cmul c eq = - if c =/ rat_0 then Inttriplefunc.undefined else Inttriplefunc.mapf (fn d => c */ d) eq; - -fun tri_equation_add eq1 eq2 = Inttriplefunc.combine (curry op +/) (fn x => x =/ rat_0) eq1 eq2; - -fun tri_equation_eval assig eq = - let fun value v = Inttriplefunc.apply assig v - in Inttriplefunc.fold (fn (v, c) => fn a => a +/ value v */ c) eq rat_0 - end; - -(* Eliminate among linear equations: return unconstrained variables and *) -(* assignments for the others in terms of them. We give one pseudo-variable *) -(* "one" that's used for a constant term. *) - -local - fun extract_first p l = case l of (* FIXME : use find_first instead *) - [] => error "extract_first" - | h::t => if p h then (h,t) else - let val (k,s) = extract_first p t in (k,h::s) end -fun eliminate vars dun eqs = case vars of - [] => if forall Inttriplefunc.is_undefined eqs then dun - else raise Unsolvable - | v::vs => - ((let - val (eq,oeqs) = extract_first (fn e => Inttriplefunc.defined e v) eqs - val a = Inttriplefunc.apply eq v - val eq' = tri_equation_cmul ((Rat.neg rat_1) // a) (Inttriplefunc.undefine v eq) - fun elim e = - let val b = Inttriplefunc.tryapplyd e v rat_0 - in if b =/ rat_0 then e else - tri_equation_add e (tri_equation_cmul (Rat.neg b // a) eq) - end - in eliminate vs (Inttriplefunc.update (v,eq') (Inttriplefunc.mapf elim dun)) (map elim oeqs) - end) - handle ERROR _ => eliminate vs dun eqs) -in -fun tri_eliminate_equations one vars eqs = - let - val assig = eliminate vars Inttriplefunc.undefined eqs - val vs = Inttriplefunc.fold (fn (x, f) => fn a => remove (dest_ord triple_int_ord) one (Inttriplefunc.dom f) @ a) assig [] - in (distinct (dest_ord triple_int_ord) vs, assig) - end -end; - -(* Eliminate all variables, in an essentially arbitrary order. *) - -fun tri_eliminate_all_equations one = - let - fun choose_variable eq = - let val (v,_) = Inttriplefunc.choose eq - in if is_equal (triple_int_ord(v,one)) then - let val eq' = Inttriplefunc.undefine v eq - in if Inttriplefunc.is_undefined eq' then error "choose_variable" - else fst (Inttriplefunc.choose eq') - end - else v - end - fun eliminate dun eqs = case eqs of - [] => dun - | eq::oeqs => - if Inttriplefunc.is_undefined eq then eliminate dun oeqs else - let val v = choose_variable eq - val a = Inttriplefunc.apply eq v - val eq' = tri_equation_cmul ((Rat.rat_of_int ~1) // a) - (Inttriplefunc.undefine v eq) - fun elim e = - let val b = Inttriplefunc.tryapplyd e v rat_0 - in if b =/ rat_0 then e - else tri_equation_add e (tri_equation_cmul (Rat.neg b // a) eq) - end - in eliminate (Inttriplefunc.update(v, eq') (Inttriplefunc.mapf elim dun)) - (map elim oeqs) - end -in fn eqs => - let - val assig = eliminate Inttriplefunc.undefined eqs - val vs = Inttriplefunc.fold (fn (x, f) => fn a => remove (dest_ord triple_int_ord) one (Inttriplefunc.dom f) @ a) assig [] - in (distinct (dest_ord triple_int_ord) vs,assig) - end -end; - -(* Solve equations by assigning arbitrary numbers. *) - -fun tri_solve_equations one eqs = - let - val (vars,assigs) = tri_eliminate_all_equations one eqs - val vfn = fold_rev (fn v => Inttriplefunc.update(v,rat_0)) vars - (Inttriplefunc.onefunc(one, Rat.rat_of_int ~1)) - val ass = - Inttriplefunc.combine (curry op +/) (K false) - (Inttriplefunc.mapf (tri_equation_eval vfn) assigs) vfn - in if forall (fn e => tri_equation_eval ass e =/ rat_0) eqs - then Inttriplefunc.undefine one ass else raise Sanity - end; - -(* Multiply equation-parametrized poly by regular poly and add accumulator. *) - -fun tri_epoly_pmul p q acc = - Monomialfunc.fold (fn (m1, c) => fn a => - Monomialfunc.fold (fn (m2,e) => fn b => - let val m = monomial_mul m1 m2 - val es = Monomialfunc.tryapplyd b m Inttriplefunc.undefined - in Monomialfunc.update (m,tri_equation_add (tri_equation_cmul c e) es) b - end) q a) p acc ; - -(* Usual operations on equation-parametrized poly. *) - -fun tri_epoly_cmul c l = - if c =/ rat_0 then Inttriplefunc.undefined else Inttriplefunc.mapf (tri_equation_cmul c) l;; - -val tri_epoly_neg = tri_epoly_cmul (Rat.rat_of_int ~1); - -val tri_epoly_add = Inttriplefunc.combine tri_equation_add Inttriplefunc.is_undefined; - -fun tri_epoly_sub p q = tri_epoly_add p (tri_epoly_neg q);; - -(* Stuff for "equations" ((int*int)->num functions). *) - -fun pi_equation_cmul c eq = - if c =/ rat_0 then Inttriplefunc.undefined else Inttriplefunc.mapf (fn d => c */ d) eq; - -fun pi_equation_add eq1 eq2 = Inttriplefunc.combine (curry op +/) (fn x => x =/ rat_0) eq1 eq2; - -fun pi_equation_eval assig eq = - let fun value v = Inttriplefunc.apply assig v - in Inttriplefunc.fold (fn (v, c) => fn a => a +/ value v */ c) eq rat_0 - end; - -(* Eliminate among linear equations: return unconstrained variables and *) -(* assignments for the others in terms of them. We give one pseudo-variable *) -(* "one" that's used for a constant term. *) - -local -fun extract_first p l = case l of - [] => error "extract_first" - | h::t => if p h then (h,t) else - let val (k,s) = extract_first p t in (k,h::s) end -fun eliminate vars dun eqs = case vars of - [] => if forall Inttriplefunc.is_undefined eqs then dun - else raise Unsolvable - | v::vs => - let - val (eq,oeqs) = extract_first (fn e => Inttriplefunc.defined e v) eqs - val a = Inttriplefunc.apply eq v - val eq' = pi_equation_cmul ((Rat.neg rat_1) // a) (Inttriplefunc.undefine v eq) - fun elim e = - let val b = Inttriplefunc.tryapplyd e v rat_0 - in if b =/ rat_0 then e else - pi_equation_add e (pi_equation_cmul (Rat.neg b // a) eq) - end - in eliminate vs (Inttriplefunc.update (v,eq') (Inttriplefunc.mapf elim dun)) (map elim oeqs) - end - handle ERROR _ => eliminate vs dun eqs -in -fun pi_eliminate_equations one vars eqs = - let - val assig = eliminate vars Inttriplefunc.undefined eqs - val vs = Inttriplefunc.fold (fn (x, f) => fn a => remove (dest_ord triple_int_ord) one (Inttriplefunc.dom f) @ a) assig [] - in (distinct (dest_ord triple_int_ord) vs, assig) - end -end; - -(* Eliminate all variables, in an essentially arbitrary order. *) - -fun pi_eliminate_all_equations one = - let - fun choose_variable eq = - let val (v,_) = Inttriplefunc.choose eq - in if is_equal (triple_int_ord(v,one)) then - let val eq' = Inttriplefunc.undefine v eq - in if Inttriplefunc.is_undefined eq' then error "choose_variable" - else fst (Inttriplefunc.choose eq') - end - else v - end - fun eliminate dun eqs = case eqs of - [] => dun - | eq::oeqs => - if Inttriplefunc.is_undefined eq then eliminate dun oeqs else - let val v = choose_variable eq - val a = Inttriplefunc.apply eq v - val eq' = pi_equation_cmul ((Rat.rat_of_int ~1) // a) - (Inttriplefunc.undefine v eq) - fun elim e = - let val b = Inttriplefunc.tryapplyd e v rat_0 - in if b =/ rat_0 then e - else pi_equation_add e (pi_equation_cmul (Rat.neg b // a) eq) - end - in eliminate (Inttriplefunc.update(v, eq') (Inttriplefunc.mapf elim dun)) - (map elim oeqs) - end -in fn eqs => - let - val assig = eliminate Inttriplefunc.undefined eqs - val vs = Inttriplefunc.fold (fn (x, f) => fn a => remove (dest_ord triple_int_ord) one (Inttriplefunc.dom f) @ a) assig [] - in (distinct (dest_ord triple_int_ord) vs,assig) - end -end; - -(* Solve equations by assigning arbitrary numbers. *) - -fun pi_solve_equations one eqs = - let - val (vars,assigs) = pi_eliminate_all_equations one eqs - val vfn = fold_rev (fn v => Inttriplefunc.update(v,rat_0)) vars - (Inttriplefunc.onefunc(one, Rat.rat_of_int ~1)) - val ass = - Inttriplefunc.combine (curry op +/) (K false) - (Inttriplefunc.mapf (pi_equation_eval vfn) assigs) vfn - in if forall (fn e => pi_equation_eval ass e =/ rat_0) eqs - then Inttriplefunc.undefine one ass else raise Sanity - end; - -(* Multiply equation-parametrized poly by regular poly and add accumulator. *) - -fun pi_epoly_pmul p q acc = - Monomialfunc.fold (fn (m1, c) => fn a => - Monomialfunc.fold (fn (m2,e) => fn b => - let val m = monomial_mul m1 m2 - val es = Monomialfunc.tryapplyd b m Inttriplefunc.undefined - in Monomialfunc.update (m,pi_equation_add (pi_equation_cmul c e) es) b - end) q a) p acc ; - -(* Usual operations on equation-parametrized poly. *) - -fun pi_epoly_cmul c l = - if c =/ rat_0 then Inttriplefunc.undefined else Inttriplefunc.mapf (pi_equation_cmul c) l;; - -val pi_epoly_neg = pi_epoly_cmul (Rat.rat_of_int ~1); - -val pi_epoly_add = Inttriplefunc.combine pi_equation_add Inttriplefunc.is_undefined; - -fun pi_epoly_sub p q = pi_epoly_add p (pi_epoly_neg q);; - -fun allpairs f l1 l2 = fold_rev (fn x => (curry (op @)) (map (f x) l2)) l1 []; - -(* Hence produce the "relevant" monomials: those whose squares lie in the *) -(* Newton polytope of the monomials in the input. (This is enough according *) -(* to Reznik: "Extremal PSD forms with few terms", Duke Math. Journal, *) -(* vol 45, pp. 363--374, 1978. *) -(* *) -(* These are ordered in sort of decreasing degree. In particular the *) -(* constant monomial is last; this gives an order in diagonalization of the *) -(* quadratic form that will tend to display constants. *) - -(* -UNUSED - -fun newton_polytope pol = - let - val vars = poly_variables pol - val mons = map (fn m => map (fn x => monomial_degree x m) vars) - (Monomialfunc.dom pol) - val ds = map (fn x => (degree x pol + 1) div 2) vars - val all = fold_rev (fn n => allpairs cons (0 upto n)) ds [[]] - val mons' = minimal_convex_hull mons - val all' = - filter (fn m => in_convex_hull mons' (map (fn x => 2 * x) m)) all - in map (fn m => fold_rev2 (fn v => fn i => fn a => if i = 0 then a else Ctermfunc.update (v,i) a) - vars m monomial_1) (rev all') - end; - -*) - -(* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form. *) - -local -fun diagonalize n i m = - if Intpairfunc.is_undefined (snd m) then [] - else - let val a11 = Intpairfunc.tryapplyd (snd m) (i,i) rat_0 - in if a11 fn a => - let val y = c // a11 - in if y = rat_0 then a else Intfunc.update (i,y) a - end) (snd v) Intfunc.undefined) - fun upt0 x y a = if y = rat_0 then a else Intpairfunc.update (x,y) a - val m' = - ((n,n), - iter (i+1,n) (fn j => - iter (i+1,n) (fn k => - (upt0 (j,k) (Intpairfunc.tryapplyd (snd m) (j,k) rat_0 -/ Intfunc.tryapplyd (snd v) j rat_0 */ Intfunc.tryapplyd (snd v') k rat_0)))) - Intpairfunc.undefined) - in (a11,v')::diagonalize n (i + 1) m' - end - end -in -fun diag m = - let - val nn = dimensions m - val n = fst nn - in if snd nn <> n then error "diagonalize: non-square matrix" - else diagonalize n 1 m - end -end; - -fun gcd_rat a b = Rat.rat_of_int (Integer.gcd (int_of_rat a) (int_of_rat b)); - -(* Adjust a diagonalization to collect rationals at the start. *) - (* FIXME : Potentially polymorphic keys, but here only: integers!! *) -local - fun upd0 x y a = if y =/ rat_0 then a else Intfunc.update(x,y) a; - fun mapa f (d,v) = - (d, Intfunc.fold (fn (i,c) => fn a => upd0 i (f c) a) v Intfunc.undefined) - fun adj (c,l) = - let val a = - Intfunc.fold (fn (i,c) => fn a => lcm_rat a (denominator_rat c)) - (snd l) rat_1 // - Intfunc.fold (fn (i,c) => fn a => gcd_rat a (numerator_rat c)) - (snd l) rat_0 - in ((c // (a */ a)),mapa (fn x => a */ x) l) - end -in -fun deration d = if null d then (rat_0,d) else - let val d' = map adj d - val a = fold (lcm_rat o denominator_rat o fst) d' rat_1 // - fold (gcd_rat o numerator_rat o fst) d' rat_0 - in ((rat_1 // a),map (fn (c,l) => (a */ c,l)) d') - end -end; - -(* Enumeration of monomials with given multidegree bound. *) - -fun enumerate_monomials d vars = - if d < 0 then [] - else if d = 0 then [Ctermfunc.undefined] - else if null vars then [monomial_1] else - let val alts = - map (fn k => let val oths = enumerate_monomials (d - k) (tl vars) - in map (fn ks => if k = 0 then ks else Ctermfunc.update (hd vars, k) ks) oths end) (0 upto d) - in fold1 (curry op @) alts - end; - -(* Enumerate products of distinct input polys with degree <= d. *) -(* We ignore any constant input polynomials. *) -(* Give the output polynomial and a record of how it was derived. *) - -local - open RealArith -in -fun enumerate_products d pols = -if d = 0 then [(poly_const rat_1,Rational_lt rat_1)] -else if d < 0 then [] else -case pols of - [] => [(poly_const rat_1,Rational_lt rat_1)] - | (p,b)::ps => - let val e = multidegree p - in if e = 0 then enumerate_products d ps else - enumerate_products d ps @ - map (fn (q,c) => (poly_mul p q,Product(b,c))) - (enumerate_products (d - e) ps) - end -end; - -(* Convert regular polynomial. Note that we treat (0,0,0) as -1. *) - -fun epoly_of_poly p = - Monomialfunc.fold (fn (m,c) => fn a => Monomialfunc.update (m, Inttriplefunc.onefunc ((0,0,0), Rat.neg c)) a) p Monomialfunc.undefined; - -(* String for block diagonal matrix numbered k. *) - -fun sdpa_of_blockdiagonal k m = - let - val pfx = string_of_int k ^" " - val ents = - Inttriplefunc.fold - (fn ((b,i,j),c) => fn a => if i > j then a else ((b,i,j),c)::a) - m [] - val entss = sort (increasing fst triple_int_ord) ents - in fold_rev (fn ((b,i,j),c) => fn a => - pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ - " " ^ decimalize 20 c ^ "\n" ^ a) entss "" - end; - -(* SDPA for problem using block diagonal (i.e. multiple SDPs) *) - -fun sdpa_of_blockproblem nblocks blocksizes obj mats = - let val m = length mats - 1 - in - string_of_int m ^ "\n" ^ - string_of_int nblocks ^ "\n" ^ - (fold1 (fn s => fn t => s^" "^t) (map string_of_int blocksizes)) ^ - "\n" ^ - sdpa_of_vector obj ^ - fold_rev2 (fn k => fn m => fn a => sdpa_of_blockdiagonal (k - 1) m ^ a) - (1 upto length mats) mats "" - end; - -(* Run prover on a problem in block diagonal form. *) - -fun run_blockproblem prover nblocks blocksizes obj mats= - parse_csdpoutput (prover (sdpa_of_blockproblem nblocks blocksizes obj mats)) - -(* -UNUSED - -(* Hence run CSDP on a problem in block diagonal form. *) - -fun run_csdp dbg nblocks blocksizes obj mats = - let - val input_file = tmp_file "sos" ".dat-s" - val output_file = tmp_file "sos" ".out" - val params_file = tmp_file "param" ".csdp" - val _ = File.write input_file - (sdpa_of_blockproblem "" nblocks blocksizes obj mats) - val _ = File.write params_file csdp_params - val current_dir = File.pwd() - val _ = File.cd (Path.variable "ISABELLE_TMP") - val rv = system ("csdp "^(Path.implode input_file) ^ " " - ^ (Path.implode output_file) ^ - (if dbg then "" else "> /dev/null")) - val opr = File.read output_file - val res = parse_csdpoutput opr - in - ((if dbg then () - else (File.rm input_file ; File.rm output_file ; File.cd current_dir)); - (rv,res)) - end; - -fun csdp nblocks blocksizes obj mats = - let - val (rv,res) = run_csdp (!debugging) nblocks blocksizes obj mats - in ((if rv = 1 orelse rv = 2 then error "csdp: Problem is infeasible" - else if rv = 3 then writeln "csdp warning: Reduced accuracy" - else if rv <> 0 then error ("csdp: error "^string_of_int rv) - else ()); - res) - end; -*) - -(* 3D versions of matrix operations to consider blocks separately. *) - -val bmatrix_add = Inttriplefunc.combine (curry op +/) (fn x => x =/ rat_0); -fun bmatrix_cmul c bm = - if c =/ rat_0 then Inttriplefunc.undefined - else Inttriplefunc.mapf (fn x => c */ x) bm; - -val bmatrix_neg = bmatrix_cmul (Rat.rat_of_int ~1); -fun bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);; - -(* Smash a block matrix into components. *) - -fun blocks blocksizes bm = - map (fn (bs,b0) => - let val m = Inttriplefunc.fold - (fn ((b,i,j),c) => fn a => if b = b0 then Intpairfunc.update ((i,j),c) a else a) bm Intpairfunc.undefined - val d = Intpairfunc.fold (fn ((i,j),c) => fn a => max a (max i j)) m 0 - in (((bs,bs),m):matrix) end) - (blocksizes ~~ (1 upto length blocksizes));; - -(* FIXME : Get rid of this !!!*) -local - fun tryfind_with msg f [] = error msg - | tryfind_with msg f (x::xs) = (f x handle ERROR s => tryfind_with s f xs); -in - fun tryfind f = tryfind_with "tryfind" f -end - -(* -fun tryfind f [] = error "tryfind" - | tryfind f (x::xs) = (f x handle ERROR _ => tryfind f xs); -*) - -(* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *) - - -local - open RealArith -in -fun real_positivnullstellensatz_general prover linf d eqs leqs pol = -let - val vars = fold_rev (curry (gen_union (op aconvc)) o poly_variables) - (pol::eqs @ map fst leqs) [] - val monoid = if linf then - (poly_const rat_1,Rational_lt rat_1):: - (filter (fn (p,c) => multidegree p <= d) leqs) - else enumerate_products d leqs - val nblocks = length monoid - fun mk_idmultiplier k p = - let - val e = d - multidegree p - val mons = enumerate_monomials e vars - val nons = mons ~~ (1 upto length mons) - in (mons, - fold_rev (fn (m,n) => Monomialfunc.update(m,Inttriplefunc.onefunc((~k,~n,n),rat_1))) nons Monomialfunc.undefined) - end - - fun mk_sqmultiplier k (p,c) = - let - val e = (d - multidegree p) div 2 - val mons = enumerate_monomials e vars - val nons = mons ~~ (1 upto length mons) - in (mons, - fold_rev (fn (m1,n1) => - fold_rev (fn (m2,n2) => fn a => - let val m = monomial_mul m1 m2 - in if n1 > n2 then a else - let val c = if n1 = n2 then rat_1 else rat_2 - val e = Monomialfunc.tryapplyd a m Inttriplefunc.undefined - in Monomialfunc.update(m, tri_equation_add (Inttriplefunc.onefunc((k,n1,n2), c)) e) a - end - end) nons) - nons Monomialfunc.undefined) - end - - val (sqmonlist,sqs) = split_list (map2 mk_sqmultiplier (1 upto length monoid) monoid) - val (idmonlist,ids) = split_list(map2 mk_idmultiplier (1 upto length eqs) eqs) - val blocksizes = map length sqmonlist - val bigsum = - fold_rev2 (fn p => fn q => fn a => tri_epoly_pmul p q a) eqs ids - (fold_rev2 (fn (p,c) => fn s => fn a => tri_epoly_pmul p s a) monoid sqs - (epoly_of_poly(poly_neg pol))) - val eqns = Monomialfunc.fold (fn (m,e) => fn a => e::a) bigsum [] - val (pvs,assig) = tri_eliminate_all_equations (0,0,0) eqns - val qvars = (0,0,0)::pvs - val allassig = fold_rev (fn v => Inttriplefunc.update(v,(Inttriplefunc.onefunc(v,rat_1)))) pvs assig - fun mk_matrix v = - Inttriplefunc.fold (fn ((b,i,j), ass) => fn m => - if b < 0 then m else - let val c = Inttriplefunc.tryapplyd ass v rat_0 - in if c = rat_0 then m else - Inttriplefunc.update ((b,j,i), c) (Inttriplefunc.update ((b,i,j), c) m) - end) - allassig Inttriplefunc.undefined - val diagents = Inttriplefunc.fold - (fn ((b,i,j), e) => fn a => if b > 0 andalso i = j then tri_equation_add e a else a) - allassig Inttriplefunc.undefined - - val mats = map mk_matrix qvars - val obj = (length pvs, - itern 1 pvs (fn v => fn i => Intfunc.updatep iszero (i,Inttriplefunc.tryapplyd diagents v rat_0)) - Intfunc.undefined) - val raw_vec = if null pvs then vector_0 0 - else tri_scale_then (run_blockproblem prover nblocks blocksizes) obj mats - fun int_element (d,v) i = Intfunc.tryapplyd v i rat_0 - fun cterm_element (d,v) i = Ctermfunc.tryapplyd v i rat_0 - - fun find_rounding d = - let - val _ = if !debugging - then writeln ("Trying rounding with limit "^Rat.string_of_rat d ^ "\n") - else () - val vec = nice_vector d raw_vec - val blockmat = iter (1,dim vec) - (fn i => fn a => bmatrix_add (bmatrix_cmul (int_element vec i) (nth mats i)) a) - (bmatrix_neg (nth mats 0)) - val allmats = blocks blocksizes blockmat - in (vec,map diag allmats) - end - val (vec,ratdias) = - if null pvs then find_rounding rat_1 - else tryfind find_rounding (map Rat.rat_of_int (1 upto 31) @ - map pow2 (5 upto 66)) - val newassigs = - fold_rev (fn k => Inttriplefunc.update (nth pvs (k - 1), int_element vec k)) - (1 upto dim vec) (Inttriplefunc.onefunc ((0,0,0), Rat.rat_of_int ~1)) - val finalassigs = - Inttriplefunc.fold (fn (v,e) => fn a => Inttriplefunc.update(v, tri_equation_eval newassigs e) a) allassig newassigs - fun poly_of_epoly p = - Monomialfunc.fold (fn (v,e) => fn a => Monomialfunc.updatep iszero (v,tri_equation_eval finalassigs e) a) - p Monomialfunc.undefined - fun mk_sos mons = - let fun mk_sq (c,m) = - (c,fold_rev (fn k=> fn a => Monomialfunc.updatep iszero (nth mons (k - 1), int_element m k) a) - (1 upto length mons) Monomialfunc.undefined) - in map mk_sq - end - val sqs = map2 mk_sos sqmonlist ratdias - val cfs = map poly_of_epoly ids - val msq = filter (fn (a,b) => not (null b)) (map2 pair monoid sqs) - fun eval_sq sqs = fold_rev (fn (c,q) => poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 - val sanity = - fold_rev (fn ((p,c),s) => poly_add (poly_mul p (eval_sq s))) msq - (fold_rev2 (fn p => fn q => poly_add (poly_mul p q)) cfs eqs - (poly_neg pol)) - -in if not(Monomialfunc.is_undefined sanity) then raise Sanity else - (cfs,map (fn (a,b) => (snd a,b)) msq) - end - - -end; - -(* Iterative deepening. *) - -fun deepen f n = - (writeln ("Searching with depth limit " ^ string_of_int n) ; (f n handle ERROR s => (writeln ("failed with message: " ^ s) ; deepen f (n+1)))) - -(* The ordering so we can create canonical HOL polynomials. *) - -fun dest_monomial mon = sort (increasing fst cterm_ord) (Ctermfunc.graph mon); - -fun monomial_order (m1,m2) = - if Ctermfunc.is_undefined m2 then LESS - else if Ctermfunc.is_undefined m1 then GREATER - else - let val mon1 = dest_monomial m1 - val mon2 = dest_monomial m2 - val deg1 = fold (curry op + o snd) mon1 0 - val deg2 = fold (curry op + o snd) mon2 0 - in if deg1 < deg2 then GREATER else if deg1 > deg2 then LESS - else list_ord (prod_ord cterm_ord int_ord) (mon1,mon2) - end; - -fun dest_poly p = - map (fn (m,c) => (c,dest_monomial m)) - (sort (prod_ord monomial_order (K EQUAL)) (Monomialfunc.graph p)); - -(* Map back polynomials and their composites to HOL. *) - -local - open Thm Numeral RealArith -in - -fun cterm_of_varpow x k = if k = 1 then x else capply (capply @{cterm "op ^ :: real => _"} x) - (mk_cnumber @{ctyp nat} k) - -fun cterm_of_monomial m = - if Ctermfunc.is_undefined m then @{cterm "1::real"} - else - let - val m' = dest_monomial m - val vps = fold_rev (fn (x,k) => cons (cterm_of_varpow x k)) m' [] - in fold1 (fn s => fn t => capply (capply @{cterm "op * :: real => _"} s) t) vps - end - -fun cterm_of_cmonomial (m,c) = if Ctermfunc.is_undefined m then cterm_of_rat c - else if c = Rat.one then cterm_of_monomial m - else capply (capply @{cterm "op *::real => _"} (cterm_of_rat c)) (cterm_of_monomial m); - -fun cterm_of_poly p = - if Monomialfunc.is_undefined p then @{cterm "0::real"} - else - let - val cms = map cterm_of_cmonomial - (sort (prod_ord monomial_order (K EQUAL)) (Monomialfunc.graph p)) - in fold1 (fn t1 => fn t2 => capply(capply @{cterm "op + :: real => _"} t1) t2) cms - end; - -fun cterm_of_sqterm (c,p) = Product(Rational_lt c,Square(cterm_of_poly p)); - -fun cterm_of_sos (pr,sqs) = if null sqs then pr - else Product(pr,fold1 (fn a => fn b => Sum(a,b)) (map cterm_of_sqterm sqs)); - -end - -(* Interface to HOL. *) -local - open Thm Conv RealArith - val concl = dest_arg o cprop_of - fun simple_cterm_ord t u = TermOrd.fast_term_ord (term_of t, term_of u) = LESS -in - (* FIXME: Replace tryfind by get_first !! *) -fun real_nonlinear_prover prover ctxt = - let - val {add,mul,neg,pow,sub,main} = Normalizer.semiring_normalizers_ord_wrapper ctxt - (valOf (NormalizerData.match ctxt @{cterm "(0::real) + 1"})) - simple_cterm_ord - val (real_poly_add_conv,real_poly_mul_conv,real_poly_neg_conv, - real_poly_pow_conv,real_poly_sub_conv,real_poly_conv) = (add,mul,neg,pow,sub,main) - fun mainf translator (eqs,les,lts) = - let - val eq0 = map (poly_of_term o dest_arg1 o concl) eqs - val le0 = map (poly_of_term o dest_arg o concl) les - val lt0 = map (poly_of_term o dest_arg o concl) lts - val eqp0 = map (fn (t,i) => (t,Axiom_eq i)) (eq0 ~~ (0 upto (length eq0 - 1))) - val lep0 = map (fn (t,i) => (t,Axiom_le i)) (le0 ~~ (0 upto (length le0 - 1))) - val ltp0 = map (fn (t,i) => (t,Axiom_lt i)) (lt0 ~~ (0 upto (length lt0 - 1))) - val (keq,eq) = List.partition (fn (p,_) => multidegree p = 0) eqp0 - val (klep,lep) = List.partition (fn (p,_) => multidegree p = 0) lep0 - val (kltp,ltp) = List.partition (fn (p,_) => multidegree p = 0) ltp0 - fun trivial_axiom (p,ax) = - case ax of - Axiom_eq n => if eval Ctermfunc.undefined p <>/ Rat.zero then nth eqs n - else error "trivial_axiom: Not a trivial axiom" - | Axiom_le n => if eval Ctermfunc.undefined p if eval Ctermfunc.undefined p <=/ Rat.zero then nth lts n - else error "trivial_axiom: Not a trivial axiom" - | _ => error "trivial_axiom: Not a trivial axiom" - in - ((let val th = tryfind trivial_axiom (keq @ klep @ kltp) - in fconv_rule (arg_conv (arg1_conv real_poly_conv) then_conv field_comp_conv) th end) - handle ERROR _ => ( - let - val pol = fold_rev poly_mul (map fst ltp) (poly_const Rat.one) - val leq = lep @ ltp - fun tryall d = - let val e = multidegree pol - val k = if e = 0 then 0 else d div e - val eq' = map fst eq - in tryfind (fn i => (d,i,real_positivnullstellensatz_general prover false d eq' leq - (poly_neg(poly_pow pol i)))) - (0 upto k) - end - val (d,i,(cert_ideal,cert_cone)) = deepen tryall 0 - val proofs_ideal = - map2 (fn q => fn (p,ax) => Eqmul(cterm_of_poly q,ax)) cert_ideal eq - val proofs_cone = map cterm_of_sos cert_cone - val proof_ne = if null ltp then Rational_lt Rat.one else - let val p = fold1 (fn s => fn t => Product(s,t)) (map snd ltp) - in funpow i (fn q => Product(p,q)) (Rational_lt Rat.one) - end - val proof = fold1 (fn s => fn t => Sum(s,t)) - (proof_ne :: proofs_ideal @ proofs_cone) - in writeln "Translating proof certificate to HOL"; - translator (eqs,les,lts) proof - end)) - end - in mainf end -end - -fun C f x y = f y x; - (* FIXME : This is very bad!!!*) -fun subst_conv eqs t = - let - val t' = fold (Thm.cabs o Thm.lhs_of) eqs t - in Conv.fconv_rule (Thm.beta_conversion true) (fold (C combination) eqs (reflexive t')) - end - -(* A wrapper that tries to substitute away variables first. *) - -local - open Thm Conv RealArith - fun simple_cterm_ord t u = TermOrd.fast_term_ord (term_of t, term_of u) = LESS - val concl = dest_arg o cprop_of - val shuffle1 = - fconv_rule (rewr_conv @{lemma "(a + x == y) == (x == y - (a::real))" by (atomize (full)) (simp add: ring_simps) }) - val shuffle2 = - fconv_rule (rewr_conv @{lemma "(x + a == y) == (x == y - (a::real))" by (atomize (full)) (simp add: ring_simps)}) - fun substitutable_monomial fvs tm = case term_of tm of - Free(_,@{typ real}) => if not (member (op aconvc) fvs tm) then (Rat.one,tm) - else error "substitutable_monomial" - | @{term "op * :: real => _"}$c$(t as Free _ ) => - if is_ratconst (dest_arg1 tm) andalso not (member (op aconvc) fvs (dest_arg tm)) - then (dest_ratconst (dest_arg1 tm),dest_arg tm) else error "substitutable_monomial" - | @{term "op + :: real => _"}$s$t => - (substitutable_monomial (add_cterm_frees (dest_arg tm) fvs) (dest_arg1 tm) - handle ERROR _ => substitutable_monomial (add_cterm_frees (dest_arg1 tm) fvs) (dest_arg tm)) - | _ => error "substitutable_monomial" - - fun isolate_variable v th = - let val w = dest_arg1 (cprop_of th) - in if v aconvc w then th - else case term_of w of - @{term "op + :: real => _"}$s$t => - if dest_arg1 w aconvc v then shuffle2 th - else isolate_variable v (shuffle1 th) - | _ => error "isolate variable : This should not happen?" - end -in - -fun real_nonlinear_subst_prover prover ctxt = - let - val {add,mul,neg,pow,sub,main} = Normalizer.semiring_normalizers_ord_wrapper ctxt - (valOf (NormalizerData.match ctxt @{cterm "(0::real) + 1"})) - simple_cterm_ord - - val (real_poly_add_conv,real_poly_mul_conv,real_poly_neg_conv, - real_poly_pow_conv,real_poly_sub_conv,real_poly_conv) = (add,mul,neg,pow,sub,main) - - fun make_substitution th = - let - val (c,v) = substitutable_monomial [] (dest_arg1(concl th)) - val th1 = Drule.arg_cong_rule (capply @{cterm "op * :: real => _"} (cterm_of_rat (Rat.inv c))) (mk_meta_eq th) - val th2 = fconv_rule (binop_conv real_poly_mul_conv) th1 - in fconv_rule (arg_conv real_poly_conv) (isolate_variable v th2) - end - fun oprconv cv ct = - let val g = Thm.dest_fun2 ct - in if g aconvc @{cterm "op <= :: real => _"} - orelse g aconvc @{cterm "op < :: real => _"} - then arg_conv cv ct else arg1_conv cv ct - end - fun mainf translator = - let - fun substfirst(eqs,les,lts) = - ((let - val eth = tryfind make_substitution eqs - val modify = fconv_rule (arg_conv (oprconv(subst_conv [eth] then_conv real_poly_conv))) - in substfirst - (filter_out (fn t => (Thm.dest_arg1 o Thm.dest_arg o cprop_of) t - aconvc @{cterm "0::real"}) (map modify eqs), - map modify les,map modify lts) - end) - handle ERROR _ => real_nonlinear_prover prover ctxt translator (rev eqs, rev les, rev lts)) - in substfirst - end - - - in mainf - end - -(* Overall function. *) - -fun real_sos prover ctxt t = gen_prover_real_arith ctxt (real_nonlinear_subst_prover prover ctxt) t; -end; - -(* A tactic *) -fun strip_all ct = - case term_of ct of - Const("all",_) $ Abs (xn,xT,p) => - let val (a,(v,t')) = (apsnd (Thm.dest_abs (SOME xn)) o Thm.dest_comb) ct - in apfst (cons v) (strip_all t') - end -| _ => ([],ct) - -fun core_sos_conv prover ctxt t = Drule.arg_cong_rule @{cterm Trueprop} (real_sos prover ctxt (Thm.dest_arg t) RS @{thm Eq_TrueI}) - -val known_sos_constants = - [@{term "op ==>"}, @{term "Trueprop"}, - @{term "op -->"}, @{term "op &"}, @{term "op |"}, - @{term "Not"}, @{term "op = :: bool => _"}, - @{term "All :: (real => _) => _"}, @{term "Ex :: (real => _) => _"}, - @{term "op = :: real => _"}, @{term "op < :: real => _"}, - @{term "op <= :: real => _"}, - @{term "op + :: real => _"}, @{term "op - :: real => _"}, - @{term "op * :: real => _"}, @{term "uminus :: real => _"}, - @{term "op / :: real => _"}, @{term "inverse :: real => _"}, - @{term "op ^ :: real => _"}, @{term "abs :: real => _"}, - @{term "min :: real => _"}, @{term "max :: real => _"}, - @{term "0::real"}, @{term "1::real"}, @{term "number_of :: int => real"}, - @{term "number_of :: int => nat"}, - @{term "Int.Bit0"}, @{term "Int.Bit1"}, - @{term "Int.Pls"}, @{term "Int.Min"}]; - -fun check_sos kcts ct = - let - val t = term_of ct - val _ = if not (null (Term.add_tfrees t []) - andalso null (Term.add_tvars t [])) - then error "SOS: not sos. Additional type varables" else () - val fs = Term.add_frees t [] - val _ = if exists (fn ((_,T)) => not (T = @{typ "real"})) fs - then error "SOS: not sos. Variables with type not real" else () - val vs = Term.add_vars t [] - val _ = if exists (fn ((_,T)) => not (T = @{typ "real"})) fs - then error "SOS: not sos. Variables with type not real" else () - val ukcs = subtract (fn (t,p) => Const p aconv t) kcts (Term.add_consts t []) - val _ = if null ukcs then () - else error ("SOSO: Unknown constants in Subgoal:" ^ commas (map fst ukcs)) -in () end - -fun core_sos_tac prover ctxt = CSUBGOAL (fn (ct, i) => - let val _ = check_sos known_sos_constants ct - val (avs, p) = strip_all ct - val th = standard (fold_rev forall_intr avs (real_sos prover ctxt (Thm.dest_arg p))) - in rtac th i end); - -fun default_SOME f NONE v = SOME v - | default_SOME f (SOME v) _ = SOME v; - -fun lift_SOME f NONE a = f a - | lift_SOME f (SOME a) _ = SOME a; - - -local - val is_numeral = can (HOLogic.dest_number o term_of) -in -fun get_denom b ct = case term_of ct of - @{term "op / :: real => _"} $ _ $ _ => - if is_numeral (Thm.dest_arg ct) then get_denom b (Thm.dest_arg1 ct) - else default_SOME (get_denom b) (get_denom b (Thm.dest_arg ct)) (Thm.dest_arg ct, b) - | @{term "op < :: real => _"} $ _ $ _ => lift_SOME (get_denom true) (get_denom true (Thm.dest_arg ct)) (Thm.dest_arg1 ct) - | @{term "op <= :: real => _"} $ _ $ _ => lift_SOME (get_denom true) (get_denom true (Thm.dest_arg ct)) (Thm.dest_arg1 ct) - | _ $ _ => lift_SOME (get_denom b) (get_denom b (Thm.dest_fun ct)) (Thm.dest_arg ct) - | _ => NONE -end; - -fun elim_one_denom_tac ctxt = -CSUBGOAL (fn (P,i) => - case get_denom false P of - NONE => no_tac - | SOME (d,ord) => - let - val ss = simpset_of ctxt addsimps @{thms field_simps} - addsimps [@{thm nonzero_power_divide}, @{thm power_divide}] - val th = instantiate' [] [SOME d, SOME (Thm.dest_arg P)] - (if ord then @{lemma "(d=0 --> P) & (d>0 --> P) & (d<(0::real) --> P) ==> P" by auto} - else @{lemma "(d=0 --> P) & (d ~= (0::real) --> P) ==> P" by blast}) - in (rtac th i THEN Simplifier.asm_full_simp_tac ss i) end); - -fun elim_denom_tac ctxt i = REPEAT (elim_one_denom_tac ctxt i); - -fun sos_tac prover ctxt = ObjectLogic.full_atomize_tac THEN' elim_denom_tac ctxt THEN' core_sos_tac prover ctxt - - -end; diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Nominal/nominal_inductive2.ML --- a/src/HOL/Nominal/nominal_inductive2.ML Mon Aug 10 08:37:37 2009 +0200 +++ b/src/HOL/Nominal/nominal_inductive2.ML Mon Aug 10 10:25:00 2009 +0200 @@ -8,7 +8,7 @@ signature NOMINAL_INDUCTIVE2 = sig - val prove_strong_ind: string -> (string * string list) list -> local_theory -> Proof.state + val prove_strong_ind: string -> string option -> (string * string list) list -> local_theory -> Proof.state end structure NominalInductive2 : NOMINAL_INDUCTIVE2 = @@ -150,7 +150,7 @@ map (Envir.subst_term env #> cterm_of thy) vs ~~ cts) th end; -fun prove_strong_ind s avoids ctxt = +fun prove_strong_ind s alt_name avoids ctxt = let val thy = ProofContext.theory_of ctxt; val ({names, ...}, {raw_induct, intrs, elims, ...}) = @@ -461,8 +461,13 @@ (strong_raw_induct, [ind_case_names, RuleCases.consumes 0]) else (strong_raw_induct RSN (2, rev_mp), [ind_case_names, RuleCases.consumes 1]); + val (induct_name, inducts_name) = + case alt_name of + NONE => (rec_qualified (Binding.name "strong_induct"), + rec_qualified (Binding.name "strong_inducts")) + | SOME s => (Binding.name s, Binding.name (s ^ "s")); val ((_, [strong_induct']), ctxt') = LocalTheory.note Thm.generatedK - ((rec_qualified (Binding.name "strong_induct"), + ((induct_name, map (Attrib.internal o K) (#2 strong_induct)), [#1 strong_induct]) ctxt; val strong_inducts = @@ -470,7 +475,7 @@ in ctxt' |> LocalTheory.note Thm.generatedK - ((rec_qualified (Binding.name "strong_inducts"), + ((inducts_name, [Attrib.internal (K ind_case_names), Attrib.internal (K (RuleCases.consumes 1))]), strong_inducts) |> snd @@ -486,9 +491,11 @@ val _ = OuterSyntax.local_theory_to_proof "nominal_inductive2" "prove strong induction theorem for inductive predicate involving nominal datatypes" K.thy_goal - (P.xname -- Scan.optional (P.$$$ "avoids" |-- P.enum1 "|" (P.name -- - (P.$$$ ":" |-- P.and_list1 P.term))) [] >> (fn (name, avoids) => - prove_strong_ind name avoids)); + (P.xname -- + Scan.option (P.$$$ "(" |-- P.!!! (P.name --| P.$$$ ")")) -- + (Scan.optional (P.$$$ "avoids" |-- P.enum1 "|" (P.name -- + (P.$$$ ":" |-- P.and_list1 P.term))) []) >> (fn ((name, rule_name), avoids) => + prove_strong_ind name rule_name avoids)); end; diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Tools/ATP_Manager/SystemOnTPTP --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/ATP_Manager/SystemOnTPTP Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,141 @@ +#!/usr/bin/env perl +# +# Wrapper for custom remote provers on SystemOnTPTP +# Author: Fabian Immler, TU Muenchen +# + +use warnings; +use strict; +use Getopt::Std; +use HTTP::Request::Common; +use LWP; + +my $SystemOnTPTPFormReplyURL = + "http://www.cs.miami.edu/~tptp/cgi-bin/SystemOnTPTPFormReply"; + +# default parameters +my %URLParameters = ( + "NoHTML" => 1, + "QuietFlag" => "-q01", + "SubmitButton" => "RunSelectedSystems", + "ProblemSource" => "UPLOAD", + ); + +#----Get format and transform options if specified +my %Options; +getopts("hwxs:t:c:",\%Options); + +#----Usage +sub usage() { + print("Usage: remote [] \n"); + print(" are ...\n"); + print(" -h - print this help\n"); + print(" -w - list available ATP systems\n"); + print(" -x - use X2TPTP to convert output of prover\n"); + print(" -s - specified system to use\n"); + print(" -t - CPU time limit for system\n"); + print(" -c - custom command for system\n"); + print(" - TPTP problem file\n"); + exit(0); +} +if (exists($Options{'h'})) { + usage(); +} + +#----What systems flag +if (exists($Options{'w'})) { + $URLParameters{"SubmitButton"} = "ListSystems"; + delete($URLParameters{"ProblemSource"}); +} + +#----X2TPTP +if (exists($Options{'x'})) { + $URLParameters{"X2TPTP"} = "-S"; +} + +#----Selected system +my $System; +if (exists($Options{'s'})) { + $System = $Options{'s'}; +} else { + # use Vampire as default + $System = "Vampire---9.0"; +} +$URLParameters{"System___$System"} = $System; + +#----Time limit +if (exists($Options{'t'})) { + $URLParameters{"TimeLimit___$System"} = $Options{'t'}; +} +#----Custom command +if (exists($Options{'c'})) { + $URLParameters{"Command___$System"} = $Options{'c'}; +} + +#----Get single file name +if (exists($URLParameters{"ProblemSource"})) { + if (scalar(@ARGV) >= 1) { + $URLParameters{"UPLOADProblem"} = [shift(@ARGV)]; + } else { + print("Missing problem file\n"); + usage(); + die; + } +} + +# Query Server +my $Agent = LWP::UserAgent->new; +if (exists($Options{'t'})) { + # give server more time to respond + $Agent->timeout($Options{'t'} + 10); +} +my $Request = POST($SystemOnTPTPFormReplyURL, + Content_Type => 'form-data',Content => \%URLParameters); +my $Response = $Agent->request($Request); + +#catch errors / failure +if(!$Response->is_success) { + print "HTTP-Error: " . $Response->message . "\n"; + exit(-1); +} elsif (exists($Options{'w'})) { + print $Response->content; + exit (0); +} elsif ($Response->content =~ /WARNING: (\S*) does not exist/) { + print "Specified System $1 does not exist\n"; + exit(-1); +} elsif (exists($Options{'x'}) && + $Response->content =~ + /%\s*Result\s*:\s*Unsatisfiable.*\n%\s*Output\s*:\s*(CNF)?Refutation.*\n%/ && + $Response->content !~ /ERROR: Could not form TPTP format derivation/ ) +{ + # converted output: extract proof + my @lines = split( /\n/, $Response->content); + my $extract = ""; + foreach my $line (@lines){ + #ignore comments + if ($line !~ /^%/ && !($line eq "")) { + $extract .= "$line"; + } + } + # insert newlines after ').' + $extract =~ s/\s//g; + $extract =~ s/\)\.cnf/\)\.\ncnf/g; + + print "========== ~~/lib/scripts/SystemOnTPTP extracted proof: ==========\n"; + # orientation for res_reconstruct.ML + print "# SZS output start CNFRefutation.\n"; + print "$extract\n"; + print "# SZS output end CNFRefutation.\n"; + # can be useful for debugging; Isabelle ignores this + print "============== original response from SystemOnTPTP: ==============\n"; + print $Response->content; + exit(0); +} elsif (!exists($Options{'x'})) { + # pass output directly to Isabelle + print $Response->content; + exit(0); +}else { + print "Remote-script could not extract proof:\n".$Response->content; + exit(-1); +} + diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Tools/ATP_Manager/atp_manager.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/ATP_Manager/atp_manager.ML Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,403 @@ +(* Title: HOL/Tools/ATP_Manager/atp_manager.ML + Author: Fabian Immler, TU Muenchen + +ATP threads are registered here. +Threads with the same birth-time are seen as one group. +All threads of a group are killed when one thread of it has been successful, +or after a certain time, +or when the maximum number of threads exceeds; then the oldest thread is killed. +*) + +signature ATP_MANAGER = +sig + val get_atps: unit -> string + val set_atps: string -> unit + val get_max_atps: unit -> int + val set_max_atps: int -> unit + val get_timeout: unit -> int + val set_timeout: int -> unit + val get_full_types: unit -> bool + val set_full_types: bool -> unit + val kill: unit -> unit + val info: unit -> unit + val messages: int option -> unit + type prover = int -> (thm * (string * int)) list option -> + (thm * (string * int)) list option -> string -> int -> + Proof.context * (thm list * thm) -> + bool * string * string * string vector * (thm * (string * int)) list + val add_prover: string -> prover -> theory -> theory + val print_provers: theory -> unit + val get_prover: string -> theory -> prover option + val sledgehammer: string list -> Proof.state -> unit +end; + +structure AtpManager: ATP_MANAGER = +struct + +(** preferences **) + +val message_store_limit = 20; +val message_display_limit = 5; + +local + +val atps = ref "e remote_vampire"; +val max_atps = ref 5; (* ~1 means infinite number of atps *) +val timeout = ref 60; +val full_types = ref false; + +in + +fun get_atps () = CRITICAL (fn () => ! atps); +fun set_atps str = CRITICAL (fn () => atps := str); + +fun get_max_atps () = CRITICAL (fn () => ! max_atps); +fun set_max_atps number = CRITICAL (fn () => max_atps := number); + +fun get_timeout () = CRITICAL (fn () => ! timeout); +fun set_timeout time = CRITICAL (fn () => timeout := time); + +fun get_full_types () = CRITICAL (fn () => ! full_types); +fun set_full_types bool = CRITICAL (fn () => full_types := bool); + +val _ = + ProofGeneralPgip.add_preference Preferences.category_proof + (Preferences.string_pref atps + "ATP: provers" "Default automatic provers (separated by whitespace)"); + +val _ = + ProofGeneralPgip.add_preference Preferences.category_proof + (Preferences.int_pref max_atps + "ATP: maximum number" "How many provers may run in parallel"); + +val _ = + ProofGeneralPgip.add_preference Preferences.category_proof + (Preferences.int_pref timeout + "ATP: timeout" "ATPs will be interrupted after this time (in seconds)"); + +val _ = + ProofGeneralPgip.add_preference Preferences.category_proof + (Preferences.bool_pref full_types + "ATP: full types" "ATPs will use full type information"); + +end; + + + +(** thread management **) + +(* data structures over threads *) + +structure ThreadHeap = HeapFun +( + type elem = Time.time * Thread.thread; + fun ord ((a, _), (b, _)) = Time.compare (a, b); +); + +fun lookup_thread xs = AList.lookup Thread.equal xs; +fun delete_thread xs = AList.delete Thread.equal xs; +fun update_thread xs = AList.update Thread.equal xs; + + +(* state of thread manager *) + +datatype T = State of + {managing_thread: Thread.thread option, + timeout_heap: ThreadHeap.T, + oldest_heap: ThreadHeap.T, + active: (Thread.thread * (Time.time * Time.time * string)) list, + cancelling: (Thread.thread * (Time.time * Time.time * string)) list, + messages: string list, + store: string list}; + +fun make_state managing_thread timeout_heap oldest_heap active cancelling messages store = + State {managing_thread = managing_thread, timeout_heap = timeout_heap, oldest_heap = oldest_heap, + active = active, cancelling = cancelling, messages = messages, store = store}; + +val state = Synchronized.var "atp_manager" + (make_state NONE ThreadHeap.empty ThreadHeap.empty [] [] [] []); + + +(* unregister thread *) + +fun unregister (success, message) thread = Synchronized.change state + (fn state as State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => + (case lookup_thread active thread of + SOME (birthtime, _, description) => + let + val (group, active') = + if success then List.partition (fn (_, (tb, _, _)) => tb = birthtime) active + else List.partition (fn (th, _) => Thread.equal (th, thread)) active + + val now = Time.now () + val cancelling' = + fold (fn (th, (tb, _, desc)) => update_thread (th, (tb, now, desc))) group cancelling + + val message' = description ^ "\n" ^ message ^ + (if length group <= 1 then "" + else "\nInterrupted " ^ string_of_int (length group - 1) ^ " other group members") + val store' = message' :: + (if length store <= message_store_limit then store + else #1 (chop message_store_limit store)) + in make_state + managing_thread timeout_heap oldest_heap active' cancelling' (message' :: messages) store' + end + | NONE => state)); + + +(* kill excessive atp threads *) + +fun excessive_atps active = + let val max = get_max_atps () + in length active > max andalso max > ~1 end; + +local + +fun kill_oldest () = + let exception Unchanged in + Synchronized.change_result state + (fn State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => + if ThreadHeap.is_empty oldest_heap orelse not (excessive_atps active) + then raise Unchanged + else + let val ((_, oldest_thread), oldest_heap') = ThreadHeap.min_elem oldest_heap + in (oldest_thread, + make_state managing_thread timeout_heap oldest_heap' active cancelling messages store) end) + |> unregister (false, "Interrupted (maximum number of ATPs exceeded)") + handle Unchanged => () + end; + +in + +fun kill_excessive () = + let val State {active, ...} = Synchronized.value state + in if excessive_atps active then (kill_oldest (); kill_excessive ()) else () end; + +end; + +fun print_new_messages () = + let val to_print = Synchronized.change_result state + (fn State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => + (messages, make_state managing_thread timeout_heap oldest_heap active cancelling [] store)) + in + if null to_print then () + else priority ("Sledgehammer: " ^ space_implode "\n\n" to_print) + end; + + +(* start a watching thread -- only one may exist *) + +fun check_thread_manager () = Synchronized.change state + (fn State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => + if (case managing_thread of SOME thread => Thread.isActive thread | NONE => false) + then make_state managing_thread timeout_heap oldest_heap active cancelling messages store + else let val managing_thread = SOME (SimpleThread.fork false (fn () => + let + val min_wait_time = Time.fromMilliseconds 300 + val max_wait_time = Time.fromSeconds 10 + + (* wait for next thread to cancel, or maximum*) + fun time_limit (State {timeout_heap, ...}) = + (case try ThreadHeap.min timeout_heap of + NONE => SOME (Time.+ (Time.now (), max_wait_time)) + | SOME (time, _) => SOME time) + + (* action: find threads whose timeout is reached, and interrupt cancelling threads *) + fun action (State {managing_thread, timeout_heap, oldest_heap, active, cancelling, + messages, store}) = + let val (timeout_threads, timeout_heap') = + ThreadHeap.upto (Time.now (), Thread.self ()) timeout_heap + in + if null timeout_threads andalso null cancelling andalso not (excessive_atps active) + then NONE + else + let + val _ = List.app (SimpleThread.interrupt o #1) cancelling + val cancelling' = filter (Thread.isActive o #1) cancelling + val state' = make_state + managing_thread timeout_heap' oldest_heap active cancelling' messages store + in SOME (map #2 timeout_threads, state') end + end + in + while Synchronized.change_result state + (fn st as + State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => + if (null active) andalso (null cancelling) andalso (null messages) + then (false, make_state NONE timeout_heap oldest_heap active cancelling messages store) + else (true, st)) + do + (Synchronized.timed_access state time_limit action + |> these + |> List.app (unregister (false, "Interrupted (reached timeout)")); + kill_excessive (); + print_new_messages (); + (*give threads time to respond to interrupt*) + OS.Process.sleep min_wait_time) + end)) + in make_state managing_thread timeout_heap oldest_heap active cancelling messages store end); + + +(* thread is registered here by sledgehammer *) + +fun register birthtime deadtime (thread, desc) = + (Synchronized.change state + (fn State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => + let + val timeout_heap' = ThreadHeap.insert (deadtime, thread) timeout_heap + val oldest_heap' = ThreadHeap.insert (birthtime, thread) oldest_heap + val active' = update_thread (thread, (birthtime, deadtime, desc)) active + in make_state managing_thread timeout_heap' oldest_heap' active' cancelling messages store end); + check_thread_manager ()); + + + +(** user commands **) + +(* kill: move all threads to cancelling *) + +fun kill () = Synchronized.change state + (fn State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => + let val formerly_active = map (fn (th, (tb, _, desc)) => (th, (tb, Time.now (), desc))) active + in make_state + managing_thread timeout_heap oldest_heap [] (formerly_active @ cancelling) messages store + end); + + +(* ATP info *) + +fun info () = + let + val State {active, cancelling, ...} = Synchronized.value state + + fun running_info (_, (birth_time, dead_time, desc)) = "Running: " + ^ (string_of_int o Time.toSeconds) (Time.- (Time.now (), birth_time)) + ^ " s -- " + ^ (string_of_int o Time.toSeconds) (Time.- (dead_time, Time.now ())) + ^ " s to live:\n" ^ desc + fun cancelling_info (_, (_, dead_time, desc)) = "Trying to interrupt thread since " + ^ (string_of_int o Time.toSeconds) (Time.- (Time.now (), dead_time)) + ^ " s:\n" ^ desc + + val running = + if null active then "No ATPs running." + else space_implode "\n\n" ("Running ATPs:" :: map running_info active) + val interrupting = + if null cancelling then "" + else space_implode "\n\n" + ("Trying to interrupt the following ATPs:" :: map cancelling_info cancelling) + + in writeln (running ^ "\n" ^ interrupting) end; + +fun messages opt_limit = + let + val limit = the_default message_display_limit opt_limit; + val State {store = msgs, ...} = Synchronized.value state + val header = "Recent ATP messages" ^ + (if length msgs <= limit then ":" else " (" ^ string_of_int limit ^ " displayed):"); + in writeln (space_implode "\n\n" (header :: #1 (chop limit msgs))) end; + + + +(** The Sledgehammer **) + +(* named provers *) + +type prover = int -> (thm * (string * int)) list option -> + (thm * (string * int)) list option -> string -> int -> + Proof.context * (thm list * thm) -> + bool * string * string * string vector * (thm * (string * int)) list + +fun err_dup_prover name = error ("Duplicate prover: " ^ quote name); + +structure Provers = TheoryDataFun +( + type T = (prover * stamp) Symtab.table + val empty = Symtab.empty + val copy = I + val extend = I + fun merge _ tabs : T = Symtab.merge (eq_snd op =) tabs + handle Symtab.DUP dup => err_dup_prover dup +); + +fun add_prover name prover thy = + Provers.map (Symtab.update_new (name, (prover, stamp ()))) thy + handle Symtab.DUP dup => err_dup_prover dup; + +fun print_provers thy = Pretty.writeln + (Pretty.strs ("external provers:" :: sort_strings (Symtab.keys (Provers.get thy)))); + +fun get_prover name thy = case Symtab.lookup (Provers.get thy) name of + NONE => NONE +| SOME (prover, _) => SOME prover; + +(* start prover thread *) + +fun start_prover name birthtime deadtime i proof_state = + (case get_prover name (Proof.theory_of proof_state) of + NONE => warning ("Unknown external prover: " ^ quote name) + | SOME prover => + let + val (ctxt, (_, goal)) = Proof.get_goal proof_state + val desc = + "external prover " ^ quote name ^ " for subgoal " ^ string_of_int i ^ ":\n" ^ + Syntax.string_of_term ctxt (Thm.term_of (Thm.cprem_of goal i)) + val _ = SimpleThread.fork true (fn () => + let + val _ = register birthtime deadtime (Thread.self (), desc) + val result = + let val (success, message, _, _, _) = + prover (get_timeout ()) NONE NONE name i (Proof.get_goal proof_state) + in (success, message) end + handle ResHolClause.TOO_TRIVIAL + => (true, "Empty clause: Try this command: " ^ Markup.markup Markup.sendback "apply metis") + | ERROR msg + => (false, "Error: " ^ msg) + val _ = unregister result (Thread.self ()) + in () end handle Interrupt => ()) + in () end); + + +(* sledghammer for first subgoal *) + +fun sledgehammer names proof_state = + let + val provers = + if null names then String.tokens (Symbol.is_ascii_blank o String.str) (get_atps ()) + else names + val birthtime = Time.now () + val deadtime = Time.+ (birthtime, Time.fromSeconds (get_timeout ())) + in List.app (fn name => start_prover name birthtime deadtime 1 proof_state) provers end; + + + +(** Isar command syntax **) + +local structure K = OuterKeyword and P = OuterParse in + +val _ = + OuterSyntax.improper_command "atp_kill" "kill all managed provers" K.diag + (Scan.succeed (Toplevel.no_timing o Toplevel.imperative kill)); + +val _ = + OuterSyntax.improper_command "atp_info" "print information about managed provers" K.diag + (Scan.succeed (Toplevel.no_timing o Toplevel.imperative info)); + +val _ = + OuterSyntax.improper_command "atp_messages" "print recent messages issued by managed provers" K.diag + (Scan.option (P.$$$ "(" |-- P.nat --| P.$$$ ")") >> + (fn limit => Toplevel.no_timing o Toplevel.imperative (fn () => messages limit))); + +val _ = + OuterSyntax.improper_command "print_atps" "print external provers" K.diag + (Scan.succeed (Toplevel.no_timing o Toplevel.unknown_theory o + Toplevel.keep (print_provers o Toplevel.theory_of))); + +val _ = + OuterSyntax.command "sledgehammer" "call all automatic theorem provers" K.diag + (Scan.repeat P.xname >> (fn names => Toplevel.no_timing o Toplevel.unknown_proof o + Toplevel.keep (sledgehammer names o Toplevel.proof_of))); + +end; + +end; + diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Tools/ATP_Manager/atp_minimal.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/ATP_Manager/atp_minimal.ML Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,223 @@ +(* Title: HOL/Tools/ATP_Manager/atp_minimal.ML + Author: Philipp Meyer, TU Muenchen + +Minimalization of theorem list for metis by using an external automated theorem prover +*) + +structure AtpMinimal: sig end = +struct + +(* output control *) + +fun debug str = Output.debug (fn () => str) +fun debug_fn f = if ! Output.debugging then f () else () +fun answer str = Output.writeln str +fun println str = Output.priority str + +fun order_unique name_list = OrdList.make (String.collate Char.compare) name_list +fun length_string namelist = Int.toString (length namelist) + +fun print_names name_thms_pairs = + let + val names = map fst name_thms_pairs + val ordered = order_unique names + in + app (fn name => (debug (" " ^ name))) ordered + end + + +(* minimalization algorithm *) + +local + fun isplit (l,r) [] = (l,r) + | isplit (l,r) (h::[]) = (h::l, r) + | isplit (l,r) (h1::h2::t) = isplit (h1::l, h2::r) t +in + fun split lst = isplit ([],[]) lst +end + +local + fun min p sup [] = raise Empty + | min p sup [s0] = [s0] + | min p sup s = + let + val (l0, r0) = split s + in + if p (sup @ l0) + then min p sup l0 + else + if p (sup @ r0) + then min p sup r0 + else + let + val l = min p (sup @ r0) l0 + val r = min p (sup @ l) r0 + in + l @ r + end + end +in + (* return a minimal subset v of s that satisfies p + @pre p(s) & ~p([]) & monotone(p) + @post v subset s & p(v) & + forall e in v. ~p(v \ e) + *) + fun minimal p s = min p [] s +end + + +(* failure check and producing answer *) + +datatype 'a prove_result = Success of 'a | Failure | Timeout | Error + +val string_of_result = + fn Success _ => "Success" + | Failure => "Failure" + | Timeout => "Timeout" + | Error => "Error" + +val failure_strings = + [("SPASS beiseite: Ran out of time.", Timeout), + ("Timeout", Timeout), + ("time limit exceeded", Timeout), + ("# Cannot determine problem status within resource limit", Timeout), + ("Error", Error)] + +fun produce_answer (success, message, result_string, thm_name_vec, filtered) = + if success then + (Success (Vector.foldr op:: [] thm_name_vec, filtered), result_string) + else + let + val failure = failure_strings |> get_first (fn (s, t) => + if String.isSubstring s result_string then SOME (t, result_string) else NONE) + in + if is_some failure then + the failure + else + (Failure, result_string) + end + + +(* wrapper for calling external prover *) + +fun sh_test_thms prover prover_name time_limit subgoalno state filtered name_thms_pairs = + let + val _ = println ("Testing " ^ (length_string name_thms_pairs) ^ " theorems... ") + val name_thm_pairs = + flat (map (fn (n, ths) => map_index (fn (i, th) => (n, th)) ths) name_thms_pairs) + val _ = debug_fn (fn () => print_names name_thm_pairs) + val axclauses = ResAxioms.cnf_rules_pairs (Proof.theory_of state) name_thm_pairs + val (result, proof) = + produce_answer + (prover time_limit (SOME axclauses) filtered prover_name subgoalno (Proof.get_goal state)) + val _ = println (string_of_result result) + val _ = debug proof + in + (result, proof) + end + + +(* minimalization of thms *) + +fun minimalize prover prover_name time_limit state name_thms_pairs = + let + val _ = + println ("Minimize called with " ^ length_string name_thms_pairs ^ " theorems, prover: " + ^ prover_name ^ ", time limit: " ^ Int.toString time_limit ^ " seconds") + val _ = debug_fn (fn () => app (fn (n, tl) => + (debug n; app (fn t => + debug (" " ^ Display.string_of_thm (Proof.context_of state) t)) tl)) name_thms_pairs) + val test_thms_fun = sh_test_thms prover prover_name time_limit 1 state + fun test_thms filtered thms = + case test_thms_fun filtered thms of (Success _, _) => true | _ => false + in + (* try prove first to check result and get used theorems *) + (case test_thms_fun NONE name_thms_pairs of + (Success (used, filtered), _) => + let + val ordered_used = order_unique used + val to_use = + if length ordered_used < length name_thms_pairs then + filter (fn (name1, _) => List.exists (equal name1) ordered_used) name_thms_pairs + else + name_thms_pairs + val min_thms = (minimal (test_thms (SOME filtered)) to_use) + val min_names = order_unique (map fst min_thms) + val _ = println ("Minimal " ^ (length_string min_thms) ^ " theorems") + val _ = debug_fn (fn () => print_names min_thms) + in + answer ("Try this command: " ^ + Markup.markup Markup.sendback ("apply (metis " ^ space_implode " " min_names ^ ")")) + end + | (Timeout, _) => + answer ("Timeout: You may need to increase the time limit of " ^ + Int.toString time_limit ^ " seconds. Call atp_minimize [time=...] ") + | (Error, msg) => + answer ("Error in prover: " ^ msg) + | (Failure, _) => + answer "Failure: No proof with the theorems supplied") + handle ResHolClause.TOO_TRIVIAL => + answer ("Trivial: Try this command: " ^ Markup.markup Markup.sendback "apply metis") + | ERROR msg => + answer ("Error: " ^ msg) + end + + +(* Isar command and parsing input *) + +local structure K = OuterKeyword and P = OuterParse and T = OuterLex in + +fun get_thms context = + map (fn (name, interval) => + let + val thmref = Facts.Named ((name, Position.none), interval) + val ths = ProofContext.get_fact context thmref + val name' = Facts.string_of_ref thmref + in + (name', ths) + end) + +val default_prover = "remote_vampire" +val default_time_limit = 5 + +fun get_time_limit_arg time_string = + (case Int.fromString time_string of + SOME t => t + | NONE => error ("Invalid time limit: " ^ quote time_string)) + +val get_options = + let + val def = (default_prover, default_time_limit) + in + foldl (fn ((name, a), (p, t)) => + (case name of + "time" => (p, (get_time_limit_arg a)) + | "atp" => (a, t) + | n => error ("Invalid argument: " ^ n))) def + end + +fun sh_min_command args thm_names state = + let + val (prover_name, time_limit) = get_options args + val prover = + case AtpManager.get_prover prover_name (Proof.theory_of state) of + SOME prover => prover + | NONE => error ("Unknown prover: " ^ quote prover_name) + val name_thms_pairs = get_thms (Proof.context_of state) thm_names + in + minimalize prover prover_name time_limit state name_thms_pairs + end + +val parse_args = Scan.optional (Args.bracks (P.list (P.xname --| P.$$$ "=" -- P.xname))) [] +val parse_thm_names = Scan.repeat (P.xname -- Scan.option Attrib.thm_sel) + +val _ = + OuterSyntax.command "atp_minimize" "minimize theorem list with external prover" K.diag + (parse_args -- parse_thm_names >> (fn (args, thm_names) => + Toplevel.no_timing o Toplevel.unknown_proof o + Toplevel.keep (sh_min_command args thm_names o Toplevel.proof_of))) + +end + +end + diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Tools/ATP_Manager/atp_wrapper.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/ATP_Manager/atp_wrapper.ML Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,217 @@ +(* Title: HOL/Tools/ATP_Manager/atp_wrapper.ML + Author: Fabian Immler, TU Muenchen + +Wrapper functions for external ATPs. +*) + +signature ATP_WRAPPER = +sig + val destdir: string ref + val problem_name: string ref + val tptp_prover_opts_full: int -> bool -> bool -> Path.T * string -> AtpManager.prover + val tptp_prover_opts: int -> bool -> Path.T * string -> AtpManager.prover + val tptp_prover: Path.T * string -> AtpManager.prover + val full_prover_opts: int -> bool -> Path.T * string -> AtpManager.prover + val full_prover: Path.T * string -> AtpManager.prover + val vampire_opts: int -> bool -> AtpManager.prover + val vampire: AtpManager.prover + val vampire_opts_full: int -> bool -> AtpManager.prover + val vampire_full: AtpManager.prover + val eprover_opts: int -> bool -> AtpManager.prover + val eprover: AtpManager.prover + val eprover_opts_full: int -> bool -> AtpManager.prover + val eprover_full: AtpManager.prover + val spass_opts: int -> bool -> AtpManager.prover + val spass: AtpManager.prover + val remote_prover_opts: int -> bool -> string -> string -> AtpManager.prover + val remote_prover: string -> string -> AtpManager.prover + val refresh_systems: unit -> unit +end; + +structure AtpWrapper: ATP_WRAPPER = +struct + +(** generic ATP wrapper **) + +(* global hooks for writing problemfiles *) + +val destdir = ref ""; (*Empty means write files to /tmp*) +val problem_name = ref "prob"; + + +(* basic template *) + +fun external_prover relevance_filter preparer writer (cmd, args) find_failure produce_answer + timeout axiom_clauses filtered_clauses name subgoalno goal = + let + (* path to unique problem file *) + val destdir' = ! destdir + val problem_name' = ! problem_name + fun prob_pathname nr = + let val probfile = Path.basic (problem_name' ^ serial_string () ^ "_" ^ string_of_int nr) + in if destdir' = "" then File.tmp_path probfile + else if File.exists (Path.explode (destdir')) + then Path.append (Path.explode (destdir')) probfile + else error ("No such directory: " ^ destdir') + end + + (* get clauses and prepare them for writing *) + val (ctxt, (chain_ths, th)) = goal + val thy = ProofContext.theory_of ctxt + val chain_ths = map (Thm.put_name_hint ResReconstruct.chained_hint) chain_ths + val goal_cls = #1 (ResAxioms.neg_conjecture_clauses ctxt th subgoalno) + val _ = app (fn th => Output.debug (fn _ => Display.string_of_thm ctxt th)) goal_cls + val the_filtered_clauses = + case filtered_clauses of + NONE => relevance_filter goal goal_cls + | SOME fcls => fcls + val the_axiom_clauses = + case axiom_clauses of + NONE => the_filtered_clauses + | SOME axcls => axcls + val (thm_names, clauses) = + preparer goal_cls chain_ths the_axiom_clauses the_filtered_clauses thy + + (* write out problem file and call prover *) + val probfile = prob_pathname subgoalno + val conj_pos = writer probfile clauses + val (proof, rc) = system_out ( + if File.exists cmd then + space_implode " " ["exec", File.shell_path cmd, args, File.platform_path probfile] + else error ("Bad executable: " ^ Path.implode cmd)) + + (* if problemfile has not been exported, delete problemfile; otherwise export proof, too *) + val _ = + if destdir' = "" then File.rm probfile + else File.write (Path.explode (Path.implode probfile ^ "_proof")) proof + + (* check for success and print out some information on failure *) + val failure = find_failure proof + val success = rc = 0 andalso is_none failure + val message = + if is_some failure then "External prover failed." + else if rc <> 0 then "External prover failed: " ^ proof + else "Try this command: " ^ + produce_answer name (proof, thm_names, conj_pos, ctxt, th, subgoalno) + val _ = Output.debug (fn () => "Sledgehammer response (rc = " ^ string_of_int rc ^ "):\n" ^ proof) + in (success, message, proof, thm_names, the_filtered_clauses) end; + + + +(** common provers **) + +(* generic TPTP-based provers *) + +fun tptp_prover_opts_full max_new theory_const full command timeout ax_clauses fcls name n goal = + external_prover + (ResAtp.get_relevant max_new theory_const) + (ResAtp.prepare_clauses false) + (ResHolClause.tptp_write_file (AtpManager.get_full_types())) + command + ResReconstruct.find_failure + (if full then ResReconstruct.structured_proof else ResReconstruct.lemma_list false) + timeout ax_clauses fcls name n goal; + +(*arbitrary ATP with TPTP input/output and problemfile as last argument*) +fun tptp_prover_opts max_new theory_const = + tptp_prover_opts_full max_new theory_const false; + +fun tptp_prover x = tptp_prover_opts 60 true x; + +(*for structured proofs: prover must support TSTP*) +fun full_prover_opts max_new theory_const = + tptp_prover_opts_full max_new theory_const true; + +fun full_prover x = full_prover_opts 60 true x; + + +(* Vampire *) + +(*NB: Vampire does not work without explicit timelimit*) + +fun vampire_opts max_new theory_const timeout = tptp_prover_opts + max_new theory_const + (Path.explode "$VAMPIRE_HOME/vampire", + ("--output_syntax tptp --mode casc -t " ^ string_of_int timeout)) + timeout; + +val vampire = vampire_opts 60 false; + +fun vampire_opts_full max_new theory_const timeout = full_prover_opts + max_new theory_const + (Path.explode "$VAMPIRE_HOME/vampire", + ("--output_syntax tptp --mode casc -t " ^ string_of_int timeout)) + timeout; + +val vampire_full = vampire_opts_full 60 false; + + +(* E prover *) + +fun eprover_opts max_new theory_const timeout = tptp_prover_opts + max_new theory_const + (Path.explode "$E_HOME/eproof", + "--tstp-in --tstp-out -l5 -xAutoDev -tAutoDev --silent --cpu-limit=" ^ string_of_int timeout) + timeout; + +val eprover = eprover_opts 100 false; + +fun eprover_opts_full max_new theory_const timeout = full_prover_opts + max_new theory_const + (Path.explode "$E_HOME/eproof", + "--tstp-in --tstp-out -l5 -xAutoDev -tAutoDev --silent --cpu-limit=" ^ string_of_int timeout) + timeout; + +val eprover_full = eprover_opts_full 100 false; + + +(* SPASS *) + +fun spass_opts max_new theory_const timeout ax_clauses fcls name n goal = external_prover + (ResAtp.get_relevant max_new theory_const) + (ResAtp.prepare_clauses true) + (ResHolClause.dfg_write_file (AtpManager.get_full_types())) + (Path.explode "$SPASS_HOME/SPASS", + "-Auto -SOS=1 -PGiven=0 -PProblem=0 -Splits=0 -FullRed=0 -DocProof -TimeLimit=" ^ + string_of_int timeout) + ResReconstruct.find_failure + (ResReconstruct.lemma_list true) + timeout ax_clauses fcls name n goal; + +val spass = spass_opts 40 true; + + +(* remote prover invocation via SystemOnTPTP *) + +val systems = + Synchronized.var "atp_wrapper_systems" ([]: string list); + +fun get_systems () = + let + val (answer, rc) = system_out ("\"$ISABELLE_ATP_MANAGER/SystemOnTPTP\" -w") + in + if rc <> 0 then error ("Failed to get available systems from SystemOnTPTP:\n" ^ answer) + else split_lines answer + end; + +fun refresh_systems () = Synchronized.change systems (fn _ => + get_systems ()); + +fun get_system prefix = Synchronized.change_result systems (fn systems => + let val systems = if null systems then get_systems() else systems + in (find_first (String.isPrefix prefix) systems, systems) end); + +fun remote_prover_opts max_new theory_const args prover_prefix timeout = + let val sys = + case get_system prover_prefix of + NONE => error ("No system like " ^ quote prover_prefix ^ " at SystemOnTPTP") + | SOME sys => sys + in tptp_prover_opts max_new theory_const + (Path.explode "$ISABELLE_ATP_MANAGER/SystemOnTPTP", + args ^ " -t " ^ string_of_int timeout ^ " -s " ^ sys) timeout + end; + +val remote_prover = remote_prover_opts 60 false; + +end; + diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Tools/ATP_Manager/etc/settings --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/Tools/ATP_Manager/etc/settings Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,2 @@ +ISABELLE_ATP_MANAGER="$COMPONENT" + diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Tools/atp_manager.ML --- a/src/HOL/Tools/atp_manager.ML Mon Aug 10 08:37:37 2009 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,403 +0,0 @@ -(* Title: HOL/Tools/atp_manager.ML - Author: Fabian Immler, TU Muenchen - -ATP threads are registered here. -Threads with the same birth-time are seen as one group. -All threads of a group are killed when one thread of it has been successful, -or after a certain time, -or when the maximum number of threads exceeds; then the oldest thread is killed. -*) - -signature ATP_MANAGER = -sig - val get_atps: unit -> string - val set_atps: string -> unit - val get_max_atps: unit -> int - val set_max_atps: int -> unit - val get_timeout: unit -> int - val set_timeout: int -> unit - val get_full_types: unit -> bool - val set_full_types: bool -> unit - val kill: unit -> unit - val info: unit -> unit - val messages: int option -> unit - type prover = int -> (thm * (string * int)) list option -> - (thm * (string * int)) list option -> string -> int -> - Proof.context * (thm list * thm) -> - bool * string * string * string vector * (thm * (string * int)) list - val add_prover: string -> prover -> theory -> theory - val print_provers: theory -> unit - val get_prover: string -> theory -> prover option - val sledgehammer: string list -> Proof.state -> unit -end; - -structure AtpManager: ATP_MANAGER = -struct - -(** preferences **) - -val message_store_limit = 20; -val message_display_limit = 5; - -local - -val atps = ref "e remote_vampire"; -val max_atps = ref 5; (* ~1 means infinite number of atps *) -val timeout = ref 60; -val full_types = ref false; - -in - -fun get_atps () = CRITICAL (fn () => ! atps); -fun set_atps str = CRITICAL (fn () => atps := str); - -fun get_max_atps () = CRITICAL (fn () => ! max_atps); -fun set_max_atps number = CRITICAL (fn () => max_atps := number); - -fun get_timeout () = CRITICAL (fn () => ! timeout); -fun set_timeout time = CRITICAL (fn () => timeout := time); - -fun get_full_types () = CRITICAL (fn () => ! full_types); -fun set_full_types bool = CRITICAL (fn () => full_types := bool); - -val _ = - ProofGeneralPgip.add_preference Preferences.category_proof - (Preferences.string_pref atps - "ATP: provers" "Default automatic provers (separated by whitespace)"); - -val _ = - ProofGeneralPgip.add_preference Preferences.category_proof - (Preferences.int_pref max_atps - "ATP: maximum number" "How many provers may run in parallel"); - -val _ = - ProofGeneralPgip.add_preference Preferences.category_proof - (Preferences.int_pref timeout - "ATP: timeout" "ATPs will be interrupted after this time (in seconds)"); - -val _ = - ProofGeneralPgip.add_preference Preferences.category_proof - (Preferences.bool_pref full_types - "ATP: full types" "ATPs will use full type information"); - -end; - - - -(** thread management **) - -(* data structures over threads *) - -structure ThreadHeap = HeapFun -( - type elem = Time.time * Thread.thread; - fun ord ((a, _), (b, _)) = Time.compare (a, b); -); - -fun lookup_thread xs = AList.lookup Thread.equal xs; -fun delete_thread xs = AList.delete Thread.equal xs; -fun update_thread xs = AList.update Thread.equal xs; - - -(* state of thread manager *) - -datatype T = State of - {managing_thread: Thread.thread option, - timeout_heap: ThreadHeap.T, - oldest_heap: ThreadHeap.T, - active: (Thread.thread * (Time.time * Time.time * string)) list, - cancelling: (Thread.thread * (Time.time * Time.time * string)) list, - messages: string list, - store: string list}; - -fun make_state managing_thread timeout_heap oldest_heap active cancelling messages store = - State {managing_thread = managing_thread, timeout_heap = timeout_heap, oldest_heap = oldest_heap, - active = active, cancelling = cancelling, messages = messages, store = store}; - -val state = Synchronized.var "atp_manager" - (make_state NONE ThreadHeap.empty ThreadHeap.empty [] [] [] []); - - -(* unregister thread *) - -fun unregister (success, message) thread = Synchronized.change state - (fn state as State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => - (case lookup_thread active thread of - SOME (birthtime, _, description) => - let - val (group, active') = - if success then List.partition (fn (_, (tb, _, _)) => tb = birthtime) active - else List.partition (fn (th, _) => Thread.equal (th, thread)) active - - val now = Time.now () - val cancelling' = - fold (fn (th, (tb, _, desc)) => update_thread (th, (tb, now, desc))) group cancelling - - val message' = description ^ "\n" ^ message ^ - (if length group <= 1 then "" - else "\nInterrupted " ^ string_of_int (length group - 1) ^ " other group members") - val store' = message' :: - (if length store <= message_store_limit then store - else #1 (chop message_store_limit store)) - in make_state - managing_thread timeout_heap oldest_heap active' cancelling' (message' :: messages) store' - end - | NONE => state)); - - -(* kill excessive atp threads *) - -fun excessive_atps active = - let val max = get_max_atps () - in length active > max andalso max > ~1 end; - -local - -fun kill_oldest () = - let exception Unchanged in - Synchronized.change_result state - (fn State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => - if ThreadHeap.is_empty oldest_heap orelse not (excessive_atps active) - then raise Unchanged - else - let val ((_, oldest_thread), oldest_heap') = ThreadHeap.min_elem oldest_heap - in (oldest_thread, - make_state managing_thread timeout_heap oldest_heap' active cancelling messages store) end) - |> unregister (false, "Interrupted (maximum number of ATPs exceeded)") - handle Unchanged => () - end; - -in - -fun kill_excessive () = - let val State {active, ...} = Synchronized.value state - in if excessive_atps active then (kill_oldest (); kill_excessive ()) else () end; - -end; - -fun print_new_messages () = - let val to_print = Synchronized.change_result state - (fn State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => - (messages, make_state managing_thread timeout_heap oldest_heap active cancelling [] store)) - in - if null to_print then () - else priority ("Sledgehammer: " ^ space_implode "\n\n" to_print) - end; - - -(* start a watching thread -- only one may exist *) - -fun check_thread_manager () = Synchronized.change state - (fn State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => - if (case managing_thread of SOME thread => Thread.isActive thread | NONE => false) - then make_state managing_thread timeout_heap oldest_heap active cancelling messages store - else let val managing_thread = SOME (SimpleThread.fork false (fn () => - let - val min_wait_time = Time.fromMilliseconds 300 - val max_wait_time = Time.fromSeconds 10 - - (* wait for next thread to cancel, or maximum*) - fun time_limit (State {timeout_heap, ...}) = - (case try ThreadHeap.min timeout_heap of - NONE => SOME (Time.+ (Time.now (), max_wait_time)) - | SOME (time, _) => SOME time) - - (* action: find threads whose timeout is reached, and interrupt cancelling threads *) - fun action (State {managing_thread, timeout_heap, oldest_heap, active, cancelling, - messages, store}) = - let val (timeout_threads, timeout_heap') = - ThreadHeap.upto (Time.now (), Thread.self ()) timeout_heap - in - if null timeout_threads andalso null cancelling andalso not (excessive_atps active) - then NONE - else - let - val _ = List.app (SimpleThread.interrupt o #1) cancelling - val cancelling' = filter (Thread.isActive o #1) cancelling - val state' = make_state - managing_thread timeout_heap' oldest_heap active cancelling' messages store - in SOME (map #2 timeout_threads, state') end - end - in - while Synchronized.change_result state - (fn st as - State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => - if (null active) andalso (null cancelling) andalso (null messages) - then (false, make_state NONE timeout_heap oldest_heap active cancelling messages store) - else (true, st)) - do - (Synchronized.timed_access state time_limit action - |> these - |> List.app (unregister (false, "Interrupted (reached timeout)")); - kill_excessive (); - print_new_messages (); - (*give threads time to respond to interrupt*) - OS.Process.sleep min_wait_time) - end)) - in make_state managing_thread timeout_heap oldest_heap active cancelling messages store end); - - -(* thread is registered here by sledgehammer *) - -fun register birthtime deadtime (thread, desc) = - (Synchronized.change state - (fn State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => - let - val timeout_heap' = ThreadHeap.insert (deadtime, thread) timeout_heap - val oldest_heap' = ThreadHeap.insert (birthtime, thread) oldest_heap - val active' = update_thread (thread, (birthtime, deadtime, desc)) active - in make_state managing_thread timeout_heap' oldest_heap' active' cancelling messages store end); - check_thread_manager ()); - - - -(** user commands **) - -(* kill: move all threads to cancelling *) - -fun kill () = Synchronized.change state - (fn State {managing_thread, timeout_heap, oldest_heap, active, cancelling, messages, store} => - let val formerly_active = map (fn (th, (tb, _, desc)) => (th, (tb, Time.now (), desc))) active - in make_state - managing_thread timeout_heap oldest_heap [] (formerly_active @ cancelling) messages store - end); - - -(* ATP info *) - -fun info () = - let - val State {active, cancelling, ...} = Synchronized.value state - - fun running_info (_, (birth_time, dead_time, desc)) = "Running: " - ^ (string_of_int o Time.toSeconds) (Time.- (Time.now (), birth_time)) - ^ " s -- " - ^ (string_of_int o Time.toSeconds) (Time.- (dead_time, Time.now ())) - ^ " s to live:\n" ^ desc - fun cancelling_info (_, (_, dead_time, desc)) = "Trying to interrupt thread since " - ^ (string_of_int o Time.toSeconds) (Time.- (Time.now (), dead_time)) - ^ " s:\n" ^ desc - - val running = - if null active then "No ATPs running." - else space_implode "\n\n" ("Running ATPs:" :: map running_info active) - val interrupting = - if null cancelling then "" - else space_implode "\n\n" - ("Trying to interrupt the following ATPs:" :: map cancelling_info cancelling) - - in writeln (running ^ "\n" ^ interrupting) end; - -fun messages opt_limit = - let - val limit = the_default message_display_limit opt_limit; - val State {store = msgs, ...} = Synchronized.value state - val header = "Recent ATP messages" ^ - (if length msgs <= limit then ":" else " (" ^ string_of_int limit ^ " displayed):"); - in writeln (space_implode "\n\n" (header :: #1 (chop limit msgs))) end; - - - -(** The Sledgehammer **) - -(* named provers *) - -type prover = int -> (thm * (string * int)) list option -> - (thm * (string * int)) list option -> string -> int -> - Proof.context * (thm list * thm) -> - bool * string * string * string vector * (thm * (string * int)) list - -fun err_dup_prover name = error ("Duplicate prover: " ^ quote name); - -structure Provers = TheoryDataFun -( - type T = (prover * stamp) Symtab.table - val empty = Symtab.empty - val copy = I - val extend = I - fun merge _ tabs : T = Symtab.merge (eq_snd op =) tabs - handle Symtab.DUP dup => err_dup_prover dup -); - -fun add_prover name prover thy = - Provers.map (Symtab.update_new (name, (prover, stamp ()))) thy - handle Symtab.DUP dup => err_dup_prover dup; - -fun print_provers thy = Pretty.writeln - (Pretty.strs ("external provers:" :: sort_strings (Symtab.keys (Provers.get thy)))); - -fun get_prover name thy = case Symtab.lookup (Provers.get thy) name of - NONE => NONE -| SOME (prover, _) => SOME prover; - -(* start prover thread *) - -fun start_prover name birthtime deadtime i proof_state = - (case get_prover name (Proof.theory_of proof_state) of - NONE => warning ("Unknown external prover: " ^ quote name) - | SOME prover => - let - val (ctxt, (_, goal)) = Proof.get_goal proof_state - val desc = - "external prover " ^ quote name ^ " for subgoal " ^ string_of_int i ^ ":\n" ^ - Syntax.string_of_term ctxt (Thm.term_of (Thm.cprem_of goal i)) - val _ = SimpleThread.fork true (fn () => - let - val _ = register birthtime deadtime (Thread.self (), desc) - val result = - let val (success, message, _, _, _) = - prover (get_timeout ()) NONE NONE name i (Proof.get_goal proof_state) - in (success, message) end - handle ResHolClause.TOO_TRIVIAL - => (true, "Empty clause: Try this command: " ^ Markup.markup Markup.sendback "apply metis") - | ERROR msg - => (false, "Error: " ^ msg) - val _ = unregister result (Thread.self ()) - in () end handle Interrupt => ()) - in () end); - - -(* sledghammer for first subgoal *) - -fun sledgehammer names proof_state = - let - val provers = - if null names then String.tokens (Symbol.is_ascii_blank o String.str) (get_atps ()) - else names - val birthtime = Time.now () - val deadtime = Time.+ (birthtime, Time.fromSeconds (get_timeout ())) - in List.app (fn name => start_prover name birthtime deadtime 1 proof_state) provers end; - - - -(** Isar command syntax **) - -local structure K = OuterKeyword and P = OuterParse in - -val _ = - OuterSyntax.improper_command "atp_kill" "kill all managed provers" K.diag - (Scan.succeed (Toplevel.no_timing o Toplevel.imperative kill)); - -val _ = - OuterSyntax.improper_command "atp_info" "print information about managed provers" K.diag - (Scan.succeed (Toplevel.no_timing o Toplevel.imperative info)); - -val _ = - OuterSyntax.improper_command "atp_messages" "print recent messages issued by managed provers" K.diag - (Scan.option (P.$$$ "(" |-- P.nat --| P.$$$ ")") >> - (fn limit => Toplevel.no_timing o Toplevel.imperative (fn () => messages limit))); - -val _ = - OuterSyntax.improper_command "print_atps" "print external provers" K.diag - (Scan.succeed (Toplevel.no_timing o Toplevel.unknown_theory o - Toplevel.keep (print_provers o Toplevel.theory_of))); - -val _ = - OuterSyntax.command "sledgehammer" "call all automatic theorem provers" K.diag - (Scan.repeat P.xname >> (fn names => Toplevel.no_timing o Toplevel.unknown_proof o - Toplevel.keep (sledgehammer names o Toplevel.proof_of))); - -end; - -end; - diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Tools/atp_minimal.ML --- a/src/HOL/Tools/atp_minimal.ML Mon Aug 10 08:37:37 2009 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,223 +0,0 @@ -(* Title: HOL/Tools/atp_minimal.ML - Author: Philipp Meyer, TU Muenchen - -Minimalization of theorem list for metis by using an external automated theorem prover -*) - -structure AtpMinimal: sig end = -struct - -(* output control *) - -fun debug str = Output.debug (fn () => str) -fun debug_fn f = if ! Output.debugging then f () else () -fun answer str = Output.writeln str -fun println str = Output.priority str - -fun order_unique name_list = OrdList.make (String.collate Char.compare) name_list -fun length_string namelist = Int.toString (length namelist) - -fun print_names name_thms_pairs = - let - val names = map fst name_thms_pairs - val ordered = order_unique names - in - app (fn name => (debug (" " ^ name))) ordered - end - - -(* minimalization algorithm *) - -local - fun isplit (l,r) [] = (l,r) - | isplit (l,r) (h::[]) = (h::l, r) - | isplit (l,r) (h1::h2::t) = isplit (h1::l, h2::r) t -in - fun split lst = isplit ([],[]) lst -end - -local - fun min p sup [] = raise Empty - | min p sup [s0] = [s0] - | min p sup s = - let - val (l0, r0) = split s - in - if p (sup @ l0) - then min p sup l0 - else - if p (sup @ r0) - then min p sup r0 - else - let - val l = min p (sup @ r0) l0 - val r = min p (sup @ l) r0 - in - l @ r - end - end -in - (* return a minimal subset v of s that satisfies p - @pre p(s) & ~p([]) & monotone(p) - @post v subset s & p(v) & - forall e in v. ~p(v \ e) - *) - fun minimal p s = min p [] s -end - - -(* failure check and producing answer *) - -datatype 'a prove_result = Success of 'a | Failure | Timeout | Error - -val string_of_result = - fn Success _ => "Success" - | Failure => "Failure" - | Timeout => "Timeout" - | Error => "Error" - -val failure_strings = - [("SPASS beiseite: Ran out of time.", Timeout), - ("Timeout", Timeout), - ("time limit exceeded", Timeout), - ("# Cannot determine problem status within resource limit", Timeout), - ("Error", Error)] - -fun produce_answer (success, message, result_string, thm_name_vec, filtered) = - if success then - (Success (Vector.foldr op:: [] thm_name_vec, filtered), result_string) - else - let - val failure = failure_strings |> get_first (fn (s, t) => - if String.isSubstring s result_string then SOME (t, result_string) else NONE) - in - if is_some failure then - the failure - else - (Failure, result_string) - end - - -(* wrapper for calling external prover *) - -fun sh_test_thms prover prover_name time_limit subgoalno state filtered name_thms_pairs = - let - val _ = println ("Testing " ^ (length_string name_thms_pairs) ^ " theorems... ") - val name_thm_pairs = - flat (map (fn (n, ths) => map_index (fn (i, th) => (n, th)) ths) name_thms_pairs) - val _ = debug_fn (fn () => print_names name_thm_pairs) - val axclauses = ResAxioms.cnf_rules_pairs (Proof.theory_of state) name_thm_pairs - val (result, proof) = - produce_answer - (prover time_limit (SOME axclauses) filtered prover_name subgoalno (Proof.get_goal state)) - val _ = println (string_of_result result) - val _ = debug proof - in - (result, proof) - end - - -(* minimalization of thms *) - -fun minimalize prover prover_name time_limit state name_thms_pairs = - let - val _ = - println ("Minimize called with " ^ length_string name_thms_pairs ^ " theorems, prover: " - ^ prover_name ^ ", time limit: " ^ Int.toString time_limit ^ " seconds") - val _ = debug_fn (fn () => app (fn (n, tl) => - (debug n; app (fn t => - debug (" " ^ Display.string_of_thm (Proof.context_of state) t)) tl)) name_thms_pairs) - val test_thms_fun = sh_test_thms prover prover_name time_limit 1 state - fun test_thms filtered thms = - case test_thms_fun filtered thms of (Success _, _) => true | _ => false - in - (* try prove first to check result and get used theorems *) - (case test_thms_fun NONE name_thms_pairs of - (Success (used, filtered), _) => - let - val ordered_used = order_unique used - val to_use = - if length ordered_used < length name_thms_pairs then - filter (fn (name1, _) => List.exists (equal name1) ordered_used) name_thms_pairs - else - name_thms_pairs - val min_thms = (minimal (test_thms (SOME filtered)) to_use) - val min_names = order_unique (map fst min_thms) - val _ = println ("Minimal " ^ (length_string min_thms) ^ " theorems") - val _ = debug_fn (fn () => print_names min_thms) - in - answer ("Try this command: " ^ - Markup.markup Markup.sendback ("apply (metis " ^ space_implode " " min_names ^ ")")) - end - | (Timeout, _) => - answer ("Timeout: You may need to increase the time limit of " ^ - Int.toString time_limit ^ " seconds. Call atp_minimize [time=...] ") - | (Error, msg) => - answer ("Error in prover: " ^ msg) - | (Failure, _) => - answer "Failure: No proof with the theorems supplied") - handle ResHolClause.TOO_TRIVIAL => - answer ("Trivial: Try this command: " ^ Markup.markup Markup.sendback "apply metis") - | ERROR msg => - answer ("Error: " ^ msg) - end - - -(* Isar command and parsing input *) - -local structure K = OuterKeyword and P = OuterParse and T = OuterLex in - -fun get_thms context = - map (fn (name, interval) => - let - val thmref = Facts.Named ((name, Position.none), interval) - val ths = ProofContext.get_fact context thmref - val name' = Facts.string_of_ref thmref - in - (name', ths) - end) - -val default_prover = "remote_vampire" -val default_time_limit = 5 - -fun get_time_limit_arg time_string = - (case Int.fromString time_string of - SOME t => t - | NONE => error ("Invalid time limit: " ^ quote time_string)) - -val get_options = - let - val def = (default_prover, default_time_limit) - in - foldl (fn ((name, a), (p, t)) => - (case name of - "time" => (p, (get_time_limit_arg a)) - | "atp" => (a, t) - | n => error ("Invalid argument: " ^ n))) def - end - -fun sh_min_command args thm_names state = - let - val (prover_name, time_limit) = get_options args - val prover = - case AtpManager.get_prover prover_name (Proof.theory_of state) of - SOME prover => prover - | NONE => error ("Unknown prover: " ^ quote prover_name) - val name_thms_pairs = get_thms (Proof.context_of state) thm_names - in - minimalize prover prover_name time_limit state name_thms_pairs - end - -val parse_args = Scan.optional (Args.bracks (P.list (P.xname --| P.$$$ "=" -- P.xname))) [] -val parse_thm_names = Scan.repeat (P.xname -- Scan.option Attrib.thm_sel) - -val _ = - OuterSyntax.command "atp_minimize" "minimize theorem list with external prover" K.diag - (parse_args -- parse_thm_names >> (fn (args, thm_names) => - Toplevel.no_timing o Toplevel.unknown_proof o - Toplevel.keep (sh_min_command args thm_names o Toplevel.proof_of))) - -end - -end - diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Tools/atp_wrapper.ML --- a/src/HOL/Tools/atp_wrapper.ML Mon Aug 10 08:37:37 2009 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,218 +0,0 @@ -(* Title: HOL/Tools/atp_wrapper.ML - Author: Fabian Immler, TU Muenchen - -Wrapper functions for external ATPs. -*) - -signature ATP_WRAPPER = -sig - val destdir: string ref - val problem_name: string ref - val tptp_prover_opts_full: int -> bool -> bool -> Path.T * string -> AtpManager.prover - val tptp_prover_opts: int -> bool -> Path.T * string -> AtpManager.prover - val tptp_prover: Path.T * string -> AtpManager.prover - val full_prover_opts: int -> bool -> Path.T * string -> AtpManager.prover - val full_prover: Path.T * string -> AtpManager.prover - val vampire_opts: int -> bool -> AtpManager.prover - val vampire: AtpManager.prover - val vampire_opts_full: int -> bool -> AtpManager.prover - val vampire_full: AtpManager.prover - val eprover_opts: int -> bool -> AtpManager.prover - val eprover: AtpManager.prover - val eprover_opts_full: int -> bool -> AtpManager.prover - val eprover_full: AtpManager.prover - val spass_opts: int -> bool -> AtpManager.prover - val spass: AtpManager.prover - val remote_prover_opts: int -> bool -> string -> string -> AtpManager.prover - val remote_prover: string -> string -> AtpManager.prover - val refresh_systems: unit -> unit -end; - -structure AtpWrapper: ATP_WRAPPER = -struct - -(** generic ATP wrapper **) - -(* global hooks for writing problemfiles *) - -val destdir = ref ""; (*Empty means write files to /tmp*) -val problem_name = ref "prob"; - - -(* basic template *) - -fun external_prover relevance_filter preparer writer (cmd, args) find_failure produce_answer - timeout axiom_clauses filtered_clauses name subgoalno goal = - let - (* path to unique problem file *) - val destdir' = ! destdir - val problem_name' = ! problem_name - fun prob_pathname nr = - let val probfile = Path.basic (problem_name' ^ serial_string () ^ "_" ^ string_of_int nr) - in if destdir' = "" then File.tmp_path probfile - else if File.exists (Path.explode (destdir')) - then Path.append (Path.explode (destdir')) probfile - else error ("No such directory: " ^ destdir') - end - - (* get clauses and prepare them for writing *) - val (ctxt, (chain_ths, th)) = goal - val thy = ProofContext.theory_of ctxt - val chain_ths = map (Thm.put_name_hint ResReconstruct.chained_hint) chain_ths - val goal_cls = #1 (ResAxioms.neg_conjecture_clauses ctxt th subgoalno) - val _ = app (fn th => Output.debug (fn _ => Display.string_of_thm ctxt th)) goal_cls - val the_filtered_clauses = - case filtered_clauses of - NONE => relevance_filter goal goal_cls - | SOME fcls => fcls - val the_axiom_clauses = - case axiom_clauses of - NONE => the_filtered_clauses - | SOME axcls => axcls - val (thm_names, clauses) = - preparer goal_cls chain_ths the_axiom_clauses the_filtered_clauses thy - - (* write out problem file and call prover *) - val probfile = prob_pathname subgoalno - val conj_pos = writer probfile clauses - val (proof, rc) = system_out ( - if File.exists cmd then - space_implode " " ["exec", File.shell_path cmd, args, File.platform_path probfile] - else error ("Bad executable: " ^ Path.implode cmd)) - - (* if problemfile has not been exported, delete problemfile; otherwise export proof, too *) - val _ = - if destdir' = "" then File.rm probfile - else File.write (Path.explode (Path.implode probfile ^ "_proof")) proof - - (* check for success and print out some information on failure *) - val failure = find_failure proof - val success = rc = 0 andalso is_none failure - val message = - if is_some failure then "External prover failed." - else if rc <> 0 then "External prover failed: " ^ proof - else "Try this command: " ^ - produce_answer name (proof, thm_names, conj_pos, ctxt, th, subgoalno) - val _ = Output.debug (fn () => "Sledgehammer response (rc = " ^ string_of_int rc ^ "):\n" ^ proof) - in (success, message, proof, thm_names, the_filtered_clauses) end; - - - -(** common provers **) - -(* generic TPTP-based provers *) - -fun tptp_prover_opts_full max_new theory_const full command timeout ax_clauses fcls name n goal = - external_prover - (ResAtp.get_relevant max_new theory_const) - (ResAtp.prepare_clauses false) - (ResHolClause.tptp_write_file (AtpManager.get_full_types())) - command - ResReconstruct.find_failure - (if full then ResReconstruct.structured_proof else ResReconstruct.lemma_list false) - timeout ax_clauses fcls name n goal; - -(*arbitrary ATP with TPTP input/output and problemfile as last argument*) -fun tptp_prover_opts max_new theory_const = - tptp_prover_opts_full max_new theory_const false; - -fun tptp_prover x = tptp_prover_opts 60 true x; - -(*for structured proofs: prover must support TSTP*) -fun full_prover_opts max_new theory_const = - tptp_prover_opts_full max_new theory_const true; - -fun full_prover x = full_prover_opts 60 true x; - - -(* Vampire *) - -(*NB: Vampire does not work without explicit timelimit*) - -fun vampire_opts max_new theory_const timeout = tptp_prover_opts - max_new theory_const - (Path.explode "$VAMPIRE_HOME/vampire", - ("--output_syntax tptp --mode casc -t " ^ string_of_int timeout)) - timeout; - -val vampire = vampire_opts 60 false; - -fun vampire_opts_full max_new theory_const timeout = full_prover_opts - max_new theory_const - (Path.explode "$VAMPIRE_HOME/vampire", - ("--output_syntax tptp --mode casc -t " ^ string_of_int timeout)) - timeout; - -val vampire_full = vampire_opts_full 60 false; - - -(* E prover *) - -fun eprover_opts max_new theory_const timeout = tptp_prover_opts - max_new theory_const - (Path.explode "$E_HOME/eproof", - "--tstp-in --tstp-out -l5 -xAutoDev -tAutoDev --silent --cpu-limit=" ^ string_of_int timeout) - timeout; - -val eprover = eprover_opts 100 false; - -fun eprover_opts_full max_new theory_const timeout = full_prover_opts - max_new theory_const - (Path.explode "$E_HOME/eproof", - "--tstp-in --tstp-out -l5 -xAutoDev -tAutoDev --silent --cpu-limit=" ^ string_of_int timeout) - timeout; - -val eprover_full = eprover_opts_full 100 false; - - -(* SPASS *) - -fun spass_opts max_new theory_const timeout ax_clauses fcls name n goal = external_prover - (ResAtp.get_relevant max_new theory_const) - (ResAtp.prepare_clauses true) - (ResHolClause.dfg_write_file (AtpManager.get_full_types())) - (Path.explode "$SPASS_HOME/SPASS", - "-Auto -SOS=1 -PGiven=0 -PProblem=0 -Splits=0 -FullRed=0 -DocProof -TimeLimit=" ^ - string_of_int timeout) - ResReconstruct.find_failure - (ResReconstruct.lemma_list true) - timeout ax_clauses fcls name n goal; - -val spass = spass_opts 40 true; - - -(* remote prover invocation via SystemOnTPTP *) - -val systems = - Synchronized.var "atp_wrapper_systems" ([]: string list); - -fun get_systems () = - let - val (answer, rc) = system_out (("$ISABELLE_HOME/lib/scripts/SystemOnTPTP" |> - Path.explode |> File.shell_path) ^ " -w") - in - if rc <> 0 then error ("Get available systems from SystemOnTPTP:\n" ^ answer) - else split_lines answer - end; - -fun refresh_systems () = Synchronized.change systems (fn _ => - get_systems ()); - -fun get_system prefix = Synchronized.change_result systems (fn systems => - let val systems = if null systems then get_systems() else systems - in (find_first (String.isPrefix prefix) systems, systems) end); - -fun remote_prover_opts max_new theory_const args prover_prefix timeout = - let val sys = - case get_system prover_prefix of - NONE => error ("No system like " ^ quote prover_prefix ^ " at SystemOnTPTP") - | SOME sys => sys - in tptp_prover_opts max_new theory_const - (Path.explode "$ISABELLE_HOME/lib/scripts/SystemOnTPTP", - args ^ " -t " ^ string_of_int timeout ^ " -s " ^ sys) timeout - end; - -val remote_prover = remote_prover_opts 60 false; - -end; - diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Tools/inductive_set.ML --- a/src/HOL/Tools/inductive_set.ML Mon Aug 10 08:37:37 2009 +0200 +++ b/src/HOL/Tools/inductive_set.ML Mon Aug 10 10:25:00 2009 +0200 @@ -9,6 +9,7 @@ sig val to_set_att: thm list -> attribute val to_pred_att: thm list -> attribute + val to_pred : thm list -> Context.generic -> thm -> thm val pred_set_conv_att: attribute val add_inductive_i: Inductive.inductive_flags -> diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/Tools/record.ML --- a/src/HOL/Tools/record.ML Mon Aug 10 08:37:37 2009 +0200 +++ b/src/HOL/Tools/record.ML Mon Aug 10 10:25:00 2009 +0200 @@ -4,7 +4,6 @@ Extensible records with structural subtyping in HOL. *) - signature BASIC_RECORD = sig val record_simproc: simproc @@ -88,6 +87,8 @@ val RepN = "Rep_"; val AbsN = "Abs_"; + + (*** utilities ***) fun but_last xs = fst (split_last xs); @@ -102,6 +103,7 @@ fun range_type' T = range_type T handle Match => T; + (* messages *) fun trace_thm str thm = @@ -113,12 +115,14 @@ fun trace_term str t = tracing (str ^ Syntax.string_of_term_global Pure.thy t); + (* timing *) val timing = ref false; fun timeit_msg s x = if !timing then (warning s; timeit x) else x (); fun timing_msg s = if !timing then warning s else (); + (* syntax *) fun prune n xs = Library.drop (n, xs); @@ -136,6 +140,7 @@ val (op ===) = Trueprop o HOLogic.mk_eq; val (op ==>) = Logic.mk_implies; + (* morphisms *) fun mk_RepN name = suffix ext_typeN (prefix_base RepN name); @@ -147,6 +152,7 @@ fun mk_Abs name repT absT = Const (mk_AbsN name,repT --> absT); + (* constructor *) fun mk_extC (name,T) Ts = (suffix extN name, Ts ---> T); @@ -155,6 +161,7 @@ let val Ts = map fastype_of ts in list_comb (Const (mk_extC (name,T) Ts),ts) end; + (* cases *) fun mk_casesC (name,T,vT) Ts = (suffix casesN name, (Ts ---> vT) --> T --> vT) @@ -163,6 +170,7 @@ let val Ts = binder_types (fastype_of f) in Const (mk_casesC (name,T,vT) Ts) $ f end; + (* selector *) fun mk_selC sT (c,T) = (c,sT --> T); @@ -171,6 +179,7 @@ let val sT = fastype_of s in Const (mk_selC sT (c,T)) $ s end; + (* updates *) fun mk_updC sfx sT (c,T) = (suffix sfx c, (T --> T) --> sT --> sT); @@ -181,6 +190,7 @@ fun mk_upd sfx c v s = mk_upd' sfx c v (fastype_of s) $ s + (* types *) fun dest_recT (typ as Type (c_ext_type, Ts as (T::_))) = @@ -209,6 +219,8 @@ val rTs' = if i < 0 then rTs else Library.take (i,rTs) in Library.foldl (fn (s,(c,T)) => s ^ c) ("",rTs') end; + + (*** extend theory by record definition ***) (** record info **) @@ -766,20 +778,20 @@ fun match rT T = (Sign.typ_match thy (varifyT rT,T) Vartab.empty); - in if !print_record_type_abbr - then (case last_extT T of - SOME (name,_) - => if name = lastExt - then - (let - val subst = match schemeT T - in - if HOLogic.is_unitT (Envir.norm_type subst (varifyT (TFree(zeta,Sign.defaultS thy)))) - then mk_type_abbr subst abbr alphas - else mk_type_abbr subst (suffix schemeN abbr) (alphas@[zeta]) - end handle TYPE_MATCH => default_tr' ctxt tm) - else raise Match (* give print translation of specialised record a chance *) - | _ => raise Match) + in + if !print_record_type_abbr then + (case last_extT T of + SOME (name, _) => + if name = lastExt then + (let + val subst = match schemeT T + in + if HOLogic.is_unitT (Envir.norm_type subst (varifyT (TFree (zeta, Sign.defaultS thy)))) + then mk_type_abbr subst abbr alphas + else mk_type_abbr subst (suffix schemeN abbr) (alphas @ [zeta]) + end handle TYPE_MATCH => default_tr' ctxt tm) + else raise Match (* give print translation of specialised record a chance *) + | _ => raise Match) else default_tr' ctxt tm end @@ -848,6 +860,8 @@ (list_comb (Syntax.const name_sfx,ts)) in (name_sfx, tr') end; + + (** record simprocs **) val record_quick_and_dirty_sensitive = ref false; @@ -1279,8 +1293,6 @@ end) - - local val inductive_atomize = thms "induct_atomize"; val inductive_rulify = thms "induct_rulify"; @@ -1363,6 +1375,7 @@ else Seq.empty end handle Subscript => Seq.empty; + (* wrapper *) val record_split_name = "record_split_tac"; @@ -1400,6 +1413,7 @@ fun induct_type_global name = [case_names_fields, Induct.induct_type name]; fun cases_type_global name = [case_names_fields, Induct.cases_type name]; + (* tactics *) fun simp_all_tac ss simps = ALLGOALS (Simplifier.asm_full_simp_tac (ss addsimps simps)); @@ -1469,7 +1483,9 @@ end; fun mixit convs refls = - let fun f ((res,lhs,rhs),refl) = ((refl,List.revAppend (lhs,refl::tl rhs))::res,hd rhs::lhs,tl rhs); + let + fun f ((res,lhs,rhs),refl) = + ((refl,List.revAppend (lhs,refl::tl rhs))::res,hd rhs::lhs,tl rhs); in #1 (Library.foldl f (([],[],convs),refls)) end; @@ -2166,8 +2182,10 @@ end); val equality = timeit_msg "record equality proof:" equality_prf; - val ((([sel_convs',upd_convs',sel_defs',upd_defs',[split_meta',split_object',split_ex'],derived_defs'], - [surjective',equality']),[induct_scheme',induct',cases_scheme',cases']), thms_thy) = + val ((([sel_convs', upd_convs', sel_defs', upd_defs', + [split_meta', split_object', split_ex'], derived_defs'], + [surjective', equality']), + [induct_scheme', induct', cases_scheme', cases']), thms_thy) = defs_thy |> (PureThy.add_thmss o map (Thm.no_attributes o apfst Binding.name)) [("select_convs", sel_convs_standard), @@ -2296,6 +2314,7 @@ val add_record = gen_add_record read_typ read_raw_parent; val add_record_i = gen_add_record cert_typ (K I); + (* setup theory *) val setup = @@ -2304,6 +2323,7 @@ Simplifier.map_simpset (fn ss => ss addsimprocs [record_simproc, record_upd_simproc, record_eq_simproc]); + (* outer syntax *) local structure P = OuterParse and K = OuterKeyword in @@ -2320,6 +2340,5 @@ end; - -structure BasicRecord: BASIC_RECORD = Record; -open BasicRecord; +structure Basic_Record: BASIC_RECORD = Record; +open Basic_Record; diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/ex/Mirabelle.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/ex/Mirabelle.thy Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,14 @@ +(* Title: Mirabelle.thy + Author: Jasmin Blanchette and Sascha Boehme +*) + +theory Mirabelle +imports Main +uses "mirabelle.ML" +begin + +(* FIXME: use a logfile for each theory file *) + +setup Mirabelle.setup + +end diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/ex/Predicate_Compile.thy --- a/src/HOL/ex/Predicate_Compile.thy Mon Aug 10 08:37:37 2009 +0200 +++ b/src/HOL/ex/Predicate_Compile.thy Mon Aug 10 10:25:00 2009 +0200 @@ -1,5 +1,5 @@ theory Predicate_Compile -imports Complex_Main +imports Complex_Main RPred uses "predicate_compile.ML" begin diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/ex/Predicate_Compile_ex.thy --- a/src/HOL/ex/Predicate_Compile_ex.thy Mon Aug 10 08:37:37 2009 +0200 +++ b/src/HOL/ex/Predicate_Compile_ex.thy Mon Aug 10 10:25:00 2009 +0200 @@ -1,5 +1,5 @@ theory Predicate_Compile_ex -imports Complex_Main Predicate_Compile +imports Main Predicate_Compile begin inductive even :: "nat \ bool" and odd :: "nat \ bool" where @@ -46,27 +46,28 @@ | "f x \ partition f xs ys zs \ partition f (x # xs) (x # ys) zs" | "\ f x \ partition f xs ys zs \ partition f (x # xs) ys (x # zs)" -(* FIXME: correct handling of parameters *) -(* -ML {* reset Predicate_Compile.do_proofs *} code_pred partition . thm partition.equation -ML {* set Predicate_Compile.do_proofs *} -*) + +inductive is_even :: "nat \ bool" +where + "n mod 2 = 0 \ is_even n" + +code_pred is_even . (* TODO: requires to handle abstractions in parameter positions correctly *) -(*FIXME values 10 "{(ys, zs). partition (\n. n mod 2 = 0) - [0, Suc 0, 2, 3, 4, 5, 6, 7] ys zs}" *) +values 10 "{(ys, zs). partition is_even + [0, Suc 0, 2, 3, 4, 5, 6, 7] ys zs}" +values 10 "{zs. partition is_even zs [0, 2] [3, 5]}" +values 10 "{zs. partition is_even zs [0, 7] [3, 5]}" lemma [code_pred_intros]: "r a b \ tranclp r a b" "r a b \ tranclp r b c \ tranclp r a c" by auto -(* Setup requires quick and dirty proof *) -(* code_pred tranclp proof - case tranclp @@ -74,6 +75,11 @@ qed thm tranclp.equation +(* +setup {* Predicate_Compile.add_sizelim_equations [@{const_name tranclp}] *} +setup {* fn thy => exception_trace (fn () => Predicate_Compile.add_quickcheck_equations [@{const_name tranclp}] thy) *} + +thm tranclp.rpred_equation *) inductive succ :: "nat \ nat \ bool" where @@ -83,12 +89,16 @@ code_pred succ . thm succ.equation +<<<<<<< local values 10 "{(m, n). succ n m}" values "{m. succ 0 m}" values "{m. succ m 0}" (* FIXME: why does this not terminate? *) +======= +(* FIXME: why does this not terminate? -- value chooses mode [] --> [1] and then starts enumerating all successors *) +>>>>>>> other (* values 20 "{n. tranclp succ 10 n}" values "{n. tranclp succ n 10}" diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/ex/RPred.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/ex/RPred.thy Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,48 @@ +theory RPred +imports Quickcheck Random Predicate +begin + +types 'a rpred = "Random.seed \ ('a Predicate.pred \ Random.seed)" + +section {* The RandomPred Monad *} + +text {* A monad to combine the random state monad and the predicate monad *} + +definition bot :: "'a rpred" + where "bot = Pair (bot_class.bot)" + +definition return :: "'a => 'a rpred" + where "return x = Pair (Predicate.single x)" + +definition bind :: "'a rpred \ ('a \ 'b rpred) \ 'b rpred" (infixl "\=" 60) + where "bind RP f = + (\s. let (P, s') = RP s; + (s1, s2) = Random.split_seed s' + in (Predicate.bind P (%a. fst (f a s1)), s2))" + +definition supp :: "'a rpred \ 'a rpred \ 'a rpred" (infixl "\" 80) +where + "supp RP1 RP2 = (\s. let (P1, s') = RP1 s; (P2, s'') = RP2 s' + in (upper_semilattice_class.sup P1 P2, s''))" + +definition if_rpred :: "bool \ unit rpred" +where + "if_rpred b = (if b then return () else bot)" + +(* Missing a good definition for negation: not_rpred *) + +definition not_rpred :: "unit Predicate.pred \ unit rpred" +where + "not_rpred = Pair o Predicate.not_pred" + +definition lift_pred :: "'a Predicate.pred \ 'a rpred" + where + "lift_pred = Pair" + +definition lift_random :: "(Random.seed \ ('a \ (unit \ term)) \ Random.seed) \ 'a rpred" + where "lift_random g = scomp g (Pair o (Predicate.single o fst))" + +definition map_rpred :: "('a \ 'b) \ ('a rpred \ 'b rpred)" +where "map_rpred f P = P \= (return o f)" + +end \ No newline at end of file diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/ex/mirabelle.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/HOL/ex/mirabelle.ML Mon Aug 10 10:25:00 2009 +0200 @@ -0,0 +1,318 @@ +(* Title: mirabelle.ML + Author: Jasmin Blanchette and Sascha Boehme +*) + +signature MIRABELLE = +sig + type action + type settings + val register : string -> action -> theory -> theory + val invoke : string -> settings -> theory -> theory + + val timeout : int Config.T + val verbose : bool Config.T + val set_logfile : string -> theory -> theory + + val setup : theory -> theory + + val step_hook : Toplevel.transition -> Toplevel.state -> Toplevel.state -> + unit + + val goal_thm_of : Proof.state -> thm + val can_apply : (Proof.context -> int -> tactic) -> Proof.state -> bool + val theorems_in_proof_term : Thm.thm -> Thm.thm list + val theorems_of_sucessful_proof : Toplevel.state -> Thm.thm list + val get_setting : settings -> string * string -> string + val get_int_setting : settings -> string * int -> int + +(* FIXME val refute_action : action *) + val quickcheck_action : action + val arith_action : action + val sledgehammer_action : action + val metis_action : action +end + + + +structure Mirabelle (*: MIRABELLE*) = +struct + +(* Mirabelle core *) + +type settings = (string * string) list +type invoked = {pre: Proof.state, post: Toplevel.state option} -> string option +type action = settings -> invoked + +structure Registered = TheoryDataFun +( + type T = action Symtab.table + val empty = Symtab.empty + val copy = I + val extend = I + fun merge _ = Symtab.merge (K true) +) + +fun register name act = Registered.map (Symtab.update_new (name, act)) + + +structure Invoked = TheoryDataFun +( + type T = (string * invoked) list + val empty = [] + val copy = I + val extend = I + fun merge _ = Library.merge (K true) +) + +fun invoke name sts thy = + let + val act = + (case Symtab.lookup (Registered.get thy) name of + SOME act => act + | NONE => error ("The invoked action " ^ quote name ^ + " is not registered.")) + in Invoked.map (cons (name, act sts)) thy end + +val (logfile, setup1) = Attrib.config_string "mirabelle_logfile" "" +val (timeout, setup2) = Attrib.config_int "mirabelle_timeout" 30 +val (verbose, setup3) = Attrib.config_bool "mirabelle_verbose" true +val (start_line, setup4) = Attrib.config_int "mirabelle_start_line" 0 +val (end_line, setup5) = Attrib.config_int "mirabelle_end_line" ~1 + +val setup_config = setup1 #> setup2 #> setup3 #> setup4 #> setup5 + +fun set_logfile name = + let val _ = File.write (Path.explode name) "" (* erase file content *) + in Config.put_thy logfile name end + +local + +fun log thy s = + let fun append_to n = if n = "" then K () else File.append (Path.explode n) + in append_to (Config.get_thy thy logfile) (s ^ "\n") end + (* FIXME: with multithreading and parallel proofs enabled, we might need to + encapsulate this inside a critical section *) + +fun verbose_msg verbose msg = if verbose then SOME msg else NONE + +fun with_time_limit (verb, secs) f x = TimeLimit.timeLimit secs f x + handle TimeLimit.TimeOut => verbose_msg verb "time out" + | ERROR msg => verbose_msg verb ("error: " ^ msg) + +fun capture_exns verb f x = + (case try f x of NONE => verbose_msg verb "exception" | SOME msg => msg) + +fun apply_action (c as (verb, _)) st (name, invoked) = + Option.map (pair name) (capture_exns verb (with_time_limit c invoked) st) + +fun in_range _ _ NONE = true + | in_range l r (SOME i) = (l <= i andalso (r < 0 orelse i <= r)) + +fun only_within_range thy pos f x = + let val l = Config.get_thy thy start_line and r = Config.get_thy thy end_line + in if in_range l r (Position.line_of pos) then f x else [] end + +fun pretty_print verbose pos name msgs = + let + val file = the_default "unknown file" (Position.file_of pos) + + val str0 = string_of_int o the_default 0 + val loc = str0 (Position.line_of pos) ^ ":" ^ str0 (Position.column_of pos) + + val full_loc = if verbose then file ^ ":" ^ loc else "at " ^ loc + val head = full_loc ^ " (" ^ name ^ "):" + + fun pretty_msg (name, msg) = Pretty.block (map Pretty.str [name, ": ", msg]) + in + Pretty.string_of (Pretty.big_list head (map pretty_msg msgs)) + end + +in + +fun basic_hook tr pre post = + let + val thy = Proof.theory_of pre + val pos = Toplevel.pos_of tr + val name = Toplevel.name_of tr + val verb = Config.get_thy thy verbose + val secs = Time.fromSeconds (Config.get_thy thy timeout) + val st = {pre=pre, post=post} + in + Invoked.get thy + |> only_within_range thy pos (map_filter (apply_action (verb, secs) st)) + |> (fn [] => () | msgs => log thy (pretty_print verb pos name msgs)) + end + +end + +fun step_hook tr pre post = + (* FIXME: might require wrapping into "interruptible" *) + if can (Proof.assert_backward o Toplevel.proof_of) pre andalso + not (member (op =) ["disable_pr", "enable_pr"] (Toplevel.name_of tr)) + then basic_hook tr (Toplevel.proof_of pre) (SOME post) + else () (* FIXME: add theory_hook here *) + + + +(* Mirabelle utility functions *) + +val goal_thm_of = snd o snd o Proof.get_goal + +fun can_apply tac st = + let val (ctxt, (facts, goal)) = Proof.get_goal st + in + (case Seq.pull (HEADGOAL (Method.insert_tac facts THEN' tac ctxt) goal) of + SOME (thm, _) => true + | NONE => false) + end + +local + +fun fold_body_thms f = + let + fun app n (PBody {thms, ...}) = thms |> fold (fn (i, (name, prop, body)) => + fn (x, seen) => + if Inttab.defined seen i then (x, seen) + else + let + val body' = Future.join body + val (x', seen') = app (n + (if name = "" then 0 else 1)) body' + (x, Inttab.update (i, ()) seen) + in (x' |> n = 0 ? f (name, prop, body'), seen') end) + in fn bodies => fn x => #1 (fold (app 0) bodies (x, Inttab.empty)) end + +in + +fun theorems_in_proof_term thm = + let + val all_thms = PureThy.all_thms_of (Thm.theory_of_thm thm) + fun collect (s, _, _) = if s <> "" then insert (op =) s else I + fun member_of xs (x, y) = if member (op =) xs x then SOME y else NONE + fun resolve_thms names = map_filter (member_of names) all_thms + in + resolve_thms (fold_body_thms collect [Thm.proof_body_of thm] []) + end + +end + +fun theorems_of_sucessful_proof state = + (case state of + NONE => [] + | SOME st => + if not (Toplevel.is_proof st) then [] + else theorems_in_proof_term (goal_thm_of (Toplevel.proof_of st))) + +fun get_setting settings (key, default) = + the_default default (AList.lookup (op =) settings key) + +fun get_int_setting settings (key, default) = + (case Option.map Int.fromString (AList.lookup (op =) settings key) of + SOME (SOME i) => i + | SOME NONE => error ("bad option: " ^ key) + | NONE => default) + + + +(* Mirabelle actions *) + +(* FIXME +fun refute_action settings {pre=st, ...} = + let + val params = [("minsize", "2") (*"maxsize", "2"*)] + val subgoal = 0 + val thy = Proof.theory_of st + val thm = goal_thm_of st + + val _ = Refute.refute_subgoal thy parms thm subgoal + in + val writ_log = Substring.full (the (Symtab.lookup tab "writeln")) + val warn_log = Substring.full (the (Symtab.lookup tab "warning")) + + val r = + if Substring.isSubstring "model found" writ_log + then + if Substring.isSubstring "spurious" warn_log + then SOME "potential counterexample" + else SOME "real counterexample (bug?)" + else + if Substring.isSubstring "time limit" writ_log + then SOME "no counterexample (time out)" + else if Substring.isSubstring "Search terminated" writ_log + then SOME "no counterexample (normal termination)" + else SOME "no counterexample (unknown)" + in r end +*) + +fun quickcheck_action settings {pre=st, ...} = + let + val has_valid_key = member (op =) ["iterations", "size", "generator"] o fst + val args = filter has_valid_key settings + in + (case Quickcheck.quickcheck args 1 st of + NONE => SOME "no counterexample" + | SOME _ => SOME "counterexample found") + end + + +fun arith_action _ {pre=st, ...} = + if can_apply Arith_Data.arith_tac st + then SOME "succeeded" + else NONE + + +fun sledgehammer_action settings {pre=st, ...} = + let + val prover_name = hd (space_explode " " (AtpManager.get_atps ())) + val thy = Proof.theory_of st + + val prover = the (AtpManager.get_prover prover_name thy) + val timeout = AtpManager.get_timeout () + + val (success, message) = + let + val (success, message, _, _, _) = + prover timeout NONE NONE prover_name 1 (Proof.get_goal st) + in (success, message) end + handle ResHolClause.TOO_TRIVIAL => (true, "trivial") + | ERROR msg => (false, "error: " ^ msg) + in + if success + then SOME ("success (" ^ prover_name ^ ": " ^ message ^ ")") + else NONE + end + + +fun metis_action settings {pre, post} = + let + val thms = theorems_of_sucessful_proof post + val names = map Thm.get_name thms + + val facts = Facts.props (ProofContext.facts_of (Proof.context_of pre)) + + fun metis ctxt = MetisTools.metis_tac ctxt (thms @ facts) + in + (if can_apply metis pre then "succeeded" else "failed") + |> suffix (" (" ^ commas names ^ ")") + |> SOME + end + + + +(* Mirabelle setup *) + +val setup = + setup_config #> +(* FIXME register "refute" refute_action #> *) + register "quickcheck" quickcheck_action #> + register "arith" arith_action #> + register "sledgehammer" sledgehammer_action #> + register "metis" metis_action (* #> FIXME: + Context.theory_map (Specification.add_theorem_hook theorem_hook) *) + +end + +val _ = Toplevel.add_hook Mirabelle.step_hook + +(* no multithreading, no parallel proofs *) +val _ = Multithreading.max_threads := 1 +val _ = Goal.parallel_proofs := 0 diff -r 5ef633275b15 -r 96f9e6402403 src/HOL/ex/predicate_compile.ML --- a/src/HOL/ex/predicate_compile.ML Mon Aug 10 08:37:37 2009 +0200 +++ b/src/HOL/ex/predicate_compile.ML Mon Aug 10 10:25:00 2009 +0200 @@ -7,16 +7,17 @@ signature PREDICATE_COMPILE = sig type mode = int list option list * int list - val add_equations_of: string list -> theory -> theory + (*val add_equations_of: bool -> string list -> theory -> theory *) val register_predicate : (thm list * thm * int) -> theory -> theory val is_registered : theory -> string -> bool - val fetch_pred_data : theory -> string -> (thm list * thm * int) + (* val fetch_pred_data : theory -> string -> (thm list * thm * int) *) val predfun_intro_of: theory -> string -> mode -> thm val predfun_elim_of: theory -> string -> mode -> thm val strip_intro_concl: int -> term -> term * (term list * term list) val predfun_name_of: theory -> string -> mode -> string val all_preds_of : theory -> string list val modes_of: theory -> string -> mode list + val string_of_mode : mode -> string val intros_of: theory -> string -> thm list val nparams_of: theory -> string -> int val add_intro: thm -> theory -> theory @@ -25,12 +26,77 @@ val code_pred: string -> Proof.context -> Proof.state val code_pred_cmd: string -> Proof.context -> Proof.state val print_stored_rules: theory -> unit + val print_all_modes: theory -> unit val do_proofs: bool ref val mk_casesrule : Proof.context -> int -> thm list -> term val analyze_compr: theory -> term -> term val eval_ref: (unit -> term Predicate.pred) option ref - val add_equations : string -> theory -> theory + val add_equations : string list -> theory -> theory val code_pred_intros_attrib : attribute + (* used by Quickcheck_Generator *) + (*val funT_of : mode -> typ -> typ + val mk_if_pred : term -> term + val mk_Eval : term * term -> term*) + val mk_tupleT : typ list -> typ +(* val mk_predT : typ -> typ *) + (* temporary for testing of the compilation *) + datatype indprem = Prem of term list * term | Negprem of term list * term | Sidecond of term | + GeneratorPrem of term list * term | Generator of (string * typ); + val prepare_intrs: theory -> string list -> + (string * typ) list * int * string list * string list * (string * mode list) list * + (string * (term list * indprem list) list) list * (string * (int option list * int)) list + datatype compilation_funs = CompilationFuns of { + mk_predT : typ -> typ, + dest_predT : typ -> typ, + mk_bot : typ -> term, + mk_single : term -> term, + mk_bind : term * term -> term, + mk_sup : term * term -> term, + mk_if : term -> term, + mk_not : term -> term, + mk_map : typ -> typ -> term -> term -> term, + lift_pred : term -> term + }; + datatype tmode = Mode of mode * int list * tmode option list; + type moded_clause = term list * (indprem * tmode) list + type 'a pred_mode_table = (string * (mode * 'a) list) list + val infer_modes : bool -> theory -> (string * (int list option list * int list) list) list + -> (string * (int option list * int)) list -> string list + -> (string * (term list * indprem list) list) list + -> (moded_clause list) pred_mode_table + val infer_modes_with_generator : theory -> (string * (int list option list * int list) list) list + -> (string * (int option list * int)) list -> string list + -> (string * (term list * indprem list) list) list + -> (moded_clause list) pred_mode_table + (*val compile_preds : theory -> compilation_funs -> string list -> string list + -> (string * typ) list -> (moded_clause list) pred_mode_table -> term pred_mode_table + val rpred_create_definitions :(string * typ) list -> string * mode list + -> theory -> theory + val split_smode : int list -> term list -> (term list * term list) *) + val print_moded_clauses : + theory -> (moded_clause list) pred_mode_table -> unit + val print_compiled_terms : theory -> term pred_mode_table -> unit + (*val rpred_prove_preds : theory -> term pred_mode_table -> thm pred_mode_table*) + val rpred_compfuns : compilation_funs + val dest_funT : typ -> typ * typ + (* val depending_preds_of : theory -> thm list -> string list *) + val add_quickcheck_equations : string list -> theory -> theory + val add_sizelim_equations : string list -> theory -> theory + val is_inductive_predicate : theory -> string -> bool + val terms_vs : term list -> string list + val subsets : int -> int -> int list list + val check_mode_clause : bool -> theory -> string list -> + (string * mode list) list -> (string * mode list) list -> mode -> (term list * indprem list) + -> (term list * (indprem * tmode) list) option + val string_of_moded_prem : theory -> (indprem * tmode) -> string + val all_modes_of : theory -> (string * mode list) list + val all_generator_modes_of : theory -> (string * mode list) list + val compile_clause : compilation_funs -> term option -> (term list -> term) -> + theory -> string list -> string list -> mode -> term -> moded_clause -> term + val preprocess_intro : theory -> thm -> thm + val is_constrt : theory -> term -> bool + val is_predT : typ -> bool + val guess_nparams : typ -> int end; structure Predicate_Compile : PREDICATE_COMPILE = @@ -42,9 +108,8 @@ fun tracing s = (if ! Toplevel.debug then Output.tracing s else ()); -fun print_tac s = (if ! Toplevel.debug then Tactical.print_tac s else Seq.single); -fun new_print_tac s = Tactical.print_tac s -fun debug_tac msg = (fn st => (Output.tracing msg; Seq.single st)); +fun print_tac s = Seq.single; (* (if ! Toplevel.debug then Tactical.print_tac s else Seq.single); *) +fun debug_tac msg = Seq.single; (* (fn st => (Output.tracing msg; Seq.single st)); *) val do_proofs = ref true; @@ -68,46 +133,44 @@ HOLogic.mk_eq (Free (a, fastype_of b), b) :: mk_eqs a cs in mk_eqs x xs end; -fun mk_pred_enumT T = Type (@{type_name Predicate.pred}, [T]) +fun mk_tupleT [] = HOLogic.unitT + | mk_tupleT Ts = foldr1 HOLogic.mk_prodT Ts; -fun dest_pred_enumT (Type (@{type_name Predicate.pred}, [T])) = T - | dest_pred_enumT T = raise TYPE ("dest_pred_enumT", [T], []); +fun dest_tupleT (Type (@{type_name Product_Type.unit}, [])) = [] + | dest_tupleT (Type (@{type_name "*"}, [T1, T2])) = T1 :: (dest_tupleT T2) + | dest_tupleT t = [t] + +fun mk_tuple [] = HOLogic.unit + | mk_tuple ts = foldr1 HOLogic.mk_prod ts; -fun mk_Enum f = - let val T as Type ("fun", [T', _]) = fastype_of f - in - Const (@{const_name Predicate.Pred}, T --> mk_pred_enumT T') $ f - end; +fun dest_tuple (Const (@{const_name Product_Type.Unity}, _)) = [] + | dest_tuple (Const (@{const_name Pair}, _) $ t1 $ t2) = t1 :: (dest_tuple t2) + | dest_tuple t = [t] -fun mk_Eval (f, x) = - let val T = fastype_of x - in - Const (@{const_name Predicate.eval}, mk_pred_enumT T --> T --> HOLogic.boolT) $ f $ x +fun mk_scomp (t, u) = + let + val T = fastype_of t + val U = fastype_of u + val [A] = binder_types T + val D = body_type U + in + Const (@{const_name "scomp"}, T --> U --> A --> D) $ t $ u end; -fun mk_empty T = Const (@{const_name Orderings.bot}, mk_pred_enumT T); - -fun mk_single t = - let val T = fastype_of t - in Const(@{const_name Predicate.single}, T --> mk_pred_enumT T) $ t end; - -fun mk_bind (x, f) = - let val T as Type ("fun", [_, U]) = fastype_of f +fun dest_funT (Type ("fun",[S, T])) = (S, T) + | dest_funT T = raise TYPE ("dest_funT", [T], []) + +fun mk_fun_comp (t, u) = + let + val (_, B) = dest_funT (fastype_of t) + val (C, A) = dest_funT (fastype_of u) in - Const (@{const_name Predicate.bind}, fastype_of x --> T --> U) $ x $ f + Const(@{const_name "Fun.comp"}, (A --> B) --> (C --> A) --> C --> B) $ t $ u end; -val mk_sup = HOLogic.mk_binop @{const_name sup}; - -fun mk_if_predenum cond = Const (@{const_name Predicate.if_pred}, - HOLogic.boolT --> mk_pred_enumT HOLogic.unitT) $ cond; - -fun mk_not_pred t = let val T = mk_pred_enumT HOLogic.unitT - in Const (@{const_name Predicate.not_pred}, T --> T) $ t end - -fun mk_pred_map T1 T2 tf tp = Const (@{const_name Predicate.map}, - (T1 --> T2) --> mk_pred_enumT T1 --> mk_pred_enumT T2) $ tf $ tp; - +fun dest_randomT (Type ("fun", [@{typ Random.seed}, + Type ("*", [Type ("*", [T, @{typ "unit => Code_Eval.term"}]) ,@{typ Random.seed}])])) = T + | dest_randomT T = raise TYPE ("dest_randomT", [T], []) (* destruction of intro rules *) @@ -118,20 +181,40 @@ val (params, args) = chop nparams all_args in (pred, (params, args)) end -(* data structures *) +(** data structures **) + +type smode = int list; +type mode = smode option list * smode; +datatype tmode = Mode of mode * int list * tmode option list; -type mode = int list option list * int list; (*pmode FIMXE*) +fun split_smode is ts = + let + fun split_smode' _ _ [] = ([], []) + | split_smode' is i (t::ts) = (if i mem is then apfst else apsnd) (cons t) + (split_smode' is (i+1) ts) + in split_smode' is 1 ts end + +fun split_mode (iss, is) ts = + let + val (t1, t2) = chop (length iss) ts + in (t1, split_smode is t2) end fun string_of_mode (iss, is) = space_implode " -> " (map (fn NONE => "X" | SOME js => enclose "[" "]" (commas (map string_of_int js))) (iss @ [SOME is])); -fun print_modes modes = Output.tracing ("Inferred modes:\n" ^ - cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map - string_of_mode ms)) modes)); +fun string_of_tmode (Mode (predmode, termmode, param_modes)) = + "predmode: " ^ (string_of_mode predmode) ^ + (if null param_modes then "" else + "; " ^ "params: " ^ commas (map (the_default "NONE" o Option.map string_of_tmode) param_modes)) + +datatype indprem = Prem of term list * term | Negprem of term list * term | Sidecond of term | + GeneratorPrem of term list * term | Generator of (string * typ); - +type moded_clause = term list * (indprem * tmode) list +type 'a pred_mode_table = (string * (mode * 'a) list) list + datatype predfun_data = PredfunData of { name : string, definition : thm, @@ -143,18 +226,30 @@ fun mk_predfun_data (name, definition, intro, elim) = PredfunData {name = name, definition = definition, intro = intro, elim = elim} +datatype function_data = FunctionData of { + name : string, + equation : thm option (* is not used at all? *) +}; + +fun rep_function_data (FunctionData data) = data; +fun mk_function_data (name, equation) = + FunctionData {name = name, equation = equation} + datatype pred_data = PredData of { intros : thm list, elim : thm option, nparams : int, - functions : (mode * predfun_data) list + functions : (mode * predfun_data) list, + generators : (mode * function_data) list, + sizelim_functions : (mode * function_data) list }; fun rep_pred_data (PredData data) = data; -fun mk_pred_data ((intros, elim, nparams), functions) = - PredData {intros = intros, elim = elim, nparams = nparams, functions = functions} -fun map_pred_data f (PredData {intros, elim, nparams, functions}) = - mk_pred_data (f ((intros, elim, nparams), functions)) +fun mk_pred_data ((intros, elim, nparams), (functions, generators, sizelim_functions)) = + PredData {intros = intros, elim = elim, nparams = nparams, + functions = functions, generators = generators, sizelim_functions = sizelim_functions} +fun map_pred_data f (PredData {intros, elim, nparams, functions, generators, sizelim_functions}) = + mk_pred_data (f ((intros, elim, nparams), (functions, generators, sizelim_functions))) fun eq_option eq (NONE, NONE) = true | eq_option eq (SOME x, SOME y) = eq (x, y) @@ -208,8 +303,8 @@ (#functions (the_pred_data thy name)) mode) fun the_predfun_data thy name mode = case lookup_predfun_data thy name mode - of NONE => error ("No such mode" ^ string_of_mode mode) - | SOME data => data; + of NONE => error ("No function defined for mode " ^ string_of_mode mode ^ " of predicate " ^ name) + | SOME data => data; val predfun_name_of = #name ooo the_predfun_data @@ -219,6 +314,76 @@ val predfun_elim_of = #elim ooo the_predfun_data +fun lookup_generator_data thy name mode = + Option.map rep_function_data (AList.lookup (op =) + (#generators (the_pred_data thy name)) mode) + +fun the_generator_data thy name mode = case lookup_generator_data thy name mode + of NONE => error ("No generator defined for mode " ^ string_of_mode mode ^ " of predicate " ^ name) + | SOME data => data + +val generator_name_of = #name ooo the_generator_data + +val generator_modes_of = (map fst) o #generators oo the_pred_data + +fun all_generator_modes_of thy = + map (fn name => (name, generator_modes_of thy name)) (all_preds_of thy) + +fun lookup_sizelim_function_data thy name mode = + Option.map rep_function_data (AList.lookup (op =) + (#sizelim_functions (the_pred_data thy name)) mode) + +fun the_sizelim_function_data thy name mode = case lookup_sizelim_function_data thy name mode + of NONE => error ("No size-limited function defined for mode " ^ string_of_mode mode + ^ " of predicate " ^ name) + | SOME data => data + +val sizelim_function_name_of = #name ooo the_sizelim_function_data + +(*val generator_modes_of = (map fst) o #generators oo the_pred_data*) + +(* diagnostic display functions *) + +fun print_modes modes = Output.tracing ("Inferred modes:\n" ^ + cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map + string_of_mode ms)) modes)); + +fun print_pred_mode_table string_of_entry thy pred_mode_table = + let + fun print_mode pred (mode, entry) = "mode : " ^ (string_of_mode mode) + ^ (string_of_entry pred mode entry) + fun print_pred (pred, modes) = + "predicate " ^ pred ^ ": " ^ cat_lines (map (print_mode pred) modes) + val _ = Output.tracing (cat_lines (map print_pred pred_mode_table)) + in () end; + +fun string_of_moded_prem thy (Prem (ts, p), tmode) = + (Syntax.string_of_term_global thy (list_comb (p, ts))) ^ + "(" ^ (string_of_tmode tmode) ^ ")" + | string_of_moded_prem thy (GeneratorPrem (ts, p), Mode (predmode, is, _)) = + (Syntax.string_of_term_global thy (list_comb (p, ts))) ^ + "(generator_mode: " ^ (string_of_mode predmode) ^ ")" + | string_of_moded_prem thy (Generator (v, T), _) = + "Generator for " ^ v ^ " of Type " ^ (Syntax.string_of_typ_global thy T) + | string_of_moded_prem thy (Negprem (ts, p), Mode (_, is, _)) = + (Syntax.string_of_term_global thy (list_comb (p, ts))) ^ + "(negative mode: " ^ (space_implode ", " (map string_of_int is)) ^ ")" + | string_of_moded_prem thy (Sidecond t, Mode (_, is, _)) = + (Syntax.string_of_term_global thy t) ^ + "(sidecond mode: " ^ (space_implode ", " (map string_of_int is)) ^ ")" + | string_of_moded_prem _ _ = error "string_of_moded_prem: unimplemented" + +fun print_moded_clauses thy = + let + fun string_of_clause pred mode clauses = + cat_lines (map (fn (ts, prems) => (space_implode " --> " + (map (string_of_moded_prem thy) prems)) ^ " --> " ^ pred ^ " " + ^ (space_implode " " (map (Syntax.string_of_term_global thy) ts))) clauses) + in print_pred_mode_table string_of_clause thy end; + +fun print_compiled_terms thy = + print_pred_mode_table (fn _ => fn _ => Syntax.string_of_term_global thy) thy + fun print_stored_rules thy = let val preds = (Graph.keys o PredData.get) thy @@ -238,6 +403,18 @@ fold print preds () end; +fun print_all_modes thy = + let + val _ = writeln ("Inferred modes:") + fun print (pred, modes) u = + let + val _ = writeln ("predicate: " ^ pred) + val _ = writeln ("modes: " ^ (commas (map string_of_mode modes))) + in u end + in + fold print (all_modes_of thy) () + end + (** preprocessing rules **) fun imp_prems_conv cv ct = @@ -256,24 +433,48 @@ (Trueprop_conv (Conv.try_conv (Conv.rewr_conv (Thm.symmetric @{thm Predicate.eq_is_eq}))))) (Thm.transfer thy rule) -fun preprocess_elim thy nargs elimrule = let - fun replace_eqs (Const ("Trueprop", _) $ (Const ("op =", T) $ lhs $ rhs)) = - HOLogic.mk_Trueprop (Const (@{const_name Predicate.eq}, T) $ lhs $ rhs) - | replace_eqs t = t - fun preprocess_case t = let - val params = Logic.strip_params t - val (assums1, assums2) = chop nargs (Logic.strip_assums_hyp t) - val assums_hyp' = assums1 @ (map replace_eqs assums2) - in list_all (params, Logic.list_implies (assums_hyp', Logic.strip_assums_concl t)) end - val prems = Thm.prems_of elimrule - val cases' = map preprocess_case (tl prems) - val elimrule' = Logic.list_implies ((hd prems) :: cases', Thm.concl_of elimrule) - in - Thm.equal_elim - (Thm.symmetric (Conv.implies_concl_conv (MetaSimplifier.rewrite true [@{thm eq_is_eq}]) - (cterm_of thy elimrule'))) - elimrule - end; +fun preprocess_elim thy nparams elimrule = + let + fun replace_eqs (Const ("Trueprop", _) $ (Const ("op =", T) $ lhs $ rhs)) = + HOLogic.mk_Trueprop (Const (@{const_name Predicate.eq}, T) $ lhs $ rhs) + | replace_eqs t = t + val prems = Thm.prems_of elimrule + val nargs = length (snd (strip_comb (HOLogic.dest_Trueprop (hd prems)))) - nparams + fun preprocess_case t = + let + val params = Logic.strip_params t + val (assums1, assums2) = chop nargs (Logic.strip_assums_hyp t) + val assums_hyp' = assums1 @ (map replace_eqs assums2) + in + list_all (params, Logic.list_implies (assums_hyp', Logic.strip_assums_concl t)) + end + val cases' = map preprocess_case (tl prems) + val elimrule' = Logic.list_implies ((hd prems) :: cases', Thm.concl_of elimrule) + in + Thm.equal_elim + (Thm.symmetric (Conv.implies_concl_conv (MetaSimplifier.rewrite true [@{thm eq_is_eq}]) + (cterm_of thy elimrule'))) + elimrule + end; + +(* special case: predicate with no introduction rule *) +fun noclause thy predname elim = let + val T = (Logic.unvarifyT o Sign.the_const_type thy) predname + val Ts = binder_types T + val names = Name.variant_list [] + (map (fn i => "x" ^ (string_of_int i)) (1 upto (length Ts))) + val vs = map2 (curry Free) names Ts + val clausehd = HOLogic.mk_Trueprop (list_comb (Const (predname, T), vs)) + val intro_t = Logic.mk_implies (@{prop False}, clausehd) + val P = HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT)) + val elim_t = Logic.list_implies ([clausehd, Logic.mk_implies (@{prop False}, P)], P) + val intro = Goal.prove (ProofContext.init thy) names [] intro_t + (fn {...} => etac @{thm FalseE} 1) + val elim = Goal.prove (ProofContext.init thy) ("P" :: names) [] elim_t + (fn {...} => etac elim 1) +in + ([intro], elim) +end fun fetch_pred_data thy name = case try (Inductive.the_inductive (ProofContext.init thy)) name of @@ -282,46 +483,79 @@ fun is_intro_of intro = let val (const, _) = strip_comb (HOLogic.dest_Trueprop (concl_of intro)) - in (fst (dest_Const const) = name) end; - val intros = map (preprocess_intro thy) (filter is_intro_of (#intrs result)) - val elim = nth (#elims result) (find_index (fn s => s = name) (#names (fst info))) + in (fst (dest_Const const) = name) end; + val intros = ind_set_codegen_preproc thy ((map (preprocess_intro thy)) + (filter is_intro_of (#intrs result))) + val pre_elim = nth (#elims result) (find_index (fn s => s = name) (#names (fst info))) val nparams = length (Inductive.params_of (#raw_induct result)) - in (intros, elim, nparams) end + val elim = singleton (ind_set_codegen_preproc thy) (preprocess_elim thy nparams pre_elim) + val (intros, elim) = if null intros then noclause thy name elim else (intros, elim) + in + mk_pred_data ((intros, SOME elim, nparams), ([], [], [])) + end | NONE => error ("No such predicate: " ^ quote name) (* updaters *) -fun add_predfun name mode data = let - val add = apsnd (cons (mode, mk_predfun_data data)) +fun apfst3 f (x, y, z) = (f x, y, z) +fun apsnd3 f (x, y, z) = (x, f y, z) +fun aptrd3 f (x, y, z) = (x, y, f z) + +fun add_predfun name mode data = + let + val add = (apsnd o apfst3 o cons) (mode, mk_predfun_data data) in PredData.map (Graph.map_node name (map_pred_data add)) end fun is_inductive_predicate thy name = is_some (try (Inductive.the_inductive (ProofContext.init thy)) name) -fun depending_preds_of thy intros = fold Term.add_consts (map Thm.prop_of intros) [] |> map fst - |> filter (fn c => is_inductive_predicate thy c orelse is_registered thy c) - +fun depending_preds_of thy (key, value) = + let + val intros = (#intros o rep_pred_data) value + in + fold Term.add_const_names (map Thm.prop_of intros) [] + |> filter (fn c => (not (c = key)) andalso (is_inductive_predicate thy c orelse is_registered thy c)) + end; + + (* code dependency graph *) +(* fun dependencies_of thy name = let val (intros, elim, nparams) = fetch_pred_data thy name - val data = mk_pred_data ((intros, SOME elim, nparams), []) + val data = mk_pred_data ((intros, SOME elim, nparams), ([], [], [])) val keys = depending_preds_of thy intros in (data, keys) end; +*) +(* guessing number of parameters *) +fun find_indexes pred xs = + let + fun find is n [] = is + | find is n (x :: xs) = find (if pred x then (n :: is) else is) (n + 1) xs; + in rev (find [] 0 xs) end; -(* TODO: add_edges - by analysing dependencies *) +fun is_predT (T as Type("fun", [_, _])) = (snd (strip_type T) = HOLogic.boolT) + | is_predT _ = false + +fun guess_nparams T = + let + val argTs = binder_types T + val nparams = fold (curry Int.max) + (map (fn x => x + 1) (find_indexes is_predT argTs)) 0 + in nparams end; + fun add_intro thm thy = let - val (name, _) = dest_Const (fst (strip_intro_concl 0 (prop_of thm))) + val (name, T) = dest_Const (fst (strip_intro_concl 0 (prop_of thm))) fun cons_intro gr = case try (Graph.get_node gr) name of SOME pred_data => Graph.map_node name (map_pred_data (apfst (fn (intro, elim, nparams) => (thm::intro, elim, nparams)))) gr | NONE => let - val nparams = the_default 0 (try (#3 o fetch_pred_data thy) name) - in Graph.new_node (name, mk_pred_data (([thm], NONE, nparams), [])) gr end; + val nparams = the_default (guess_nparams T) (try (#nparams o rep_pred_data o (fetch_pred_data thy)) name) + in Graph.new_node (name, mk_pred_data (([thm], NONE, nparams), ([], [], []))) gr end; in PredData.map cons_intro thy end fun set_elim thm = let @@ -333,16 +567,221 @@ fun set_nparams name nparams = let fun set (intros, elim, _ ) = (intros, elim, nparams) in PredData.map (Graph.map_node name (map_pred_data (apfst set))) end + +fun register_predicate (pre_intros, pre_elim, nparams) thy = let + val (name, _) = dest_Const (fst (strip_intro_concl nparams (prop_of (hd pre_intros)))) + (* preprocessing *) + val intros = ind_set_codegen_preproc thy (map (preprocess_intro thy) pre_intros) + val elim = singleton (ind_set_codegen_preproc thy) (preprocess_elim thy nparams pre_elim) + in + PredData.map + (Graph.new_node (name, mk_pred_data ((intros, SOME elim, nparams), ([], [], [])))) thy + end -fun register_predicate (intros, elim, nparams) thy = let - val (name, _) = dest_Const (fst (strip_intro_concl nparams (prop_of (hd intros)))) - fun set _ = (intros, SOME elim, nparams) +fun set_generator_name pred mode name = + let + val set = (apsnd o apsnd3 o cons) (mode, mk_function_data (name, NONE)) in - PredData.map (Graph.new_node (name, mk_pred_data ((intros, SOME elim, nparams), [])) - #> fold Graph.add_edge (map (pair name) (depending_preds_of thy intros))) thy + PredData.map (Graph.map_node pred (map_pred_data set)) + end + +fun set_sizelim_function_name pred mode name = + let + val set = (apsnd o aptrd3 o cons) (mode, mk_function_data (name, NONE)) + in + PredData.map (Graph.map_node pred (map_pred_data set)) end +(** data structures for generic compilation for different monads **) + +(* maybe rename functions more generic: + mk_predT -> mk_monadT; dest_predT -> dest_monadT + mk_single -> mk_return (?) +*) +datatype compilation_funs = CompilationFuns of { + mk_predT : typ -> typ, + dest_predT : typ -> typ, + mk_bot : typ -> term, + mk_single : term -> term, + mk_bind : term * term -> term, + mk_sup : term * term -> term, + mk_if : term -> term, + mk_not : term -> term, +(* funT_of : mode -> typ -> typ, *) +(* mk_fun_of : theory -> (string * typ) -> mode -> term, *) + mk_map : typ -> typ -> term -> term -> term, + lift_pred : term -> term +}; + +fun mk_predT (CompilationFuns funs) = #mk_predT funs +fun dest_predT (CompilationFuns funs) = #dest_predT funs +fun mk_bot (CompilationFuns funs) = #mk_bot funs +fun mk_single (CompilationFuns funs) = #mk_single funs +fun mk_bind (CompilationFuns funs) = #mk_bind funs +fun mk_sup (CompilationFuns funs) = #mk_sup funs +fun mk_if (CompilationFuns funs) = #mk_if funs +fun mk_not (CompilationFuns funs) = #mk_not funs +(*fun funT_of (CompilationFuns funs) = #funT_of funs*) +(*fun mk_fun_of (CompilationFuns funs) = #mk_fun_of funs*) +fun mk_map (CompilationFuns funs) = #mk_map funs +fun lift_pred (CompilationFuns funs) = #lift_pred funs + +fun funT_of compfuns (iss, is) T = + let + val Ts = binder_types T + val (paramTs, (inargTs, outargTs)) = split_mode (iss, is) Ts + val paramTs' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) iss paramTs + in + (paramTs' @ inargTs) ---> (mk_predT compfuns (mk_tupleT outargTs)) + end; + +fun sizelim_funT_of compfuns (iss, is) T = + let + val Ts = binder_types T + val (paramTs, (inargTs, outargTs)) = split_mode (iss, is) Ts + val paramTs' = map2 (fn SOME is => sizelim_funT_of compfuns ([], is) | NONE => I) iss paramTs + in + (paramTs' @ inargTs @ [@{typ "code_numeral"}]) ---> (mk_predT compfuns (mk_tupleT outargTs)) + end; + +fun mk_fun_of compfuns thy (name, T) mode = + Const (predfun_name_of thy name mode, funT_of compfuns mode T) + +fun mk_sizelim_fun_of compfuns thy (name, T) mode = + Const (sizelim_function_name_of thy name mode, sizelim_funT_of compfuns mode T) +fun mk_generator_of compfuns thy (name, T) mode = + Const (generator_name_of thy name mode, sizelim_funT_of compfuns mode T) + + +structure PredicateCompFuns = +struct + +fun mk_predT T = Type (@{type_name "Predicate.pred"}, [T]) + +fun dest_predT (Type (@{type_name "Predicate.pred"}, [T])) = T + | dest_predT T = raise TYPE ("dest_predT", [T], []); + +fun mk_bot T = Const (@{const_name Orderings.bot}, mk_predT T); + +fun mk_single t = + let val T = fastype_of t + in Const(@{const_name Predicate.single}, T --> mk_predT T) $ t end; + +fun mk_bind (x, f) = + let val T as Type ("fun", [_, U]) = fastype_of f + in + Const (@{const_name Predicate.bind}, fastype_of x --> T --> U) $ x $ f + end; + +val mk_sup = HOLogic.mk_binop @{const_name sup}; + +fun mk_if cond = Const (@{const_name Predicate.if_pred}, + HOLogic.boolT --> mk_predT HOLogic.unitT) $ cond; + +fun mk_not t = let val T = mk_predT HOLogic.unitT + in Const (@{const_name Predicate.not_pred}, T --> T) $ t end + +fun mk_Enum f = + let val T as Type ("fun", [T', _]) = fastype_of f + in + Const (@{const_name Predicate.Pred}, T --> mk_predT T') $ f + end; + +fun mk_Eval (f, x) = + let + val T = fastype_of x + in + Const (@{const_name Predicate.eval}, mk_predT T --> T --> HOLogic.boolT) $ f $ x + end; + +fun mk_map T1 T2 tf tp = Const (@{const_name Predicate.map}, + (T1 --> T2) --> mk_predT T1 --> mk_predT T2) $ tf $ tp; + +val lift_pred = I + +val compfuns = CompilationFuns {mk_predT = mk_predT, dest_predT = dest_predT, mk_bot = mk_bot, + mk_single = mk_single, mk_bind = mk_bind, mk_sup = mk_sup, mk_if = mk_if, mk_not = mk_not, + mk_map = mk_map, lift_pred = lift_pred}; + +end; + +(* termify_code: +val termT = Type ("Code_Eval.term", []); +fun termifyT T = HOLogic.mk_prodT (T, HOLogic.unitT --> termT) +*) +(* +fun lift_random random = + let + val T = dest_randomT (fastype_of random) + in + mk_scomp (random, + mk_fun_comp (HOLogic.pair_const (PredicateCompFuns.mk_predT T) @{typ Random.seed}, + mk_fun_comp (Const (@{const_name Predicate.single}, T --> (PredicateCompFuns.mk_predT T)), + Const (@{const_name "fst"}, HOLogic.mk_prodT (T, @{typ "unit => term"}) --> T)))) + end; +*) + +structure RPredCompFuns = +struct + +fun mk_rpredT T = + @{typ "Random.seed"} --> HOLogic.mk_prodT (PredicateCompFuns.mk_predT T, @{typ "Random.seed"}) + +fun dest_rpredT (Type ("fun", [_, + Type (@{type_name "*"}, [Type (@{type_name "Predicate.pred"}, [T]), _])])) = T + | dest_rpredT T = raise TYPE ("dest_rpredT", [T], []); + +fun mk_bot T = Const(@{const_name RPred.bot}, mk_rpredT T) + +fun mk_single t = + let + val T = fastype_of t + in + Const (@{const_name RPred.return}, T --> mk_rpredT T) $ t + end; + +fun mk_bind (x, f) = + let + val T as (Type ("fun", [_, U])) = fastype_of f + in + Const (@{const_name RPred.bind}, fastype_of x --> T --> U) $ x $ f + end + +val mk_sup = HOLogic.mk_binop @{const_name RPred.supp} + +fun mk_if cond = Const (@{const_name RPred.if_rpred}, + HOLogic.boolT --> mk_rpredT HOLogic.unitT) $ cond; + +fun mk_not t = error "Negation is not defined for RPred" + +fun mk_map t = error "FIXME" (*FIXME*) + +fun lift_pred t = + let + val T = PredicateCompFuns.dest_predT (fastype_of t) + val lift_predT = PredicateCompFuns.mk_predT T --> mk_rpredT T + in + Const (@{const_name "RPred.lift_pred"}, lift_predT) $ t + end; + +val compfuns = CompilationFuns {mk_predT = mk_rpredT, dest_predT = dest_rpredT, mk_bot = mk_bot, + mk_single = mk_single, mk_bind = mk_bind, mk_sup = mk_sup, mk_if = mk_if, mk_not = mk_not, + mk_map = mk_map, lift_pred = lift_pred}; + +end; +(* for external use with interactive mode *) +val rpred_compfuns = RPredCompFuns.compfuns; + +fun lift_random random = + let + val T = dest_randomT (fastype_of random) + in + Const (@{const_name lift_random}, (@{typ Random.seed} --> + HOLogic.mk_prodT (HOLogic.mk_prodT (T, @{typ "unit => term"}), @{typ Random.seed})) --> + RPredCompFuns.mk_rpredT T) $ random + end; + (* Mode analysis *) (*** check if a term contains only constructor functions ***) @@ -371,12 +810,6 @@ fun term_vTs tm = fold_aterms (fn Free xT => cons xT | _ => I) tm []; -fun get_args is ts = let - fun get_args' _ _ [] = ([], []) - | get_args' is i (t::ts) = (if member (op =) is i then apfst else apsnd) (cons t) - (get_args' is (i+1) ts) -in get_args' is 1 ts end - (*FIXME this function should not be named merge... make it local instead*) fun merge xs [] = xs | merge [] ys = ys @@ -394,11 +827,10 @@ fun cprods xss = foldr (map op :: o cprod) [[]] xss; -datatype hmode = Mode of mode * int list * hmode option list; (*FIXME don't understand - why there is another mode type tmode !?*) (*TODO: cleanup function and put together with modes_of_term *) +(* fun modes_of_param default modes t = let val (vs, t') = strip_abs t val b = length vs @@ -409,8 +841,8 @@ error ("Too few arguments for inductive predicate " ^ name) else chop (length iss) args; val k = length args2; - val perm = map (fn i => (find_index (fn t => t = Bound (b - i)) args2) + 1) - (1 upto b) + val perm = map (fn i => (find_index_eq (Bound (b - i)) args2) + 1) + (1 upto b) val partial_mode = (1 upto k) \\ perm in if not (partial_mode subset is) then [] else @@ -432,7 +864,9 @@ | (Free (name, _), args) => the (mk_modes name args) | _ => default end -and modes_of_term modes t = +and +*) +fun modes_of_term modes t = let val ks = 1 upto length (binder_types (fastype_of t)); val default = [Mode (([], ks), ks, [])]; @@ -455,21 +889,20 @@ end end)) (AList.lookup op = modes name) - in (case strip_comb t of + in + case strip_comb (Envir.eta_contract t) of (Const (name, _), args) => the_default default (mk_modes name args) | (Var ((name, _), _), args) => the (mk_modes name args) | (Free (name, _), args) => the (mk_modes name args) - | (Abs _, []) => modes_of_param default modes t - | _ => default) + | (Abs _, []) => error "Abs at param position" (* modes_of_param default modes t *) + | _ => default end - -datatype indprem = Prem of term list * term | Negprem of term list * term | Sidecond of term; - + fun select_mode_prem thy modes vs ps = find_first (is_some o snd) (ps ~~ map (fn Prem (us, t) => find_first (fn Mode (_, is, _) => let - val (in_ts, out_ts) = get_args is us; + val (in_ts, out_ts) = split_smode is us; val (out_ts', in_ts') = List.partition (is_constrt thy) out_ts; val vTs = maps term_vTs out_ts'; val dupTs = map snd (duplicates (op =) vTs) @ @@ -492,69 +925,139 @@ else NONE ) ps); -fun check_mode_clause thy param_vs modes (iss, is) (ts, ps) = +fun fold_prem f (Prem (args, _)) = fold f args + | fold_prem f (Negprem (args, _)) = fold f args + | fold_prem f (Sidecond t) = f t + +fun all_subsets [] = [[]] + | all_subsets (x::xs) = let val xss' = all_subsets xs in xss' @ (map (cons x) xss') end + +fun generator vTs v = + let + val T = the (AList.lookup (op =) vTs v) + in + (Generator (v, T), Mode (([], []), [], [])) + end; + +fun gen_prem (Prem (us, t)) = GeneratorPrem (us, t) + | gen_prem _ = error "gen_prem : invalid input for gen_prem" + +fun param_gen_prem param_vs (p as Prem (us, t as Free (v, _))) = + if member (op =) param_vs v then + GeneratorPrem (us, t) + else p + | param_gen_prem param_vs p = p + +fun check_mode_clause with_generator thy param_vs modes gen_modes (iss, is) (ts, ps) = let val modes' = modes @ List.mapPartial (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)])) - (param_vs ~~ iss); - fun check_mode_prems vs [] = SOME vs - | check_mode_prems vs ps = (case select_mode_prem thy modes' vs ps of - NONE => NONE - | SOME (x, _) => check_mode_prems - (case x of Prem (us, _) => vs union terms_vs us | _ => vs) - (filter_out (equal x) ps)) - val (in_ts, in_ts') = List.partition (is_constrt thy) (fst (get_args is ts)); + (param_vs ~~ iss); + val gen_modes' = gen_modes @ List.mapPartial + (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)])) + (param_vs ~~ iss); + val vTs = distinct (op =) ((fold o fold_prem) Term.add_frees ps (fold Term.add_frees ts [])) + val prem_vs = distinct (op =) ((fold o fold_prem) Term.add_free_names ps []) + fun check_mode_prems acc_ps vs [] = SOME (acc_ps, vs) + | check_mode_prems acc_ps vs ps = (case select_mode_prem thy modes' vs ps of + NONE => + (if with_generator then + (case select_mode_prem thy gen_modes' vs ps of + SOME (p, SOME mode) => check_mode_prems ((gen_prem p, mode) :: acc_ps) + (case p of Prem (us, _) => vs union terms_vs us | _ => vs) + (filter_out (equal p) ps) + | NONE => + let + val all_generator_vs = all_subsets (prem_vs \\ vs) |> sort (int_ord o (pairself length)) + in + case (find_first (fn generator_vs => is_some + (select_mode_prem thy modes' (vs union generator_vs) ps)) all_generator_vs) of + SOME generator_vs => check_mode_prems ((map (generator vTs) generator_vs) @ acc_ps) + (vs union generator_vs) ps + | NONE => NONE + end) + else + NONE) + | SOME (p, SOME mode) => check_mode_prems ((if with_generator then param_gen_prem param_vs p else p, mode) :: acc_ps) + (case p of Prem (us, _) => vs union terms_vs us | _ => vs) + (filter_out (equal p) ps)) + val (in_ts, in_ts') = List.partition (is_constrt thy) (fst (split_smode is ts)); val in_vs = terms_vs in_ts; val concl_vs = terms_vs ts in - forall is_eqT (map snd (duplicates (op =) (maps term_vTs in_ts))) andalso - forall (is_eqT o fastype_of) in_ts' andalso - (case check_mode_prems (param_vs union in_vs) ps of - NONE => false - | SOME vs => concl_vs subset vs) + if forall is_eqT (map snd (duplicates (op =) (maps term_vTs in_ts))) andalso + forall (is_eqT o fastype_of) in_ts' then + case check_mode_prems [] (param_vs union in_vs) ps of + NONE => NONE + | SOME (acc_ps, vs) => + if with_generator then + SOME (ts, (rev acc_ps) @ (map (generator vTs) (concl_vs \\ vs))) + else + if concl_vs subset vs then SOME (ts, rev acc_ps) else NONE + else NONE end; -fun check_modes_pred thy param_vs preds modes (p, ms) = +fun check_modes_pred with_generator thy param_vs preds modes gen_modes (p, ms) = let val SOME rs = AList.lookup (op =) preds p in (p, List.filter (fn m => case find_index - (not o check_mode_clause thy param_vs modes m) rs of + (is_none o check_mode_clause with_generator thy param_vs modes gen_modes m) rs of ~1 => true - | i => (tracing ("Clause " ^ string_of_int (i+1) ^ " of " ^ + | i => (Output.tracing ("Clause " ^ string_of_int (i + 1) ^ " of " ^ p ^ " violates mode " ^ string_of_mode m); false)) ms) end; +fun get_modes_pred with_generator thy param_vs preds modes gen_modes (p, ms) = + let + val SOME rs = AList.lookup (op =) preds p + in + (p, map (fn m => + (m, map (the o check_mode_clause with_generator thy param_vs modes gen_modes m) rs)) ms) + end; + fun fixp f (x : (string * mode list) list) = let val y = f x in if x = y then x else fixp f y end; -fun infer_modes thy extra_modes arities param_vs preds = fixp (fn modes => - map (check_modes_pred thy param_vs preds (modes @ extra_modes)) modes) - (map (fn (s, (ks, k)) => (s, cprod (cprods (map - (fn NONE => [NONE] - | SOME k' => map SOME (subsets 1 k')) ks), - subsets 1 k))) arities); +fun modes_of_arities arities = + (map (fn (s, (ks, k)) => (s, cprod (cprods (map + (fn NONE => [NONE] + | SOME k' => map SOME (subsets 1 k')) ks), + subsets 1 k))) arities) + +fun infer_modes with_generator thy extra_modes arities param_vs preds = + let + val modes = + fixp (fn modes => + map (check_modes_pred with_generator thy param_vs preds (modes @ extra_modes) []) modes) + (modes_of_arities arities) + in + map (get_modes_pred with_generator thy param_vs preds (modes @ extra_modes) []) modes + end; +fun remove_from rem [] = [] + | remove_from rem ((k, vs) :: xs) = + (case AList.lookup (op =) rem k of + NONE => (k, vs) + | SOME vs' => (k, vs \\ vs')) + :: remove_from rem xs + +fun infer_modes_with_generator thy extra_modes arities param_vs preds = + let + val prednames = map fst preds + val extra_modes = all_modes_of thy + val gen_modes = all_generator_modes_of thy + |> filter_out (fn (name, _) => member (op =) prednames name) + val starting_modes = remove_from extra_modes (modes_of_arities arities) + val modes = + fixp (fn modes => + map (check_modes_pred true thy param_vs preds extra_modes (gen_modes @ modes)) modes) + starting_modes + in + map (get_modes_pred true thy param_vs preds extra_modes (gen_modes @ modes)) modes + end; (* term construction *) -(* for simple modes (e.g. parameters) only: better call it param_funT *) -(* or even better: remove it and only use funT'_of - some modifications to funT'_of necessary *) -fun funT_of T NONE = T - | funT_of T (SOME mode) = let - val Ts = binder_types T; - val (Us1, Us2) = get_args mode Ts - in Us1 ---> (mk_pred_enumT (HOLogic.mk_tupleT Us2)) end; - -fun funT'_of (iss, is) T = let - val Ts = binder_types T - val (paramTs, argTs) = chop (length iss) Ts - val paramTs' = map2 (fn SOME is => funT'_of ([], is) | NONE => I) iss paramTs - val (inargTs, outargTs) = get_args is argTs - in - (paramTs' @ inargTs) ---> (mk_pred_enumT (HOLogic.mk_tupleT outargTs)) - end; - - fun mk_v (names, vs) s T = (case AList.lookup (op =) vs s of NONE => (Free (s, T), (names, (s, [])::vs)) | SOME xs => @@ -573,104 +1076,135 @@ in (t' $ u', nvs'') end | distinct_v x nvs = (x, nvs); -fun compile_match thy eqs eqs' out_ts success_t = - let +fun compile_match thy compfuns eqs eqs' out_ts success_t = + let val eqs'' = maps mk_eq eqs @ eqs' val names = fold Term.add_free_names (success_t :: eqs'' @ out_ts) []; val name = Name.variant names "x"; val name' = Name.variant (name :: names) "y"; - val T = HOLogic.mk_tupleT (map fastype_of out_ts); + val T = mk_tupleT (map fastype_of out_ts); val U = fastype_of success_t; - val U' = dest_pred_enumT U; + val U' = dest_predT compfuns U; val v = Free (name, T); val v' = Free (name', T); in lambda v (fst (Datatype.make_case (ProofContext.init thy) false [] v - [(HOLogic.mk_tuple out_ts, + [(mk_tuple out_ts, if null eqs'' then success_t else Const (@{const_name HOL.If}, HOLogic.boolT --> U --> U --> U) $ foldr1 HOLogic.mk_conj eqs'' $ success_t $ - mk_empty U'), - (v', mk_empty U')])) + mk_bot compfuns U'), + (v', mk_bot compfuns U')])) end; -fun compile_param_ext thy modes (NONE, t) = t - | compile_param_ext thy modes (m as SOME (Mode ((iss, is'), is, ms)), t) = +(*FIXME function can be removed*) +fun mk_funcomp f t = + let + val names = Term.add_free_names t []; + val Ts = binder_types (fastype_of t); + val vs = map Free + (Name.variant_list names (replicate (length Ts) "x") ~~ Ts) + in + fold_rev lambda vs (f (list_comb (t, vs))) + end; +(* +fun compile_param_ext thy compfuns modes (NONE, t) = t + | compile_param_ext thy compfuns modes (m as SOME (Mode ((iss, is'), is, ms)), t) = let val (vs, u) = strip_abs t - val (ivs, ovs) = get_args is vs + val (ivs, ovs) = split_mode is vs val (f, args) = strip_comb u val (params, args') = chop (length ms) args - val (inargs, outargs) = get_args is' args' + val (inargs, outargs) = split_mode is' args' val b = length vs - val perm = map (fn i => find_index (fn t => t = Bound (b - i)) args' + 1) (1 upto b) + val perm = map (fn i => (find_index_eq (Bound (b - i)) args') + 1) (1 upto b) val outp_perm = - snd (get_args is perm) + snd (split_mode is perm) |> map (fn i => i - length (filter (fn x => x < i) is')) - val names = [] (* TODO *) + val names = [] -- TODO val out_names = Name.variant_list names (replicate (length outargs) "x") val f' = case f of Const (name, T) => if AList.defined op = modes name then - Const (predfun_name_of thy name (iss, is'), funT'_of (iss, is') T) + mk_predfun_of thy compfuns (name, T) (iss, is') else error "compile param: Not an inductive predicate with correct mode" - | Free (name, T) => Free (name, funT_of T (SOME is')) - val outTs = HOLogic.strip_tupleT (dest_pred_enumT (body_type (fastype_of f'))) + | Free (name, T) => Free (name, param_funT_of compfuns T (SOME is')) + val outTs = dest_tupleT (dest_predT compfuns (body_type (fastype_of f'))) val out_vs = map Free (out_names ~~ outTs) val params' = map (compile_param thy modes) (ms ~~ params) val f_app = list_comb (f', params' @ inargs) - val single_t = (mk_single (HOLogic.mk_tuple (map (fn i => nth out_vs (i - 1)) outp_perm))) - val match_t = compile_match thy [] [] out_vs single_t + val single_t = (mk_single compfuns (mk_tuple (map (fn i => nth out_vs (i - 1)) outp_perm))) + val match_t = compile_match thy compfuns [] [] out_vs single_t in list_abs (ivs, - mk_bind (f_app, match_t)) + mk_bind compfuns (f_app, match_t)) end - | compile_param_ext _ _ _ = error "compile params" + | compile_param_ext _ _ _ _ = error "compile params" +*) -and compile_param thy modes (NONE, t) = t - | compile_param thy modes (m as SOME (Mode ((iss, is'), is, ms)), t) = - (* (case t of - Abs _ => error "compile_param: Invalid term" *) (* compile_param_ext thy modes (m, t) *) - (* | _ => let *) - let +fun compile_param size thy compfuns (NONE, t) = t + | compile_param size thy compfuns (m as SOME (Mode ((iss, is'), is, ms)), t) = + let val (f, args) = strip_comb (Envir.eta_contract t) val (params, args') = chop (length ms) args - val params' = map (compile_param thy modes) (ms ~~ params) - val f' = case f of - Const (name, T) => - if AList.defined op = modes name then - Const (predfun_name_of thy name (iss, is'), funT'_of (iss, is') T) - else error "compile param: Not an inductive predicate with correct mode" - | Free (name, T) => Free (name, funT_of T (SOME is')) + val params' = map (compile_param size thy compfuns) (ms ~~ params) + val mk_fun_of = case size of NONE => mk_fun_of | SOME _ => mk_sizelim_fun_of + val funT_of = case size of NONE => funT_of | SOME _ => sizelim_funT_of + val f' = + case f of + Const (name, T) => + mk_fun_of compfuns thy (name, T) (iss, is') + | Free (name, T) => Free (name, funT_of compfuns (iss, is') T) + | _ => error ("PredicateCompiler: illegal parameter term") in list_comb (f', params' @ args') end - | compile_param _ _ _ = error "compile params" - - -fun compile_expr thy modes (SOME (Mode (mode, is, ms)), t) = - (case strip_comb t of - (Const (name, T), params) => - if AList.defined op = modes name then - let - val (Ts, Us) = get_args is - (curry Library.drop (length ms) (fst (strip_type T))) - val params' = map (compile_param thy modes) (ms ~~ params) - in list_comb (Const (predfun_name_of thy name mode, ((map fastype_of params') @ Ts) ---> - mk_pred_enumT (HOLogic.mk_tupleT Us)), params') - end - else error "not a valid inductive expression" - | (Free (name, T), args) => - (*if name mem param_vs then *) - (* Higher order mode call *) - let val r = Free (name, funT_of T (SOME is)) - in list_comb (r, args) end) - | compile_expr _ _ _ = error "not a valid inductive expression" + +fun compile_expr size thy ((Mode (mode, is, ms)), t) = + case strip_comb t of + (Const (name, T), params) => + let + val params' = map (compile_param size thy PredicateCompFuns.compfuns) (ms ~~ params) + val mk_fun_of = case size of NONE => mk_fun_of | SOME _ => mk_sizelim_fun_of + in + list_comb (mk_fun_of PredicateCompFuns.compfuns thy (name, T) mode, params') + end + | (Free (name, T), args) => + let + val funT_of = case size of NONE => funT_of | SOME _ => sizelim_funT_of + in + list_comb (Free (name, funT_of PredicateCompFuns.compfuns ([], is) T), args) + end; + +fun compile_gen_expr size thy compfuns ((Mode (mode, is, ms)), t) = + case strip_comb t of + (Const (name, T), params) => + let + val params' = map (compile_param size thy compfuns) (ms ~~ params) + in + list_comb (mk_generator_of compfuns thy (name, T) mode, params') + end + | (Free (name, T), args) => + list_comb (Free (name, sizelim_funT_of RPredCompFuns.compfuns ([], is) T), args) + +(** specific rpred functions -- move them to the correct place in this file *) +(* uncommented termify code; causes more trouble than expected at first *) +(* +fun mk_valtermify_term (t as Const (c, T)) = HOLogic.mk_prod (t, Abs ("u", HOLogic.unitT, HOLogic.reflect_term t)) + | mk_valtermify_term (Free (x, T)) = Free (x, termifyT T) + | mk_valtermify_term (t1 $ t2) = + let + val T = fastype_of t1 + val (T1, T2) = dest_funT T + val t1' = mk_valtermify_term t1 + val t2' = mk_valtermify_term t2 + in + Const ("Code_Eval.valapp", termifyT T --> termifyT T1 --> termifyT T2) $ t1' $ t2' + end + | mk_valtermify_term _ = error "Not a valid term for mk_valtermify_term" +*) -fun compile_clause thy all_vs param_vs modes (iss, is) (ts, ps) inp = +fun compile_clause compfuns size final_term thy all_vs param_vs (iss, is) inp (ts, moded_ps) = let - val modes' = modes @ List.mapPartial - (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)])) - (param_vs ~~ iss); fun check_constrt t (names, eqs) = if is_constrt thy t then (t, (names, eqs)) else let @@ -678,7 +1212,7 @@ val v = Free (s, fastype_of t) in (v, (s::names, HOLogic.mk_eq (v, t)::eqs)) end; - val (in_ts, out_ts) = get_args is ts; + val (in_ts, out_ts) = split_smode is ts; val (in_ts', (all_vs', eqs)) = fold_map check_constrt in_ts (all_vs, []); @@ -689,15 +1223,16 @@ val (out_ts''', (names'', constr_vs)) = fold_map distinct_v out_ts'' (names', map (rpair []) vs); in - compile_match thy constr_vs (eqs @ eqs') out_ts''' - (mk_single (HOLogic.mk_tuple out_ts)) + (* termify code: + compile_match thy compfuns constr_vs (eqs @ eqs') out_ts''' + (mk_single compfuns (mk_tuple (map mk_valtermify_term out_ts))) + *) + compile_match thy compfuns constr_vs (eqs @ eqs') out_ts''' + (final_term out_ts) end - | compile_prems out_ts vs names ps = + | compile_prems out_ts vs names ((p, mode as Mode ((_, is), _, _)) :: ps) = let val vs' = distinct (op =) (flat (vs :: map term_vs out_ts)); - val SOME (p, mode as SOME (Mode (_, js, _))) = - select_mode_prem thy modes' vs' ps - val ps' = filter_out (equal p) ps val (out_ts', (names', eqs)) = fold_map check_constrt out_ts (names, []) val (out_ts'', (names'', constr_vs')) = fold_map distinct_v @@ -705,67 +1240,97 @@ val (compiled_clause, rest) = case p of Prem (us, t) => let - val (in_ts, out_ts''') = get_args js us; - val u = list_comb (compile_expr thy modes (mode, t), in_ts) - val rest = compile_prems out_ts''' vs' names'' ps' + val (in_ts, out_ts''') = split_smode is us; + val args = case size of + NONE => in_ts + | SOME size_t => in_ts @ [size_t] + val u = lift_pred compfuns + (list_comb (compile_expr size thy (mode, t), args)) + val rest = compile_prems out_ts''' vs' names'' ps in (u, rest) end | Negprem (us, t) => let - val (in_ts, out_ts''') = get_args js us - val u = list_comb (compile_expr thy modes (mode, t), in_ts) - val rest = compile_prems out_ts''' vs' names'' ps' + val (in_ts, out_ts''') = split_smode is us + val u = lift_pred compfuns + (mk_not PredicateCompFuns.compfuns (list_comb (compile_expr NONE thy (mode, t), in_ts))) + val rest = compile_prems out_ts''' vs' names'' ps in - (mk_not_pred u, rest) + (u, rest) end | Sidecond t => let - val rest = compile_prems [] vs' names'' ps'; + val rest = compile_prems [] vs' names'' ps; in - (mk_if_predenum t, rest) + (mk_if compfuns t, rest) + end + | GeneratorPrem (us, t) => + let + val (in_ts, out_ts''') = split_smode is us; + val args = case size of + NONE => in_ts + | SOME size_t => in_ts @ [size_t] + val u = list_comb (compile_gen_expr size thy compfuns (mode, t), args) + val rest = compile_prems out_ts''' vs' names'' ps + in + (u, rest) + end + | Generator (v, T) => + let + val u = lift_random (HOLogic.mk_random T @{term "1::code_numeral"}) + val rest = compile_prems [Free (v, T)] vs' names'' ps; + in + (u, rest) end in - compile_match thy constr_vs' eqs out_ts'' - (mk_bind (compiled_clause, rest)) + compile_match thy compfuns constr_vs' eqs out_ts'' + (mk_bind compfuns (compiled_clause, rest)) end - val prem_t = compile_prems in_ts' param_vs all_vs' ps; + val prem_t = compile_prems in_ts' param_vs all_vs' moded_ps; in - mk_bind (mk_single inp, prem_t) + mk_bind compfuns (mk_single compfuns inp, prem_t) end -fun compile_pred thy all_vs param_vs modes s T cls mode = +fun compile_pred compfuns mk_fun_of use_size thy all_vs param_vs s T mode moded_cls = let - val Ts = binder_types T; - val (Ts1, Ts2) = chop (length param_vs) Ts; - val Ts1' = map2 funT_of Ts1 (fst mode) - val (Us1, Us2) = get_args (snd mode) Ts2; - val xnames = Name.variant_list param_vs + val (Ts1, (Us1, Us2)) = split_mode mode (binder_types T) + val funT_of = if use_size then sizelim_funT_of else funT_of + val Ts1' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) (fst mode) Ts1 + val xnames = Name.variant_list (all_vs @ param_vs) (map (fn i => "x" ^ string_of_int i) (snd mode)); + val size_name = Name.variant (all_vs @ param_vs @ xnames) "size" + (* termify code: val xs = map2 (fn s => fn T => Free (s, termifyT T)) xnames Us1; *) val xs = map2 (fn s => fn T => Free (s, T)) xnames Us1; + val params = map2 (fn s => fn T => Free (s, T)) param_vs Ts1' + val size = Free (size_name, @{typ "code_numeral"}) + val decr_size = + if use_size then + SOME (Const ("HOL.minus_class.minus", @{typ "code_numeral => code_numeral => code_numeral"}) + $ size $ Const ("HOL.one_class.one", @{typ "Code_Numeral.code_numeral"})) + else + NONE val cl_ts = - map (fn cl => compile_clause thy - all_vs param_vs modes mode cl (HOLogic.mk_tuple xs)) cls; - val mode_id = predfun_name_of thy s mode + map (compile_clause compfuns decr_size (fn out_ts => mk_single compfuns (mk_tuple out_ts)) + thy all_vs param_vs mode (mk_tuple xs)) moded_cls; + val t = foldr1 (mk_sup compfuns) cl_ts + val T' = mk_predT compfuns (mk_tupleT Us2) + val size_t = Const (@{const_name "If"}, @{typ bool} --> T' --> T' --> T') + $ HOLogic.mk_eq (size, @{term "0 :: code_numeral"}) + $ mk_bot compfuns (dest_predT compfuns T') $ t + val fun_const = mk_fun_of compfuns thy (s, T) mode + val eq = if use_size then + (list_comb (fun_const, params @ xs @ [size]), size_t) + else + (list_comb (fun_const, params @ xs), t) in - HOLogic.mk_Trueprop (HOLogic.mk_eq - (list_comb (Const (mode_id, (Ts1' @ Us1) ---> - mk_pred_enumT (HOLogic.mk_tupleT Us2)), - map2 (fn s => fn T => Free (s, T)) param_vs Ts1' @ xs), - foldr1 mk_sup cl_ts)) + HOLogic.mk_Trueprop (HOLogic.mk_eq eq) end; - -fun compile_preds thy all_vs param_vs modes preds = - map (fn (s, (T, cls)) => - map (compile_pred thy all_vs param_vs modes s T cls) - ((the o AList.lookup (op =) modes) s)) preds; - - + (* special setup for simpset *) val HOL_basic_ss' = HOL_basic_ss setSolver (mk_solver "all_tac_solver" (fn _ => fn _ => all_tac)) - (* Definition of executable functions and their intro and elim rules *) fun print_arities arities = tracing ("Arities:\n" ^ @@ -780,41 +1345,40 @@ val argnames = Name.variant_list names (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts))); val args = map Free (argnames ~~ Ts) - val (inargs, outargs) = get_args mode args - val r = mk_Eval (list_comb (x, inargs), HOLogic.mk_tuple outargs) + val (inargs, outargs) = split_smode mode args + val r = PredicateCompFuns.mk_Eval (list_comb (x, inargs), mk_tuple outargs) val t = fold_rev lambda args r in (t, argnames @ names) end; -fun create_intro_elim_rule nparams mode defthm mode_id funT pred thy = +fun create_intro_elim_rule (mode as (iss, is)) defthm mode_id funT pred thy = let val Ts = binder_types (fastype_of pred) val funtrm = Const (mode_id, funT) val argnames = Name.variant_list [] (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts))); - val (Ts1, Ts2) = chop nparams Ts; - val Ts1' = map2 funT_of Ts1 (fst mode) + val (Ts1, Ts2) = chop (length iss) Ts; + val Ts1' = map2 (fn NONE => I | SOME is => funT_of (PredicateCompFuns.compfuns) ([], is)) iss Ts1 val args = map Free (argnames ~~ (Ts1' @ Ts2)) - val (params, io_args) = chop nparams args - val (inargs, outargs) = get_args (snd mode) io_args + val (params, ioargs) = chop (length iss) args + val (inargs, outargs) = split_smode is ioargs val param_names = Name.variant_list argnames - (map (fn i => "p" ^ string_of_int i) (1 upto nparams)) + (map (fn i => "p" ^ string_of_int i) (1 upto (length iss))) val param_vs = map Free (param_names ~~ Ts1) - val (params', names) = fold_map mk_Eval_of ((params ~~ Ts1) ~~ (fst mode)) [] - val predpropI = HOLogic.mk_Trueprop (list_comb (pred, param_vs @ io_args)) - val predpropE = HOLogic.mk_Trueprop (list_comb (pred, params' @ io_args)) + val (params', names) = fold_map mk_Eval_of ((params ~~ Ts1) ~~ iss) [] + val predpropI = HOLogic.mk_Trueprop (list_comb (pred, param_vs @ ioargs)) + val predpropE = HOLogic.mk_Trueprop (list_comb (pred, params' @ ioargs)) val param_eqs = map (HOLogic.mk_Trueprop o HOLogic.mk_eq) (param_vs ~~ params') val funargs = params @ inargs - val funpropE = HOLogic.mk_Trueprop (mk_Eval (list_comb (funtrm, funargs), - if null outargs then Free("y", HOLogic.unitT) else HOLogic.mk_tuple outargs)) - val funpropI = HOLogic.mk_Trueprop (mk_Eval (list_comb (funtrm, funargs), - HOLogic.mk_tuple outargs)) + val funpropE = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, funargs), + if null outargs then Free("y", HOLogic.unitT) else mk_tuple outargs)) + val funpropI = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, funargs), + mk_tuple outargs)) val introtrm = Logic.list_implies (predpropI :: param_eqs, funpropI) - val _ = Output.tracing (Syntax.string_of_term_global thy introtrm) val simprules = [defthm, @{thm eval_pred}, @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}] - val unfolddef_tac = (Simplifier.asm_full_simp_tac (HOL_basic_ss addsimps simprules) 1) + val unfolddef_tac = Simplifier.asm_full_simp_tac (HOL_basic_ss addsimps simprules) 1 val introthm = Goal.prove (ProofContext.init thy) (argnames @ param_names @ ["y"]) [] introtrm (fn {...} => unfolddef_tac) val P = HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT)); val elimtrm = Logic.list_implies ([funpropE, Logic.mk_implies (predpropE, P)], P) @@ -823,53 +1387,92 @@ (introthm, elimthm) end; -fun create_definitions preds nparams (name, modes) thy = +fun create_constname_of_mode thy prefix name mode = let - val _ = tracing "create definitions" + fun string_of_mode mode = if null mode then "0" + else space_implode "_" (map string_of_int mode) + val HOmode = space_implode "_and_" + (fold (fn NONE => I | SOME mode => cons (string_of_mode mode)) (fst mode) []) + in + (Sign.full_bname thy (prefix ^ (Long_Name.base_name name))) ^ + (if HOmode = "" then "_" else "_for_" ^ HOmode ^ "_yields_") ^ (string_of_mode (snd mode)) + end; + +fun create_definitions preds (name, modes) thy = + let + val compfuns = PredicateCompFuns.compfuns val T = AList.lookup (op =) preds name |> the - fun create_definition mode thy = let - fun string_of_mode mode = if null mode then "0" - else space_implode "_" (map string_of_int mode) - val HOmode = let - fun string_of_HOmode m s = case m of NONE => s | SOME mode => s ^ "__" ^ (string_of_mode mode) - in (fold string_of_HOmode (fst mode) "") end; - val mode_id = name ^ (if HOmode = "" then "_" else HOmode ^ "___") - ^ (string_of_mode (snd mode)) - val Ts = binder_types T; - val (Ts1, Ts2) = chop nparams Ts; - val Ts1' = map2 funT_of Ts1 (fst mode) - val (Us1, Us2) = get_args (snd mode) Ts2; + fun create_definition (mode as (iss, is)) thy = let + val mode_cname = create_constname_of_mode thy "" name mode + val mode_cbasename = Long_Name.base_name mode_cname + val Ts = binder_types T + val (Ts1, Ts2) = chop (length iss) Ts + val (Us1, Us2) = split_smode is Ts2 + val Ts1' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) iss Ts1 + val funT = (Ts1' @ Us1) ---> (mk_predT compfuns (mk_tupleT Us2)) val names = Name.variant_list [] (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts))); - val xs = map Free (names ~~ (Ts1' @ Ts2)); - val (xparams, xargs) = chop nparams xs; - val (xparams', names') = fold_map mk_Eval_of ((xparams ~~ Ts1) ~~ (fst mode)) names - val (xins, xouts) = get_args (snd mode) xargs; + val xs = map Free (names ~~ (Ts1' @ Ts2)); + val (xparams, xargs) = chop (length iss) xs; + val (xins, xouts) = split_smode is xargs + val (xparams', names') = fold_map mk_Eval_of ((xparams ~~ Ts1) ~~ iss) names fun mk_split_lambda [] t = lambda (Free (Name.variant names' "x", HOLogic.unitT)) t - | mk_split_lambda [x] t = lambda x t - | mk_split_lambda xs t = let - fun mk_split_lambda' (x::y::[]) t = HOLogic.mk_split (lambda x (lambda y t)) - | mk_split_lambda' (x::xs) t = HOLogic.mk_split (lambda x (mk_split_lambda' xs t)) - in mk_split_lambda' xs t end; - val predterm = mk_Enum (mk_split_lambda xouts (list_comb (Const (name, T), xparams' @ xargs))) - val funT = (Ts1' @ Us1) ---> (mk_pred_enumT (HOLogic.mk_tupleT Us2)) - val mode_id = Sign.full_bname thy (Long_Name.base_name mode_id) - val lhs = list_comb (Const (mode_id, funT), xparams @ xins) + | mk_split_lambda [x] t = lambda x t + | mk_split_lambda xs t = + let + fun mk_split_lambda' (x::y::[]) t = HOLogic.mk_split (lambda x (lambda y t)) + | mk_split_lambda' (x::xs) t = HOLogic.mk_split (lambda x (mk_split_lambda' xs t)) + in + mk_split_lambda' xs t + end; + val predterm = PredicateCompFuns.mk_Enum (mk_split_lambda xouts + (list_comb (Const (name, T), xparams' @ xargs))) + val lhs = list_comb (Const (mode_cname, funT), xparams @ xins) val def = Logic.mk_equals (lhs, predterm) val ([definition], thy') = thy |> - Sign.add_consts_i [(Binding.name (Long_Name.base_name mode_id), funT, NoSyn)] |> - PureThy.add_defs false [((Binding.name (Long_Name.base_name mode_id ^ "_def"), def), [])] - val (intro, elim) = create_intro_elim_rule nparams mode definition mode_id funT (Const (name, T)) thy' - in thy' |> add_predfun name mode (mode_id, definition, intro, elim) - |> PureThy.store_thm (Binding.name (Long_Name.base_name mode_id ^ "I"), intro) |> snd - |> PureThy.store_thm (Binding.name (Long_Name.base_name mode_id ^ "E"), elim) |> snd + Sign.add_consts_i [(Binding.name mode_cbasename, funT, NoSyn)] |> + PureThy.add_defs false [((Binding.name (mode_cbasename ^ "_def"), def), [])] + val (intro, elim) = + create_intro_elim_rule mode definition mode_cname funT (Const (name, T)) thy' + in thy' |> add_predfun name mode (mode_cname, definition, intro, elim) + |> PureThy.store_thm (Binding.name (mode_cbasename ^ "I"), intro) |> snd + |> PureThy.store_thm (Binding.name (mode_cbasename ^ "E"), elim) |> snd |> Theory.checkpoint end; in fold create_definition modes thy end; -(**************************************************************************************) +fun sizelim_create_definitions preds (name, modes) thy = + let + val T = AList.lookup (op =) preds name |> the + fun create_definition mode thy = + let + val mode_cname = create_constname_of_mode thy "sizelim_" name mode + val funT = sizelim_funT_of PredicateCompFuns.compfuns mode T + in + thy |> Sign.add_consts_i [(Binding.name (Long_Name.base_name mode_cname), funT, NoSyn)] + |> set_sizelim_function_name name mode mode_cname + end; + in + fold create_definition modes thy + end; + +fun rpred_create_definitions preds (name, modes) thy = + let + val T = AList.lookup (op =) preds name |> the + fun create_definition mode thy = + let + val mode_cname = create_constname_of_mode thy "gen_" name mode + val funT = sizelim_funT_of RPredCompFuns.compfuns mode T + in + thy |> Sign.add_consts_i [(Binding.name (Long_Name.base_name mode_cname), funT, NoSyn)] + |> set_generator_name name mode mode_cname + end; + in + fold create_definition modes thy + end; + (* Proving equivalence of term *) fun is_Type (Type _) = true @@ -892,65 +1495,48 @@ (* MAJOR FIXME: prove_params should be simple - different form of introrule for parameters ? *) -fun prove_param thy modes (NONE, t) = - all_tac -| prove_param thy modes (m as SOME (Mode (mode, is, ms)), t) = - REPEAT_DETERM (etac @{thm thin_rl} 1) - THEN REPEAT_DETERM (rtac @{thm ext} 1) - THEN (rtac @{thm iffI} 1) - THEN new_print_tac "prove_param" - (* proof in one direction *) - THEN (atac 1) - (* proof in the other direction *) - THEN (atac 1) - THEN new_print_tac "after prove_param" -(* let - val (f, args) = strip_comb t +fun prove_param thy (NONE, t) = TRY (rtac @{thm refl} 1) + | prove_param thy (m as SOME (Mode (mode, is, ms)), t) = + let + val (f, args) = strip_comb (Envir.eta_contract t) val (params, _) = chop (length ms) args val f_tac = case f of - Const (name, T) => simp_tac (HOL_basic_ss addsimps - (@{thm eval_pred}::(predfun_definition_of thy name mode):: - @{thm "Product_Type.split_conv"}::[])) 1 - | Free _ => all_tac - | Abs _ => error "TODO: implement here" - in - print_tac "before simplification in prove_args:" + Const (name, T) => simp_tac (HOL_basic_ss addsimps + (@{thm eval_pred}::(predfun_definition_of thy name mode):: + @{thm "Product_Type.split_conv"}::[])) 1 + | Free _ => TRY (rtac @{thm refl} 1) + | Abs _ => error "prove_param: No valid parameter term" + in + REPEAT_DETERM (etac @{thm thin_rl} 1) + THEN REPEAT_DETERM (rtac @{thm ext} 1) + THEN print_tac "prove_param" THEN f_tac THEN print_tac "after simplification in prove_args" - THEN (EVERY (map (prove_param thy modes) (ms ~~ params))) + THEN (EVERY (map (prove_param thy) (ms ~~ params))) THEN (REPEAT_DETERM (atac 1)) end -*) -fun prove_expr thy modes (SOME (Mode (mode, is, ms)), t, us) (premposition : int) = - (case strip_comb t of - (Const (name, T), args) => - if AList.defined op = modes name then (let - val introrule = predfun_intro_of thy name mode - (*val (in_args, out_args) = get_args is us - val (pred, rargs) = strip_comb (HOLogic.dest_Trueprop - (hd (Logic.strip_imp_prems (prop_of introrule)))) - val nparams = length ms (* get_nparams thy (fst (dest_Const pred)) *) - val (_, args) = chop nparams rargs - val subst = map (pairself (cterm_of thy)) (args ~~ us) - val inst_introrule = Drule.cterm_instantiate subst introrule*) - (* the next line is old and probably wrong *) - val (args1, args2) = chop (length ms) args - in + +fun prove_expr thy (Mode (mode, is, ms), t, us) (premposition : int) = + case strip_comb t of + (Const (name, T), args) => + let + val introrule = predfun_intro_of thy name mode + val (args1, args2) = chop (length ms) args + in rtac @{thm bindI} 1 THEN print_tac "before intro rule:" (* for the right assumption in first position *) THEN rotate_tac premposition 1 + THEN debug_tac (Display.string_of_thm (ProofContext.init thy) introrule) THEN rtac introrule 1 - THEN new_print_tac "after intro rule" + THEN print_tac "after intro rule" (* work with parameter arguments *) THEN (atac 1) - THEN (new_print_tac "parameter goal") - THEN (EVERY (map (prove_param thy modes) (ms ~~ args1))) - THEN (REPEAT_DETERM (atac 1)) end) - else error "Prove expr if case not implemented" - | _ => rtac @{thm bindI} 1 - THEN atac 1) - | prove_expr _ _ _ _ = error "Prove expr not implemented" + THEN (print_tac "parameter goal") + THEN (EVERY (map (prove_param thy) (ms ~~ args1))) + THEN (REPEAT_DETERM (atac 1)) + end + | _ => rtac @{thm bindI} 1 THEN atac 1 fun SOLVED tac st = FILTER (fn st' => nprems_of st' = nprems_of st - 1) tac st; @@ -994,105 +1580,86 @@ (* need better control here! *) end -fun prove_clause thy nargs all_vs param_vs modes (iss, is) (ts, ps) = let - val modes' = modes @ List.mapPartial - (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)])) - (param_vs ~~ iss); - fun check_constrt ((names, eqs), t) = - if is_constrt thy t then ((names, eqs), t) else - let - val s = Name.variant names "x"; - val v = Free (s, fastype_of t) - in ((s::names, HOLogic.mk_eq (v, t)::eqs), v) end; - - val (in_ts, clause_out_ts) = get_args is ts; - val ((all_vs', eqs), in_ts') = - (*FIXME*) Library.foldl_map check_constrt ((all_vs, []), in_ts); - fun prove_prems out_ts vs [] = - (prove_match thy out_ts) - THEN asm_simp_tac HOL_basic_ss' 1 - THEN print_tac "before the last rule of singleI:" - THEN (rtac (if null clause_out_ts then @{thm singleI_unit} else @{thm singleI}) 1) - | prove_prems out_ts vs rps = - let - val vs' = distinct (op =) (flat (vs :: map term_vs out_ts)); - val SOME (p, mode as SOME (Mode ((iss, js), _, param_modes))) = - select_mode_prem thy modes' vs' rps; - val premposition = (find_index (equal p) ps) + nargs - val rps' = filter_out (equal p) rps; - val rest_tac = (case p of Prem (us, t) => - let - val (in_ts, out_ts''') = get_args js us - val rec_tac = prove_prems out_ts''' vs' rps' - in - print_tac "before clause:" - THEN asm_simp_tac HOL_basic_ss 1 - THEN print_tac "before prove_expr:" - THEN prove_expr thy modes (mode, t, us) premposition - THEN print_tac "after prove_expr:" - THEN rec_tac - end - | Negprem (us, t) => - let - val (in_ts, out_ts''') = get_args js us - val rec_tac = prove_prems out_ts''' vs' rps' - val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE) - val (_, params) = strip_comb t - in - rtac @{thm bindI} 1 - THEN (if (is_some name) then - simp_tac (HOL_basic_ss addsimps [predfun_definition_of thy (the name) (iss, js)]) 1 - THEN rtac @{thm not_predI} 1 - (* FIXME: work with parameter arguments *) - THEN (EVERY (map (prove_param thy modes) (param_modes ~~ params))) - else - rtac @{thm not_predI'} 1) - THEN (REPEAT_DETERM (atac 1)) - THEN rec_tac - end - | Sidecond t => - rtac @{thm bindI} 1 - THEN rtac @{thm if_predI} 1 - THEN print_tac "before sidecond:" - THEN prove_sidecond thy modes t - THEN print_tac "after sidecond:" - THEN prove_prems [] vs' rps') - in (prove_match thy out_ts) - THEN rest_tac - end; - val prems_tac = prove_prems in_ts' param_vs ps -in - rtac @{thm bindI} 1 - THEN rtac @{thm singleI} 1 - THEN prems_tac -end; +fun prove_clause thy nargs modes (iss, is) (_, clauses) (ts, moded_ps) = + let + val (in_ts, clause_out_ts) = split_smode is ts; + fun prove_prems out_ts [] = + (prove_match thy out_ts) + THEN asm_simp_tac HOL_basic_ss' 1 + THEN (rtac (if null clause_out_ts then @{thm singleI_unit} else @{thm singleI}) 1) + | prove_prems out_ts ((p, mode as Mode ((iss, is), _, param_modes)) :: ps) = + let + val premposition = (find_index (equal p) clauses) + nargs + val rest_tac = (case p of Prem (us, t) => + let + val (_, out_ts''') = split_smode is us + val rec_tac = prove_prems out_ts''' ps + in + print_tac "before clause:" + THEN asm_simp_tac HOL_basic_ss 1 + THEN print_tac "before prove_expr:" + THEN prove_expr thy (mode, t, us) premposition + THEN print_tac "after prove_expr:" + THEN rec_tac + end + | Negprem (us, t) => + let + val (_, out_ts''') = split_smode is us + val rec_tac = prove_prems out_ts''' ps + val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE) + val (_, params) = strip_comb t + in + rtac @{thm bindI} 1 + THEN (if (is_some name) then + simp_tac (HOL_basic_ss addsimps [predfun_definition_of thy (the name) (iss, is)]) 1 + THEN rtac @{thm not_predI} 1 + THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1 + THEN (REPEAT_DETERM (atac 1)) + (* FIXME: work with parameter arguments *) + THEN (EVERY (map (prove_param thy) (param_modes ~~ params))) + else + rtac @{thm not_predI'} 1) + THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1 + THEN rec_tac + end + | Sidecond t => + rtac @{thm bindI} 1 + THEN rtac @{thm if_predI} 1 + THEN print_tac "before sidecond:" + THEN prove_sidecond thy modes t + THEN print_tac "after sidecond:" + THEN prove_prems [] ps) + in (prove_match thy out_ts) + THEN rest_tac + end; + val prems_tac = prove_prems in_ts moded_ps + in + rtac @{thm bindI} 1 + THEN rtac @{thm singleI} 1 + THEN prems_tac + end; fun select_sup 1 1 = [] | select_sup _ 1 = [rtac @{thm supI1}] | select_sup n i = (rtac @{thm supI2})::(select_sup (n - 1) (i - 1)); -fun prove_one_direction thy all_vs param_vs modes clauses ((pred, T), mode) = let -(* val ind_result = Inductive.the_inductive (ProofContext.init thy) pred - val index = find_index (fn s => s = pred) (#names (fst ind_result)) - val (_, T) = dest_Const (nth (#preds (snd ind_result)) index) *) - val nargs = length (binder_types T) - nparams_of thy pred - val pred_case_rule = singleton (ind_set_codegen_preproc thy) - (preprocess_elim thy nargs (the_elim_of thy pred)) - (* FIXME preprocessor |> Simplifier.full_simplify (HOL_basic_ss addsimps [@{thm Predicate.memb_code}])*) -in - REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"})) - THEN etac (predfun_elim_of thy pred mode) 1 - THEN etac pred_case_rule 1 - THEN (EVERY (map - (fn i => EVERY' (select_sup (length clauses) i) i) - (1 upto (length clauses)))) - THEN (EVERY (map (prove_clause thy nargs all_vs param_vs modes mode) clauses)) - THEN new_print_tac "proved one direction" -end; +fun prove_one_direction thy clauses preds modes pred mode moded_clauses = + let + val T = the (AList.lookup (op =) preds pred) + val nargs = length (binder_types T) - nparams_of thy pred + val pred_case_rule = the_elim_of thy pred + in + REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"})) + THEN etac (predfun_elim_of thy pred mode) 1 + THEN etac pred_case_rule 1 + THEN (EVERY (map + (fn i => EVERY' (select_sup (length moded_clauses) i) i) + (1 upto (length moded_clauses)))) + THEN (EVERY (map2 (prove_clause thy nargs modes mode) clauses moded_clauses)) + THEN print_tac "proved one direction" + end; -(*******************************************************************************************************) -(* Proof in the other direction ************************************************************************) -(*******************************************************************************************************) +(** Proof in the other direction **) fun prove_match2 thy out_ts = let fun split_term_tac (Free _) = all_tac @@ -1114,51 +1681,50 @@ end else all_tac in - split_term_tac (HOLogic.mk_tuple out_ts) + split_term_tac (mk_tuple out_ts) THEN (DETERM (TRY ((Splitter.split_asm_tac [@{thm "split_if_asm"}] 1) THEN (etac @{thm botE} 2)))) end (* VERY LARGE SIMILIRATIY to function prove_param -- join both functions *) +(* TODO: remove function *) -fun prove_param2 thy modes (NONE, t) = all_tac - | prove_param2 thy modes (m as SOME (Mode (mode, is, ms)), t) = let - val (f, args) = strip_comb t +fun prove_param2 thy (NONE, t) = all_tac + | prove_param2 thy (m as SOME (Mode (mode, is, ms)), t) = let + val (f, args) = strip_comb (Envir.eta_contract t) val (params, _) = chop (length ms) args val f_tac = case f of Const (name, T) => full_simp_tac (HOL_basic_ss addsimps (@{thm eval_pred}::(predfun_definition_of thy name mode) :: @{thm "Product_Type.split_conv"}::[])) 1 | Free _ => all_tac + | _ => error "prove_param2: illegal parameter term" in print_tac "before simplification in prove_args:" THEN f_tac THEN print_tac "after simplification in prove_args" - THEN (EVERY (map (prove_param2 thy modes) (ms ~~ params))) + THEN (EVERY (map (prove_param2 thy) (ms ~~ params))) end -fun prove_expr2 thy modes (SOME (Mode (mode, is, ms)), t) = +fun prove_expr2 thy (Mode (mode, is, ms), t) = (case strip_comb t of (Const (name, T), args) => - if AList.defined op = modes name then - etac @{thm bindE} 1 - THEN (REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"}))) - THEN new_print_tac "prove_expr2-before" - THEN (debug_tac (Syntax.string_of_term_global thy - (prop_of (predfun_elim_of thy name mode)))) - THEN (etac (predfun_elim_of thy name mode) 1) - THEN new_print_tac "prove_expr2" - (* TODO -- FIXME: replace remove_last_goal*) - (* THEN (EVERY (replicate (length args) (remove_last_goal thy))) *) - THEN (EVERY (map (prove_param thy modes) (ms ~~ args))) - THEN new_print_tac "finished prove_expr2" - - else error "Prove expr2 if case not implemented" + etac @{thm bindE} 1 + THEN (REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"}))) + THEN print_tac "prove_expr2-before" + THEN (debug_tac (Syntax.string_of_term_global thy + (prop_of (predfun_elim_of thy name mode)))) + THEN (etac (predfun_elim_of thy name mode) 1) + THEN print_tac "prove_expr2" + THEN (EVERY (map (prove_param2 thy) (ms ~~ args))) + THEN print_tac "finished prove_expr2" | _ => etac @{thm bindE} 1) - | prove_expr2 _ _ _ = error "Prove expr2 not implemented" - + +(* FIXME: what is this for? *) +(* replace defined by has_mode thy pred *) +(* TODO: rewrite function *) fun prove_sidecond2 thy modes t = let fun preds_of t nameTs = case strip_comb t of (f as Const (name, T), args) => @@ -1176,147 +1742,140 @@ THEN print_tac "after sidecond2 simplification" end -fun prove_clause2 thy all_vs param_vs modes (iss, is) (ts, ps) pred i = let - val modes' = modes @ List.mapPartial - (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)])) - (param_vs ~~ iss); - fun check_constrt ((names, eqs), t) = - if is_constrt thy t then ((names, eqs), t) else - let - val s = Name.variant names "x"; - val v = Free (s, fastype_of t) - in ((s::names, HOLogic.mk_eq (v, t)::eqs), v) end; - val pred_intro_rule = nth (intros_of thy pred) (i - 1) - |> preprocess_intro thy - |> (fn thm => hd (ind_set_codegen_preproc thy [thm])) - (* FIXME preprocess |> Simplifier.full_simplify (HOL_basic_ss addsimps [@ {thm Predicate.memb_code}]) *) - val (in_ts, clause_out_ts) = get_args is ts; - val ((all_vs', eqs), in_ts') = - (*FIXME*) Library.foldl_map check_constrt ((all_vs, []), in_ts); - fun prove_prems2 out_ts vs [] = - print_tac "before prove_match2 - last call:" - THEN prove_match2 thy out_ts - THEN print_tac "after prove_match2 - last call:" - THEN (etac @{thm singleE} 1) - THEN (REPEAT_DETERM (etac @{thm Pair_inject} 1)) - THEN (asm_full_simp_tac HOL_basic_ss' 1) - THEN (REPEAT_DETERM (etac @{thm Pair_inject} 1)) - THEN (asm_full_simp_tac HOL_basic_ss' 1) - THEN SOLVED (print_tac "state before applying intro rule:" +fun prove_clause2 thy modes pred (iss, is) (ts, ps) i = + let + val pred_intro_rule = nth (intros_of thy pred) (i - 1) + val (in_ts, clause_out_ts) = split_smode is ts; + fun prove_prems2 out_ts [] = + print_tac "before prove_match2 - last call:" + THEN prove_match2 thy out_ts + THEN print_tac "after prove_match2 - last call:" + THEN (etac @{thm singleE} 1) + THEN (REPEAT_DETERM (etac @{thm Pair_inject} 1)) + THEN (asm_full_simp_tac HOL_basic_ss' 1) + THEN (REPEAT_DETERM (etac @{thm Pair_inject} 1)) + THEN (asm_full_simp_tac HOL_basic_ss' 1) + THEN SOLVED (print_tac "state before applying intro rule:" THEN (rtac pred_intro_rule 1) (* How to handle equality correctly? *) THEN (print_tac "state before assumption matching") THEN (REPEAT (atac 1 ORELSE (CHANGED (asm_full_simp_tac HOL_basic_ss' 1) THEN print_tac "state after simp_tac:")))) - | prove_prems2 out_ts vs ps = let - val vs' = distinct (op =) (flat (vs :: map term_vs out_ts)); - val SOME (p, mode as SOME (Mode ((iss, js), _, param_modes))) = - select_mode_prem thy modes' vs' ps; - val ps' = filter_out (equal p) ps; - val rest_tac = (case p of Prem (us, t) => + | prove_prems2 out_ts ((p, mode as Mode ((iss, is), _, param_modes)) :: ps) = + let + val rest_tac = (case p of + Prem (us, t) => let - val (in_ts, out_ts''') = get_args js us - val rec_tac = prove_prems2 out_ts''' vs' ps' + val (_, out_ts''') = split_smode is us + val rec_tac = prove_prems2 out_ts''' ps in - (prove_expr2 thy modes (mode, t)) THEN rec_tac + (prove_expr2 thy (mode, t)) THEN rec_tac end | Negprem (us, t) => let - val (in_ts, out_ts''') = get_args js us - val rec_tac = prove_prems2 out_ts''' vs' ps' + val (_, out_ts''') = split_smode is us + val rec_tac = prove_prems2 out_ts''' ps val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE) val (_, params) = strip_comb t in print_tac "before neg prem 2" THEN etac @{thm bindE} 1 THEN (if is_some name then - full_simp_tac (HOL_basic_ss addsimps [predfun_definition_of thy (the name) (iss, js)]) 1 + full_simp_tac (HOL_basic_ss addsimps [predfun_definition_of thy (the name) (iss, is)]) 1 THEN etac @{thm not_predE} 1 - THEN (EVERY (map (prove_param thy modes) (param_modes ~~ params))) + THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1 + THEN (EVERY (map (prove_param2 thy) (param_modes ~~ params))) else etac @{thm not_predE'} 1) THEN rec_tac end | Sidecond t => - etac @{thm bindE} 1 - THEN etac @{thm if_predE} 1 - THEN prove_sidecond2 thy modes t - THEN prove_prems2 [] vs' ps') - in print_tac "before prove_match2:" - THEN prove_match2 thy out_ts - THEN print_tac "after prove_match2:" - THEN rest_tac - end; - val prems_tac = prove_prems2 in_ts' param_vs ps -in - new_print_tac "starting prove_clause2" - THEN etac @{thm bindE} 1 - THEN (etac @{thm singleE'} 1) - THEN (TRY (etac @{thm Pair_inject} 1)) - THEN print_tac "after singleE':" - THEN prems_tac -end; + etac @{thm bindE} 1 + THEN etac @{thm if_predE} 1 + THEN prove_sidecond2 thy modes t + THEN prove_prems2 [] ps) + in print_tac "before prove_match2:" + THEN prove_match2 thy out_ts + THEN print_tac "after prove_match2:" + THEN rest_tac + end; + val prems_tac = prove_prems2 in_ts ps + in + print_tac "starting prove_clause2" + THEN etac @{thm bindE} 1 + THEN (etac @{thm singleE'} 1) + THEN (TRY (etac @{thm Pair_inject} 1)) + THEN print_tac "after singleE':" + THEN prems_tac + end; -fun prove_other_direction thy all_vs param_vs modes clauses (pred, mode) = let - fun prove_clause (clause, i) = - (if i < length clauses then etac @{thm supE} 1 else all_tac) - THEN (prove_clause2 thy all_vs param_vs modes mode clause pred i) -in - (DETERM (TRY (rtac @{thm unit.induct} 1))) - THEN (REPEAT_DETERM (CHANGED (rewtac @{thm split_paired_all}))) - THEN (rtac (predfun_intro_of thy pred mode) 1) - THEN (REPEAT_DETERM (rtac @{thm refl} 2)) - THEN (EVERY (map prove_clause (clauses ~~ (1 upto (length clauses))))) -end; +fun prove_other_direction thy modes pred mode moded_clauses = + let + fun prove_clause clause i = + (if i < length moded_clauses then etac @{thm supE} 1 else all_tac) + THEN (prove_clause2 thy modes pred mode clause i) + in + (DETERM (TRY (rtac @{thm unit.induct} 1))) + THEN (REPEAT_DETERM (CHANGED (rewtac @{thm split_paired_all}))) + THEN (rtac (predfun_intro_of thy pred mode) 1) + THEN (REPEAT_DETERM (rtac @{thm refl} 2)) + THEN (EVERY (map2 prove_clause moded_clauses (1 upto (length moded_clauses)))) + end; + +(** proof procedure **) -fun prove_pred thy all_vs param_vs modes clauses (((pred, T), mode), t) = let - val ctxt = ProofContext.init thy - val clauses' = the (AList.lookup (op =) clauses pred) -in - Goal.prove ctxt (Term.fold_aterms (fn Free (x, _) => insert (op =) x | _ => I) t []) [] t - (if !do_proofs then - (fn _ => - rtac @{thm pred_iffI} 1 - THEN prove_one_direction thy all_vs param_vs modes clauses' ((pred, T), mode) - THEN print_tac "proved one direction" - THEN prove_other_direction thy all_vs param_vs modes clauses' (pred, mode) - THEN print_tac "proved other direction") - else (fn _ => mycheat_tac thy 1)) -end; +fun prove_pred thy clauses preds modes pred mode (moded_clauses, compiled_term) = + let + val ctxt = ProofContext.init thy + val clauses = the (AList.lookup (op =) clauses pred) + in + Goal.prove ctxt (Term.add_free_names compiled_term []) [] compiled_term + (if !do_proofs then + (fn _ => + rtac @{thm pred_iffI} 1 + THEN prove_one_direction thy clauses preds modes pred mode moded_clauses + THEN print_tac "proved one direction" + THEN prove_other_direction thy modes pred mode moded_clauses + THEN print_tac "proved other direction") + else (fn _ => mycheat_tac thy 1)) + end; -fun prove_preds thy all_vs param_vs modes clauses pmts = - map (prove_pred thy all_vs param_vs modes clauses) pmts +(* composition of mode inference, definition, compilation and proof *) + +(** auxillary combinators for table of preds and modes **) -(* special case: inductive predicate with no clauses *) -fun noclause (predname, T) thy = let - val Ts = binder_types T - val names = Name.variant_list [] - (map (fn i => "x" ^ (string_of_int i)) (1 upto (length Ts))) - val vs = map2 (curry Free) names Ts - val clausehd = HOLogic.mk_Trueprop (list_comb(Const (predname, T), vs)) - val intro_t = Logic.mk_implies (@{prop False}, clausehd) - val P = HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT)) - val elim_t = Logic.list_implies ([clausehd, Logic.mk_implies (@{prop False}, P)], P) - val intro = Goal.prove (ProofContext.init thy) names [] intro_t - (fn {...} => etac @{thm FalseE} 1) - val elim = Goal.prove (ProofContext.init thy) ("P" :: names) [] elim_t - (fn {...} => etac (the_elim_of thy predname) 1) -in - add_intro intro thy - |> set_elim elim -end +fun map_preds_modes f preds_modes_table = + map (fn (pred, modes) => + (pred, map (fn (mode, value) => (mode, f pred mode value)) modes)) preds_modes_table +fun join_preds_modes table1 table2 = + map_preds_modes (fn pred => fn mode => fn value => + (value, the (AList.lookup (op =) (the (AList.lookup (op =) table2 pred)) mode))) table1 + +fun maps_modes preds_modes_table = + map (fn (pred, modes) => + (pred, map (fn (mode, value) => value) modes)) preds_modes_table + +fun compile_preds compfuns mk_fun_of use_size thy all_vs param_vs preds moded_clauses = + map_preds_modes (fn pred => compile_pred compfuns mk_fun_of use_size thy all_vs param_vs pred + (the (AList.lookup (op =) preds pred))) moded_clauses + +fun prove thy clauses preds modes moded_clauses compiled_terms = + map_preds_modes (prove_pred thy clauses preds modes) + (join_preds_modes moded_clauses compiled_terms) + +fun prove_by_skip thy _ _ _ _ compiled_terms = + map_preds_modes (fn pred => fn mode => fn t => Drule.standard (SkipProof.make_thm thy t)) + compiled_terms + fun prepare_intrs thy prednames = let - (* FIXME: preprocessing moved to fetch_pred_data *) - val intrs = map (preprocess_intro thy) (maps (intros_of thy) prednames) - |> ind_set_codegen_preproc thy (*FIXME preprocessor - |> map (Simplifier.full_simplify (HOL_basic_ss addsimps [@ {thm Predicate.memb_code}]))*) + val intrs = maps (intros_of thy) prednames |> map (Logic.unvarify o prop_of) val nparams = nparams_of thy (hd prednames) + val extra_modes = all_modes_of thy |> filter_out (fn (name, _) => member (op =) prednames name) val preds = distinct (op =) (map (dest_Const o fst o (strip_intro_concl nparams)) intrs) - val extra_modes = all_modes_of thy |> filter_out (fn (name, _) => member (op =) prednames name) val _ $ u = Logic.strip_imp_concl (hd intrs); val params = List.take (snd (strip_comb u), nparams); val param_vs = maps term_vs params @@ -1324,7 +1883,7 @@ fun dest_prem t = (case strip_comb t of (v as Free _, ts) => if v mem params then Prem (ts, v) else Sidecond t - | (c as Const (@{const_name Not}, _), [t]) => (case dest_prem t of + | (c as Const (@{const_name Not}, _), [t]) => (case dest_prem t of Prem (ts, t) => Negprem (ts, t) | Negprem _ => error ("Double negation not allowed in premise: " ^ (Syntax.string_of_term_global thy (c $ t))) | Sidecond t => Sidecond (c $ t)) @@ -1352,46 +1911,95 @@ val (clauses, arities) = fold add_clause intrs ([], []); in (preds, nparams, all_vs, param_vs, extra_modes, clauses, arities) end; -fun arrange kvs = +(** main function of predicate compiler **) + +fun add_equations_of steps prednames thy = let - fun add (key, value) table = - AList.update op = (key, these (AList.lookup op = table key) @ [value]) table - in fold add kvs [] end; - -(* main function *) + val _ = Output.tracing ("Starting predicate compiler for predicates " ^ commas prednames ^ "...") + val (preds, nparams, all_vs, param_vs, extra_modes, clauses, arities) = + prepare_intrs thy prednames + val _ = Output.tracing "Infering modes..." + val moded_clauses = #infer_modes steps thy extra_modes arities param_vs clauses + val modes = map (fn (p, mps) => (p, map fst mps)) moded_clauses + val _ = print_modes modes + val _ = print_moded_clauses thy moded_clauses + val _ = Output.tracing "Defining executable functions..." + val thy' = fold (#create_definitions steps preds) modes thy + |> Theory.checkpoint + val _ = Output.tracing "Compiling equations..." + val compiled_terms = + (#compile_preds steps) thy' all_vs param_vs preds moded_clauses + val _ = print_compiled_terms thy' compiled_terms + val _ = Output.tracing "Proving equations..." + val result_thms = #prove steps thy' clauses preds (extra_modes @ modes) + moded_clauses compiled_terms + val qname = #qname steps + (* val attrib = gn thy => Attrib.attribute_i thy Code.add_eqn_attrib *) + val attrib = fn thy => Attrib.attribute_i thy (Attrib.internal (K (Thm.declaration_attribute + (fn thm => Context.mapping (Code.add_eqn thm) I)))) + val thy'' = fold (fn (name, result_thms) => fn thy => snd (PureThy.add_thmss + [((Binding.qualify true (Long_Name.base_name name) (Binding.name qname), result_thms), + [attrib thy ])] thy)) + (maps_modes result_thms) thy' + |> Theory.checkpoint + in + thy'' + end -fun add_equations_of prednames thy = -let - val _ = tracing ("starting add_equations with " ^ commas prednames ^ "...") - (* null clause handling *) - (* - val thy' = fold (fn pred as (predname, T) => fn thy => - if null (intros_of thy predname) then noclause pred thy else thy) preds thy - *) - val (preds, nparams, all_vs, param_vs, extra_modes, clauses, arities) = - prepare_intrs thy prednames - val _ = tracing "Infering modes..." - val modes = infer_modes thy extra_modes arities param_vs clauses - val _ = print_modes modes - val _ = tracing "Defining executable functions..." - val thy' = fold (create_definitions preds nparams) modes thy |> Theory.checkpoint - val clauses' = map (fn (s, cls) => (s, (the (AList.lookup (op =) preds s), cls))) clauses - val _ = tracing "Compiling equations..." - val ts = compile_preds thy' all_vs param_vs (extra_modes @ modes) clauses' - val _ = map (Output.tracing o (Syntax.string_of_term_global thy')) (flat ts) - val pred_mode = - maps (fn (s, (T, _)) => map (pair (s, T)) ((the o AList.lookup (op =) modes) s)) clauses' - val _ = Output.tracing "Proving equations..." - val result_thms = - prove_preds thy' all_vs param_vs (extra_modes @ modes) clauses (pred_mode ~~ (flat ts)) - val thy'' = fold (fn (name, result_thms) => fn thy => snd (PureThy.add_thmss - [((Binding.qualify true (Long_Name.base_name name) (Binding.name "equation"), result_thms), - [Attrib.attribute_i thy Code.add_default_eqn_attrib])] thy)) - (arrange ((map (fn ((name, _), _) => name) pred_mode) ~~ result_thms)) thy' - |> Theory.checkpoint -in - thy'' -end +fun extend' value_of edges_of key (G, visited) = + let + val (G', v) = case try (Graph.get_node G) key of + SOME v => (G, v) + | NONE => (Graph.new_node (key, value_of key) G, value_of key) + val (G'', visited') = fold (extend' value_of edges_of) (edges_of (key, v) \\ visited) + (G', key :: visited) + in + (fold (Graph.add_edge o (pair key)) (edges_of (key, v)) G'', visited') + end; + +fun extend value_of edges_of key G = fst (extend' value_of edges_of key (G, [])) + +fun gen_add_equations steps names thy = + let + val thy' = PredData.map (fold (extend (fetch_pred_data thy) (depending_preds_of thy)) names) thy + |> Theory.checkpoint; + fun strong_conn_of gr keys = + Graph.strong_conn (Graph.subgraph (member (op =) (Graph.all_succs gr keys)) gr) + val scc = strong_conn_of (PredData.get thy') names + val thy'' = fold_rev + (fn preds => fn thy => + if #are_not_defined steps thy preds then add_equations_of steps preds thy else thy) + scc thy' |> Theory.checkpoint + in thy'' end + +(* different instantiantions of the predicate compiler *) + +val add_equations = gen_add_equations + {infer_modes = infer_modes false, + create_definitions = create_definitions, + compile_preds = compile_preds PredicateCompFuns.compfuns mk_fun_of false, + prove = prove, + are_not_defined = (fn thy => forall (null o modes_of thy)), + qname = "equation"} + +val add_sizelim_equations = gen_add_equations + {infer_modes = infer_modes false, + create_definitions = sizelim_create_definitions, + compile_preds = compile_preds PredicateCompFuns.compfuns mk_sizelim_fun_of true, + prove = prove_by_skip, + are_not_defined = (fn thy => fn preds => true), (* TODO *) + qname = "sizelim_equation" + } + +val add_quickcheck_equations = gen_add_equations + {infer_modes = infer_modes_with_generator, + create_definitions = rpred_create_definitions, + compile_preds = compile_preds RPredCompFuns.compfuns mk_generator_of true, + prove = prove_by_skip, + are_not_defined = (fn thy => fn preds => true), (* TODO *) + qname = "rpred_equation"} + +(** user interface **) (* generation of case rules from user-given introduction rules *) @@ -1404,7 +2012,8 @@ val (argnames, ctxt2) = Variable.variant_fixes (map (fn i => "a" ^ string_of_int i) (1 upto (length args))) ctxt1 val argvs = map2 (curry Free) argnames (map fastype_of args) - fun mk_case intro = let + fun mk_case intro = + let val (_, (_, args)) = strip_intro_concl nparams intro val prems = Logic.strip_imp_prems intro val eqprems = map (HOLogic.mk_Trueprop o HOLogic.mk_eq) (argvs ~~ args) @@ -1412,46 +2021,30 @@ (fn t as Free _ => if member (op aconv) params t then I else insert (op aconv) t | _ => I) (args @ prems) [] - in fold Logic.all frees (Logic.list_implies (eqprems @ prems, prop)) end + in fold Logic.all frees (Logic.list_implies (eqprems @ prems, prop)) end val assm = HOLogic.mk_Trueprop (list_comb (pred, params @ argvs)) val cases = map mk_case intros in Logic.list_implies (assm :: cases, prop) end; -fun add_equations name thy = - let - val thy' = PredData.map (Graph.extend (dependencies_of thy) name) thy |> Theory.checkpoint; - (*val preds = Graph.all_preds (PredData.get thy') [name] |> filter_out (has_elim thy') *) - fun strong_conn_of gr keys = - Graph.strong_conn (Graph.subgraph (member (op =) (Graph.all_succs gr keys)) gr) - val scc = strong_conn_of (PredData.get thy') [name] - val thy'' = fold_rev - (fn preds => fn thy => - if forall (null o modes_of thy) preds then add_equations_of preds thy else thy) - scc thy' |> Theory.checkpoint - in thy'' end +(* code_pred_intro attribute *) - fun attrib f = Thm.declaration_attribute (fn thm => Context.mapping (f thm) I); val code_pred_intros_attrib = attrib add_intro; -(** user interface **) - local (* TODO: make TheoryDataFun to GenericDataFun & remove duplication of local theory and theory *) (* TODO: must create state to prove multiple cases *) fun generic_code_pred prep_const raw_const lthy = let - val thy = ProofContext.theory_of lthy val const = prep_const thy raw_const - - val lthy' = LocalTheory.theory (PredData.map (Graph.extend (dependencies_of thy) const)) lthy + val lthy' = LocalTheory.theory (PredData.map + (extend (fetch_pred_data thy) (depending_preds_of thy) const)) lthy |> LocalTheory.checkpoint val thy' = ProofContext.theory_of lthy' val preds = Graph.all_preds (PredData.get thy') [const] |> filter_out (has_elim thy') - fun mk_cases const = let val nparams = nparams_of thy' const @@ -1463,11 +2056,16 @@ assumes = [("", Logic.strip_imp_prems case_rule)], binds = [], cases = []}) cases_rules val case_env = map2 (fn p => fn c => (Long_Name.base_name p, SOME c)) preds cases - val _ = Output.tracing (commas (map fst case_env)) - val lthy'' = ProofContext.add_cases true case_env lthy' - - fun after_qed thms = - LocalTheory.theory (fold set_elim (map the_single thms) #> add_equations const) + val lthy'' = lthy' + |> fold Variable.auto_fixes cases_rules + |> ProofContext.add_cases true case_env + fun after_qed thms goal_ctxt = + let + val global_thms = ProofContext.export goal_ctxt + (ProofContext.init (ProofContext.theory_of goal_ctxt)) (map the_single thms) + in + goal_ctxt |> LocalTheory.theory (fold set_elim global_thms #> add_equations [const]) + end in Proof.theorem_i NONE after_qed (map (single o (rpair [])) cases_rules) lthy'' end; @@ -1523,9 +2121,8 @@ | [m] => m | m :: _ :: _ => (warning ("Multiple modes possible for comprehension " ^ Syntax.string_of_term_global thy t_compr); m); - val (inargs, outargs) = get_args user_mode args; - val t_pred = list_comb (compile_expr thy (all_modes_of thy) (SOME m, list_comb (pred, params)), - inargs); + val (inargs, outargs) = split_smode user_mode args; + val t_pred = list_comb (compile_expr NONE thy (m, list_comb (pred, params)), inargs); val t_eval = if null outargs then t_pred else let val outargs_bounds = map (fn Bound i => i) outargs; val outargsTs = map (nth Ts) outargs_bounds; @@ -1537,14 +2134,14 @@ val arrange = funpow (length outargs_bounds - 1) HOLogic.mk_split (Term.list_abs (map (pair "") outargsTs, HOLogic.mk_ptuple fp T_compr (map Bound arrange_bounds))) - in mk_pred_map T_pred T_compr arrange t_pred end + in mk_map PredicateCompFuns.compfuns T_pred T_compr arrange t_pred end in t_eval end; fun eval thy t_compr = let val t = analyze_compr thy t_compr; - val T = dest_pred_enumT (fastype_of t); - val t' = mk_pred_map T HOLogic.termT (HOLogic.term_of_const T) t; + val T = dest_predT PredicateCompFuns.compfuns (fastype_of t); + val t' = mk_map PredicateCompFuns.compfuns T HOLogic.termT (HOLogic.term_of_const T) t; in (T, Code_ML.eval NONE ("Predicate_Compile.eval_ref", eval_ref) Predicate.map thy t' []) end; fun values ctxt k t_compr = diff -r 5ef633275b15 -r 96f9e6402403 src/Pure/Concurrent/future.ML --- a/src/Pure/Concurrent/future.ML Mon Aug 10 08:37:37 2009 +0200 +++ b/src/Pure/Concurrent/future.ML Mon Aug 10 10:25:00 2009 +0200 @@ -120,11 +120,10 @@ fun SYNCHRONIZED name = SimpleThread.synchronized name lock; fun wait cond = (*requires SYNCHRONIZED*) - Multithreading.sync_wait NONE cond lock; + Multithreading.sync_wait NONE NONE cond lock; -fun wait_interruptible timeout cond = (*requires SYNCHRONIZED*) - interruptible (fn () => - ignore (Multithreading.sync_wait (SOME (Time.+ (Time.now (), timeout))) cond lock)) (); +fun wait_timeout timeout cond = (*requires SYNCHRONIZED*) + Multithreading.sync_wait NONE (SOME (Time.+ (Time.now (), timeout))) cond lock; fun signal cond = (*requires SYNCHRONIZED*) ConditionVar.signal cond; @@ -149,11 +148,11 @@ val res = if ok then Exn.capture (fn () => - (Thread.testInterrupt (); - Multithreading.with_attributes Multithreading.restricted_interrupts - (fn _ => fn () => e ())) ()) () + Multithreading.with_attributes Multithreading.private_interrupts (fn _ => e ())) () else Exn.Exn Exn.Interrupt; - val _ = Synchronized.change result (K (SOME res)); + val _ = Synchronized.change result + (fn NONE => SOME res + | SOME _ => raise Fail "Duplicate assignment of future value"); in (case res of Exn.Exn exn => (Task_Queue.cancel_group group exn; false) @@ -276,20 +275,23 @@ broadcast_work ()); (*delay loop*) - val _ = wait_interruptible next_round scheduler_event - handle Exn.Interrupt => - (Multithreading.tracing 1 (fn () => "Interrupt"); - List.app do_cancel (Task_Queue.cancel_all (! queue))); + val _ = Exn.release (wait_timeout next_round scheduler_event); (*shutdown*) val _ = if Task_Queue.is_empty (! queue) then do_shutdown := true else (); val continue = not (! do_shutdown andalso null (! workers)); val _ = if continue then () else scheduler := NONE; val _ = broadcast scheduler_event; - in continue end; + in continue end + handle Exn.Interrupt => + (Multithreading.tracing 1 (fn () => "Interrupt"); + uninterruptible (fn _ => fn () => List.app do_cancel (Task_Queue.cancel_all (! queue))) (); + scheduler_next ()); fun scheduler_loop () = - while SYNCHRONIZED "scheduler" (fn () => scheduler_next ()) do (); + Multithreading.with_attributes + (Multithreading.sync_interrupts Multithreading.public_interrupts) + (fn _ => while SYNCHRONIZED "scheduler" (fn () => scheduler_next ()) do ()); fun scheduler_active () = (*requires SYNCHRONIZED*) (case ! scheduler of NONE => false | SOME thread => Thread.isActive thread); @@ -393,12 +395,11 @@ fun interruptible_task f x = if Multithreading.available then - (Thread.testInterrupt (); Multithreading.with_attributes (if is_worker () - then Multithreading.restricted_interrupts - else Multithreading.regular_interrupts) - (fn _ => fn x => f x) x) + then Multithreading.private_interrupts + else Multithreading.public_interrupts) + (fn _ => f x) else interruptible f x; (*cancel: present and future group members will be interrupted eventually*) diff -r 5ef633275b15 -r 96f9e6402403 src/Pure/Concurrent/simple_thread.ML --- a/src/Pure/Concurrent/simple_thread.ML Mon Aug 10 08:37:37 2009 +0200 +++ b/src/Pure/Concurrent/simple_thread.ML Mon Aug 10 10:25:00 2009 +0200 @@ -16,7 +16,7 @@ fun fork interrupts body = Thread.fork (fn () => exception_trace (fn () => body ()), - if interrupts then Multithreading.regular_interrupts else Multithreading.no_interrupts); + if interrupts then Multithreading.public_interrupts else Multithreading.no_interrupts); fun interrupt thread = Thread.interrupt thread handle Thread _ => (); diff -r 5ef633275b15 -r 96f9e6402403 src/Pure/Concurrent/synchronized.ML --- a/src/Pure/Concurrent/synchronized.ML Mon Aug 10 08:37:37 2009 +0200 +++ b/src/Pure/Concurrent/synchronized.ML Mon Aug 10 10:25:00 2009 +0200 @@ -48,9 +48,10 @@ (case f x of SOME (y, x') => (var := x'; SOME y) | NONE => - if Multithreading.sync_wait (time_limit x) cond lock - then try_change () - else NONE) + (case Multithreading.sync_wait NONE (time_limit x) cond lock of + Exn.Result true => try_change () + | Exn.Result false => NONE + | Exn.Exn exn => reraise exn)) end; val res = try_change (); val _ = ConditionVar.broadcast cond; diff -r 5ef633275b15 -r 96f9e6402403 src/Pure/ML-Systems/multithreading.ML --- a/src/Pure/ML-Systems/multithreading.ML Mon Aug 10 08:37:37 2009 +0200 +++ b/src/Pure/ML-Systems/multithreading.ML Mon Aug 10 10:25:00 2009 +0200 @@ -13,20 +13,21 @@ signature MULTITHREADING = sig include BASIC_MULTITHREADING - val trace: int ref - val tracing: int -> (unit -> string) -> unit - val tracing_time: bool -> Time.time -> (unit -> string) -> unit - val real_time: ('a -> unit) -> 'a -> Time.time val available: bool val max_threads: int ref val max_threads_value: unit -> int val enabled: unit -> bool val no_interrupts: Thread.threadAttribute list - val regular_interrupts: Thread.threadAttribute list - val restricted_interrupts: Thread.threadAttribute list - val with_attributes: Thread.threadAttribute list -> - (Thread.threadAttribute list -> 'a -> 'b) -> 'a -> 'b - val sync_wait: Time.time option -> ConditionVar.conditionVar -> Mutex.mutex -> bool + val public_interrupts: Thread.threadAttribute list + val private_interrupts: Thread.threadAttribute list + val sync_interrupts: Thread.threadAttribute list -> Thread.threadAttribute list + val with_attributes: Thread.threadAttribute list -> (Thread.threadAttribute list -> 'a) -> 'a + val sync_wait: Thread.threadAttribute list option -> Time.time option -> + ConditionVar.conditionVar -> Mutex.mutex -> bool Exn.result + val trace: int ref + val tracing: int -> (unit -> string) -> unit + val tracing_time: bool -> Time.time -> (unit -> string) -> unit + val real_time: ('a -> unit) -> 'a -> Time.time val self_critical: unit -> bool val serial: unit -> int end; @@ -34,14 +35,6 @@ structure Multithreading: MULTITHREADING = struct -(* tracing *) - -val trace = ref (0: int); -fun tracing _ _ = (); -fun tracing_time _ _ _ = (); -fun real_time f x = (f x; Time.zeroTime); - - (* options *) val available = false; @@ -52,18 +45,22 @@ (* attributes *) -val no_interrupts = - [Thread.EnableBroadcastInterrupt false, Thread.InterruptState Thread.InterruptDefer]; +val no_interrupts = []; +val public_interrupts = []; +val private_interrupts = []; +fun sync_interrupts _ = []; -val regular_interrupts = - [Thread.EnableBroadcastInterrupt true, Thread.InterruptState Thread.InterruptAsynchOnce]; +fun with_attributes _ e = e []; -val restricted_interrupts = - [Thread.EnableBroadcastInterrupt false, Thread.InterruptState Thread.InterruptAsynchOnce]; +fun sync_wait _ _ _ _ = Exn.Result true; + + +(* tracing *) -fun with_attributes _ f x = f [] x; - -fun sync_wait _ _ _ = false; +val trace = ref (0: int); +fun tracing _ _ = (); +fun tracing_time _ _ _ = (); +fun real_time f x = (f x; Time.zeroTime); (* critical section *) diff -r 5ef633275b15 -r 96f9e6402403 src/Pure/ML-Systems/multithreading_polyml.ML --- a/src/Pure/ML-Systems/multithreading_polyml.ML Mon Aug 10 08:37:37 2009 +0200 +++ b/src/Pure/ML-Systems/multithreading_polyml.ML Mon Aug 10 10:25:00 2009 +0200 @@ -27,31 +27,6 @@ structure Multithreading: MULTITHREADING = struct -(* tracing *) - -val trace = ref 0; - -fun tracing level msg = - if level > ! trace then () - else (TextIO.output (TextIO.stdErr, (">>> " ^ msg () ^ "\n")); TextIO.flushOut TextIO.stdErr) - handle _ (*sic*) => (); - -fun tracing_time detailed time = - tracing - (if not detailed then 5 - else if Time.>= (time, Time.fromMilliseconds 1000) then 1 - else if Time.>= (time, Time.fromMilliseconds 100) then 2 - else if Time.>= (time, Time.fromMilliseconds 10) then 3 - else if Time.>= (time, Time.fromMilliseconds 1) then 4 else 5); - -fun real_time f x = - let - val timer = Timer.startRealTimer (); - val () = f x; - val time = Timer.checkRealTimer timer; - in time end; - - (* options *) val available = true; @@ -91,57 +66,76 @@ val no_interrupts = [Thread.EnableBroadcastInterrupt false, Thread.InterruptState Thread.InterruptDefer]; -val regular_interrupts = +val public_interrupts = [Thread.EnableBroadcastInterrupt true, Thread.InterruptState Thread.InterruptAsynchOnce]; -val restricted_interrupts = +val private_interrupts = [Thread.EnableBroadcastInterrupt false, Thread.InterruptState Thread.InterruptAsynchOnce]; +val sync_interrupts = map + (fn x as Thread.InterruptState Thread.InterruptDefer => x + | Thread.InterruptState _ => Thread.InterruptState Thread.InterruptSynch + | x => x); + val safe_interrupts = map (fn Thread.InterruptState Thread.InterruptAsynch => Thread.InterruptState Thread.InterruptAsynchOnce | x => x); -fun with_attributes new_atts f x = +fun with_attributes new_atts e = let val orig_atts = safe_interrupts (Thread.getAttributes ()); val result = Exn.capture (fn () => - (Thread.setAttributes (safe_interrupts new_atts); f orig_atts x)) (); + (Thread.setAttributes (safe_interrupts new_atts); e orig_atts)) (); val _ = Thread.setAttributes orig_atts; in Exn.release result end; -(* regular interruptibility *) +(* portable wrappers *) + +fun interruptible f x = with_attributes public_interrupts (fn _ => f x); -fun interruptible f x = - (Thread.testInterrupt (); with_attributes regular_interrupts (fn _ => fn x => f x) x); - -fun uninterruptible f = - with_attributes no_interrupts (fn atts => fn x => - f (fn g => with_attributes atts (fn _ => fn y => g y)) x); +fun uninterruptible f x = + with_attributes no_interrupts (fn atts => + f (fn g => fn y => with_attributes atts (fn _ => g y)) x); (* synchronous wait *) -fun sync_attributes e = +fun sync_wait opt_atts time cond lock = + with_attributes + (sync_interrupts (case opt_atts of SOME atts => atts | NONE => Thread.getAttributes ())) + (fn _ => + (case time of + SOME t => Exn.Result (ConditionVar.waitUntil (cond, lock, t)) + | NONE => (ConditionVar.wait (cond, lock); Exn.Result true)) + handle exn => Exn.Exn exn); + + +(* tracing *) + +val trace = ref 0; + +fun tracing level msg = + if level > ! trace then () + else uninterruptible (fn _ => fn () => + (TextIO.output (TextIO.stdErr, (">>> " ^ msg () ^ "\n")); TextIO.flushOut TextIO.stdErr) + handle _ (*sic*) => ()) (); + +fun tracing_time detailed time = + tracing + (if not detailed then 5 + else if Time.>= (time, Time.fromMilliseconds 1000) then 1 + else if Time.>= (time, Time.fromMilliseconds 100) then 2 + else if Time.>= (time, Time.fromMilliseconds 10) then 3 + else if Time.>= (time, Time.fromMilliseconds 1) then 4 else 5); + +fun real_time f x = let - val orig_atts = Thread.getAttributes (); - val broadcast = - (case List.find (fn Thread.EnableBroadcastInterrupt _ => true | _ => false) orig_atts of - NONE => Thread.EnableBroadcastInterrupt false - | SOME att => att); - val interrupt_state = - (case List.find (fn Thread.InterruptState _ => true | _ => false) orig_atts of - NONE => Thread.InterruptState Thread.InterruptDefer - | SOME (state as Thread.InterruptState Thread.InterruptDefer) => state - | _ => Thread.InterruptState Thread.InterruptSynch); - in with_attributes [broadcast, interrupt_state] (fn _ => fn () => e ()) () end; - -fun sync_wait time cond lock = - sync_attributes (fn () => - (case time of - SOME t => ConditionVar.waitUntil (cond, lock, t) - | NONE => (ConditionVar.wait (cond, lock); true))); + val timer = Timer.startRealTimer (); + val () = f x; + val time = Timer.checkRealTimer timer; + in time end; (* execution with time limit *) @@ -169,7 +163,7 @@ (* system shell processes, with propagation of interrupts *) -fun system_out script = uninterruptible (fn restore_attributes => fn () => +fun system_out script = with_attributes no_interrupts (fn orig_atts => let val script_name = OS.FileSys.tmpName (); val _ = write_file script_name script; @@ -180,13 +174,12 @@ (*result state*) datatype result = Wait | Signal | Result of int; val result = ref Wait; - val result_mutex = Mutex.mutex (); - val result_cond = ConditionVar.conditionVar (); + val lock = Mutex.mutex (); + val cond = ConditionVar.conditionVar (); fun set_result res = - (Mutex.lock result_mutex; result := res; Mutex.unlock result_mutex; - ConditionVar.signal result_cond); + (Mutex.lock lock; result := res; ConditionVar.signal cond; Mutex.unlock lock); - val _ = Mutex.lock result_mutex; + val _ = Mutex.lock lock; (*system thread*) val system_thread = Thread.fork (fn () => @@ -216,11 +209,12 @@ handle OS.SysErr _ => () | IO.Io _ => (OS.Process.sleep (Time.fromMilliseconds 100); if n > 0 then kill (n - 1) else ()); - val _ = while ! result = Wait do - restore_attributes (fn () => - (ignore (sync_wait (SOME (Time.+ (Time.now (), Time.fromMilliseconds 100))) - result_cond result_mutex) - handle Exn.Interrupt => kill 10)) (); + val _ = + while ! result = Wait do + let val res = + sync_wait (SOME orig_atts) + (SOME (Time.+ (Time.now (), Time.fromMilliseconds 100))) cond lock + in case res of Exn.Exn Exn.Interrupt => kill 10 | _ => () end; (*cleanup*) val output = read_file output_name handle IO.Io _ => ""; @@ -229,7 +223,7 @@ val _ = OS.FileSys.remove output_name handle OS.SysErr _ => (); val _ = Thread.interrupt system_thread handle Thread _ => (); val rc = (case ! result of Signal => raise Exn.Interrupt | Result rc => rc); - in (output, rc) end) (); + in (output, rc) end); (* critical section -- may be nested within the same thread *) diff -r 5ef633275b15 -r 96f9e6402403 src/Pure/System/isabelle_system.scala --- a/src/Pure/System/isabelle_system.scala Mon Aug 10 08:37:37 2009 +0200 +++ b/src/Pure/System/isabelle_system.scala Mon Aug 10 10:25:00 2009 +0200 @@ -298,6 +298,12 @@ /** Isabelle resources **/ + /* components */ + + def components(): List[String] = + getenv("ISABELLE_COMPONENTS").split(":").toList + + /* find logics */ def find_logics(): List[String] = diff -r 5ef633275b15 -r 96f9e6402403 src/Pure/subgoal.ML --- a/src/Pure/subgoal.ML Mon Aug 10 08:37:37 2009 +0200 +++ b/src/Pure/subgoal.ML Mon Aug 10 10:25:00 2009 +0200 @@ -102,7 +102,7 @@ *) fun lift_subgoals params asms th = let - val lift = fold_rev Thm.all_name params o curry Drule.list_implies asms; + fun lift ct = fold_rev Thm.all_name params (Drule.list_implies (asms, ct)); val unlift = fold (Thm.elim_implies o Thm.assume) asms o Drule.forall_elim_list (map #2 params) o Thm.assume; @@ -133,14 +133,14 @@ fun GEN_FOCUS flags tac ctxt i st = if Thm.nprems_of st < i then Seq.empty else - let val (args as {context, params, asms, ...}, st') = gen_focus flags ctxt i st; - in Seq.lifts (retrofit context ctxt params asms i) (tac args st') st end; + let val (args as {context = ctxt', params, asms, ...}, st') = gen_focus flags ctxt i st; + in Seq.lifts (retrofit ctxt' ctxt params asms i) (tac args st') st end; val FOCUS_PARAMS = GEN_FOCUS (false, false); val FOCUS_PREMS = GEN_FOCUS (true, false); val FOCUS = GEN_FOCUS (true, true); -fun SUBPROOF tac = FOCUS (FILTER Thm.no_prems o tac); +fun SUBPROOF tac ctxt = FOCUS (Seq.map (tap (Goal.check_finished ctxt)) oo tac) ctxt; end; diff -r 5ef633275b15 -r 96f9e6402403 src/Tools/quickcheck.ML --- a/src/Tools/quickcheck.ML Mon Aug 10 08:37:37 2009 +0200 +++ b/src/Tools/quickcheck.ML Mon Aug 10 10:25:00 2009 +0200 @@ -11,6 +11,7 @@ val test_term: Proof.context -> bool -> string option -> int -> int -> term -> (string * term) list option val add_generator: string * (Proof.context -> term -> int -> term list option) -> theory -> theory + val quickcheck: (string * string) list -> int -> Proof.state -> (string * term) list option end; structure Quickcheck : QUICKCHECK = @@ -215,18 +216,21 @@ |> (Data.map o apsnd o map_test_params) f end; -fun quickcheck_cmd args i state = +fun quickcheck args i state = let - val prf = Toplevel.proof_of state; - val thy = Toplevel.theory_of state; - val ctxt = Toplevel.context_of state; + val thy = Proof.theory_of state; + val ctxt = Proof.context_of state; val default_params = (dest_test_params o snd o Data.get) thy; val f = fold (parse_test_param_inst ctxt) args; val (((size, iterations), default_type), (generator_name, insts)) = f (default_params, (NONE, [])); - val counterex = test_goal false generator_name size iterations - default_type insts i [] prf; - in (Pretty.writeln o pretty_counterex ctxt) counterex end; + in + test_goal false generator_name size iterations default_type insts i [] state + end; + +fun quickcheck_cmd args i state = + quickcheck args i (Toplevel.proof_of state) + |> Pretty.writeln o pretty_counterex (Toplevel.context_of state); local structure P = OuterParse and K = OuterKeyword in