merged, resolving obvious conflicts in NEWS and src/Pure/System/isabelle_process.ML;
authorwenzelm
Thu Dec 05 17:58:03 2013 +0100 (2013-12-05)
changeset 54671d64a4ef26edb
parent 54670 cfb21e03fe2a
parent 54635 30666a281ae3
child 54672 748778ac0ab8
merged, resolving obvious conflicts in NEWS and src/Pure/System/isabelle_process.ML;
Admin/MacOS/App1/README
Admin/MacOS/App1/build
Admin/MacOS/App1/script
Admin/MacOS/App2/Isabelle.app/Contents/Info.plist
Admin/MacOS/App2/Isabelle.app/Contents/MacOS/Isabelle
Admin/MacOS/App2/README
Admin/MacOS/App2/mk
Admin/MacOS/App3/Info.plist-part1
Admin/MacOS/App3/Info.plist-part2
Admin/MacOS/App3/README
Admin/MacOS/App3/Resources/en.lproj/Localizable.strings
Admin/MacOS/isabelle.icns
Admin/MacOS/theory.icns
Admin/Windows/launch4j/README
Admin/Windows/launch4j/isabelle.ico
Admin/Windows/launch4j/isabelle.xml
Admin/lib/Tools/makedist_bundle
NEWS
src/Doc/JEdit/JEdit.thy
src/HOL/BNF/Coinduction.thy
src/HOL/BNF/Countable_Type.thy
src/HOL/BNF/Ctr_Sugar.thy
src/HOL/BNF/Tools/bnf_fp_rec_sugar.ML
src/HOL/BNF/Tools/bnf_fp_rec_sugar_tactics.ML
src/HOL/BNF/Tools/coinduction.ML
src/HOL/BNF/Tools/ctr_sugar.ML
src/HOL/BNF/Tools/ctr_sugar_tactics.ML
src/HOL/BNF/Tools/ctr_sugar_util.ML
src/HOL/Cardinals/Cardinal_Order_Relation_Base.thy
src/HOL/Cardinals/Constructions_on_Wellorders_Base.thy
src/HOL/Cardinals/Fun_More_Base.thy
src/HOL/Cardinals/Order_Relation_More_Base.thy
src/HOL/Cardinals/Wellfounded_More_Base.thy
src/HOL/Cardinals/Wellorder_Embedding_Base.thy
src/HOL/Cardinals/Wellorder_Relation_Base.thy
src/HOL/Library/Abstract_Rat.thy
src/HOL/Library/Glbs.thy
src/HOL/Library/Order_Relation.thy
src/HOL/Library/Order_Union.thy
src/HOL/Library/Univ_Poly.thy
src/HOL/Lubs.thy
src/Pure/Concurrent/future.ML
src/Pure/PIDE/command.ML
src/Pure/System/isabelle_process.ML
src/Pure/build-jars
src/Tools/jEdit/src/theories_dockable.scala
     1.1 --- a/.hgignore	Thu Dec 05 17:52:12 2013 +0100
     1.2 +++ b/.hgignore	Thu Dec 05 17:58:03 2013 +0100
     1.3 @@ -5,7 +5,9 @@
     1.4  *.jar
     1.5  *.orig
     1.6  *.rej
     1.7 +*.pyc
     1.8  .DS_Store
     1.9 +.swp
    1.10  
    1.11  
    1.12  syntax: regexp
     2.1 --- a/Admin/MacOS/App1/README	Thu Dec 05 17:52:12 2013 +0100
     2.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.3 @@ -1,14 +0,0 @@
     2.4 -Isabelle application bundle for MacOS
     2.5 -=====================================
     2.6 -
     2.7 -Requirements:
     2.8 -
     2.9 -* CocoaDialog 2.1.1 http://cocoadialog.sourceforge.net/
    2.10 -
    2.11 -* Platypus 4.7 http://www.sveinbjorn.org/platypus
    2.12 -  Preferences: Install command line tool
    2.13 -
    2.14 -* final packaging:
    2.15 -
    2.16 -  hdiutil create -srcfolder DIR DMG
    2.17 -
     3.1 --- a/Admin/MacOS/App1/build	Thu Dec 05 17:52:12 2013 +0100
     3.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.3 @@ -1,23 +0,0 @@
     3.4 -#!/usr/bin/env bash
     3.5 -#
     3.6 -# Make Isabelle application bundle
     3.7 -
     3.8 -THIS="$(cd "$(dirname "$0")"; pwd)"
     3.9 -
    3.10 -COCOADIALOG_APP="/Applications/CocoaDialog.app"
    3.11 -
    3.12 -/usr/local/bin/platypus \
    3.13 -  -a Isabelle -u Isabelle \
    3.14 -  -I "de.tum.in.isabelle" \
    3.15 -  -i "$THIS/../isabelle.icns" \
    3.16 -  -D -X thy \
    3.17 -  -Q "$THIS/../theory.icns" \
    3.18 -  -p /bin/bash \
    3.19 -  -R \
    3.20 -  -o None \
    3.21 -  -f "$COCOADIALOG_APP" \
    3.22 -  "$THIS/script" \
    3.23 -  "$PWD/Isabelle.app"
    3.24 -
    3.25 -rm -f Contents/Resources/Isabelle
    3.26 -ln -s Contents/Resources/Isabelle Isabelle.app/Isabelle
    3.27 \ No newline at end of file
     4.1 --- a/Admin/MacOS/App1/script	Thu Dec 05 17:52:12 2013 +0100
     4.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.3 @@ -1,82 +0,0 @@
     4.4 -#!/usr/bin/env bash
     4.5 -#
     4.6 -# Author: Makarius
     4.7 -#
     4.8 -# Isabelle application wrapper
     4.9 -
    4.10 -THIS="$(cd "$(dirname "$0")"; pwd)"
    4.11 -THIS_APP="$(cd "$THIS/../.."; pwd)"
    4.12 -SUPER_APP="$(cd "$THIS/../../.."; pwd)"
    4.13 -
    4.14 -
    4.15 -# global defaults
    4.16 -
    4.17 -ISABELLE_TOOL="$THIS/Isabelle/bin/isabelle"
    4.18 -PROOFGENERAL_EMACS="$THIS/Aquamacs.app/Contents/MacOS/Aquamacs"
    4.19 -
    4.20 -
    4.21 -# environment
    4.22 -
    4.23 -cd "$HOME"
    4.24 -if [ -x /usr/libexec/path_helper ]; then
    4.25 -  eval $(/usr/libexec/path_helper -s)
    4.26 -fi
    4.27 -
    4.28 -[ -z "$LANG" ] && export LANG=en_US.UTF-8
    4.29 -
    4.30 -
    4.31 -# run interface with error feedback
    4.32 -
    4.33 -ISABELLE_INTERFACE_CHOICE="$("$ISABELLE_TOOL" getenv -b ISABELLE_INTERFACE_CHOICE)"
    4.34 -if [ "$ISABELLE_INTERFACE_CHOICE" != emacs -a "$ISABELLE_INTERFACE_CHOICE" != jedit ]
    4.35 -then
    4.36 -  declare -a CHOICE
    4.37 -  CHOICE=($("$THIS/CocoaDialog.app/Contents/MacOS/CocoaDialog" dropdown \
    4.38 -    --title Isabelle \
    4.39 -    --text "Which Isabelle interface?" \
    4.40 -    --items "Isabelle/jEdit PIDE" "Emacs / Proof General" \
    4.41 -    --button2 "OK, do not ask again" --button1 "OK"))
    4.42 -  if [ "${CHOICE[1]}" = 0 ]; then
    4.43 -    ISABELLE_INTERFACE_CHOICE=jedit
    4.44 -  else
    4.45 -    ISABELLE_INTERFACE_CHOICE=emacs
    4.46 -  fi
    4.47 -  if [ "${CHOICE[0]}" = 2 ]; then
    4.48 -    ISABELLE_HOME_USER="$("$ISABELLE_TOOL" getenv -b ISABELLE_HOME_USER)"
    4.49 -    mkdir -p "$ISABELLE_HOME_USER/etc"
    4.50 -    ( echo; echo "ISABELLE_INTERFACE_CHOICE=$ISABELLE_INTERFACE_CHOICE"; ) \
    4.51 -      >> "$ISABELLE_HOME_USER/etc/settings"
    4.52 -    "$THIS/CocoaDialog.app/Contents/MacOS/CocoaDialog" ok-msgbox \
    4.53 -      --title Isabelle \
    4.54 -      --text Note \
    4.55 -      --informative-text "ISABELLE_INTERFACE_CHOICE stored in $ISABELLE_HOME_USER/etc/settings" \
    4.56 -      --no-cancel
    4.57 -  fi
    4.58 -fi
    4.59 -
    4.60 -OUTPUT="/tmp/isabelle$$.out"
    4.61 -
    4.62 -if [ "$ISABELLE_INTERFACE_CHOICE" = emacs ]; then
    4.63 -  ( "$ISABELLE_TOOL" emacs -p "$PROOFGENERAL_EMACS" "$@" ) > "$OUTPUT" 2>&1
    4.64 -  RC=$?
    4.65 -else
    4.66 -  ( "$ISABELLE_TOOL" jedit -s "$@" ) > "$OUTPUT" 2>&1
    4.67 -  RC=$?
    4.68 -fi
    4.69 -
    4.70 -if [ "$RC" != 0 ]; then
    4.71 -  echo >> "$OUTPUT"
    4.72 -  echo "Return code: $RC" >> "$OUTPUT"
    4.73 -fi
    4.74 -
    4.75 -if [ $(stat -f "%z" "$OUTPUT") != 0 ]; then
    4.76 -  "$THIS/CocoaDialog.app/Contents/MacOS/CocoaDialog" textbox \
    4.77 -    --title "Isabelle" \
    4.78 -    --informative-text "Isabelle output" \
    4.79 -    --text-from-file "$OUTPUT" \
    4.80 -    --button1 "OK"
    4.81 -fi
    4.82 -
    4.83 -rm -f "$OUTPUT"
    4.84 -
    4.85 -exit "$RC"
     5.1 --- a/Admin/MacOS/App2/Isabelle.app/Contents/Info.plist	Thu Dec 05 17:52:12 2013 +0100
     5.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.3 @@ -1,48 +0,0 @@
     5.4 -<?xml version="1.0" encoding="UTF-8"?>
     5.5 -<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
     5.6 -<plist version="1.0">
     5.7 -<dict>
     5.8 -	<key>CFBundleDevelopmentRegion</key>
     5.9 -	<string>English</string>
    5.10 -	<key>CFBundleExecutable</key>
    5.11 -	<string>Isabelle</string>
    5.12 -	<key>CFBundleGetInfoString</key>
    5.13 -	<string>Isabelle</string>
    5.14 -	<key>CFBundleIconFile</key>
    5.15 -	<string>isabelle.icns</string>
    5.16 -	<key>CFBundleIdentifier</key>
    5.17 -	<string>de.tum.in.isabelle</string>
    5.18 -	<key>CFBundleInfoDictionaryVersion</key>
    5.19 -	<string>6.0</string>
    5.20 -	<key>CFBundleName</key>
    5.21 -	<string>Isabelle</string>
    5.22 -	<key>CFBundlePackageType</key>
    5.23 -	<string>APPL</string>
    5.24 -	<key>CFBundleShortVersionString</key>
    5.25 -	<string>????</string>
    5.26 -	<key>CFBundleSignature</key>
    5.27 -	<string>????</string>
    5.28 -	<key>CFBundleVersion</key>
    5.29 -	<string>????</string>
    5.30 -	<key>Java</key>
    5.31 -	<dict>
    5.32 -		<key>JVMVersion</key>
    5.33 -		<string>1.6</string>
    5.34 -		<key>VMOptions</key>
    5.35 -		<string>-Xms128m -Xmx512m -Xss2m</string>
    5.36 -		<key>ClassPath</key>
    5.37 -		<string>$JAVAROOT/isabelle-scala.jar</string>
    5.38 -		<key>MainClass</key>
    5.39 -		<string>isabelle.GUI_Setup</string>
    5.40 -		<key>Properties</key>
    5.41 -		<dict>
    5.42 -			<key>isabelle.home</key>
    5.43 -			<string>$APP_PACKAGE/Contents/Resources/Isabelle</string>
    5.44 -			<key>apple.laf.useScreenMenuBar</key>
    5.45 -			<string>true</string>
    5.46 -			<key>com.apple.mrj.application.apple.menu.about.name</key>
    5.47 -			<string>Isabelle</string>
    5.48 -		</dict>
    5.49 -	</dict>
    5.50 -</dict>
    5.51 -</plist>
     6.1 --- a/Admin/MacOS/App2/Isabelle.app/Contents/MacOS/Isabelle	Thu Dec 05 17:52:12 2013 +0100
     6.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.3 @@ -1,1 +0,0 @@
     6.4 -/System/Library/Frameworks/JavaVM.framework/Resources/MacOS/JavaApplicationStub
     6.5 \ No newline at end of file
     7.1 --- a/Admin/MacOS/App2/README	Thu Dec 05 17:52:12 2013 +0100
     7.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.3 @@ -1,7 +0,0 @@
     7.4 -Isabelle/JVM application bundle for MacOS
     7.5 -=========================================
     7.6 -
     7.7 -* http://developer.apple.com/documentation/Java/Conceptual/Java14Development/03-JavaDeployment/JavaDeployment.html
     7.8 -
     7.9 -* http://developer.apple.com/documentation/Java/Reference/Java_InfoplistRef/Articles/JavaDictionaryInfo.plistKeys.html#//apple_ref/doc/uid/TP40001969
    7.10 -
     8.1 --- a/Admin/MacOS/App2/mk	Thu Dec 05 17:52:12 2013 +0100
     8.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.3 @@ -1,12 +0,0 @@
     8.4 -#!/usr/bin/env bash
     8.5 -#
     8.6 -# Make Isabelle/JVM application bundle
     8.7 -
     8.8 -THIS="$(cd "$(dirname "$0")"; pwd)"
     8.9 -
    8.10 -APP="$THIS/Isabelle.app"
    8.11 -
    8.12 -mkdir -p "$APP/Contents/Resources/Java"
    8.13 -cp "$THIS/../../../lib/classes/isabelle-scala.jar" "$APP/Contents/Resources/Java"
    8.14 -cp "$THIS/../isabelle.icns" "$APP/Contents/Resources"
    8.15 -
     9.1 --- a/Admin/MacOS/App3/Info.plist-part1	Thu Dec 05 17:52:12 2013 +0100
     9.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3 @@ -1,36 +0,0 @@
     9.4 -<?xml version="1.0" ?>
     9.5 -<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
     9.6 -<plist version="1.0">
     9.7 -<dict>
     9.8 -<key>CFBundleDevelopmentRegion</key>
     9.9 -<string>English</string>
    9.10 -<key>CFBundleExecutable</key>
    9.11 -<string>JavaAppLauncher</string>
    9.12 -<key>CFBundleIconFile</key>
    9.13 -<string>isabelle.icns</string>
    9.14 -<key>CFBundleIdentifier</key>
    9.15 -<string>de.tum.in.isabelle</string>
    9.16 -<key>CFBundleDisplayName</key>
    9.17 -<string>{ISABELLE_NAME}</string>
    9.18 -<key>CFBundleInfoDictionaryVersion</key>
    9.19 -<string>6.0</string>
    9.20 -<key>CFBundleName</key>
    9.21 -<string>{ISABELLE_NAME}</string>
    9.22 -<key>CFBundlePackageType</key>
    9.23 -<string>APPL</string>
    9.24 -<key>CFBundleShortVersionString</key>
    9.25 -<string>1.0</string>
    9.26 -<key>CFBundleSignature</key>
    9.27 -<string>????</string>
    9.28 -<key>CFBundleVersion</key>
    9.29 -<string>1</string>
    9.30 -<key>NSHumanReadableCopyright</key>
    9.31 -<string></string>
    9.32 -<key>LSApplicationCategoryType</key>
    9.33 -<string>public.app-category.developer-tools</string>
    9.34 -<key>JVMRuntime</key>
    9.35 -<string>jdk</string>
    9.36 -<key>JVMMainClassName</key>
    9.37 -<string>isabelle.Main</string>
    9.38 -<key>JVMOptions</key>
    9.39 -<array>
    10.1 --- a/Admin/MacOS/App3/Info.plist-part2	Thu Dec 05 17:52:12 2013 +0100
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,7 +0,0 @@
    10.4 -<string>-Disabelle.home=$APP_ROOT/Contents/Resources/{ISABELLE_NAME}</string>
    10.5 -</array>
    10.6 -<key>JVMArguments</key>
    10.7 -<array>
    10.8 -</array>
    10.9 -</dict>
   10.10 -</plist>
    11.1 --- a/Admin/MacOS/App3/README	Thu Dec 05 17:52:12 2013 +0100
    11.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.3 @@ -1,8 +0,0 @@
    11.4 -Isabelle/JVM application bundle for Mac OS X
    11.5 -============================================
    11.6 -
    11.7 -* http://java.net/projects/appbundler
    11.8 -
    11.9 -  see appbundler-1.0.jar
   11.10 -  see com/oracle/appbundler/JavaAppLauncher
   11.11 -
    12.1 --- a/Admin/MacOS/App3/Resources/en.lproj/Localizable.strings	Thu Dec 05 17:52:12 2013 +0100
    12.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.3 @@ -1,3 +0,0 @@
    12.4 -"JRELoadError" = "Unable to load Java Runtime Environment.";
    12.5 -"MainClassNameRequired" = "Main class name is required.";
    12.6 -"JavaDirectoryNotFound" = "Unable to enumerate Java directory contents.";
    13.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.2 +++ b/Admin/MacOS/Info.plist-part1	Thu Dec 05 17:58:03 2013 +0100
    13.3 @@ -0,0 +1,36 @@
    13.4 +<?xml version="1.0" ?>
    13.5 +<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
    13.6 +<plist version="1.0">
    13.7 +<dict>
    13.8 +<key>CFBundleDevelopmentRegion</key>
    13.9 +<string>English</string>
   13.10 +<key>CFBundleExecutable</key>
   13.11 +<string>JavaAppLauncher</string>
   13.12 +<key>CFBundleIconFile</key>
   13.13 +<string>isabelle.icns</string>
   13.14 +<key>CFBundleIdentifier</key>
   13.15 +<string>de.tum.in.isabelle</string>
   13.16 +<key>CFBundleDisplayName</key>
   13.17 +<string>{ISABELLE_NAME}</string>
   13.18 +<key>CFBundleInfoDictionaryVersion</key>
   13.19 +<string>6.0</string>
   13.20 +<key>CFBundleName</key>
   13.21 +<string>{ISABELLE_NAME}</string>
   13.22 +<key>CFBundlePackageType</key>
   13.23 +<string>APPL</string>
   13.24 +<key>CFBundleShortVersionString</key>
   13.25 +<string>1.0</string>
   13.26 +<key>CFBundleSignature</key>
   13.27 +<string>????</string>
   13.28 +<key>CFBundleVersion</key>
   13.29 +<string>1</string>
   13.30 +<key>NSHumanReadableCopyright</key>
   13.31 +<string></string>
   13.32 +<key>LSApplicationCategoryType</key>
   13.33 +<string>public.app-category.developer-tools</string>
   13.34 +<key>JVMRuntime</key>
   13.35 +<string>jdk</string>
   13.36 +<key>JVMMainClassName</key>
   13.37 +<string>isabelle.Main</string>
   13.38 +<key>JVMOptions</key>
   13.39 +<array>
    14.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.2 +++ b/Admin/MacOS/Info.plist-part2	Thu Dec 05 17:58:03 2013 +0100
    14.3 @@ -0,0 +1,7 @@
    14.4 +<string>-Disabelle.home=$APP_ROOT/Contents/Resources/{ISABELLE_NAME}</string>
    14.5 +</array>
    14.6 +<key>JVMArguments</key>
    14.7 +<array>
    14.8 +</array>
    14.9 +</dict>
   14.10 +</plist>
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/Admin/MacOS/README	Thu Dec 05 17:58:03 2013 +0100
    15.3 @@ -0,0 +1,8 @@
    15.4 +Isabelle/JVM application bundle for Mac OS X
    15.5 +============================================
    15.6 +
    15.7 +* http://java.net/projects/appbundler
    15.8 +
    15.9 +  see appbundler-1.0.jar
   15.10 +  see com/oracle/appbundler/JavaAppLauncher
   15.11 +
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/Admin/MacOS/Resources/en.lproj/Localizable.strings	Thu Dec 05 17:58:03 2013 +0100
    16.3 @@ -0,0 +1,3 @@
    16.4 +"JRELoadError" = "Unable to load Java Runtime Environment.";
    16.5 +"MainClassNameRequired" = "Main class name is required.";
    16.6 +"JavaDirectoryNotFound" = "Unable to enumerate Java directory contents.";
    17.1 Binary file Admin/MacOS/Resources/isabelle.icns has changed
    18.1 Binary file Admin/MacOS/Resources/theory.icns has changed
    19.1 Binary file Admin/MacOS/isabelle.icns has changed
    20.1 Binary file Admin/MacOS/theory.icns has changed
    21.1 --- a/Admin/Windows/launch4j/README	Thu Dec 05 17:52:12 2013 +0100
    21.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.3 @@ -1,4 +0,0 @@
    21.4 -Java application wrapper for Windows
    21.5 -====================================
    21.6 -
    21.7 -* http://launch4j.sourceforge.net
    22.1 Binary file Admin/Windows/launch4j/isabelle.ico has changed
    23.1 --- a/Admin/Windows/launch4j/isabelle.xml	Thu Dec 05 17:52:12 2013 +0100
    23.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.3 @@ -1,39 +0,0 @@
    23.4 -<launch4jConfig>
    23.5 -  <dontWrapJar>true</dontWrapJar>
    23.6 -  <headerType>gui</headerType>
    23.7 -  <jar></jar>
    23.8 -  <outfile>Isabelle.exe</outfile>
    23.9 -  <errTitle></errTitle>
   23.10 -  <cmdLine></cmdLine>
   23.11 -  <chdir></chdir>
   23.12 -  <priority>normal</priority>
   23.13 -  <downloadUrl></downloadUrl>
   23.14 -  <supportUrl></supportUrl>
   23.15 -  <customProcName>false</customProcName>
   23.16 -  <stayAlive>true</stayAlive>
   23.17 -  <manifest></manifest>
   23.18 -  <icon>isabelle.ico</icon>
   23.19 -  <classPath>
   23.20 -    <mainClass>isabelle.Main</mainClass>
   23.21 -    <cp>%EXEDIR%\lib\classes\ext\Pure.jar</cp>
   23.22 -    <cp>%EXEDIR%\lib\classes\ext\scala-compiler.jar</cp>
   23.23 -    <cp>%EXEDIR%\lib\classes\ext\scala-library.jar</cp>
   23.24 -    <cp>%EXEDIR%\lib\classes\ext\scala-swing.jar</cp>
   23.25 -    <cp>%EXEDIR%\lib\classes\ext\scala-actors.jar</cp>
   23.26 -    <cp>%EXEDIR%\lib\classes\ext\scala-reflect.jar</cp>
   23.27 -    <cp>%EXEDIR%\src\Tools\jEdit\dist\jedit.jar</cp>
   23.28 -  </classPath>
   23.29 -  <jre>
   23.30 -    <path>%EXEDIR%\contrib\jdk\x86-cygwin</path>
   23.31 -    <minVersion></minVersion>
   23.32 -    <maxVersion></maxVersion>
   23.33 -    <jdkPreference>jdkOnly</jdkPreference>
   23.34 -    <opt>-Dfile.encoding=UTF-8 -server -Xms128m -Xmx1024m -Xss2m -Dactors.corePoolSize=4 -Dactors.enableForkJoin=false -Disabelle.home=&quot;%EXEDIR%&quot;</opt>
   23.35 -  </jre>
   23.36 -  <splash>
   23.37 -    <file>isabelle.bmp</file>
   23.38 -    <waitForWindow>false</waitForWindow>
   23.39 -    <timeout>10</timeout>
   23.40 -    <timeoutErr>false</timeoutErr>
   23.41 -  </splash>
   23.42 -</launch4jConfig>
   23.43 \ No newline at end of file
    24.1 --- a/Admin/isatest/isatest-stats	Thu Dec 05 17:52:12 2013 +0100
    24.2 +++ b/Admin/isatest/isatest-stats	Thu Dec 05 17:58:03 2013 +0100
    24.3 @@ -14,11 +14,9 @@
    24.4    HOL-Auth
    24.5    HOL-BNF
    24.6    HOL-BNF-Examples
    24.7 +  HOL-BNF-LFP
    24.8    HOL-BNF-Nitpick_Examples
    24.9 -  HOL-BNF-LFP
   24.10    HOL-Bali
   24.11 -  HOL-Boogie
   24.12 -  HOL-Boogie-Examples
   24.13    HOL-Cardinals
   24.14    HOL-Cardinals-Base
   24.15    HOL-Codegenerator_Test
    25.1 --- a/Admin/lib/Tools/makedist_bundle	Thu Dec 05 17:52:12 2013 +0100
    25.2 +++ b/Admin/lib/Tools/makedist_bundle	Thu Dec 05 17:58:03 2013 +0100
    25.3 @@ -261,7 +261,7 @@
    25.4        (
    25.5          cd "$TMP"
    25.6  
    25.7 -        APP_TEMPLATE="$ISABELLE_HOME/Admin/MacOS/App3"
    25.8 +        APP_TEMPLATE="$ISABELLE_HOME/Admin/MacOS"
    25.9          APP="${ISABELLE_NAME}.app"
   25.10  
   25.11          for NAME in Java MacOS PlugIns Resources
   25.12 @@ -289,7 +289,6 @@
   25.13          done
   25.14  
   25.15          cp -R "$APP_TEMPLATE/Resources/." "$APP/Contents/Resources/."
   25.16 -        cp "$APP_TEMPLATE/../isabelle.icns" "$APP/Contents/Resources/."
   25.17  
   25.18          ln -sf "../Resources/${ISABELLE_NAME}/contrib/jdk/x86_64-darwin" \
   25.19            "$APP/Contents/PlugIns/jdk"
    26.1 --- a/CONTRIBUTORS	Thu Dec 05 17:52:12 2013 +0100
    26.2 +++ b/CONTRIBUTORS	Thu Dec 05 17:58:03 2013 +0100
    26.3 @@ -3,6 +3,10 @@
    26.4  who is listed as an author in one of the source files of this Isabelle
    26.5  distribution.
    26.6  
    26.7 +Contributions to this Isabelle version
    26.8 +--------------------------------------
    26.9 +
   26.10 +
   26.11  Contributions to Isabelle2013-1
   26.12  -------------------------------
   26.13  
    27.1 --- a/NEWS	Thu Dec 05 17:52:12 2013 +0100
    27.2 +++ b/NEWS	Thu Dec 05 17:58:03 2013 +0100
    27.3 @@ -1,6 +1,98 @@
    27.4  Isabelle NEWS -- history user-relevant changes
    27.5  ==============================================
    27.6  
    27.7 +New in this Isabelle version
    27.8 +----------------------------
    27.9 +
   27.10 +*** Prover IDE -- Isabelle/Scala/jEdit ***
   27.11 +
   27.12 +* Auxiliary files ('ML_file' etc.) are managed by the Prover IDE.
   27.13 +Open text buffers take precedence over copies within the file-system.
   27.14 +
   27.15 +
   27.16 +*** HOL ***
   27.17 +
   27.18 +* Qualified constant names Wellfounded.acc, Wellfounded.accp.
   27.19 +INCOMPATIBILITY.
   27.20 +
   27.21 +* Fact generalization and consolidation:
   27.22 +    neq_one_mod_two, mod_2_not_eq_zero_eq_one_int ~> not_mod_2_eq_0_eq_1
   27.23 +INCOMPATIBILITY.
   27.24 +
   27.25 +* Purely algebraic definition of even.  Fact generalization and consolidation:
   27.26 +    nat_even_iff_2_dvd, int_even_iff_2_dvd ~> even_iff_2_dvd
   27.27 +    even_zero_(nat|int) ~> even_zero
   27.28 +INCOMPATIBILITY.
   27.29 +
   27.30 +* Abolished neg_numeral.
   27.31 +  * Canonical representation for minus one is "- 1".
   27.32 +  * Canonical representation for other negative numbers is "- (numeral _)".
   27.33 +  * When devising rule sets for number calculation, consider the
   27.34 +    following canonical cases: 0, 1, numeral _, - 1, - numeral _.
   27.35 +  * HOLogic.dest_number also recognizes numerals in non-canonical forms
   27.36 +    like "numeral One", "- numeral One", "- 0" and even "- … - _".
   27.37 +  * Syntax for negative numerals is mere input syntax.
   27.38 +INCOMPATBILITY.
   27.39 +
   27.40 +* Elimination of fact duplicates:
   27.41 +    equals_zero_I ~> minus_unique
   27.42 +    diff_eq_0_iff_eq ~> right_minus_eq
   27.43 +    nat_infinite ~> infinite_UNIV_nat
   27.44 +    int_infinite ~> infinite_UNIV_int
   27.45 +INCOMPATIBILITY.
   27.46 +
   27.47 +* Fact name consolidation:
   27.48 +    diff_def, diff_minus, ab_diff_minus ~> diff_conv_add_uminus
   27.49 +    minus_le_self_iff ~> neg_less_eq_nonneg
   27.50 +    le_minus_self_iff ~> less_eq_neg_nonpos
   27.51 +    neg_less_nonneg ~> neg_less_pos
   27.52 +    less_minus_self_iff ~> less_neg_neg [simp]
   27.53 +INCOMPATIBILITY.
   27.54 +
   27.55 +* More simplification rules on unary and binary minus:
   27.56 +add_diff_cancel, add_diff_cancel_left, add_le_same_cancel1,
   27.57 +add_le_same_cancel2, add_less_same_cancel1, add_less_same_cancel2,
   27.58 +add_minus_cancel, diff_add_cancel, le_add_same_cancel1,
   27.59 +le_add_same_cancel2, less_add_same_cancel1, less_add_same_cancel2,
   27.60 +minus_add_cancel, uminus_add_conv_diff.  These correspondingly
   27.61 +have been taken away from fact collections algebra_simps and
   27.62 +field_simps.  INCOMPATIBILITY.
   27.63 +
   27.64 +To restore proofs, the following patterns are helpful:
   27.65 +
   27.66 +a) Arbitrary failing proof not involving "diff_def":
   27.67 +Consider simplification with algebra_simps or field_simps.
   27.68 +
   27.69 +b) Lifting rules from addition to subtraction:
   27.70 +Try with "using <rule for addition> of [… "- _" …]" by simp".
   27.71 +
   27.72 +c) Simplification with "diff_def": just drop "diff_def".
   27.73 +Consider simplification with algebra_simps or field_simps;
   27.74 +or the brute way with
   27.75 +"simp add: diff_conv_add_uminus del: add_uminus_conv_diff".
   27.76 +
   27.77 +* SUP and INF generalized to conditionally_complete_lattice
   27.78 +
   27.79 +* Theory Lubs moved HOL image to HOL-Library. It is replaced by
   27.80 +Conditionally_Complete_Lattices.   INCOMPATIBILITY.
   27.81 +
   27.82 +* Introduce bdd_above and bdd_below in Conditionally_Complete_Lattices, use them
   27.83 +instead of explicitly stating boundedness of sets.
   27.84 +
   27.85 +* ccpo.admissible quantifies only over non-empty chains to allow
   27.86 +more syntax-directed proof rules; the case of the empty chain
   27.87 +shows up as additional case in fixpoint induction proofs.
   27.88 +INCOMPATIBILITY
   27.89 +
   27.90 +*** ML ***
   27.91 +
   27.92 +* Toplevel function "use" refers to raw ML bootstrap environment,
   27.93 +without Isar context nor antiquotations.  Potential INCOMPATIBILITY.
   27.94 +Note that 'ML_file' is the canonical command to load ML files into the
   27.95 +formal context.
   27.96 +
   27.97 +
   27.98 +
   27.99  New in Isabelle2013-2 (December 2013)
  27.100  -------------------------------------
  27.101  
  27.102 @@ -457,6 +549,10 @@
  27.103      sets ~> set
  27.104  IMCOMPATIBILITY.
  27.105  
  27.106 +* Nitpick:
  27.107 +  - Fixed soundness bug whereby mutually recursive datatypes could take
  27.108 +    infinite values.
  27.109 +
  27.110  
  27.111  *** ML ***
  27.112  
    28.1 --- a/etc/isar-keywords.el	Thu Dec 05 17:52:12 2013 +0100
    28.2 +++ b/etc/isar-keywords.el	Thu Dec 05 17:58:03 2013 +0100
    28.3 @@ -1,6 +1,6 @@
    28.4  ;;
    28.5  ;; Keyword classification tables for Isabelle/Isar.
    28.6 -;; Generated from HOL + HOL-Auth + HOL-BNF + HOL-BNF-LFP + HOL-Bali + HOL-Decision_Procs + HOL-IMP + HOL-Imperative_HOL + HOL-Import + HOL-Library + HOL-Mutabelle + HOL-Nominal + HOL-Proofs + HOL-Proofs-Extraction + HOL-SPARK + HOL-Statespace + HOL-TPTP + HOL-ex + HOLCF + Pure.
    28.7 +;; Generated from HOL + HOL-Auth + HOL-BNF + HOL-BNF-LFP + HOL-Bali + HOL-Decision_Procs + HOL-IMP + HOL-Imperative_HOL + HOL-Import + HOL-Library + HOL-Mutabelle + HOL-Nominal + HOL-Proofs + HOL-Proofs-Extraction + HOL-SPARK + HOL-Statespace + HOL-TPTP + HOL-Word-SMT_Examples + HOL-ex + HOLCF + Pure.
    28.8  ;; *** DO NOT EDIT *** DO NOT EDIT *** DO NOT EDIT ***
    28.9  ;;
   28.10  
   28.11 @@ -33,6 +33,7 @@
   28.12      "axiomatization"
   28.13      "back"
   28.14      "bnf"
   28.15 +    "boogie_file"
   28.16      "bundle"
   28.17      "by"
   28.18      "cannot_undo"
   28.19 @@ -343,7 +344,6 @@
   28.20      "module_name"
   28.21      "monos"
   28.22      "morphisms"
   28.23 -    "no_discs_sels"
   28.24      "notes"
   28.25      "obtains"
   28.26      "open"
   28.27 @@ -352,7 +352,6 @@
   28.28      "parametric"
   28.29      "permissive"
   28.30      "pervasive"
   28.31 -    "rep_compat"
   28.32      "shows"
   28.33      "structure"
   28.34      "type_class"
   28.35 @@ -487,6 +486,7 @@
   28.36      "atom_decl"
   28.37      "attribute_setup"
   28.38      "axiomatization"
   28.39 +    "boogie_file"
   28.40      "bundle"
   28.41      "case_of_simps"
   28.42      "class"
    29.1 --- a/src/Doc/Datatypes/Datatypes.thy	Thu Dec 05 17:52:12 2013 +0100
    29.2 +++ b/src/Doc/Datatypes/Datatypes.thy	Thu Dec 05 17:58:03 2013 +0100
    29.3 @@ -8,22 +8,9 @@
    29.4  *)
    29.5  
    29.6  theory Datatypes
    29.7 -imports Setup
    29.8 -keywords
    29.9 -  "primcorec_notyet" :: thy_decl
   29.10 +imports Setup "~~/src/HOL/Library/Simps_Case_Conv"
   29.11  begin
   29.12  
   29.13 -(*<*)
   29.14 -(* FIXME: Temporary setup until "primcorec" and "primcorecursive" are fully implemented. *)
   29.15 -ML_command {*
   29.16 -fun add_dummy_cmd _ _ lthy = lthy;
   29.17 -
   29.18 -val _ = Outer_Syntax.local_theory @{command_spec "primcorec_notyet"} ""
   29.19 -  (Parse.fixes -- Parse_Spec.where_alt_specs >> uncurry add_dummy_cmd);
   29.20 -*}
   29.21 -(*>*)
   29.22 -
   29.23 -
   29.24  section {* Introduction
   29.25    \label{sec:introduction} *}
   29.26  
   29.27 @@ -54,17 +41,19 @@
   29.28  
   29.29  text {*
   29.30  \noindent
   29.31 -The package also provides some convenience, notably automatically generated
   29.32 -discriminators and selectors.
   29.33 -
   29.34 -In addition to plain inductive datatypes, the new package supports coinductive
   29.35 -datatypes, or \emph{codatatypes}, which may have infinite values. For example,
   29.36 -the following command introduces the type of lazy lists, which comprises both
   29.37 -finite and infinite values:
   29.38 +Furthermore, the package provides a lot of convenience, including automatically
   29.39 +generated discriminators, selectors, and relators as well as a wealth of
   29.40 +properties about them.
   29.41 +
   29.42 +In addition to inductive datatypes, the new package supports coinductive
   29.43 +datatypes, or \emph{codatatypes}, which allow infinite values. For example, the
   29.44 +following command introduces the type of lazy lists, which comprises both finite
   29.45 +and infinite values:
   29.46  *}
   29.47  
   29.48  (*<*)
   29.49      locale early
   29.50 +    locale late
   29.51  (*>*)
   29.52      codatatype (*<*)(in early) (*>*)'a llist = LNil | LCons 'a "'a llist"
   29.53  
   29.54 @@ -80,10 +69,10 @@
   29.55      codatatype (*<*)(in early) (*>*)'a tree\<^sub>i\<^sub>i = Node\<^sub>i\<^sub>i 'a "'a tree\<^sub>i\<^sub>i llist"
   29.56  
   29.57  text {*
   29.58 -The first two tree types allow only finite branches, whereas the last two allow
   29.59 -branches of infinite length. Orthogonally, the nodes in the first and third
   29.60 -types have finite branching, whereas those of the second and fourth may have
   29.61 -infinitely many direct subtrees.
   29.62 +The first two tree types allow only paths of finite length, whereas the last two
   29.63 +allow infinite paths. Orthogonally, the nodes in the first and third types have
   29.64 +finitely many direct subtrees, whereas those of the second and fourth may have
   29.65 +infinite branching.
   29.66  
   29.67  To use the package, it is necessary to import the @{theory BNF} theory, which
   29.68  can be precompiled into the \texttt{HOL-BNF} image. The following commands show
   29.69 @@ -152,15 +141,15 @@
   29.70  
   29.71  
   29.72  \newbox\boxA
   29.73 -\setbox\boxA=\hbox{\texttt{nospam}}
   29.74 -
   29.75 -\newcommand\authoremaili{\texttt{blan{\color{white}nospam}\kern-\wd\boxA{}chette@\allowbreak
   29.76 +\setbox\boxA=\hbox{\texttt{NOSPAM}}
   29.77 +
   29.78 +\newcommand\authoremaili{\texttt{blan{\color{white}NOSPAM}\kern-\wd\boxA{}chette@\allowbreak
   29.79  in.\allowbreak tum.\allowbreak de}}
   29.80 -\newcommand\authoremailii{\texttt{lore{\color{white}nospam}\kern-\wd\boxA{}nz.panny@\allowbreak
   29.81 +\newcommand\authoremailii{\texttt{lore{\color{white}NOSPAM}\kern-\wd\boxA{}nz.panny@\allowbreak
   29.82  \allowbreak tum.\allowbreak de}}
   29.83 -\newcommand\authoremailiii{\texttt{pope{\color{white}nospam}\kern-\wd\boxA{}scua@\allowbreak
   29.84 +\newcommand\authoremailiii{\texttt{pope{\color{white}NOSPAM}\kern-\wd\boxA{}scua@\allowbreak
   29.85  in.\allowbreak tum.\allowbreak de}}
   29.86 -\newcommand\authoremailiv{\texttt{tray{\color{white}nospam}\kern-\wd\boxA{}tel@\allowbreak
   29.87 +\newcommand\authoremailiv{\texttt{tray{\color{white}NOSPAM}\kern-\wd\boxA{}tel@\allowbreak
   29.88  in.\allowbreak tum.\allowbreak de}}
   29.89  
   29.90  The commands @{command datatype_new} and @{command primrec_new} are expected to
   29.91 @@ -171,13 +160,6 @@
   29.92  Comments and bug reports concerning either the tool or this tutorial should be
   29.93  directed to the authors at \authoremaili, \authoremailii, \authoremailiii,
   29.94  and \authoremailiv.
   29.95 -
   29.96 -\begin{framed}
   29.97 -\noindent
   29.98 -\textbf{Warning:}\enskip This tutorial and the package it describes are under
   29.99 -construction. Please forgive their appearance. Should you have suggestions
  29.100 -or comments regarding either, please let the authors know.
  29.101 -\end{framed}
  29.102  *}
  29.103  
  29.104  
  29.105 @@ -195,7 +177,7 @@
  29.106  text {*
  29.107  Datatypes are illustrated through concrete examples featuring different flavors
  29.108  of recursion. More examples can be found in the directory
  29.109 -\verb|~~/src/HOL/BNF/Examples|.
  29.110 +\verb|~~/src/HOL/|\allowbreak\verb|BNF/Examples|.
  29.111  *}
  29.112  
  29.113  subsubsection {* Nonrecursive Types
  29.114 @@ -260,7 +242,8 @@
  29.115  
  29.116  text {*
  29.117  \noindent
  29.118 -Lists were shown in the introduction. Terminated lists are a variant:
  29.119 +Lists were shown in the introduction. Terminated lists are a variant that
  29.120 +stores a value of type @{typ 'b} at the very end:
  29.121  *}
  29.122  
  29.123      datatype_new (*<*)(in early) (*>*)('a, 'b) tlist = TNil 'b | TCons 'a "('a, 'b) tlist"
  29.124 @@ -310,7 +293,7 @@
  29.125  Not all nestings are admissible. For example, this command will fail:
  29.126  *}
  29.127  
  29.128 -    datatype_new 'a wrong = Wrong (*<*)'a
  29.129 +    datatype_new 'a wrong = W1 | W2 (*<*)'a
  29.130      typ (*>*)"'a wrong \<Rightarrow> 'a"
  29.131  
  29.132  text {*
  29.133 @@ -321,7 +304,7 @@
  29.134  *}
  29.135  
  29.136      datatype_new ('a, 'b) fn = Fn "'a \<Rightarrow> 'b"
  29.137 -    datatype_new 'a also_wrong = Also_Wrong (*<*)'a
  29.138 +    datatype_new 'a also_wrong = W1 | W2 (*<*)'a
  29.139      typ (*>*)"('a also_wrong, 'a) fn"
  29.140  
  29.141  text {*
  29.142 @@ -344,20 +327,30 @@
  29.143  datatype_new} and @{command codatatype} commands.
  29.144  Section~\ref{sec:registering-bounded-natural-functors} explains how to register
  29.145  arbitrary type constructors as BNFs.
  29.146 +
  29.147 +Here is another example that fails:
  29.148  *}
  29.149  
  29.150 -
  29.151 -subsubsection {* Custom Names and Syntaxes
  29.152 -  \label{sssec:datatype-custom-names-and-syntaxes} *}
  29.153 +    datatype_new 'a pow_list = PNil 'a (*<*)'a
  29.154 +    datatype_new 'a pow_list' = PNil' 'a (*>*)| PCons "('a * 'a) pow_list"
  29.155 +
  29.156 +text {*
  29.157 +\noindent
  29.158 +This one features a different flavor of nesting, where the recursive call in the
  29.159 +type specification occurs around (rather than inside) another type constructor.
  29.160 +*}
  29.161 +
  29.162 +subsubsection {* Auxiliary Constants and Properties
  29.163 +  \label{sssec:datatype-auxiliary-constants-and-properties} *}
  29.164  
  29.165  text {*
  29.166  The @{command datatype_new} command introduces various constants in addition to
  29.167  the constructors. With each datatype are associated set functions, a map
  29.168  function, a relator, discriminators, and selectors, all of which can be given
  29.169 -custom names. In the example below, the traditional names
  29.170 -@{text set}, @{text map}, @{text list_all2}, @{text null}, @{text hd}, and
  29.171 -@{text tl} override the default names @{text list_set}, @{text list_map}, @{text
  29.172 -list_rel}, @{text is_Nil}, @{text un_Cons1}, and @{text un_Cons2}:
  29.173 +custom names. In the example below, the familiar names @{text null}, @{text hd},
  29.174 +@{text tl}, @{text set}, @{text map}, and @{text list_all2}, override the
  29.175 +default names @{text is_Nil}, @{text un_Cons1}, @{text un_Cons2},
  29.176 +@{text set_list}, @{text map_list}, and @{text rel_list}:
  29.177  *}
  29.178  
  29.179  (*<*)
  29.180 @@ -370,7 +363,7 @@
  29.181        Cons (infixr "#" 65)
  29.182  
  29.183      hide_type list
  29.184 -    hide_const Nil Cons hd tl set map list_all2 list_case list_rec
  29.185 +    hide_const Nil Cons hd tl set map list_all2
  29.186  
  29.187      context early begin
  29.188  (*>*)
  29.189 @@ -380,14 +373,34 @@
  29.190  
  29.191  text {*
  29.192  \noindent
  29.193 -The command introduces a discriminator @{const null} and a pair of selectors
  29.194 -@{const hd} and @{const tl} characterized as follows:
  29.195 +
  29.196 +\begin{tabular}{@ {}ll@ {}}
  29.197 +Constructors: &
  29.198 +  @{text "Nil \<Colon> 'a list"} \\
  29.199 +&
  29.200 +  @{text "Cons \<Colon> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list"} \\
  29.201 +Discriminator: &
  29.202 +  @{text "null \<Colon> 'a list \<Rightarrow> bool"} \\
  29.203 +Selectors: &
  29.204 +  @{text "hd \<Colon> 'a list \<Rightarrow> 'a"} \\
  29.205 +&
  29.206 +  @{text "tl \<Colon> 'a list \<Rightarrow> 'a list"} \\
  29.207 +Set function: &
  29.208 +  @{text "set \<Colon> 'a list \<Rightarrow> 'a set"} \\
  29.209 +Map function: &
  29.210 +  @{text "map \<Colon> ('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list"} \\
  29.211 +Relator: &
  29.212 +  @{text "list_all2 \<Colon> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> bool"}
  29.213 +\end{tabular}
  29.214 +
  29.215 +The discriminator @{const null} and the selectors @{const hd} and @{const tl}
  29.216 +are characterized as follows:
  29.217  %
  29.218  \[@{thm list.collapse(1)[of xs, no_vars]}
  29.219    \qquad @{thm list.collapse(2)[of xs, no_vars]}\]
  29.220  %
  29.221 -For two-constructor datatypes, a single discriminator constant suffices. The
  29.222 -discriminator associated with @{const Cons} is simply
  29.223 +For two-constructor datatypes, a single discriminator constant is sufficient.
  29.224 +The discriminator associated with @{const Cons} is simply
  29.225  @{term "\<lambda>xs. \<not> null xs"}.
  29.226  
  29.227  The @{text defaults} clause following the @{const Nil} constructor specifies a
  29.228 @@ -447,7 +460,7 @@
  29.229    @@{command datatype_new} target? @{syntax dt_options}? \\
  29.230      (@{syntax dt_name} '=' (@{syntax ctor} + '|') + @'and')
  29.231    ;
  29.232 -  @{syntax_def dt_options}: '(' (('no_discs_sels' | 'rep_compat') + ',') ')'
  29.233 +  @{syntax_def dt_options}: '(' (('no_discs_sels' | 'no_code' | 'rep_compat') + ',') ')'
  29.234  "}
  29.235  
  29.236  The syntactic entity \synt{target} can be used to specify a local
  29.237 @@ -464,6 +477,10 @@
  29.238  should be generated.
  29.239  
  29.240  \item
  29.241 +The @{text "no_code"} option indicates that the datatype should not be
  29.242 +registered for code generation.
  29.243 +
  29.244 +\item
  29.245  The @{text "rep_compat"} option indicates that the generated names should
  29.246  contain optional (and normally not displayed) ``@{text "new."}'' components to
  29.247  prevent clashes with a later call to \keyw{rep\_datatype}. See
  29.248 @@ -488,7 +505,7 @@
  29.249  reference manual \cite{isabelle-isar-ref}.
  29.250  
  29.251  The optional names preceding the type variables allow to override the default
  29.252 -names of the set functions (@{text t_set1}, \ldots, @{text t_setM}).
  29.253 +names of the set functions (@{text set1_t}, \ldots, @{text setM_t}).
  29.254  Inside a mutually recursive specification, all defined datatypes must
  29.255  mention exactly the same type variables in the same order.
  29.256  
  29.257 @@ -589,6 +606,10 @@
  29.258  or the function type. In principle, it should be possible to support old-style
  29.259  datatypes as well, but the command does not support this yet (and there is
  29.260  currently no way to register old-style datatypes as new-style datatypes).
  29.261 +
  29.262 +\item The recursor produced for types that recurse through functions has a
  29.263 +different signature than with the old package. This makes it impossible to use
  29.264 +the old \keyw{primrec} command.
  29.265  \end{itemize}
  29.266  
  29.267  An alternative to @{command datatype_new_compat} is to use the old package's
  29.268 @@ -609,7 +630,7 @@
  29.269  \begin{itemize}
  29.270  \setlength{\itemsep}{0pt}
  29.271  
  29.272 -\item \relax{Case combinator}: @{text t_case} (rendered using the familiar
  29.273 +\item \relax{Case combinator}: @{text t.case_t} (rendered using the familiar
  29.274  @{text case}--@{text of} syntax)
  29.275  
  29.276  \item \relax{Discriminators}: @{text "t.is_C\<^sub>1"}, \ldots,
  29.277 @@ -621,22 +642,22 @@
  29.278  \phantom{\relax{Selectors:}} @{text t.un_C\<^sub>n1}$, \ldots, @{text t.un_C\<^sub>nk\<^sub>n}.
  29.279  
  29.280  \item \relax{Set functions} (or \relax{natural transformations}):
  29.281 -@{text t_set1}, \ldots, @{text t_setm}
  29.282 -
  29.283 -\item \relax{Map function} (or \relax{functorial action}): @{text t_map}
  29.284 -
  29.285 -\item \relax{Relator}: @{text t_rel}
  29.286 -
  29.287 -\item \relax{Iterator}: @{text t_fold}
  29.288 -
  29.289 -\item \relax{Recursor}: @{text t_rec}
  29.290 +@{text set1_t}, \ldots, @{text t.setm_t}
  29.291 +
  29.292 +\item \relax{Map function} (or \relax{functorial action}): @{text t.map_t}
  29.293 +
  29.294 +\item \relax{Relator}: @{text t.rel_t}
  29.295 +
  29.296 +\item \relax{Iterator}: @{text t.fold_t}
  29.297 +
  29.298 +\item \relax{Recursor}: @{text t.rec_t}
  29.299  
  29.300  \end{itemize}
  29.301  
  29.302  \noindent
  29.303  The case combinator, discriminators, and selectors are collectively called
  29.304  \emph{destructors}. The prefix ``@{text "t."}'' is an optional component of the
  29.305 -name and is normally hidden. 
  29.306 +names and is normally hidden.
  29.307  *}
  29.308  
  29.309  
  29.310 @@ -687,8 +708,9 @@
  29.311  (*>*)
  29.312  
  29.313  text {*
  29.314 -The first subgroup of properties is concerned with the constructors.
  29.315 -They are listed below for @{typ "'a list"}:
  29.316 +The free constructor theorems are partitioned in three subgroups. The first
  29.317 +subgroup of properties is concerned with the constructors. They are listed below
  29.318 +for @{typ "'a list"}:
  29.319  
  29.320  \begin{indentblock}
  29.321  \begin{description}
  29.322 @@ -715,7 +737,7 @@
  29.323  \begin{indentblock}
  29.324  \begin{description}
  29.325  
  29.326 -\item[@{text "t."}\hthm{list.distinct {\upshape[}THEN notE}@{text ", elim!"}\hthm{\upshape]}\rm:] ~ \\
  29.327 +\item[@{text "t."}\hthm{distinct {\upshape[}THEN notE}@{text ", elim!"}\hthm{\upshape]}\rm:] ~ \\
  29.328  @{thm list.distinct(1)[THEN notE, elim!, no_vars]} \\
  29.329  @{thm list.distinct(2)[THEN notE, elim!, no_vars]}
  29.330  
  29.331 @@ -750,7 +772,7 @@
  29.332  \end{indentblock}
  29.333  
  29.334  \noindent
  29.335 -The third and last subgroup revolves around discriminators and selectors:
  29.336 +The third subgroup revolves around discriminators and selectors:
  29.337  
  29.338  \begin{indentblock}
  29.339  \begin{description}
  29.340 @@ -793,11 +815,15 @@
  29.341  \item[@{text "t."}\hthm{sel\_split\_asm}\rm:] ~ \\
  29.342  @{thm list.sel_split_asm[no_vars]}
  29.343  
  29.344 -\item[@{text "t."}\hthm{case\_conv\_if}\rm:] ~ \\
  29.345 -@{thm list.case_conv_if[no_vars]}
  29.346 +\item[@{text "t."}\hthm{case\_eq\_if}\rm:] ~ \\
  29.347 +@{thm list.case_eq_if[no_vars]}
  29.348  
  29.349  \end{description}
  29.350  \end{indentblock}
  29.351 +
  29.352 +\noindent
  29.353 +In addition, equational versions of @{text t.disc} are registered with the @{text "[code]"}
  29.354 +attribute.
  29.355  *}
  29.356  
  29.357  
  29.358 @@ -805,7 +831,9 @@
  29.359    \label{sssec:functorial-theorems} *}
  29.360  
  29.361  text {*
  29.362 -The BNF-related theorem are as follows:
  29.363 +The functorial theorems are partitioned in two subgroups. The first subgroup
  29.364 +consists of properties involving the constructors and either a set function, the
  29.365 +map function, or the relator:
  29.366  
  29.367  \begin{indentblock}
  29.368  \begin{description}
  29.369 @@ -818,16 +846,56 @@
  29.370  @{thm list.map(1)[no_vars]} \\
  29.371  @{thm list.map(2)[no_vars]}
  29.372  
  29.373 -\item[@{text "t."}\hthm{rel\_inject} @{text "[simp, code]"}\rm:] ~ \\
  29.374 +\item[@{text "t."}\hthm{rel\_inject} @{text "[simp]"}\rm:] ~ \\
  29.375  @{thm list.rel_inject(1)[no_vars]} \\
  29.376  @{thm list.rel_inject(2)[no_vars]}
  29.377  
  29.378 -\item[@{text "t."}\hthm{rel\_distinct} @{text "[simp, code]"}\rm:] ~ \\
  29.379 +\item[@{text "t."}\hthm{rel\_distinct} @{text "[simp]"}\rm:] ~ \\
  29.380  @{thm list.rel_distinct(1)[no_vars]} \\
  29.381  @{thm list.rel_distinct(2)[no_vars]}
  29.382  
  29.383  \end{description}
  29.384  \end{indentblock}
  29.385 +
  29.386 +\noindent
  29.387 +In addition, equational versions of @{text t.rel_inject} and @{text
  29.388 +rel_distinct} are registered with the @{text "[code]"} attribute.
  29.389 +
  29.390 +The second subgroup consists of more abstract properties of the set functions,
  29.391 +the map function, and the relator:
  29.392 +
  29.393 +\begin{indentblock}
  29.394 +\begin{description}
  29.395 +
  29.396 +\item[@{text "t."}\hthm{map\_comp}\rm:] ~ \\
  29.397 +@{thm list.map_cong0[no_vars]}
  29.398 +
  29.399 +\item[@{text "t."}\hthm{map\_cong} @{text "[fundef_cong]"}\rm:] ~ \\
  29.400 +@{thm list.map_cong[no_vars]}
  29.401 +
  29.402 +\item[@{text "t."}\hthm{map\_id}\rm:] ~ \\
  29.403 +@{thm list.map_id[no_vars]}
  29.404 +
  29.405 +\item[@{text "t."}\hthm{rel\_compp}\rm:] ~ \\
  29.406 +@{thm list.rel_compp[no_vars]}
  29.407 +
  29.408 +\item[@{text "t."}\hthm{rel\_conversep}\rm:] ~ \\
  29.409 +@{thm list.rel_conversep[no_vars]}
  29.410 +
  29.411 +\item[@{text "t."}\hthm{rel\_eq}\rm:] ~ \\
  29.412 +@{thm list.rel_eq[no_vars]}
  29.413 +
  29.414 +\item[@{text "t."}\hthm{rel\_flip}\rm:] ~ \\
  29.415 +@{thm list.rel_flip[no_vars]}
  29.416 +
  29.417 +\item[@{text "t."}\hthm{rel\_mono}\rm:] ~ \\
  29.418 +@{thm list.rel_mono[no_vars]}
  29.419 +
  29.420 +\item[@{text "t."}\hthm{set\_map}\rm:] ~ \\
  29.421 +@{thm list.set_map[no_vars]}
  29.422 +
  29.423 +\end{description}
  29.424 +\end{indentblock}
  29.425  *}
  29.426  
  29.427  
  29.428 @@ -889,18 +957,22 @@
  29.429  is recommended to use @{command datatype_new_compat} or \keyw{rep\_datatype}
  29.430  to register new-style datatypes as old-style datatypes.
  29.431  
  29.432 -\item \emph{The recursor @{text "t_rec"} has a different signature for nested
  29.433 -recursive datatypes.} In the old package, nested recursion was internally
  29.434 -reduced to mutual recursion. This reduction was visible in the type of the
  29.435 -recursor, used by \keyw{primrec}. In the new package, nested recursion is
  29.436 -handled in a more modular fashion. The old-style recursor can be generated on
  29.437 -demand using @{command primrec_new}, as explained in
  29.438 +\item \emph{The constants @{text t_case} and @{text t_rec} are now called
  29.439 +@{text case_t} and @{text rec_t}.}
  29.440 +
  29.441 +\item \emph{The recursor @{text rec_t} has a different signature for nested
  29.442 +recursive datatypes.} In the old package, nested recursion through non-functions
  29.443 +was internally reduced to mutual recursion. This reduction was visible in the
  29.444 +type of the recursor, used by \keyw{primrec}. Recursion through functions was
  29.445 +handled specially. In the new package, nested recursion (for functions and
  29.446 +non-functions) is handled in a more modular fashion. The old-style recursor can
  29.447 +be generated on demand using @{command primrec_new}, as explained in
  29.448  Section~\ref{sssec:primrec-nested-as-mutual-recursion}, if the recursion is via
  29.449  new-style datatypes.
  29.450  
  29.451 -\item \emph{Accordingly, the induction principle is different for nested
  29.452 -recursive datatypes.} Again, the old-style induction principle can be generated
  29.453 -on demand using @{command primrec_new}, as explained in
  29.454 +\item \emph{Accordingly, the induction rule is different for nested recursive
  29.455 +datatypes.} Again, the old-style induction rule can be generated on demand using
  29.456 +@{command primrec_new}, as explained in
  29.457  Section~\ref{sssec:primrec-nested-as-mutual-recursion}, if the recursion is via
  29.458  new-style datatypes.
  29.459  
  29.460 @@ -940,9 +1012,9 @@
  29.461    \label{sec:defining-recursive-functions} *}
  29.462  
  29.463  text {*
  29.464 -Recursive functions over datatypes can be specified using @{command
  29.465 -primrec_new}, which supports primitive recursion, or using the more general
  29.466 -\keyw{fun} and \keyw{function} commands. Here, the focus is on @{command
  29.467 +Recursive functions over datatypes can be specified using the @{command
  29.468 +primrec_new} command, which supports primitive recursion, or using the more
  29.469 +general \keyw{fun} and \keyw{function} commands. Here, the focus is on @{command
  29.470  primrec_new}; the other two commands are described in a separate tutorial
  29.471  \cite{isabelle-function}.
  29.472  
  29.473 @@ -1026,9 +1098,24 @@
  29.474  
  29.475  text {*
  29.476  \noindent
  29.477 -The next example is not primitive recursive, but it can be defined easily using
  29.478 -\keyw{fun}. The @{command datatype_new_compat} command is needed to register
  29.479 -new-style datatypes for use with \keyw{fun} and \keyw{function}
  29.480 +Pattern matching is only available for the argument on which the recursion takes
  29.481 +place. Fortunately, it is easy to generate pattern-maching equations using the
  29.482 +\keyw{simps\_of\_case} command provided by the theory
  29.483 +\verb|~~/src/HOL/Library/Simps_Case_Conv|.
  29.484 +*}
  29.485 +
  29.486 +    simps_of_case at_simps: at.simps
  29.487 +
  29.488 +text {*
  29.489 +This generates the lemma collection @{thm [source] at_simps}:
  29.490 +%
  29.491 +\[@{thm at_simps(1)[no_vars]}
  29.492 +  \qquad @{thm at_simps(2)[no_vars]}\]
  29.493 +%
  29.494 +The next example is defined using \keyw{fun} to escape the syntactic
  29.495 +restrictions imposed on primitive recursive functions. The
  29.496 +@{command datatype_new_compat} command is needed to register new-style datatypes
  29.497 +for use with \keyw{fun} and \keyw{function}
  29.498  (Section~\ref{sssec:datatype-new-compat}):
  29.499  *}
  29.500  
  29.501 @@ -1109,13 +1196,13 @@
  29.502  \noindent
  29.503  The next example features recursion through the @{text option} type. Although
  29.504  @{text option} is not a new-style datatype, it is registered as a BNF with the
  29.505 -map function @{const option_map}:
  29.506 +map function @{const map_option}:
  29.507  *}
  29.508  
  29.509      primrec_new (*<*)(in early) (*>*)sum_btree :: "('a\<Colon>{zero,plus}) btree \<Rightarrow> 'a" where
  29.510        "sum_btree (BNode a lt rt) =
  29.511 -         a + the_default 0 (option_map sum_btree lt) +
  29.512 -           the_default 0 (option_map sum_btree rt)"
  29.513 +         a + the_default 0 (map_option sum_btree lt) +
  29.514 +           the_default 0 (map_option sum_btree rt)"
  29.515  
  29.516  text {*
  29.517  \noindent
  29.518 @@ -1124,28 +1211,51 @@
  29.519  (@{text \<Rightarrow>}) is simply composition (@{text "op \<circ>"}):
  29.520  *}
  29.521  
  29.522 -    primrec_new (*<*)(in early) (*>*)ftree_map :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
  29.523 -      "ftree_map f (FTLeaf x) = FTLeaf (f x)" |
  29.524 -      "ftree_map f (FTNode g) = FTNode (ftree_map f \<circ> g)"
  29.525 +    primrec_new (*<*)(in early) (*>*)relabel_ft :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
  29.526 +      "relabel_ft f (FTLeaf x) = FTLeaf (f x)" |
  29.527 +      "relabel_ft f (FTNode g) = FTNode (relabel_ft f \<circ> g)"
  29.528 +
  29.529 +text {*
  29.530 +\noindent
  29.531 +For convenience, recursion through functions can also be expressed using
  29.532 +$\lambda$-abstractions and function application rather than through composition.
  29.533 +For example:
  29.534 +*}
  29.535 +
  29.536 +    primrec_new relabel_ft :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
  29.537 +      "relabel_ft f (FTLeaf x) = FTLeaf (f x)" |
  29.538 +      "relabel_ft f (FTNode g) = FTNode (\<lambda>x. relabel_ft f (g x))"
  29.539 +
  29.540 +text {* \blankline *}
  29.541 +
  29.542 +    primrec_new subtree_ft :: "'a \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
  29.543 +      "subtree_ft x (FTNode g) = g x"
  29.544  
  29.545  text {*
  29.546  \noindent
  29.547 -(No such map function is defined by the package because the type
  29.548 -variable @{typ 'a} is dead in @{typ "'a ftree"}.)
  29.549 -
  29.550 -Using \keyw{fun} or \keyw{function}, recursion through functions can be
  29.551 -expressed using $\lambda$-expressions and function application rather
  29.552 -than through composition. For example:
  29.553 +For recursion through curried $n$-ary functions, $n$ applications of
  29.554 +@{term "op \<circ>"} are necessary. The examples below illustrate the case where
  29.555 +$n = 2$:
  29.556  *}
  29.557  
  29.558 -    datatype_new_compat ftree
  29.559 +    datatype_new 'a ftree2 = FTLeaf2 'a | FTNode2 "'a \<Rightarrow> 'a \<Rightarrow> 'a ftree2"
  29.560  
  29.561  text {* \blankline *}
  29.562  
  29.563 -    function ftree_map :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
  29.564 -      "ftree_map f (FTLeaf x) = FTLeaf (f x)" |
  29.565 -      "ftree_map f (FTNode g) = FTNode (\<lambda>x. ftree_map f (g x))"
  29.566 -    by auto (metis ftree.exhaust)
  29.567 +    primrec_new (*<*)(in early) (*>*)relabel_ft2 :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree2 \<Rightarrow> 'a ftree2" where
  29.568 +      "relabel_ft2 f (FTLeaf2 x) = FTLeaf2 (f x)" |
  29.569 +      "relabel_ft2 f (FTNode2 g) = FTNode2 (op \<circ> (op \<circ> (relabel_ft2 f)) g)"
  29.570 +
  29.571 +text {* \blankline *}
  29.572 +
  29.573 +    primrec_new relabel_ft2 :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree2 \<Rightarrow> 'a ftree2" where
  29.574 +      "relabel_ft2 f (FTLeaf2 x) = FTLeaf2 (f x)" |
  29.575 +      "relabel_ft2 f (FTNode2 g) = FTNode2 (\<lambda>x y. relabel_ft2 f (g x y))"
  29.576 +
  29.577 +text {* \blankline *}
  29.578 +
  29.579 +    primrec_new subtree_ft2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a ftree2 \<Rightarrow> 'a ftree2" where
  29.580 +      "subtree_ft2 x y (FTNode2 g) = g x y"
  29.581  
  29.582  
  29.583  subsubsection {* Nested-as-Mutual Recursion
  29.584 @@ -1177,12 +1287,12 @@
  29.585  
  29.586  text {*
  29.587  \noindent
  29.588 -Appropriate induction principles are generated under the names
  29.589 +Appropriate induction rules are generated as
  29.590  @{thm [source] at\<^sub>f\<^sub>f.induct},
  29.591  @{thm [source] ats\<^sub>f\<^sub>f.induct}, and
  29.592 -@{thm [source] at\<^sub>f\<^sub>f_ats\<^sub>f\<^sub>f.induct}.
  29.593 -
  29.594 -%%% TODO: Add recursors.
  29.595 +@{thm [source] at\<^sub>f\<^sub>f_ats\<^sub>f\<^sub>f.induct}. The
  29.596 +induction rules and the underlying recursors are generated on a per-need basis
  29.597 +and are kept in a cache to speed up subsequent definitions.
  29.598  
  29.599  Here is a second example:
  29.600  *}
  29.601 @@ -1340,7 +1450,7 @@
  29.602  \begin{itemize}
  29.603  \setlength{\itemsep}{0pt}
  29.604  
  29.605 -\item \emph{Theorems sometimes have different names.}
  29.606 +\item \emph{Some theorems have different names.}
  29.607  For $m > 1$ mutually recursive functions,
  29.608  @{text "f\<^sub>1_\<dots>_f\<^sub>m.simps"} has been broken down into separate
  29.609  subcollections @{text "f\<^sub>i.simps"}.
  29.610 @@ -1415,7 +1525,7 @@
  29.611  text {*
  29.612  \noindent
  29.613  Notice that the @{const cont} selector is associated with both @{const Skip}
  29.614 -and @{const Choice}.
  29.615 +and @{const Action}.
  29.616  *}
  29.617  
  29.618  
  29.619 @@ -1488,9 +1598,9 @@
  29.620  \begin{itemize}
  29.621  \setlength{\itemsep}{0pt}
  29.622  
  29.623 -\item \relax{Coiterator}: @{text t_unfold}
  29.624 -
  29.625 -\item \relax{Corecursor}: @{text t_corec}
  29.626 +\item \relax{Coiterator}: @{text unfold_t}
  29.627 +
  29.628 +\item \relax{Corecursor}: @{text corec_t}
  29.629  
  29.630  \end{itemize}
  29.631  *}
  29.632 @@ -1606,10 +1716,10 @@
  29.633    \label{sec:defining-corecursive-functions} *}
  29.634  
  29.635  text {*
  29.636 -Corecursive functions can be specified using @{command primcorec} and
  29.637 -@{command primcorecursive}, which support primitive corecursion, or using the
  29.638 -more general \keyw{partial\_function} command. Here, the focus is on
  29.639 -the former two. More examples can be found in the directory
  29.640 +Corecursive functions can be specified using the @{command primcorec} and
  29.641 +\keyw{prim\-corec\-ursive} commands, which support primitive corecursion, or
  29.642 +using the more general \keyw{partial\_function} command. Here, the focus is on
  29.643 +the first two. More examples can be found in the directory
  29.644  \verb|~~/src/HOL/BNF/Examples|.
  29.645  
  29.646  Whereas recursive functions consume datatypes one constructor at a time,
  29.647 @@ -1630,7 +1740,7 @@
  29.648  This style is popular in the coalgebraic literature.
  29.649  
  29.650  \item The \emph{constructor view} specifies $f$ by equations of the form
  29.651 -\[@{text "\<dots> \<Longrightarrow> f x\<^sub>1 \<dots> x\<^sub>n = C \<dots>"}\]
  29.652 +\[@{text "\<dots> \<Longrightarrow> f x\<^sub>1 \<dots> x\<^sub>n = C\<^sub>j \<dots>"}\]
  29.653  This style is often more concise than the previous one.
  29.654  
  29.655  \item The \emph{code view} specifies $f$ by a single equation of the form
  29.656 @@ -1643,14 +1753,6 @@
  29.657  All three styles are available as input syntax. Whichever syntax is chosen,
  29.658  characteristic theorems for all three styles are generated.
  29.659  
  29.660 -\begin{framed}
  29.661 -\noindent
  29.662 -\textbf{Warning:}\enskip The @{command primcorec} and @{command primcorecursive}
  29.663 -commands are under development. Some of the functionality described here is
  29.664 -vaporware. An alternative is to define corecursive functions directly using the
  29.665 -generated @{text t_unfold} or @{text t_corec} combinators.
  29.666 -\end{framed}
  29.667 -
  29.668  %%% TODO: partial_function? E.g. for defining tail recursive function on lazy
  29.669  %%% lists (cf. terminal0 in TLList.thy)
  29.670  *}
  29.671 @@ -1668,11 +1770,6 @@
  29.672  present the same examples expressed using the constructor and destructor views.
  29.673  *}
  29.674  
  29.675 -(*<*)
  29.676 -    locale code_view
  29.677 -    begin
  29.678 -(*>*)
  29.679 -
  29.680  subsubsection {* Simple Corecursion
  29.681    \label{sssec:primcorec-simple-corecursion} *}
  29.682  
  29.683 @@ -1683,19 +1780,19 @@
  29.684  *}
  29.685  
  29.686      primcorec literate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a llist" where
  29.687 -      "literate f x = LCons x (literate f (f x))"
  29.688 +      "literate g x = LCons x (literate g (g x))"
  29.689  
  29.690  text {* \blankline *}
  29.691  
  29.692      primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a stream" where
  29.693 -      "siterate f x = SCons x (siterate f (f x))"
  29.694 +      "siterate g x = SCons x (siterate g (g x))"
  29.695  
  29.696  text {*
  29.697  \noindent
  29.698  The constructor ensures that progress is made---i.e., the function is
  29.699  \emph{productive}. The above functions compute the infinite lazy list or stream
  29.700 -@{text "[x, f x, f (f x), \<dots>]"}. Productivity guarantees that prefixes
  29.701 -@{text "[x, f x, f (f x), \<dots>, (f ^^ k) x]"} of arbitrary finite length
  29.702 +@{text "[x, g x, g (g x), \<dots>]"}. Productivity guarantees that prefixes
  29.703 +@{text "[x, g x, g (g x), \<dots>, (g ^^ k) x]"} of arbitrary finite length
  29.704  @{text k} can be computed by unfolding the code equation a finite number of
  29.705  times.
  29.706  
  29.707 @@ -1714,7 +1811,7 @@
  29.708  appear around constructors that guard corecursive calls:
  29.709  *}
  29.710  
  29.711 -    primcorec_notyet lappend :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
  29.712 +    primcorec lappend :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
  29.713        "lappend xs ys =
  29.714           (case xs of
  29.715              LNil \<Rightarrow> ys
  29.716 @@ -1722,6 +1819,19 @@
  29.717  
  29.718  text {*
  29.719  \noindent
  29.720 +Pattern matching is not supported by @{command primcorec}. Fortunately, it is
  29.721 +easy to generate pattern-maching equations using the \keyw{simps\_of\_case}
  29.722 +command provided by the theory \verb|~~/src/HOL/Library/Simps_Case_Conv|.
  29.723 +*}
  29.724 +
  29.725 +    simps_of_case lappend_simps: lappend.code
  29.726 +
  29.727 +text {*
  29.728 +This generates the lemma collection @{thm [source] lappend_simps}:
  29.729 +%
  29.730 +\[@{thm lappend_simps(1)[no_vars]}
  29.731 +  \qquad @{thm lappend_simps(2)[no_vars]}\]
  29.732 +%
  29.733  Corecursion is useful to specify not only functions but also infinite objects:
  29.734  *}
  29.735  
  29.736 @@ -1735,7 +1845,7 @@
  29.737  pseudorandom seed (@{text n}):
  29.738  *}
  29.739  
  29.740 -    primcorec_notyet
  29.741 +    primcorec
  29.742        random_process :: "'a stream \<Rightarrow> (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> 'a process"
  29.743      where
  29.744        "random_process s f n =
  29.745 @@ -1780,43 +1890,71 @@
  29.746  The next pair of examples generalize the @{const literate} and @{const siterate}
  29.747  functions (Section~\ref{sssec:primcorec-nested-corecursion}) to possibly
  29.748  infinite trees in which subnodes are organized either as a lazy list (@{text
  29.749 -tree\<^sub>i\<^sub>i}) or as a finite set (@{text tree\<^sub>i\<^sub>s}):
  29.750 +tree\<^sub>i\<^sub>i}) or as a finite set (@{text tree\<^sub>i\<^sub>s}). They rely on the map functions of
  29.751 +the nesting type constructors to lift the corecursive calls:
  29.752  *}
  29.753  
  29.754      primcorec iterate\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>i" where
  29.755 -      "iterate\<^sub>i\<^sub>i f x = Node\<^sub>i\<^sub>i x (lmap (iterate\<^sub>i\<^sub>i f) (f x))"
  29.756 +      "iterate\<^sub>i\<^sub>i g x = Node\<^sub>i\<^sub>i x (lmap (iterate\<^sub>i\<^sub>i g) (g x))"
  29.757  
  29.758  text {* \blankline *}
  29.759  
  29.760      primcorec iterate\<^sub>i\<^sub>s :: "('a \<Rightarrow> 'a fset) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>s" where
  29.761 -      "iterate\<^sub>i\<^sub>s f x = Node\<^sub>i\<^sub>s x (fimage (iterate\<^sub>i\<^sub>s f) (f x))"
  29.762 +      "iterate\<^sub>i\<^sub>s g x = Node\<^sub>i\<^sub>s x (fimage (iterate\<^sub>i\<^sub>s g) (g x))"
  29.763  
  29.764  text {*
  29.765  \noindent
  29.766 -Deterministic finite automata (DFAs) are traditionally defined as 5-tuples
  29.767 -@{text "(Q, \<Sigma>, \<delta>, q\<^sub>0, F)"}, where @{text Q} is a finite set of states,
  29.768 +Both examples follow the usual format for constructor arguments associated
  29.769 +with nested recursive occurrences of the datatype. Consider
  29.770 +@{const iterate\<^sub>i\<^sub>i}. The term @{term "g x"} constructs an @{typ "'a llist"}
  29.771 +value, which is turned into an @{typ "'a tree\<^sub>i\<^sub>i llist"} value using
  29.772 +@{const lmap}.
  29.773 +
  29.774 +This format may sometimes feel artificial. The following function constructs
  29.775 +a tree with a single, infinite branch from a stream:
  29.776 +*}
  29.777 +
  29.778 +    primcorec tree\<^sub>i\<^sub>i_of_stream :: "'a stream \<Rightarrow> 'a tree\<^sub>i\<^sub>i" where
  29.779 +      "tree\<^sub>i\<^sub>i_of_stream s =
  29.780 +         Node\<^sub>i\<^sub>i (shd s) (lmap tree\<^sub>i\<^sub>i_of_stream (LCons (stl s) LNil))"
  29.781 +
  29.782 +text {*
  29.783 +\noindent
  29.784 +Fortunately, it is easy to prove the following lemma, where the corecursive call
  29.785 +is moved inside the lazy list constructor, thereby eliminating the need for
  29.786 +@{const lmap}:
  29.787 +*}
  29.788 +
  29.789 +    lemma tree\<^sub>i\<^sub>i_of_stream_alt:
  29.790 +      "tree\<^sub>i\<^sub>i_of_stream s = Node\<^sub>i\<^sub>i (shd s) (LCons (tree\<^sub>i\<^sub>i_of_stream (stl s)) LNil)"
  29.791 +    by (subst tree\<^sub>i\<^sub>i_of_stream.code) simp
  29.792 +
  29.793 +text {*
  29.794 +The next example illustrates corecursion through functions, which is a bit
  29.795 +special. Deterministic finite automata (DFAs) are traditionally defined as
  29.796 +5-tuples @{text "(Q, \<Sigma>, \<delta>, q\<^sub>0, F)"}, where @{text Q} is a finite set of states,
  29.797  @{text \<Sigma>} is a finite alphabet, @{text \<delta>} is a transition function, @{text q\<^sub>0}
  29.798  is an initial state, and @{text F} is a set of final states. The following
  29.799  function translates a DFA into a @{type state_machine}:
  29.800  *}
  29.801  
  29.802 -    primcorec (*<*)(in early) (*>*)
  29.803 -      sm_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> 'a state_machine"
  29.804 +    primcorec
  29.805 +      (*<*)(in early) (*>*)sm_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> 'a state_machine"
  29.806      where
  29.807 -      "sm_of_dfa \<delta> F q = State_Machine (q \<in> F) (sm_of_dfa \<delta> F o \<delta> q)"
  29.808 +      "sm_of_dfa \<delta> F q = State_Machine (q \<in> F) (sm_of_dfa \<delta> F \<circ> \<delta> q)"
  29.809  
  29.810  text {*
  29.811  \noindent
  29.812  The map function for the function type (@{text \<Rightarrow>}) is composition
  29.813 -(@{text "op \<circ>"}). For convenience, corecursion through functions can be
  29.814 -expressed using $\lambda$-expressions and function application rather
  29.815 +(@{text "op \<circ>"}). For convenience, corecursion through functions can
  29.816 +also be expressed using $\lambda$-abstractions and function application rather
  29.817  than through composition. For example:
  29.818  *}
  29.819  
  29.820      primcorec
  29.821        sm_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> 'a state_machine"
  29.822      where
  29.823 -      "sm_of_dfa \<delta> F q = State_Machine (q \<in> F) (sm_of_dfa \<delta> F o \<delta> q)"
  29.824 +      "sm_of_dfa \<delta> F q = State_Machine (q \<in> F) (\<lambda>a. sm_of_dfa \<delta> F (\<delta> q a))"
  29.825  
  29.826  text {* \blankline *}
  29.827  
  29.828 @@ -1833,9 +1971,32 @@
  29.829      primcorec
  29.830        or_sm :: "'a state_machine \<Rightarrow> 'a state_machine \<Rightarrow> 'a state_machine"
  29.831      where
  29.832 -      "or_sm M N =
  29.833 -         State_Machine (accept M \<or> accept N)
  29.834 -           (\<lambda>a. or_sm (trans M a) (trans N a))"
  29.835 +      "or_sm M N = State_Machine (accept M \<or> accept N)
  29.836 +         (\<lambda>a. or_sm (trans M a) (trans N a))"
  29.837 +
  29.838 +text {*
  29.839 +\noindent
  29.840 +For recursion through curried $n$-ary functions, $n$ applications of
  29.841 +@{term "op \<circ>"} are necessary. The examples below illustrate the case where
  29.842 +$n = 2$:
  29.843 +*}
  29.844 +
  29.845 +    codatatype ('a, 'b) state_machine2 =
  29.846 +      State_Machine2 (accept2: bool) (trans2: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) state_machine2")
  29.847 +
  29.848 +text {* \blankline *}
  29.849 +
  29.850 +    primcorec
  29.851 +      (*<*)(in early) (*>*)sm2_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> ('a, 'b) state_machine2"
  29.852 +    where
  29.853 +      "sm2_of_dfa \<delta> F q = State_Machine2 (q \<in> F) (op \<circ> (op \<circ> (sm2_of_dfa \<delta> F)) (\<delta> q))"
  29.854 +
  29.855 +text {* \blankline *}
  29.856 +
  29.857 +    primcorec
  29.858 +      sm2_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> ('a, 'b) state_machine2"
  29.859 +    where
  29.860 +      "sm2_of_dfa \<delta> F q = State_Machine2 (q \<in> F) (\<lambda>a b. sm2_of_dfa \<delta> F (\<delta> q a b))"
  29.861  
  29.862  
  29.863  subsubsection {* Nested-as-Mutual Corecursion
  29.864 @@ -1848,15 +2009,31 @@
  29.865  pretend that nested codatatypes are mutually corecursive. For example:
  29.866  *}
  29.867  
  29.868 -    primcorec_notyet
  29.869 +(*<*)
  29.870 +    context late
  29.871 +    begin
  29.872 +(*>*)
  29.873 +    primcorec
  29.874        iterate\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>i" and
  29.875        iterates\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a llist \<Rightarrow> 'a tree\<^sub>i\<^sub>i llist"
  29.876      where
  29.877 -      "iterate\<^sub>i\<^sub>i f x = Node\<^sub>i\<^sub>i x (iterates\<^sub>i\<^sub>i f (f x))" |
  29.878 -      "iterates\<^sub>i\<^sub>i f xs =
  29.879 +      "iterate\<^sub>i\<^sub>i g x = Node\<^sub>i\<^sub>i x (iterates\<^sub>i\<^sub>i g (g x))" |
  29.880 +      "iterates\<^sub>i\<^sub>i g xs =
  29.881           (case xs of
  29.882              LNil \<Rightarrow> LNil
  29.883 -          | LCons x xs' \<Rightarrow> LCons (iterate\<^sub>i\<^sub>i f x) (iterates\<^sub>i\<^sub>i f xs'))"
  29.884 +          | LCons x xs' \<Rightarrow> LCons (iterate\<^sub>i\<^sub>i g x) (iterates\<^sub>i\<^sub>i g xs'))"
  29.885 +
  29.886 +text {*
  29.887 +\noindent
  29.888 +Coinduction rules are generated as
  29.889 +@{thm [source] iterate\<^sub>i\<^sub>i.coinduct},
  29.890 +@{thm [source] iterates\<^sub>i\<^sub>i.coinduct}, and
  29.891 +@{thm [source] iterate\<^sub>i\<^sub>i_iterates\<^sub>i\<^sub>i.coinduct}
  29.892 +and analogously for @{text strong_coinduct}. These rules and the
  29.893 +underlying corecursors are generated on a per-need basis and are kept in a cache
  29.894 +to speed up subsequent definitions.
  29.895 +*}
  29.896 +
  29.897  (*<*)
  29.898      end
  29.899  (*>*)
  29.900 @@ -1866,7 +2043,7 @@
  29.901    \label{ssec:primrec-constructor-view} *}
  29.902  
  29.903  (*<*)
  29.904 -    locale ctr_view = code_view
  29.905 +    locale ctr_view
  29.906      begin
  29.907  (*>*)
  29.908  
  29.909 @@ -1937,7 +2114,7 @@
  29.910    \label{ssec:primrec-destructor-view} *}
  29.911  
  29.912  (*<*)
  29.913 -    locale dest_view
  29.914 +    locale dtr_view
  29.915      begin
  29.916  (*>*)
  29.917  
  29.918 @@ -1951,13 +2128,13 @@
  29.919      primcorec literate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a llist" where
  29.920        "\<not> lnull (literate _ x)" |
  29.921        "lhd (literate _ x) = x" |
  29.922 -      "ltl (literate f x) = literate f (f x)"
  29.923 +      "ltl (literate g x) = literate g (g x)"
  29.924  
  29.925  text {* \blankline *}
  29.926  
  29.927      primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a stream" where
  29.928        "shd (siterate _ x) = x" |
  29.929 -      "stl (siterate f x) = siterate f (f x)"
  29.930 +      "stl (siterate g x) = siterate g (g x)"
  29.931  
  29.932  text {* \blankline *}
  29.933  
  29.934 @@ -1993,6 +2170,9 @@
  29.935  (*<*)
  29.936      end
  29.937  
  29.938 +    locale dtr_view2
  29.939 +    begin
  29.940 +
  29.941      primcorec lappend :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
  29.942        "lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)" |
  29.943  (*>*)
  29.944 @@ -2000,8 +2180,6 @@
  29.945  (*<*) |
  29.946        "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)" |
  29.947        "ltl (lappend xs ys) = (if xs = LNil then ltl ys else lappend (ltl xs) ys)"
  29.948 -
  29.949 -    context dest_view begin
  29.950  (*>*)
  29.951  
  29.952  text {*
  29.953 @@ -2044,8 +2222,8 @@
  29.954  text {* \blankline *}
  29.955  
  29.956      primcorec iterate\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>i" where
  29.957 -      "lbl\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i f x) = x" |
  29.958 -      "sub\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i f x) = lmap (iterate\<^sub>i\<^sub>i f) (f x)"
  29.959 +      "lbl\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i g x) = x" |
  29.960 +      "sub\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i g x) = lmap (iterate\<^sub>i\<^sub>i g) (g x)"
  29.961  (*<*)
  29.962      end
  29.963  (*>*)
  29.964 @@ -2148,11 +2326,39 @@
  29.965  \end{matharray}
  29.966  
  29.967  @{rail "
  29.968 -  @@{command bnf} target? (name ':')? term \\
  29.969 -    term_list term term_list term?
  29.970 +  @@{command bnf} target? (name ':')? typ \\
  29.971 +    'map:' term ('sets:' (term +))? 'bd:' term \\
  29.972 +    ('wits:' (term +))? ('rel:' term)?
  29.973 +"}
  29.974 +*}
  29.975 +
  29.976 +
  29.977 +subsubsection {* \keyw{bnf\_decl}
  29.978 +  \label{sssec:bnf-decl} *}
  29.979 +
  29.980 +text {*
  29.981 +%%% TODO: use command_def once the command is available
  29.982 +\begin{matharray}{rcl}
  29.983 +  @{text "bnf_decl"} & : & @{text "local_theory \<rightarrow> local_theory"}
  29.984 +\end{matharray}
  29.985 +
  29.986 +@{rail "
  29.987 +  @@{command bnf_decl} target? @{syntax dt_name}
  29.988    ;
  29.989 -  X_list: '[' (X + ',') ']'
  29.990 +  @{syntax_def dt_name}: @{syntax tyargs}? name @{syntax map_rel}? mixfix?
  29.991 +  ;
  29.992 +  @{syntax_def tyargs}: typefree | '(' (((name | '-') ':')? typefree + ',') ')'
  29.993 +  ;
  29.994 +  @{syntax_def map_rel}: '(' ((('map' | 'rel') ':' name) +) ')'
  29.995  "}
  29.996 +
  29.997 +Declares a fresh type and fresh constants (map, set, relator, cardinal bound)
  29.998 +and asserts the bnf properties for these constants as axioms. Additionally,
  29.999 +type arguments may be marked as dead (by using @{syntax "-"} instead of a name for the
 29.1000 +set function)---this is the only difference of @{syntax dt_name} compared to
 29.1001 +the syntax used by the @{command datatype_new}/@{command codatatype} commands.
 29.1002 +
 29.1003 +The axioms are sound, since one there exists a bnf of any given arity.
 29.1004  *}
 29.1005  
 29.1006  
 29.1007 @@ -2185,8 +2391,10 @@
 29.1008  %    old \keyw{datatype}
 29.1009  %
 29.1010  %  * @{command wrap_free_constructors}
 29.1011 -%    * @{text "no_discs_sels"}, @{text "rep_compat"}
 29.1012 +%    * @{text "no_discs_sels"}, @{text "no_code"}, @{text "rep_compat"}
 29.1013  %    * hack to have both co and nonco view via locale (cf. ext nats)
 29.1014 +%  * code generator
 29.1015 +%     * eq, refl, simps
 29.1016  *}
 29.1017  
 29.1018  
 29.1019 @@ -2215,11 +2423,11 @@
 29.1020    @{syntax_def wfc_discs_sels}: name_list (name_list_list name_term_list_list? )?
 29.1021    ;
 29.1022    @{syntax_def name_term}: (name ':' term)
 29.1023 +  ;
 29.1024 +  X_list: '[' (X + ',') ']'
 29.1025  "}
 29.1026  
 29.1027 -% options: no_discs_sels rep_compat
 29.1028 -
 29.1029 -% X_list is as for BNF
 29.1030 +% options: no_discs_sels no_code rep_compat
 29.1031  
 29.1032  \noindent
 29.1033  Section~\ref{ssec:datatype-generated-theorems} lists the generated theorems.
 29.1034 @@ -2307,8 +2515,9 @@
 29.1035  suggested major simplifications to the internal constructions, much of which has
 29.1036  yet to be implemented. Florian Haftmann and Christian Urban provided general
 29.1037  advice on Isabelle and package writing. Stefan Milius and Lutz Schr\"oder
 29.1038 -found an elegant proof to eliminate one of the BNF assumptions. Christian
 29.1039 -Sternagel suggested many textual improvements to this tutorial.
 29.1040 +found an elegant proof to eliminate one of the BNF assumptions. Andreas
 29.1041 +Lochbihler and Christian Sternagel suggested many textual improvements to this
 29.1042 +tutorial.
 29.1043  *}
 29.1044  
 29.1045  end
    30.1 --- a/src/Doc/Datatypes/document/root.tex	Thu Dec 05 17:52:12 2013 +0100
    30.2 +++ b/src/Doc/Datatypes/document/root.tex	Thu Dec 05 17:58:03 2013 +0100
    30.3 @@ -58,10 +58,10 @@
    30.4  
    30.5  \begin{abstract}
    30.6  \noindent
    30.7 -This tutorial describes how to use the new package for defining datatypes and
    30.8 -codatatypes in Isabelle/HOL. The package provides five main commands:
    30.9 +This tutorial describes the new package for defining datatypes and codatatypes
   30.10 +in Isabelle/HOL. The package provides four main commands:
   30.11  \keyw{datatype\_new}, \keyw{codatatype}, \keyw{primrec\_new},
   30.12 -\keyw{primcorecursive}, and \keyw{primcorec}. The commands suffixed by
   30.13 +and \keyw{primcorec}. The commands suffixed by
   30.14  \keyw{\_new} are intended to subsume, and eventually replace, the corresponding
   30.15  commands from the old datatype package.
   30.16  \end{abstract}
    31.1 --- a/src/Doc/Functions/Functions.thy	Thu Dec 05 17:52:12 2013 +0100
    31.2 +++ b/src/Doc/Functions/Functions.thy	Thu Dec 05 17:58:03 2013 +0100
    31.3 @@ -1003,13 +1003,13 @@
    31.4    recursive calls. In general, there is one introduction rule for each
    31.5    recursive call.
    31.6  
    31.7 -  The predicate @{term "accp findzero_rel"} is the accessible part of
    31.8 +  The predicate @{term "Wellfounded.accp findzero_rel"} is the accessible part of
    31.9    that relation. An argument belongs to the accessible part, if it can
   31.10    be reached in a finite number of steps (cf.~its definition in @{text
   31.11    "Wellfounded.thy"}).
   31.12  
   31.13    Since the domain predicate is just an abbreviation, you can use
   31.14 -  lemmas for @{const accp} and @{const findzero_rel} directly. Some
   31.15 +  lemmas for @{const Wellfounded.accp} and @{const findzero_rel} directly. Some
   31.16    lemmas which are occasionally useful are @{thm [source] accpI}, @{thm [source]
   31.17    accp_downward}, and of course the introduction and elimination rules
   31.18    for the recursion relation @{thm [source] "findzero_rel.intros"} and @{thm
    32.1 --- a/src/Doc/IsarImplementation/ML.thy	Thu Dec 05 17:52:12 2013 +0100
    32.2 +++ b/src/Doc/IsarImplementation/ML.thy	Thu Dec 05 17:58:03 2013 +0100
    32.3 @@ -1033,7 +1033,7 @@
    32.4    without any message output.
    32.5  
    32.6    \begin{warn}
    32.7 -  The actual error channel is accessed via @{ML Output.error_msg}, but
    32.8 +  The actual error channel is accessed via @{ML Output.error_message}, but
    32.9    the old interaction protocol of Proof~General \emph{crashes} if that
   32.10    function is used in regular ML code: error output and toplevel
   32.11    command failure always need to coincide in classic TTY interaction.
    33.1 --- a/src/Doc/JEdit/JEdit.thy	Thu Dec 05 17:52:12 2013 +0100
    33.2 +++ b/src/Doc/JEdit/JEdit.thy	Thu Dec 05 17:58:03 2013 +0100
    33.3 @@ -1068,12 +1068,6 @@
    33.4  text {*
    33.5    \begin{itemize}
    33.6  
    33.7 -  \item \textbf{Problem:} Lack of dependency management for auxiliary files
    33.8 -  that contribute to a theory (e.g.\ @{command ML_file}).
    33.9 -
   33.10 -  \textbf{Workaround:} Re-load files manually within the prover, by
   33.11 -  editing corresponding command in the text.
   33.12 -
   33.13    \item \textbf{Problem:} Odd behavior of some diagnostic commands with
   33.14    global side-effects, like writing a physical file.
   33.15  
    34.1 --- a/src/Doc/Nitpick/document/root.tex	Thu Dec 05 17:52:12 2013 +0100
    34.2 +++ b/src/Doc/Nitpick/document/root.tex	Thu Dec 05 17:58:03 2013 +0100
    34.3 @@ -1965,6 +1965,8 @@
    34.4  \texttt{.kki}, \texttt{.cnf}, \texttt{.out}, and
    34.5  \texttt{.err}; you may safely remove them after Nitpick has run.
    34.6  
    34.7 +\textbf{Warning:} This option is not thread-safe. Use at your own risks.
    34.8 +
    34.9  \nopagebreak
   34.10  {\small See also \textit{debug} (\S\ref{output-format}).}
   34.11  \end{enum}
   34.12 @@ -2382,6 +2384,14 @@
   34.13  \cite{kodkod-2009}. Unlike the standard version of MiniSat, the JNI version can
   34.14  be used incrementally.
   34.15  
   34.16 +\item[\labelitemi] \textbf{\textit{Riss3g}:} Riss3g is an efficient solver written in
   34.17 +\cpp{}. To use Riss3g, set the environment variable \texttt{RISS3G\_HOME} to the
   34.18 +directory that contains the \texttt{riss3g} executable.%
   34.19 +\footref{cygwin-paths}
   34.20 +The \cpp{} sources for Riss3g are available at
   34.21 +\url{http://tools.computational-logic.org/content/riss3g.php}.
   34.22 +Nitpick has been tested with the SAT Competition 2013 version.
   34.23 +
   34.24  \item[\labelitemi] \textbf{\textit{zChaff}:} zChaff is an older solver written
   34.25  in \cpp{}. To use zChaff, set the environment variable \texttt{ZCHAFF\_HOME} to
   34.26  the directory that contains the \texttt{zchaff} executable.%
   34.27 @@ -2794,11 +2804,12 @@
   34.28  \subsection{Registering Coinductive Datatypes}
   34.29  \label{registering-coinductive-datatypes}
   34.30  
   34.31 +Coinductive datatypes defined using the \textbf{codatatype} command that do not
   34.32 +involve nested recursion through non-codatatypes are supported by Nitpick.
   34.33  If you have defined a custom coinductive datatype, you can tell Nitpick about
   34.34 -it, so that it can use an efficient Kodkod axiomatization similar to the one it
   34.35 -uses for lazy lists. The interface for registering and unregistering coinductive
   34.36 -datatypes consists of the following pair of functions defined in the
   34.37 -\textit{Nitpick\_HOL} structure:
   34.38 +it, so that it can use an efficient Kodkod axiomatization. The interface for
   34.39 +registering and unregistering coinductive datatypes consists of the following
   34.40 +pair of functions defined in the \textit{Nitpick\_HOL} structure:
   34.41  
   34.42  \prew
   34.43  $\textbf{val}\,~\textit{register\_codatatype\/} : {}$ \\
   34.44 @@ -2886,6 +2897,12 @@
   34.45  \item[\labelitemi] Nitpick produces spurious counterexamples when invoked after a
   34.46  \textbf{guess} command in a structured proof.
   34.47  
   34.48 +\item[\labelitemi] Datatypes defined using \textbf{datatype\_new} are not
   34.49 +supported.
   34.50 +
   34.51 +\item[\labelitemi] Codatatypes defined using \textbf{codatatype} that
   34.52 +involve nested recursion through non-codatatypes are not supported.
   34.53 +
   34.54  \item[\labelitemi] The \textit{nitpick\_xxx} attributes and the
   34.55  \textit{Nitpick\_xxx.register\_yyy} functions can cause havoc if used
   34.56  improperly.
    35.1 --- a/src/Doc/ProgProve/Basics.thy	Thu Dec 05 17:52:12 2013 +0100
    35.2 +++ b/src/Doc/ProgProve/Basics.thy	Thu Dec 05 17:58:03 2013 +0100
    35.3 @@ -22,8 +22,8 @@
    35.4  \item[type constructors,]
    35.5   in particular @{text list}, the type of
    35.6  lists, and @{text set}, the type of sets. Type constructors are written
    35.7 -postfix, e.g.\ @{typ "nat list"} is the type of lists whose elements are
    35.8 -natural numbers.
    35.9 +postfix, i.e., after their arguments. For example,
   35.10 +@{typ "nat list"} is the type of lists whose elements are natural numbers.
   35.11  \item[function types,]
   35.12  denoted by @{text"\<Rightarrow>"}.
   35.13  \item[type variables,]
   35.14 @@ -41,8 +41,8 @@
   35.15  \begin{warn}
   35.16  There are many predefined infix symbols like @{text "+"} and @{text"\<le>"}.
   35.17  The name of the corresponding binary function is @{term"op +"},
   35.18 -not just @{text"+"}. That is, @{term"x + y"} is syntactic sugar for
   35.19 -\noquotes{@{term[source]"op + x y"}}.
   35.20 +not just @{text"+"}. That is, @{term"x + y"} is nice surface syntax
   35.21 +(``syntactic sugar'') for \noquotes{@{term[source]"op + x y"}}.
   35.22  \end{warn}
   35.23  
   35.24  HOL also supports some basic constructs from functional programming:
    36.1 --- a/src/Doc/ProgProve/Bool_nat_list.thy	Thu Dec 05 17:52:12 2013 +0100
    36.2 +++ b/src/Doc/ProgProve/Bool_nat_list.thy	Thu Dec 05 17:58:03 2013 +0100
    36.3 @@ -99,10 +99,10 @@
    36.4    For example, given the goal @{text"x + 0 = x"}, there is nothing to indicate
    36.5    that you are talking about natural numbers. Hence Isabelle can only infer
    36.6    that @{term x} is of some arbitrary type where @{text 0} and @{text"+"}
    36.7 -  exist. As a consequence, you will be unable to prove the
    36.8 -  goal. To alert you to such pitfalls, Isabelle flags numerals without a
    36.9 -  fixed type in its output: @{prop"x+0 = x"}.  In this particular example,
   36.10 -  you need to include
   36.11 +  exist. As a consequence, you will be unable to prove the goal.
   36.12 +%  To alert you to such pitfalls, Isabelle flags numerals without a
   36.13 +%  fixed type in its output: @ {prop"x+0 = x"}.
   36.14 +  In this particular example, you need to include
   36.15    an explicit type constraint, for example @{text"x+0 = (x::nat)"}. If there
   36.16    is enough contextual information this may not be necessary: @{prop"Suc x =
   36.17    x"} automatically implies @{text"x::nat"} because @{term Suc} is not
   36.18 @@ -372,10 +372,10 @@
   36.19  ys zs)"}. It appears almost mysterious because we suddenly complicate the
   36.20  term by appending @{text Nil} on the left. What is really going on is this:
   36.21  when proving some equality \mbox{@{prop"s = t"}}, both @{text s} and @{text t} are
   36.22 -simplified to some common term @{text u}.  This heuristic for equality proofs
   36.23 +simplified until they ``meet in the middle''. This heuristic for equality proofs
   36.24  works well for a functional programming context like ours. In the base case
   36.25 -@{text s} is @{term"app (app Nil ys) zs"}, @{text t} is @{term"app Nil (app
   36.26 -ys zs)"}, and @{text u} is @{term"app ys zs"}.
   36.27 +both @{term"app (app Nil ys) zs"} and @{term"app Nil (app
   36.28 +ys zs)"} are simplified to @{term"app ys zs"}, the term in the middle.
   36.29  
   36.30  \subsection{Predefined Lists}
   36.31  \label{sec:predeflists}
   36.32 @@ -419,13 +419,19 @@
   36.33  From now on lists are always the predefined lists.
   36.34  
   36.35  
   36.36 -\subsection{Exercises}
   36.37 +\subsection*{Exercises}
   36.38 +
   36.39 +\begin{exercise}
   36.40 +Use the \isacom{value} command to evaluate the following expressions:
   36.41 +@{term[source] "1 + (2::nat)"}, @{term[source] "1 + (2::int)"},
   36.42 +@{term[source] "1 - (2::nat)"} and @{term[source] "1 - (2::int)"}.
   36.43 +\end{exercise}
   36.44  
   36.45  \begin{exercise}
   36.46  Start from the definition of @{const add} given above.
   36.47 -Prove it is associative (@{prop"add (add m n) p = add m (add n p)"})
   36.48 -and commutative (@{prop"add m n = add n m"}). Define a recursive function
   36.49 -@{text double} @{text"::"} @{typ"nat \<Rightarrow> nat"} and prove that @{prop"double m = add m m"}.
   36.50 +Prove that @{const add} is associative and commutative.
   36.51 +Define a recursive function @{text double} @{text"::"} @{typ"nat \<Rightarrow> nat"}
   36.52 +and prove @{prop"double m = add m m"}.
   36.53  \end{exercise}
   36.54  
   36.55  \begin{exercise}
   36.56 @@ -436,11 +442,15 @@
   36.57  
   36.58  \begin{exercise}
   36.59  Define a recursive function @{text "snoc ::"} @{typ"'a list \<Rightarrow> 'a \<Rightarrow> 'a list"}
   36.60 -that appends an element to the end of a list. Do not use the predefined append
   36.61 -operator @{text"@"}. With the help of @{text snoc} define a recursive function
   36.62 -@{text "reverse ::"} @{typ"'a list \<Rightarrow> 'a list"} that reverses a list. Do not
   36.63 -use the predefined function @{const rev}.
   36.64 -Prove @{prop"reverse(reverse xs) = xs"}.
   36.65 +that appends an element to the end of a list. With the help of @{text snoc}
   36.66 +define a recursive function @{text "reverse ::"} @{typ"'a list \<Rightarrow> 'a list"}
   36.67 +that reverses a list. Prove @{prop"reverse(reverse xs) = xs"}.
   36.68 +\end{exercise}
   36.69 +
   36.70 +\begin{exercise}
   36.71 +Define a recursive function @{text "sum ::"} @{typ"nat \<Rightarrow> nat"} such that
   36.72 +\mbox{@{text"sum n"}} @{text"="} @{text"0 + ... + n"} and prove
   36.73 +@{prop" sum(n::nat) = n * (n+1) div 2"}.
   36.74  \end{exercise}
   36.75  *}
   36.76  (*<*)
    37.1 --- a/src/Doc/ProgProve/Isar.thy	Thu Dec 05 17:52:12 2013 +0100
    37.2 +++ b/src/Doc/ProgProve/Isar.thy	Thu Dec 05 17:58:03 2013 +0100
    37.3 @@ -590,15 +590,15 @@
    37.4  the fact just proved, in this case the preceding block. In general,
    37.5  \isacom{note} introduces a new name for one or more facts.
    37.6  
    37.7 -\subsection{Exercises}
    37.8 +\subsection*{Exercises}
    37.9  
   37.10  \exercise
   37.11  Give a readable, structured proof of the following lemma:
   37.12  *}
   37.13 -lemma assumes T: "\<forall> x y. T x y \<or> T y x"
   37.14 -  and A: "\<forall> x y. A x y \<and> A y x \<longrightarrow> x = y"
   37.15 -  and TA: "\<forall> x y. T x y \<longrightarrow> A x y" and "A x y"
   37.16 -shows "T x y"
   37.17 +lemma assumes T: "\<forall>x y. T x y \<or> T y x"
   37.18 +  and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
   37.19 +  and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
   37.20 +  shows "T x y"
   37.21  (*<*)oops(*>*)
   37.22  text{*
   37.23  \endexercise
   37.24 @@ -612,10 +612,11 @@
   37.25  text{*
   37.26  Hint: There are predefined functions @{const_typ take} and @{const_typ drop}
   37.27  such that @{text"take k [x\<^sub>1,\<dots>] = [x\<^sub>1,\<dots>,x\<^sub>k]"} and
   37.28 -@{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let @{text simp} and especially
   37.29 -sledgehammer find and apply the relevant @{const take} and @{const drop} lemmas for you.
   37.30 +@{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let sledgehammer find and apply
   37.31 +the relevant @{const take} and @{const drop} lemmas for you.
   37.32  \endexercise
   37.33  
   37.34 +
   37.35  \section{Case Analysis and Induction}
   37.36  
   37.37  \subsection{Datatype Case Analysis}
   37.38 @@ -1018,7 +1019,7 @@
   37.39  \isacom{lemma} @{text[source]"I r s t \<Longrightarrow> \<dots>"}
   37.40  \end{isabelle}
   37.41  Applying the standard form of
   37.42 -rule induction in such a situation will lead to strange and typically unproveable goals.
   37.43 +rule induction in such a situation will lead to strange and typically unprovable goals.
   37.44  We can easily reduce this situation to the standard one by introducing
   37.45  new variables @{text x}, @{text y}, @{text z} and reformulating the goal like this:
   37.46  \begin{isabelle}
   37.47 @@ -1040,7 +1041,7 @@
   37.48  proof(induction "Suc m" arbitrary: m rule: ev.induct)
   37.49    fix n assume IH: "\<And>m. n = Suc m \<Longrightarrow> \<not> ev m"
   37.50    show "\<not> ev (Suc n)"
   37.51 -  proof --"contradition"
   37.52 +  proof --"contradiction"
   37.53      assume "ev(Suc n)"
   37.54      thus False
   37.55      proof cases --"rule inversion"
   37.56 @@ -1075,45 +1076,38 @@
   37.57  @{text induct} method.
   37.58  \end{warn}
   37.59  
   37.60 -\subsection{Exercises}
   37.61 +
   37.62 +\subsection*{Exercises}
   37.63 +
   37.64 +
   37.65 +\exercise
   37.66 +Give a structured proof by rule inversion:
   37.67 +*}
   37.68 +
   37.69 +lemma assumes a: "ev(Suc(Suc n))" shows "ev n"
   37.70 +(*<*)oops(*>*)
   37.71 +
   37.72 +text{*
   37.73 +\endexercise
   37.74 +
   37.75 +\begin{exercise}
   37.76 +Give a structured proof of @{prop "\<not> ev(Suc(Suc(Suc 0)))"}
   37.77 +by rule inversions. If there are no cases to be proved you can close
   37.78 +a proof immediateley with \isacom{qed}.
   37.79 +\end{exercise}
   37.80 +
   37.81 +\begin{exercise}
   37.82 +Recall predicate @{text star} from \autoref{sec:star} and @{text iter}
   37.83 +from Exercise~\ref{exe:iter}. Prove @{prop "iter r n x y \<Longrightarrow> star r x y"}
   37.84 +in a structured style, do not just sledgehammer each case of the
   37.85 +required induction.
   37.86 +\end{exercise}
   37.87  
   37.88  \begin{exercise}
   37.89  Define a recursive function @{text "elems ::"} @{typ"'a list \<Rightarrow> 'a set"}
   37.90  and prove @{prop "x : elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"}.
   37.91  \end{exercise}
   37.92 -
   37.93 -\begin{exercise}
   37.94 -A context-free grammar can be seen as an inductive definition where each
   37.95 -nonterminal $A$ is an inductively defined predicate on lists of terminal
   37.96 -symbols: $A(w)$ mans
   37.97 -that $w$ is in the language generated by $A$. For example, the production $S
   37.98 -\to a S b$ can be viewed as the implication @{prop"S w \<Longrightarrow> S (a # w @ [b])"}
   37.99 -where @{text a} and @{text b} are constructors of some datatype of terminal
  37.100 -symbols: \isacom{datatype} @{text"tsymbs = a | b | \<dots>"}
  37.101 -
  37.102 -Define the two grammars
  37.103 -\[
  37.104 -\begin{array}{r@ {\quad}c@ {\quad}l}
  37.105 -S &\to& \varepsilon \quad\mid\quad a~S~b \quad\mid\quad S~S \\
  37.106 -T &\to& \varepsilon \quad\mid\quad T~a~T~b
  37.107 -\end{array}
  37.108 -\]
  37.109 -($\varepsilon$ is the empty word)
  37.110 -as two inductive predicates and prove @{prop"S w \<longleftrightarrow> T w"}.
  37.111 -\end{exercise}
  37.112 -
  37.113  *}
  37.114 -(*
  37.115 -lemma "\<not> ev(Suc(Suc(Suc 0)))"
  37.116 -proof
  37.117 -  assume "ev(Suc(Suc(Suc 0)))"
  37.118 -  then show False
  37.119 -  proof cases
  37.120 -    case evSS
  37.121 -    from `ev(Suc 0)` show False by cases
  37.122 -  qed
  37.123 -qed
  37.124 -*)
  37.125  
  37.126  (*<*)
  37.127  end
    38.1 --- a/src/Doc/ProgProve/Logic.thy	Thu Dec 05 17:52:12 2013 +0100
    38.2 +++ b/src/Doc/ProgProve/Logic.thy	Thu Dec 05 17:58:03 2013 +0100
    38.3 @@ -141,6 +141,28 @@
    38.4  See \cite{Nipkow-Main} for the wealth of further predefined functions in theory
    38.5  @{theory Main}.
    38.6  
    38.7 +
    38.8 +\subsection*{Exercises}
    38.9 +
   38.10 +\exercise
   38.11 +Start from the data type of binary trees defined earlier:
   38.12 +*}
   38.13 +
   38.14 +datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"
   38.15 +
   38.16 +text{*
   38.17 +Define a function @{text "set ::"} @{typ "'a tree \<Rightarrow> 'a set"}
   38.18 +that returns the elements in a tree and a function
   38.19 +@{text "ord ::"} @{typ "int tree \<Rightarrow> bool"}
   38.20 +the tests if an @{typ "int tree"} is ordered.
   38.21 +
   38.22 +Define a function @{text ins} that inserts an element into an ordered @{typ "int tree"}
   38.23 +while maintaining the order of the tree. If the element is already in the tree, the
   38.24 +same tree should be returned. Prove correctness of @{text ins}:
   38.25 +@{prop "set(ins x t) = {x} \<union> set t"} and @{prop "ord t \<Longrightarrow> ord(ins i t)"}.
   38.26 +\endexercise
   38.27 +
   38.28 +
   38.29  \section{Proof Automation}
   38.30  
   38.31  So far we have only seen @{text simp} and @{text auto}: Both perform
   38.32 @@ -459,12 +481,12 @@
   38.33  text{* In this particular example we could have backchained with
   38.34  @{thm[source] Suc_leD}, too, but because the premise is more complicated than the conclusion this can easily lead to nontermination.
   38.35  
   38.36 -\subsection{Finding Theorems}
   38.37 -
   38.38 -Command \isacom{find{\isacharunderscorekeyword}theorems} searches for specific theorems in the current
   38.39 -theory. Search criteria include pattern matching on terms and on names.
   38.40 -For details see the Isabelle/Isar Reference Manual~\cite{IsarRef}.
   38.41 -\bigskip
   38.42 +%\subsection{Finding Theorems}
   38.43 +%
   38.44 +%Command \isacom{find{\isacharunderscorekeyword}theorems} searches for specific theorems in the current
   38.45 +%theory. Search criteria include pattern matching on terms and on names.
   38.46 +%For details see the Isabelle/Isar Reference Manual~\cite{IsarRef}.
   38.47 +%\bigskip
   38.48  
   38.49  \begin{warn}
   38.50  To ease readability we will drop the question marks
   38.51 @@ -708,8 +730,8 @@
   38.52  apply(rename_tac u x y)
   38.53  defer
   38.54  (*>*)
   38.55 -txt{* The induction is over @{prop"star r x y"} and we try to prove
   38.56 -\mbox{@{prop"star r y z \<Longrightarrow> star r x z"}},
   38.57 +txt{* The induction is over @{prop"star r x y"} (the first matching assumption)
   38.58 +and we try to prove \mbox{@{prop"star r y z \<Longrightarrow> star r x z"}},
   38.59  which we abbreviate by @{prop"P x y"}. These are our two subgoals:
   38.60  @{subgoals[display,indent=0]}
   38.61  The first one is @{prop"P x x"}, the result of case @{thm[source]refl},
   38.62 @@ -764,6 +786,95 @@
   38.63  conditions}. In rule inductions, these side-conditions appear as additional
   38.64  assumptions. The \isacom{for} clause seen in the definition of the reflexive
   38.65  transitive closure merely simplifies the form of the induction rule.
   38.66 +
   38.67 +
   38.68 +\subsection*{Exercises}
   38.69 +
   38.70 +\begin{exercise}
   38.71 +Formalise the following definition of palindromes
   38.72 +\begin{itemize}
   38.73 +\item The empty list and a singleton list are palindromes.
   38.74 +\item If @{text xs} is a palindrome, so is @{term "a # xs @ [a]"}.
   38.75 +\end{itemize}
   38.76 +as an inductive predicate @{text "palindrome ::"} @{typ "'a list \<Rightarrow> bool"}
   38.77 +and prove that @{prop "rev xs = xs"} if @{text xs} is a palindrome.
   38.78 +\end{exercise}
   38.79 +
   38.80 +\exercise
   38.81 +We could also have defined @{const star} as follows:
   38.82 +*}
   38.83 +
   38.84 +inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
   38.85 +refl': "star' r x x" |
   38.86 +step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"
   38.87 +
   38.88 +text{*
   38.89 +The single @{text r} step is performer after rather than before the @{text star'}
   38.90 +steps. Prove @{prop "star' r x y \<Longrightarrow> star r x y"} and
   38.91 +@{prop "star r x y \<Longrightarrow> star r' x y"}. You may need lemmas.
   38.92 +Note that rule induction fails
   38.93 +if the assumption about the inductive predicate is not the first assumption.
   38.94 +\endexercise
   38.95 +
   38.96 +\begin{exercise}\label{exe:iter}
   38.97 +Analogous to @{const star}, give an inductive definition of the @{text n}-fold iteration
   38.98 +of a relation @{text r}: @{term "iter r n x y"} should hold if there are @{text x\<^sub>0}, \dots, @{text x\<^sub>n}
   38.99 +such that @{prop"x = x\<^sub>0"}, @{prop"x\<^sub>n = y"} and @{text"r x\<^bsub>i\<^esub> x\<^bsub>i+1\<^esub>"} for
  38.100 +all @{prop"i < n"}. Correct and prove the following claim:
  38.101 +@{prop"star r x y \<Longrightarrow> iter r n x y"}.
  38.102 +\end{exercise}
  38.103 +
  38.104 +\begin{exercise}
  38.105 +A context-free grammar can be seen as an inductive definition where each
  38.106 +nonterminal $A$ is an inductively defined predicate on lists of terminal
  38.107 +symbols: $A(w)$ mans that $w$ is in the language generated by $A$.
  38.108 +For example, the production $S \to a S b$ can be viewed as the implication
  38.109 +@{prop"S w \<Longrightarrow> S (a # w @ [b])"} where @{text a} and @{text b} are terminal symbols,
  38.110 +i.e., elements of some alphabet. The alphabet can be defined like this:
  38.111 +\isacom{datatype} @{text"alpha = a | b | \<dots>"}
  38.112 +
  38.113 +Define the two grammars (where $\varepsilon$ is the empty word)
  38.114 +\[
  38.115 +\begin{array}{r@ {\quad}c@ {\quad}l}
  38.116 +S &\to& \varepsilon \quad\mid\quad aSb \quad\mid\quad SS \\
  38.117 +T &\to& \varepsilon \quad\mid\quad TaTb
  38.118 +\end{array}
  38.119 +\]
  38.120 +as two inductive predicates.
  38.121 +If you think of @{text a} and @{text b} as ``@{text "("}'' and  ``@{text ")"}'',
  38.122 +the grammars defines strings of balanced parentheses.
  38.123 +Prove @{prop"T w \<Longrightarrow> S w"} and @{prop "S w \<Longrightarrow> T w"} separately and conclude
  38.124 +@{prop "S w = T w"}.
  38.125 +\end{exercise}
  38.126 +
  38.127 +\ifsem
  38.128 +\begin{exercise}
  38.129 +In \autoref{sec:AExp} we defined a recursive evaluation function
  38.130 +@{text "aval :: aexp \<Rightarrow> state \<Rightarrow> val"}.
  38.131 +Define an inductive evaluation predicate
  38.132 +@{text "aval_rel :: aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool"}
  38.133 +and prove that it agrees with the recursive function:
  38.134 +@{prop "aval_rel a s v \<Longrightarrow> aval a s = v"}, 
  38.135 +@{prop "aval a s = v \<Longrightarrow> aval_rel a s v"} and thus
  38.136 +\noquotes{@{prop [source] "aval_rel a s v \<longleftrightarrow> aval a s = v"}}.
  38.137 +\end{exercise}
  38.138 +
  38.139 +\begin{exercise}
  38.140 +Consider the stack machine from Chapter~3
  38.141 +and recall the concept of \concept{stack underflow}
  38.142 +from Exercise~\ref{exe:stack-underflow}.
  38.143 +Define an inductive predicate
  38.144 +@{text "ok :: nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool"}
  38.145 +such that @{text "ok n is n'"} means that with any initial stack of length
  38.146 +@{text n} the instructions @{text "is"} can be executed
  38.147 +without stack underflow and that the final stack has length @{text n'}.
  38.148 +Prove that @{text ok} correctly computes the final stack size
  38.149 +@{prop[display] "\<lbrakk>ok n is n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec is s stk) = n'"}
  38.150 +and that instruction sequences generated by @{text comp}
  38.151 +cannot cause stack underflow: \ @{text "ok n (comp a) ?"} \ for
  38.152 +some suitable value of @{text "?"}.
  38.153 +\end{exercise}
  38.154 +\fi
  38.155  *}
  38.156  (*<*)
  38.157  end
    39.1 --- a/src/Doc/ProgProve/Types_and_funs.thy	Thu Dec 05 17:52:12 2013 +0100
    39.2 +++ b/src/Doc/ProgProve/Types_and_funs.thy	Thu Dec 05 17:58:03 2013 +0100
    39.3 @@ -156,7 +156,7 @@
    39.4  
    39.5  fun div2 :: "nat \<Rightarrow> nat" where
    39.6  "div2 0 = 0" |
    39.7 -"div2 (Suc 0) = Suc 0" |
    39.8 +"div2 (Suc 0) = 0" |
    39.9  "div2 (Suc(Suc n)) = Suc(div2 n)"
   39.10  
   39.11  text{* does not just define @{const div2} but also proves a
   39.12 @@ -171,16 +171,25 @@
   39.13  This customized induction rule can simplify inductive proofs. For example,
   39.14  *}
   39.15  
   39.16 -lemma "div2(n+n) = n"
   39.17 +lemma "div2(n) = n div 2"
   39.18  apply(induction n rule: div2.induct)
   39.19  
   39.20 -txt{* yields the 3 subgoals
   39.21 +txt{* (where the infix @{text div} is the predefined division operation)
   39.22 +yields the 3 subgoals
   39.23  @{subgoals[display,margin=65]}
   39.24  An application of @{text auto} finishes the proof.
   39.25  Had we used ordinary structural induction on @{text n},
   39.26  the proof would have needed an additional
   39.27  case analysis in the induction step.
   39.28  
   39.29 +This example leads to the following induction heuristic:
   39.30 +\begin{quote}
   39.31 +\emph{Let @{text f} be a recursive function.
   39.32 +If the definition of @{text f} is more complicated
   39.33 +than having one equation for each constructor of some datatype,
   39.34 +then properties of @{text f} are best proved via @{text "f.induct"}.}
   39.35 +\end{quote}
   39.36 +
   39.37  The general case is often called \concept{computation induction},
   39.38  because the induction follows the (terminating!) computation.
   39.39  For every defining equation
   39.40 @@ -200,6 +209,35 @@
   39.41  But note that the induction rule does not mention @{text f} at all,
   39.42  except in its name, and is applicable independently of @{text f}.
   39.43  
   39.44 +
   39.45 +\subsection*{Exercises}
   39.46 +
   39.47 +\begin{exercise}
   39.48 +Starting from the type @{text "'a tree"} defined in the text, define
   39.49 +a function @{text "contents ::"} @{typ "'a tree \<Rightarrow> 'a list"}
   39.50 +that collects all values in a tree in a list, in any order,
   39.51 +without removing duplicates.
   39.52 +Then define a function @{text "treesum ::"} @{typ "nat tree \<Rightarrow> nat"}
   39.53 +that sums up all values in a tree of natural numbers
   39.54 +and prove @{prop "treesum t = listsum(contents t)"}.
   39.55 +\end{exercise}
   39.56 +
   39.57 +\begin{exercise}
   39.58 +Define a new type @{text "'a tree2"} of binary trees where values are also
   39.59 +stored in the leaves of the tree.  Also reformulate the
   39.60 +@{const mirror} function accordingly. Define two functions
   39.61 +@{text "pre_order"} and @{text "post_order"} of type @{text "'a tree2 \<Rightarrow> 'a list"}
   39.62 +that traverse a tree and collect all stored values in the respective order in
   39.63 +a list. Prove @{prop "pre_order (mirror t) = rev (post_order t)"}.
   39.64 +\end{exercise}
   39.65 +
   39.66 +\begin{exercise}
   39.67 +Define a function @{text "intersperse ::"} @{typ "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"}
   39.68 +such that @{text "intersperse a [x\<^sub>1, ..., x\<^sub>n] = [x\<^sub>1, a, x\<^sub>2, a, ..., a, x\<^sub>n]"}.
   39.69 +Now prove that @{prop "map f (intersperse a xs) = intersperse (f a) (map f xs)"}.
   39.70 +\end{exercise}
   39.71 +
   39.72 +
   39.73  \section{Induction Heuristics}
   39.74  
   39.75  We have already noted that theorems about recursive functions are proved by
   39.76 @@ -307,6 +345,18 @@
   39.77  matters in some cases. The variables that need to be quantified are typically
   39.78  those that change in recursive calls.
   39.79  
   39.80 +
   39.81 +\subsection*{Exercises}
   39.82 +
   39.83 +\begin{exercise}
   39.84 +Write a tail-recursive variant of the @{text add} function on @{typ nat}:
   39.85 +@{term "itadd :: nat \<Rightarrow> nat \<Rightarrow> nat"}.
   39.86 +Tail-recursive means that in the recursive case, @{text itadd} needs to call
   39.87 +itself directly: \mbox{@{term"itadd (Suc m) n"}} @{text"= itadd \<dots>"}.
   39.88 +Prove @{prop "itadd m n = add m n"}.
   39.89 +\end{exercise}
   39.90 +
   39.91 +
   39.92  \section{Simplification}
   39.93  
   39.94  So far we have talked a lot about simplifying terms without explaining the concept. \concept{Simplification} means
   39.95 @@ -481,9 +531,37 @@
   39.96  splits all case-expressions over natural numbers. For an arbitrary
   39.97  datatype @{text t} it is @{text "t.split"} instead of @{thm[source] nat.split}.
   39.98  Method @{text auto} can be modified in exactly the same way.
   39.99 +The modifier @{text "split:"} can be followed by multiple names.
  39.100 +Splitting if or case-expressions in the assumptions requires 
  39.101 +@{text "split: if_splits"} or @{text "split: t.splits"}.
  39.102  
  39.103  
  39.104 -\subsection{Exercises}
  39.105 +\subsection*{Exercises}
  39.106 +
  39.107 +\exercise\label{exe:tree0}
  39.108 +Define a datatype @{text tree0} of binary tree skeletons which do not store
  39.109 +any information, neither in the inner nodes nor in the leaves.
  39.110 +Define a function @{text "nodes :: tree0 \<Rightarrow> nat"} that counts the number of
  39.111 +all nodes (inner nodes and leaves) in such a tree.
  39.112 +Consider the following recursive function:
  39.113 +*}
  39.114 +(*<*)
  39.115 +datatype tree0 = Tip | Node tree0 tree0
  39.116 +(*>*)
  39.117 +fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
  39.118 +"explode 0 t = t" |
  39.119 +"explode (Suc n) t = explode n (Node t t)"
  39.120 +
  39.121 +text {*
  39.122 +Find an equation expressing the size of a tree after exploding it
  39.123 +(\noquotes{@{term [source] "nodes (explode n t)"}}) as a function
  39.124 +of @{term "nodes t"} and @{text n}. Prove your equation.
  39.125 +You may use the usual arithmetic operators including the exponentiation
  39.126 +operator ``@{text"^"}''. For example, \noquotes{@{prop [source] "2 ^ 2 = 4"}}.
  39.127 +
  39.128 +Hint: simplifying with the list of theorems @{thm[source] algebra_simps}
  39.129 +takes care of common algebraic properties of the arithmetic operators.
  39.130 +\endexercise
  39.131  
  39.132  \exercise
  39.133  Define arithmetic expressions in one variable over integers (type @{typ int})
  39.134 @@ -506,8 +584,7 @@
  39.135  that transforms an expression into a polynomial. This may require auxiliary
  39.136  functions. Prove that @{text coeffs} preserves the value of the expression:
  39.137  \mbox{@{prop"evalp (coeffs e) x = eval e x"}.}
  39.138 -Hint: simplifying with @{thm[source] algebra_simps} takes care of
  39.139 -common algebraic properties of @{text "+"} and @{text "*"}.
  39.140 +Hint: consider the hint in Exercise~\ref{exe:tree0}.
  39.141  \endexercise
  39.142  *}
  39.143  (*<*)
    40.1 --- a/src/Doc/ProgProve/document/intro-isabelle.tex	Thu Dec 05 17:52:12 2013 +0100
    40.2 +++ b/src/Doc/ProgProve/document/intro-isabelle.tex	Thu Dec 05 17:58:03 2013 +0100
    40.3 @@ -16,7 +16,7 @@
    40.4  of recursive functions.
    40.5  \ifsem
    40.6  \autoref{sec:CaseStudyExp} contains a
    40.7 -little case study: arithmetic and boolean expressions, their evaluation,
    40.8 +small case study: arithmetic and boolean expressions, their evaluation,
    40.9  optimization and compilation.
   40.10  \fi
   40.11  \autoref{ch:Logic} introduces the rest of HOL: the
   40.12 @@ -35,8 +35,8 @@
   40.13  % in the intersection of computation and logic.
   40.14  
   40.15  This introduction to the core of Isabelle is intentionally concrete and
   40.16 -example-based: we concentrate on examples that illustrate the typical cases;
   40.17 -we do not explain the general case if it can be inferred from the examples.
   40.18 +example-based: we concentrate on examples that illustrate the typical cases
   40.19 +without explaining the general case if it can be inferred from the examples.
   40.20  We cover the essentials (from a functional programming point of view) as
   40.21  quickly and compactly as possible.
   40.22  \ifsem
   40.23 @@ -46,7 +46,7 @@
   40.24  For a comprehensive treatment of all things Isabelle we recommend the
   40.25  \emph{Isabelle/Isar Reference Manual}~\cite{IsarRef}, which comes with the
   40.26  Isabelle distribution.
   40.27 -The tutorial by Nipkow, Paulson and Wenzel~\cite{LNCS2283} (in its updated version that comes with the Isabelle distribution) is still recommended for the wealth of examples and material, but its proof style is outdated. In particular it fails to cover the structured proof language Isar.
   40.28 +The tutorial by Nipkow, Paulson and Wenzel~\cite{LNCS2283} (in its updated version that comes with the Isabelle distribution) is still recommended for the wealth of examples and material, but its proof style is outdated. In particular it does not cover the structured proof language Isar.
   40.29  
   40.30  %This introduction to Isabelle has grown out of many years of teaching
   40.31  %Isabelle courses. 
   40.32 @@ -88,7 +88,7 @@
   40.33  
   40.34  \ifsem\else
   40.35  \paragraph{Acknowledgements}
   40.36 -I wish to thank the following people for their comments
   40.37 -on this document:
   40.38 -Florian Haftmann, Ren\'{e} Thiemann and Christian Sternagel.
   40.39 +I wish to thank the following people for their comments on this document:
   40.40 +Florian Haftmann, Ren\'{e} Thiemann, Sean Seefried, Christian Sternagel
   40.41 +and Carl Witty.
   40.42  \fi
   40.43 \ No newline at end of file
    41.1 --- a/src/Doc/Sledgehammer/document/root.tex	Thu Dec 05 17:52:12 2013 +0100
    41.2 +++ b/src/Doc/Sledgehammer/document/root.tex	Thu Dec 05 17:58:03 2013 +0100
    41.3 @@ -121,8 +121,8 @@
    41.4  
    41.5  For Isabelle/jEdit users, Sledgehammer provides an automatic mode that can be
    41.6  enabled via the ``Auto Sledgehammer'' option under ``Plugins > Plugin Options >
    41.7 -Isabelle > General.'' In this mode, Sledgehammer is run on every newly entered
    41.8 -theorem.
    41.9 +Isabelle > General.'' In this mode, a reduced version of Sledgehammer is run on
   41.10 +every newly entered theorem for a few seconds.
   41.11  
   41.12  \newbox\boxA
   41.13  \setbox\boxA=\hbox{\texttt{NOSPAM}}
   41.14 @@ -719,12 +719,16 @@
   41.15  If you use Isabelle/jEdit, Sledgehammer also provides an automatic mode that can
   41.16  be enabled via the ``Auto Sledgehammer'' option under ``Plugins > Plugin Options
   41.17  > Isabelle > General.'' For automatic runs, only the first prover set using
   41.18 -\textit{provers} (\S\ref{mode-of-operation}) is considered, fewer facts are
   41.19 -passed to the prover, \textit{slice} (\S\ref{mode-of-operation}) is disabled,
   41.20 -\textit{strict} (\S\ref{problem-encoding}) is enabled, \textit{verbose}
   41.21 -(\S\ref{output-format}) and \textit{debug} (\S\ref{output-format}) are disabled,
   41.22 -and \textit{timeout} (\S\ref{timeouts}) is superseded by the ``Auto Time Limit''
   41.23 -option in jEdit. Sledgehammer's output is also more concise.
   41.24 +\textit{provers} (\S\ref{mode-of-operation}) is considered (typically E),
   41.25 +\textit{slice} (\S\ref{mode-of-operation}) is disabled,
   41.26 +\textit{minimize} (\S\ref{mode-of-operation}) is disabled, fewer facts are
   41.27 +passed to the prover, \textit{fact\_filter} (\S\ref{relevance-filter}) is set to
   41.28 +\textit{mepo}, \textit{strict} (\S\ref{problem-encoding}) is enabled,
   41.29 +\textit{verbose} (\S\ref{output-format}) and \textit{debug}
   41.30 +(\S\ref{output-format}) are disabled, \textit{preplay\_timeout}
   41.31 +(\S\ref{timeouts}) is set to 0, and \textit{timeout} (\S\ref{timeouts}) is
   41.32 +superseded by the ``Auto Time Limit'' option in jEdit. Sledgehammer's output is
   41.33 +also more concise.
   41.34  
   41.35  \subsection{Metis}
   41.36  
   41.37 @@ -999,8 +1003,7 @@
   41.38  number of facts. For SMT solvers, several slices are tried with the same options
   41.39  each time but fewer and fewer facts. According to benchmarks with a timeout of
   41.40  30 seconds, slicing is a valuable optimization, and you should probably leave it
   41.41 -enabled unless you are conducting experiments. This option is implicitly
   41.42 -disabled for (short) automatic runs.
   41.43 +enabled unless you are conducting experiments.
   41.44  
   41.45  \nopagebreak
   41.46  {\small See also \textit{verbose} (\S\ref{output-format}).}
   41.47 @@ -1035,6 +1038,8 @@
   41.48  simultaneously. The files are identified by the prefixes \texttt{prob\_} and
   41.49  \texttt{mash\_}; you may safely remove them after Sledgehammer has run.
   41.50  
   41.51 +\textbf{Warning:} This option is not thread-safe. Use at your own risks.
   41.52 +
   41.53  \nopagebreak
   41.54  {\small See also \textit{debug} (\S\ref{output-format}).}
   41.55  \end{enum}
   41.56 @@ -1282,14 +1287,12 @@
   41.57  
   41.58  \opfalse{verbose}{quiet}
   41.59  Specifies whether the \textbf{sledgehammer} command should explain what it does.
   41.60 -This option is implicitly disabled for automatic runs.
   41.61  
   41.62  \opfalse{debug}{no\_debug}
   41.63  Specifies whether Sledgehammer should display additional debugging information
   41.64  beyond what \textit{verbose} already displays. Enabling \textit{debug} also
   41.65  enables \textit{verbose} and \textit{blocking} (\S\ref{mode-of-operation})
   41.66 -behind the scenes. The \textit{debug} option is implicitly disabled for
   41.67 -automatic runs.
   41.68 +behind the scenes.
   41.69  
   41.70  \nopagebreak
   41.71  {\small See also \textit{spy} (\S\ref{mode-of-operation}) and
   41.72 @@ -1349,8 +1352,6 @@
   41.73  \opdefault{timeout}{float\_or\_none}{\upshape 30}
   41.74  Specifies the maximum number of seconds that the automatic provers should spend
   41.75  searching for a proof. This excludes problem preparation and is a soft limit.
   41.76 -For automatic runs, the ``Auto Time Limit'' option under ``Plugins > Plugin
   41.77 -Options > Isabelle > General'' is used instead.
   41.78  
   41.79  \opdefault{preplay\_timeout}{float\_or\_none}{\upshape 3}
   41.80  Specifies the maximum number of seconds that \textit{metis} or \textit{smt}
    42.1 --- a/src/Doc/System/Sessions.thy	Thu Dec 05 17:52:12 2013 +0100
    42.2 +++ b/src/Doc/System/Sessions.thy	Thu Dec 05 17:58:03 2013 +0100
    42.3 @@ -399,7 +399,7 @@
    42.4    \smallskip Build some session images with cleanup of their
    42.5    descendants, while retaining their ancestry:
    42.6  \begin{ttbox}
    42.7 -isabelle build -b -c HOL-Boogie HOL-SPARK
    42.8 +isabelle build -b -c HOL-Algebra HOL-Word
    42.9  \end{ttbox}
   42.10  
   42.11    \smallskip Clean all sessions without building anything:
    43.1 --- a/src/Doc/Tutorial/document/rules.tex	Thu Dec 05 17:52:12 2013 +0100
    43.2 +++ b/src/Doc/Tutorial/document/rules.tex	Thu Dec 05 17:58:03 2013 +0100
    43.3 @@ -1,4 +1,4 @@
    43.4 -%!TEX root = ../tutorial.tex
    43.5 +%!TEX root = root.tex
    43.6  \chapter{The Rules of the Game}
    43.7  \label{chap:rules}
    43.8   
    43.9 @@ -33,6 +33,8 @@
   43.10  one symbol only.  For predicate logic this can be 
   43.11  done, but when users define their own concepts they typically 
   43.12  have to refer to other symbols as well.  It is best not to be dogmatic.
   43.13 +Our system is not based on pure natural deduction, but includes elements from the sequent calculus 
   43.14 +and free-variable tableaux.
   43.15  
   43.16  Natural deduction generally deserves its name.  It is easy to use.  Each
   43.17  proof step consists of identifying the outermost symbol of a formula and
   43.18 @@ -240,13 +242,14 @@
   43.19  of a conjunction.  Rules of this sort (where the conclusion is a subformula of a
   43.20  premise) are called \textbf{destruction} rules because they take apart and destroy
   43.21  a premise.%
   43.22 -\footnote{This Isabelle terminology has no counterpart in standard logic texts, 
   43.23 +\footnote{This Isabelle terminology is not used in standard logic texts, 
   43.24  although the distinction between the two forms of elimination rule is well known. 
   43.25  Girard \cite[page 74]{girard89},\index{Girard, Jean-Yves|fnote}
   43.26  for example, writes ``The elimination rules 
   43.27  [for $\disj$ and $\exists$] are very
   43.28  bad.  What is catastrophic about them is the parasitic presence of a formula [$R$]
   43.29 -which has no structural link with the formula which is eliminated.''}
   43.30 +which has no structural link with the formula which is eliminated.''
   43.31 +These Isabelle rules are inspired by the sequent calculus.}
   43.32  
   43.33  The first proof step applies conjunction introduction, leaving 
   43.34  two subgoals: 
    44.1 --- a/src/Doc/Tutorial/document/sets.tex	Thu Dec 05 17:52:12 2013 +0100
    44.2 +++ b/src/Doc/Tutorial/document/sets.tex	Thu Dec 05 17:58:03 2013 +0100
    44.3 @@ -660,8 +660,8 @@
    44.4  \textbf{Composition} of relations (the infix \sdx{O}) is also
    44.5  available: 
    44.6  \begin{isabelle}
    44.7 -r\ O\ s\ \isasymequiv\ \isacharbraceleft(x,z).\ \isasymexists y.\ (x,y)\ \isasymin\ s\ \isasymand\ (y,z)\ \isasymin\ r\isacharbraceright
    44.8 -\rulenamedx{rel_comp_def}
    44.9 +r\ O\ s\ = \isacharbraceleft(x,z).\ \isasymexists y.\ (x,y)\ \isasymin\ s\ \isasymand\ (y,z)\ \isasymin\ r\isacharbraceright
   44.10 +\rulenamedx{relcomp_unfold}
   44.11  \end{isabelle}
   44.12  %
   44.13  This is one of the many lemmas proved about these concepts: 
   44.14 @@ -677,7 +677,7 @@
   44.15  \isasymlbrakk r\isacharprime\ \isasymsubseteq\ r;\ s\isacharprime\
   44.16  \isasymsubseteq\ s\isasymrbrakk\ \isasymLongrightarrow\ r\isacharprime\ O\
   44.17  s\isacharprime\ \isasymsubseteq\ r\ O\ s%
   44.18 -\rulename{rel_comp_mono}
   44.19 +\rulename{relcomp_mono}
   44.20  \end{isabelle}
   44.21  
   44.22  \indexbold{converse!of a relation}%
   44.23 @@ -695,7 +695,7 @@
   44.24  Here is a typical law proved about converse and composition: 
   44.25  \begin{isabelle}
   44.26  (r\ O\ s)\isasyminverse\ =\ s\isasyminverse\ O\ r\isasyminverse
   44.27 -\rulename{converse_rel_comp}
   44.28 +\rulename{converse_relcomp}
   44.29  \end{isabelle}
   44.30  
   44.31  \indexbold{image!under a relation}%
    45.1 --- a/src/Doc/manual.bib	Thu Dec 05 17:52:12 2013 +0100
    45.2 +++ b/src/Doc/manual.bib	Thu Dec 05 17:58:03 2013 +0100
    45.3 @@ -194,7 +194,7 @@
    45.4  @incollection{basin91,
    45.5    author	= {David Basin and Matt Kaufmann},
    45.6    title		= {The {Boyer-Moore} Prover and {Nuprl}: An Experimental
    45.7 -		   Comparison}, 
    45.8 +		   Comparison},
    45.9    crossref	= {huet-plotkin91},
   45.10    pages		= {89-119}}
   45.11  
   45.12 @@ -472,7 +472,7 @@
   45.13  @book{constable86,
   45.14    author	= {R. L. Constable and others},
   45.15    title		= {Implementing Mathematics with the Nuprl Proof
   45.16 -		 Development System}, 
   45.17 +		 Development System},
   45.18    publisher	= Prentice,
   45.19    year		= 1986}
   45.20  
   45.21 @@ -505,7 +505,7 @@
   45.22  @incollection{dybjer91,
   45.23    author	= {Peter Dybjer},
   45.24    title		= {Inductive Sets and Families in {Martin-L{\"o}f's} Type
   45.25 -		  Theory and Their Set-Theoretic Semantics}, 
   45.26 +		  Theory and Their Set-Theoretic Semantics},
   45.27    crossref	= {huet-plotkin91},
   45.28    pages		= {280-306}}
   45.29  
   45.30 @@ -533,7 +533,7 @@
   45.31  @InProceedings{felty91a,
   45.32    Author	= {Amy Felty},
   45.33    Title		= {A Logic Program for Transforming Sequent Proofs to Natural
   45.34 -		  Deduction Proofs}, 
   45.35 +		  Deduction Proofs},
   45.36    crossref	= {extensions91},
   45.37    pages		= {157-178}}
   45.38  
   45.39 @@ -566,9 +566,9 @@
   45.40  
   45.41  @inproceedings{OBJ,
   45.42    author	= {K. Futatsugi and J.A. Goguen and Jean-Pierre Jouannaud
   45.43 -		 and J. Meseguer}, 
   45.44 +		 and J. Meseguer},
   45.45    title		= {Principles of {OBJ2}},
   45.46 -  booktitle	= POPL, 
   45.47 +  booktitle	= POPL,
   45.48    year		= 1985,
   45.49    pages		= {52-66}}
   45.50  
   45.51 @@ -576,7 +576,7 @@
   45.52  
   45.53  @book{gallier86,
   45.54    author	= {J. H. Gallier},
   45.55 -  title		= {Logic for Computer Science: 
   45.56 +  title		= {Logic for Computer Science:
   45.57  		Foundations of Automatic Theorem Proving},
   45.58    year		= 1986,
   45.59    publisher	= {Harper \& Row}}
   45.60 @@ -605,8 +605,8 @@
   45.61    author	= {Jean-Yves Girard},
   45.62    title		= {Proofs and Types},
   45.63    year		= 1989,
   45.64 -  publisher	= CUP, 
   45.65 -  note		= {Translated by Yves LaFont and Paul Taylor}}
   45.66 +  publisher	= CUP,
   45.67 +  note		= {Translated by Yves Lafont and Paul Taylor}}
   45.68  
   45.69  @Book{mgordon-hol,
   45.70    editor	= {M. J. C. Gordon and T. F. Melham},
   45.71 @@ -777,21 +777,21 @@
   45.72  
   45.73  @article{huet78,
   45.74    author	= {G. P. Huet and B. Lang},
   45.75 -  title		= {Proving and Applying Program Transformations Expressed with 
   45.76 +  title		= {Proving and Applying Program Transformations Expressed with
   45.77  			Second-Order Patterns},
   45.78    journal	= acta,
   45.79    volume	= 11,
   45.80 -  year		= 1978, 
   45.81 +  year		= 1978,
   45.82    pages		= {31-55}}
   45.83  
   45.84  @inproceedings{huet88,
   45.85    author	= {G{\'e}rard Huet},
   45.86    title		= {Induction Principles Formalized in the {Calculus of
   45.87 -		 Constructions}}, 
   45.88 +		 Constructions}},
   45.89    booktitle	= {Programming of Future Generation Computers},
   45.90    editor	= {K. Fuchi and M. Nivat},
   45.91    year		= 1988,
   45.92 -  pages		= {205-216}, 
   45.93 +  pages		= {205-216},
   45.94    publisher	= {Elsevier}}
   45.95  
   45.96  @inproceedings{Huffman-Kuncar:2013:lifting_transfer,
   45.97 @@ -843,7 +843,7 @@
   45.98  %K
   45.99  
  45.100  @InProceedings{kammueller-locales,
  45.101 -  author = 	 {Florian Kamm{\"u}ller and Markus Wenzel and 
  45.102 +  author = 	 {Florian Kamm{\"u}ller and Markus Wenzel and
  45.103                    Lawrence C. Paulson},
  45.104    title = 	 {Locales: A Sectioning Concept for {Isabelle}},
  45.105    crossref =	 {tphols99}}
  45.106 @@ -926,7 +926,7 @@
  45.107    note = "\url{https://github.com/frelindb/agsyHOL}"}
  45.108  
  45.109  @incollection{lochbihler-2010,
  45.110 -  title = "Coinduction",
  45.111 +  title = "Coinductive",
  45.112    author = "Andreas Lochbihler",
  45.113    booktitle = "The Archive of Formal Proofs",
  45.114    editor = "Gerwin Klein and Tobias Nipkow and Lawrence C. Paulson",
  45.115 @@ -944,7 +944,7 @@
  45.116    author	= {Gavin Lowe},
  45.117    title		= {Breaking and Fixing the {Needham}-{Schroeder} Public-Key
  45.118  		  Protocol using {CSP} and {FDR}},
  45.119 -  booktitle = 	 {Tools and Algorithms for the Construction and Analysis 
  45.120 +  booktitle = 	 {Tools and Algorithms for the Construction and Analysis
  45.121                    of Systems:  second international workshop, TACAS '96},
  45.122    editor =	 {T. Margaria and B. Steffen},
  45.123    series =	 {LNCS 1055},
  45.124 @@ -978,7 +978,7 @@
  45.125  @incollection{melham89,
  45.126    author	= {Thomas F. Melham},
  45.127    title		= {Automating Recursive Type Definitions in Higher Order
  45.128 -		 Logic}, 
  45.129 +		 Logic},
  45.130    pages		= {341-386},
  45.131    crossref	= {birtwistle89}}
  45.132  
  45.133 @@ -1057,7 +1057,7 @@
  45.134  
  45.135  @InProceedings{NaraschewskiW-TPHOLs98,
  45.136    author	= {Wolfgang Naraschewski and Markus Wenzel},
  45.137 -  title		= 
  45.138 +  title		=
  45.139  {Object-Oriented Verification based on Record Subtyping in
  45.140                    Higher-Order Logic},
  45.141    crossref      = {tphols98}}
  45.142 @@ -1190,8 +1190,8 @@
  45.143  @book{nordstrom90,
  45.144    author	= {Bengt {Nordstr{\"o}m} and Kent Petersson and Jan Smith},
  45.145    title		= {Programming in {Martin-L{\"o}f}'s Type Theory.  An
  45.146 -		 Introduction}, 
  45.147 -  publisher	= {Oxford University Press}, 
  45.148 +		 Introduction},
  45.149 +  publisher	= {Oxford University Press},
  45.150    year		= 1990}
  45.151  
  45.152  %O
  45.153 @@ -1251,7 +1251,7 @@
  45.154  @InProceedings{paulson-COLOG,
  45.155    author	= {Lawrence C. Paulson},
  45.156    title		= {A Formulation of the Simple Theory of Types (for
  45.157 -		 {Isabelle})}, 
  45.158 +		 {Isabelle})},
  45.159    pages		= {246-274},
  45.160    crossref	= {colog88},
  45.161    url		= {\url{http://www.cl.cam.ac.uk/Research/Reports/TR175-lcp-simple.dvi.gz}}}
  45.162 @@ -1304,7 +1304,7 @@
  45.163  %replaces paulson-final
  45.164  @Article{paulson-mscs,
  45.165    author	= {Lawrence C. Paulson},
  45.166 -  title = 	 {Final Coalgebras as Greatest Fixed Points 
  45.167 +  title = 	 {Final Coalgebras as Greatest Fixed Points
  45.168                    in {ZF} Set Theory},
  45.169    journal	= {Mathematical Structures in Computer Science},
  45.170    year		= 1999,
  45.171 @@ -1337,9 +1337,9 @@
  45.172    crossref	= {milner-fest}}
  45.173  
  45.174  @book{milner-fest,
  45.175 -  title		= {Proof, Language, and Interaction: 
  45.176 +  title		= {Proof, Language, and Interaction:
  45.177                     Essays in Honor of {Robin Milner}},
  45.178 -  booktitle	= {Proof, Language, and Interaction: 
  45.179 +  booktitle	= {Proof, Language, and Interaction:
  45.180                     Essays in Honor of {Robin Milner}},
  45.181    publisher	= MIT,
  45.182    year		= 2000,
  45.183 @@ -1427,7 +1427,7 @@
  45.184  @book{paulson87,
  45.185    author	= {Lawrence C. Paulson},
  45.186    title		= {Logic and Computation: Interactive proof with Cambridge
  45.187 -		 LCF}, 
  45.188 +		 LCF},
  45.189    year		= 1987,
  45.190    publisher	= CUP}
  45.191  
  45.192 @@ -1470,7 +1470,7 @@
  45.193  @article{pelletier86,
  45.194    author	= {F. J. Pelletier},
  45.195    title		= {Seventy-five Problems for Testing Automatic Theorem
  45.196 -		 Provers}, 
  45.197 +		 Provers},
  45.198    journal	= JAR,
  45.199    volume	= 2,
  45.200    pages		= {191-216},
  45.201 @@ -1486,13 +1486,13 @@
  45.202    publisher	= CUP,
  45.203    year		= 1993}
  45.204  
  45.205 -@Article{pitts94,  
  45.206 +@Article{pitts94,
  45.207    author	= {Andrew M. Pitts},
  45.208    title		= {A Co-induction Principle for Recursively Defined Domains},
  45.209    journal	= TCS,
  45.210 -  volume	= 124, 
  45.211 +  volume	= 124,
  45.212    pages		= {195-219},
  45.213 -  year		= 1994} 
  45.214 +  year		= 1994}
  45.215  
  45.216  @Article{plaisted90,
  45.217    author	= {David A. Plaisted},
  45.218 @@ -1561,7 +1561,7 @@
  45.219  @inproceedings{saaltink-fme,
  45.220    author	= {Mark Saaltink and Sentot Kromodimoeljo and Bill Pase and
  45.221  		 Dan Craigen and Irwin Meisels},
  45.222 -  title		= {An {EVES} Data Abstraction Example}, 
  45.223 +  title		= {An {EVES} Data Abstraction Example},
  45.224    pages		= {578-596},
  45.225    crossref	= {fme93}}
  45.226  
  45.227 @@ -1897,7 +1897,7 @@
  45.228    author	= {A. N. Whitehead and B. Russell},
  45.229    title		= {Principia Mathematica},
  45.230    year		= 1962,
  45.231 -  publisher	= CUP, 
  45.232 +  publisher	= CUP,
  45.233    note		= {Paperback edition to *56,
  45.234    abridged from the 2nd edition (1927)}}
  45.235  
  45.236 @@ -1982,9 +1982,9 @@
  45.237  @book{birtwistle89,
  45.238    editor	= {Graham Birtwistle and P. A. Subrahmanyam},
  45.239    title		= {Current Trends in Hardware Verification and Automated
  45.240 -		 Theorem Proving}, 
  45.241 +		 Theorem Proving},
  45.242    booktitle	= {Current Trends in Hardware Verification and Automated
  45.243 -		 Theorem Proving}, 
  45.244 +		 Theorem Proving},
  45.245    publisher	= {Springer},
  45.246    year		= 1989}
  45.247  
  45.248 @@ -1997,9 +1997,9 @@
  45.249  
  45.250  @Proceedings{cade12,
  45.251    editor	= {Alan Bundy},
  45.252 -  title		= {Automated Deduction --- {CADE}-12 
  45.253 +  title		= {Automated Deduction --- {CADE}-12
  45.254  		  International Conference},
  45.255 -  booktitle	= {Automated Deduction --- {CADE}-12 
  45.256 +  booktitle	= {Automated Deduction --- {CADE}-12
  45.257  		  International Conference},
  45.258    year		= 1994,
  45.259    series	= {LNAI 814},
  45.260 @@ -2059,7 +2059,7 @@
  45.261    title		= {Extensions of Logic Programming},
  45.262    booktitle	= {Extensions of Logic Programming},
  45.263    year		= 1991,
  45.264 -  series	= {LNAI 475}, 
  45.265 +  series	= {LNAI 475},
  45.266    publisher	= {Springer}}
  45.267  
  45.268  @proceedings{cade10,
  45.269 @@ -2078,9 +2078,9 @@
  45.270    year		= 1993}
  45.271  
  45.272  @book{wos-fest,
  45.273 -  title		= {Automated Reasoning and its Applications: 
  45.274 +  title		= {Automated Reasoning and its Applications:
  45.275  			Essays in Honor of {Larry Wos}},
  45.276 -  booktitle	= {Automated Reasoning and its Applications: 
  45.277 +  booktitle	= {Automated Reasoning and its Applications:
  45.278  			Essays in Honor of {Larry Wos}},
  45.279    publisher	= MIT,
  45.280    year		= 1997,
    46.1 --- a/src/HOL/ATP.thy	Thu Dec 05 17:52:12 2013 +0100
    46.2 +++ b/src/HOL/ATP.thy	Thu Dec 05 17:58:03 2013 +0100
    46.3 @@ -18,34 +18,34 @@
    46.4  
    46.5  subsection {* Higher-order reasoning helpers *}
    46.6  
    46.7 -definition fFalse :: bool where [no_atp]:
    46.8 +definition fFalse :: bool where
    46.9  "fFalse \<longleftrightarrow> False"
   46.10  
   46.11 -definition fTrue :: bool where [no_atp]:
   46.12 +definition fTrue :: bool where
   46.13  "fTrue \<longleftrightarrow> True"
   46.14  
   46.15 -definition fNot :: "bool \<Rightarrow> bool" where [no_atp]:
   46.16 +definition fNot :: "bool \<Rightarrow> bool" where
   46.17  "fNot P \<longleftrightarrow> \<not> P"
   46.18  
   46.19 -definition fComp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where [no_atp]:
   46.20 +definition fComp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where
   46.21  "fComp P = (\<lambda>x. \<not> P x)"
   46.22  
   46.23 -definition fconj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
   46.24 +definition fconj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
   46.25  "fconj P Q \<longleftrightarrow> P \<and> Q"
   46.26  
   46.27 -definition fdisj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
   46.28 +definition fdisj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
   46.29  "fdisj P Q \<longleftrightarrow> P \<or> Q"
   46.30  
   46.31 -definition fimplies :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
   46.32 +definition fimplies :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
   46.33  "fimplies P Q \<longleftrightarrow> (P \<longrightarrow> Q)"
   46.34  
   46.35 -definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where [no_atp]:
   46.36 +definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
   46.37  "fequal x y \<longleftrightarrow> (x = y)"
   46.38  
   46.39 -definition fAll :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where [no_atp]:
   46.40 +definition fAll :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
   46.41  "fAll P \<longleftrightarrow> All P"
   46.42  
   46.43 -definition fEx :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where [no_atp]:
   46.44 +definition fEx :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
   46.45  "fEx P \<longleftrightarrow> Ex P"
   46.46  
   46.47  lemma fTrue_ne_fFalse: "fFalse \<noteq> fTrue"
    47.1 --- a/src/HOL/Archimedean_Field.thy	Thu Dec 05 17:52:12 2013 +0100
    47.2 +++ b/src/HOL/Archimedean_Field.thy	Thu Dec 05 17:58:03 2013 +0100
    47.3 @@ -129,12 +129,8 @@
    47.4    fix y z assume
    47.5      "of_int y \<le> x \<and> x < of_int (y + 1)"
    47.6      "of_int z \<le> x \<and> x < of_int (z + 1)"
    47.7 -  then have
    47.8 -    "of_int y \<le> x" "x < of_int (y + 1)"
    47.9 -    "of_int z \<le> x" "x < of_int (z + 1)"
   47.10 -    by simp_all
   47.11 -  from le_less_trans [OF `of_int y \<le> x` `x < of_int (z + 1)`]
   47.12 -       le_less_trans [OF `of_int z \<le> x` `x < of_int (y + 1)`]
   47.13 +  with le_less_trans [of "of_int y" "x" "of_int (z + 1)"]
   47.14 +       le_less_trans [of "of_int z" "x" "of_int (y + 1)"]
   47.15    show "y = z" by (simp del: of_int_add)
   47.16  qed
   47.17  
   47.18 @@ -208,8 +204,8 @@
   47.19  lemma floor_numeral [simp]: "floor (numeral v) = numeral v"
   47.20    using floor_of_int [of "numeral v"] by simp
   47.21  
   47.22 -lemma floor_neg_numeral [simp]: "floor (neg_numeral v) = neg_numeral v"
   47.23 -  using floor_of_int [of "neg_numeral v"] by simp
   47.24 +lemma floor_neg_numeral [simp]: "floor (- numeral v) = - numeral v"
   47.25 +  using floor_of_int [of "- numeral v"] by simp
   47.26  
   47.27  lemma zero_le_floor [simp]: "0 \<le> floor x \<longleftrightarrow> 0 \<le> x"
   47.28    by (simp add: le_floor_iff)
   47.29 @@ -222,7 +218,7 @@
   47.30    by (simp add: le_floor_iff)
   47.31  
   47.32  lemma neg_numeral_le_floor [simp]:
   47.33 -  "neg_numeral v \<le> floor x \<longleftrightarrow> neg_numeral v \<le> x"
   47.34 +  "- numeral v \<le> floor x \<longleftrightarrow> - numeral v \<le> x"
   47.35    by (simp add: le_floor_iff)
   47.36  
   47.37  lemma zero_less_floor [simp]: "0 < floor x \<longleftrightarrow> 1 \<le> x"
   47.38 @@ -236,7 +232,7 @@
   47.39    by (simp add: less_floor_iff)
   47.40  
   47.41  lemma neg_numeral_less_floor [simp]:
   47.42 -  "neg_numeral v < floor x \<longleftrightarrow> neg_numeral v + 1 \<le> x"
   47.43 +  "- numeral v < floor x \<longleftrightarrow> - numeral v + 1 \<le> x"
   47.44    by (simp add: less_floor_iff)
   47.45  
   47.46  lemma floor_le_zero [simp]: "floor x \<le> 0 \<longleftrightarrow> x < 1"
   47.47 @@ -250,7 +246,7 @@
   47.48    by (simp add: floor_le_iff)
   47.49  
   47.50  lemma floor_le_neg_numeral [simp]:
   47.51 -  "floor x \<le> neg_numeral v \<longleftrightarrow> x < neg_numeral v + 1"
   47.52 +  "floor x \<le> - numeral v \<longleftrightarrow> x < - numeral v + 1"
   47.53    by (simp add: floor_le_iff)
   47.54  
   47.55  lemma floor_less_zero [simp]: "floor x < 0 \<longleftrightarrow> x < 0"
   47.56 @@ -264,7 +260,7 @@
   47.57    by (simp add: floor_less_iff)
   47.58  
   47.59  lemma floor_less_neg_numeral [simp]:
   47.60 -  "floor x < neg_numeral v \<longleftrightarrow> x < neg_numeral v"
   47.61 +  "floor x < - numeral v \<longleftrightarrow> x < - numeral v"
   47.62    by (simp add: floor_less_iff)
   47.63  
   47.64  text {* Addition and subtraction of integers *}
   47.65 @@ -276,10 +272,6 @@
   47.66      "floor (x + numeral v) = floor x + numeral v"
   47.67    using floor_add_of_int [of x "numeral v"] by simp
   47.68  
   47.69 -lemma floor_add_neg_numeral [simp]:
   47.70 -    "floor (x + neg_numeral v) = floor x + neg_numeral v"
   47.71 -  using floor_add_of_int [of x "neg_numeral v"] by simp
   47.72 -
   47.73  lemma floor_add_one [simp]: "floor (x + 1) = floor x + 1"
   47.74    using floor_add_of_int [of x 1] by simp
   47.75  
   47.76 @@ -290,10 +282,6 @@
   47.77    "floor (x - numeral v) = floor x - numeral v"
   47.78    using floor_diff_of_int [of x "numeral v"] by simp
   47.79  
   47.80 -lemma floor_diff_neg_numeral [simp]:
   47.81 -  "floor (x - neg_numeral v) = floor x - neg_numeral v"
   47.82 -  using floor_diff_of_int [of x "neg_numeral v"] by simp
   47.83 -
   47.84  lemma floor_diff_one [simp]: "floor (x - 1) = floor x - 1"
   47.85    using floor_diff_of_int [of x 1] by simp
   47.86  
   47.87 @@ -357,8 +345,8 @@
   47.88  lemma ceiling_numeral [simp]: "ceiling (numeral v) = numeral v"
   47.89    using ceiling_of_int [of "numeral v"] by simp
   47.90  
   47.91 -lemma ceiling_neg_numeral [simp]: "ceiling (neg_numeral v) = neg_numeral v"
   47.92 -  using ceiling_of_int [of "neg_numeral v"] by simp
   47.93 +lemma ceiling_neg_numeral [simp]: "ceiling (- numeral v) = - numeral v"
   47.94 +  using ceiling_of_int [of "- numeral v"] by simp
   47.95  
   47.96  lemma ceiling_le_zero [simp]: "ceiling x \<le> 0 \<longleftrightarrow> x \<le> 0"
   47.97    by (simp add: ceiling_le_iff)
   47.98 @@ -371,7 +359,7 @@
   47.99    by (simp add: ceiling_le_iff)
  47.100  
  47.101  lemma ceiling_le_neg_numeral [simp]:
  47.102 -  "ceiling x \<le> neg_numeral v \<longleftrightarrow> x \<le> neg_numeral v"
  47.103 +  "ceiling x \<le> - numeral v \<longleftrightarrow> x \<le> - numeral v"
  47.104    by (simp add: ceiling_le_iff)
  47.105  
  47.106  lemma ceiling_less_zero [simp]: "ceiling x < 0 \<longleftrightarrow> x \<le> -1"
  47.107 @@ -385,7 +373,7 @@
  47.108    by (simp add: ceiling_less_iff)
  47.109  
  47.110  lemma ceiling_less_neg_numeral [simp]:
  47.111 -  "ceiling x < neg_numeral v \<longleftrightarrow> x \<le> neg_numeral v - 1"
  47.112 +  "ceiling x < - numeral v \<longleftrightarrow> x \<le> - numeral v - 1"
  47.113    by (simp add: ceiling_less_iff)
  47.114  
  47.115  lemma zero_le_ceiling [simp]: "0 \<le> ceiling x \<longleftrightarrow> -1 < x"
  47.116 @@ -399,7 +387,7 @@
  47.117    by (simp add: le_ceiling_iff)
  47.118  
  47.119  lemma neg_numeral_le_ceiling [simp]:
  47.120 -  "neg_numeral v \<le> ceiling x \<longleftrightarrow> neg_numeral v - 1 < x"
  47.121 +  "- numeral v \<le> ceiling x \<longleftrightarrow> - numeral v - 1 < x"
  47.122    by (simp add: le_ceiling_iff)
  47.123  
  47.124  lemma zero_less_ceiling [simp]: "0 < ceiling x \<longleftrightarrow> 0 < x"
  47.125 @@ -413,7 +401,7 @@
  47.126    by (simp add: less_ceiling_iff)
  47.127  
  47.128  lemma neg_numeral_less_ceiling [simp]:
  47.129 -  "neg_numeral v < ceiling x \<longleftrightarrow> neg_numeral v < x"
  47.130 +  "- numeral v < ceiling x \<longleftrightarrow> - numeral v < x"
  47.131    by (simp add: less_ceiling_iff)
  47.132  
  47.133  text {* Addition and subtraction of integers *}
  47.134 @@ -425,10 +413,6 @@
  47.135      "ceiling (x + numeral v) = ceiling x + numeral v"
  47.136    using ceiling_add_of_int [of x "numeral v"] by simp
  47.137  
  47.138 -lemma ceiling_add_neg_numeral [simp]:
  47.139 -    "ceiling (x + neg_numeral v) = ceiling x + neg_numeral v"
  47.140 -  using ceiling_add_of_int [of x "neg_numeral v"] by simp
  47.141 -
  47.142  lemma ceiling_add_one [simp]: "ceiling (x + 1) = ceiling x + 1"
  47.143    using ceiling_add_of_int [of x 1] by simp
  47.144  
  47.145 @@ -439,10 +423,6 @@
  47.146    "ceiling (x - numeral v) = ceiling x - numeral v"
  47.147    using ceiling_diff_of_int [of x "numeral v"] by simp
  47.148  
  47.149 -lemma ceiling_diff_neg_numeral [simp]:
  47.150 -  "ceiling (x - neg_numeral v) = ceiling x - neg_numeral v"
  47.151 -  using ceiling_diff_of_int [of x "neg_numeral v"] by simp
  47.152 -
  47.153  lemma ceiling_diff_one [simp]: "ceiling (x - 1) = ceiling x - 1"
  47.154    using ceiling_diff_of_int [of x 1] by simp
  47.155  
    48.1 --- a/src/HOL/BNF/BNF.thy	Thu Dec 05 17:52:12 2013 +0100
    48.2 +++ b/src/HOL/BNF/BNF.thy	Thu Dec 05 17:58:03 2013 +0100
    48.3 @@ -10,7 +10,7 @@
    48.4  header {* Bounded Natural Functors for (Co)datatypes *}
    48.5  
    48.6  theory BNF
    48.7 -imports More_BNFs BNF_LFP BNF_GFP Coinduction
    48.8 +imports Countable_Set_Type BNF_LFP BNF_GFP BNF_Decl
    48.9  begin
   48.10  
   48.11  hide_const (open) image2 image2p vimage2p Gr Grp collect fsts snds setl setr 
    49.1 --- a/src/HOL/BNF/BNF_Comp.thy	Thu Dec 05 17:52:12 2013 +0100
    49.2 +++ b/src/HOL/BNF/BNF_Comp.thy	Thu Dec 05 17:58:03 2013 +0100
    49.3 @@ -11,6 +11,9 @@
    49.4  imports Basic_BNFs
    49.5  begin
    49.6  
    49.7 +lemma wpull_id: "wpull UNIV B1 B2 id id id id"
    49.8 +unfolding wpull_def by simp
    49.9 +
   49.10  lemma empty_natural: "(\<lambda>_. {}) o f = image g o (\<lambda>_. {})"
   49.11  by (rule ext) simp
   49.12  
    50.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    50.2 +++ b/src/HOL/BNF/BNF_Decl.thy	Thu Dec 05 17:58:03 2013 +0100
    50.3 @@ -0,0 +1,18 @@
    50.4 +(*  Title:      HOL/BNF/BNF_Decl.thy
    50.5 +    Author:     Dmitriy Traytel, TU Muenchen
    50.6 +    Copyright   2013
    50.7 +
    50.8 +Axiomatic declaration of bounded natural functors.
    50.9 +*)
   50.10 +
   50.11 +header {* Axiomatic declaration of Bounded Natural Functors *}
   50.12 +
   50.13 +theory BNF_Decl
   50.14 +imports BNF_Def
   50.15 +keywords
   50.16 +  "bnf_decl" :: thy_decl
   50.17 +begin
   50.18 +
   50.19 +ML_file "Tools/bnf_decl.ML"
   50.20 +
   50.21 +end
    51.1 --- a/src/HOL/BNF/BNF_Def.thy	Thu Dec 05 17:52:12 2013 +0100
    51.2 +++ b/src/HOL/BNF/BNF_Def.thy	Thu Dec 05 17:58:03 2013 +0100
    51.3 @@ -9,6 +9,8 @@
    51.4  
    51.5  theory BNF_Def
    51.6  imports BNF_Util
    51.7 +   (*FIXME: register fundef_cong attribute in an interpretation to remove this dependency*)
    51.8 +  FunDef
    51.9  keywords
   51.10    "print_bnfs" :: diag and
   51.11    "bnf" :: thy_goal
   51.12 @@ -190,17 +192,17 @@
   51.13  lemma vimage2pI: "R (f x) (g y) \<Longrightarrow> vimage2p f g R x y"
   51.14    unfolding vimage2p_def by -
   51.15  
   51.16 -lemma vimage2pD: "vimage2p f g R x y \<Longrightarrow> R (f x) (g y)"
   51.17 -  unfolding vimage2p_def by -
   51.18 -
   51.19  lemma fun_rel_iff_leq_vimage2p: "(fun_rel R S) f g = (R \<le> vimage2p f g S)"
   51.20    unfolding fun_rel_def vimage2p_def by auto
   51.21  
   51.22  lemma convol_image_vimage2p: "<f o fst, g o snd> ` Collect (split (vimage2p f g R)) \<subseteq> Collect (split R)"
   51.23    unfolding vimage2p_def convol_def by auto
   51.24  
   51.25 +(*FIXME: duplicates lemma from Record.thy*)
   51.26 +lemma o_eq_dest_lhs: "a o b = c \<Longrightarrow> a (b v) = c v"
   51.27 +  by clarsimp
   51.28 +
   51.29  ML_file "Tools/bnf_def_tactics.ML"
   51.30  ML_file "Tools/bnf_def.ML"
   51.31  
   51.32 -
   51.33  end
    52.1 --- a/src/HOL/BNF/BNF_FP_Base.thy	Thu Dec 05 17:52:12 2013 +0100
    52.2 +++ b/src/HOL/BNF/BNF_FP_Base.thy	Thu Dec 05 17:58:03 2013 +0100
    52.3 @@ -13,12 +13,6 @@
    52.4  imports BNF_Comp Ctr_Sugar
    52.5  begin
    52.6  
    52.7 -lemma not_TrueE: "\<not> True \<Longrightarrow> P"
    52.8 -by (erule notE, rule TrueI)
    52.9 -
   52.10 -lemma neq_eq_eq_contradict: "\<lbrakk>t \<noteq> u; s = t; s = u\<rbrakk> \<Longrightarrow> P"
   52.11 -by fast
   52.12 -
   52.13  lemma mp_conj: "(P \<longrightarrow> Q) \<and> R \<Longrightarrow> P \<Longrightarrow> R \<and> Q"
   52.14  by auto
   52.15  
   52.16 @@ -172,7 +166,5 @@
   52.17  ML_file "Tools/bnf_fp_n2m.ML"
   52.18  ML_file "Tools/bnf_fp_n2m_sugar.ML"
   52.19  ML_file "Tools/bnf_fp_rec_sugar_util.ML"
   52.20 -ML_file "Tools/bnf_fp_rec_sugar_tactics.ML"
   52.21 -ML_file "Tools/bnf_fp_rec_sugar.ML"
   52.22  
   52.23  end
    53.1 --- a/src/HOL/BNF/BNF_GFP.thy	Thu Dec 05 17:52:12 2013 +0100
    53.2 +++ b/src/HOL/BNF/BNF_GFP.thy	Thu Dec 05 17:58:03 2013 +0100
    53.3 @@ -8,21 +8,29 @@
    53.4  header {* Greatest Fixed Point Operation on Bounded Natural Functors *}
    53.5  
    53.6  theory BNF_GFP
    53.7 -imports BNF_FP_Base Equiv_Relations_More "~~/src/HOL/Library/Sublist"
    53.8 +imports BNF_FP_Base Equiv_Relations_More List_Prefix
    53.9  keywords
   53.10    "codatatype" :: thy_decl and
   53.11    "primcorecursive" :: thy_goal and
   53.12    "primcorec" :: thy_decl
   53.13  begin
   53.14  
   53.15 +lemma not_TrueE: "\<not> True \<Longrightarrow> P"
   53.16 +by (erule notE, rule TrueI)
   53.17 +
   53.18 +lemma neq_eq_eq_contradict: "\<lbrakk>t \<noteq> u; s = t; s = u\<rbrakk> \<Longrightarrow> P"
   53.19 +by fast
   53.20 +
   53.21  lemma sum_case_expand_Inr: "f o Inl = g \<Longrightarrow> f x = sum_case g (f o Inr) x"
   53.22  by (auto split: sum.splits)
   53.23  
   53.24  lemma sum_case_expand_Inr': "f o Inl = g \<Longrightarrow> h = f o Inr \<longleftrightarrow> sum_case g h = f"
   53.25 -by (metis sum_case_o_inj(1,2) surjective_sum)
   53.26 +apply rule
   53.27 + apply (rule ext, force split: sum.split)
   53.28 +by (rule ext, metis sum_case_o_inj(2))
   53.29  
   53.30  lemma converse_Times: "(A \<times> B) ^-1 = B \<times> A"
   53.31 -by auto
   53.32 +by fast
   53.33  
   53.34  lemma equiv_proj:
   53.35    assumes e: "equiv A R" and "z \<in> R"
   53.36 @@ -37,7 +45,6 @@
   53.37  (* Operators: *)
   53.38  definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"
   53.39  
   53.40 -
   53.41  lemma Id_onD: "(a, b) \<in> Id_on A \<Longrightarrow> a = b"
   53.42  unfolding Id_on_def by simp
   53.43  
   53.44 @@ -56,9 +63,6 @@
   53.45  lemma Id_on_Gr: "Id_on A = Gr A id"
   53.46  unfolding Id_on_def Gr_def by auto
   53.47  
   53.48 -lemma Id_on_UNIV_I: "x = y \<Longrightarrow> (x, y) \<in> Id_on UNIV"
   53.49 -unfolding Id_on_def by auto
   53.50 -
   53.51  lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
   53.52  unfolding image2_def by auto
   53.53  
   53.54 @@ -77,6 +81,12 @@
   53.55  lemma Gr_incl: "Gr A f \<subseteq> A <*> B \<longleftrightarrow> f ` A \<subseteq> B"
   53.56  unfolding Gr_def by auto
   53.57  
   53.58 +lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
   53.59 +by blast
   53.60 +
   53.61 +lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
   53.62 +by blast
   53.63 +
   53.64  lemma in_rel_Collect_split_eq: "in_rel (Collect (split X)) = X"
   53.65  unfolding fun_eq_iff by auto
   53.66  
   53.67 @@ -130,9 +140,6 @@
   53.68  "R \<subseteq> relInvImage UNIV (relImage R f) f"
   53.69  unfolding relInvImage_def relImage_def by auto
   53.70  
   53.71 -lemma equiv_Image: "equiv A R \<Longrightarrow> (\<And>a b. (a, b) \<in> R \<Longrightarrow> a \<in> A \<and> b \<in> A \<and> R `` {a} = R `` {b})"
   53.72 -unfolding equiv_def refl_on_def Image_def by (auto intro: transD symD)
   53.73 -
   53.74  lemma relImage_proj:
   53.75  assumes "equiv A R"
   53.76  shows "relImage R (proj R) \<subseteq> Id_on (A//R)"
   53.77 @@ -143,7 +150,7 @@
   53.78  lemma relImage_relInvImage:
   53.79  assumes "R \<subseteq> f ` A <*> f ` A"
   53.80  shows "relImage (relInvImage A R f) f = R"
   53.81 -using assms unfolding relImage_def relInvImage_def by fastforce
   53.82 +using assms unfolding relImage_def relInvImage_def by fast
   53.83  
   53.84  lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
   53.85  by simp
   53.86 @@ -159,6 +166,8 @@
   53.87  
   53.88  (*Extended Sublist*)
   53.89  
   53.90 +definition clists where "clists r = |lists (Field r)|"
   53.91 +
   53.92  definition prefCl where
   53.93    "prefCl Kl = (\<forall> kl1 kl2. prefixeq kl1 kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl)"
   53.94  definition PrefCl where
   53.95 @@ -255,13 +264,18 @@
   53.96  shows "\<exists> a. a \<in> A \<and> p1 a = b1 \<and> p2 a = b2"
   53.97  using assms unfolding wpull_def by blast
   53.98  
   53.99 -lemma pickWP:
  53.100 +lemma pickWP_raw:
  53.101  assumes "wpull A B1 B2 f1 f2 p1 p2" and
  53.102  "b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
  53.103 -shows "pickWP A p1 p2 b1 b2 \<in> A"
  53.104 -      "p1 (pickWP A p1 p2 b1 b2) = b1"
  53.105 -      "p2 (pickWP A p1 p2 b1 b2) = b2"
  53.106 -unfolding pickWP_def using assms someI_ex[OF pickWP_pred] by fastforce+
  53.107 +shows "pickWP A p1 p2 b1 b2 \<in> A
  53.108 +       \<and> p1 (pickWP A p1 p2 b1 b2) = b1
  53.109 +       \<and> p2 (pickWP A p1 p2 b1 b2) = b2"
  53.110 +unfolding pickWP_def using assms someI_ex[OF pickWP_pred] by fastforce
  53.111 +
  53.112 +lemmas pickWP =
  53.113 +  pickWP_raw[THEN conjunct1]
  53.114 +  pickWP_raw[THEN conjunct2, THEN conjunct1]
  53.115 +  pickWP_raw[THEN conjunct2, THEN conjunct2]
  53.116  
  53.117  lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
  53.118  unfolding Field_card_of csum_def by auto
  53.119 @@ -293,21 +307,17 @@
  53.120  lemma image2pI: "R x y \<Longrightarrow> (image2p f g R) (f x) (g y)"
  53.121    unfolding image2p_def by blast
  53.122  
  53.123 -lemma image2p_eqI: "\<lbrakk>fx = f x; gy = g y; R x y\<rbrakk> \<Longrightarrow> (image2p f g R) fx gy"
  53.124 -  unfolding image2p_def by blast
  53.125 -
  53.126  lemma image2pE: "\<lbrakk>(image2p f g R) fx gy; (\<And>x y. fx = f x \<Longrightarrow> gy = g y \<Longrightarrow> R x y \<Longrightarrow> P)\<rbrakk> \<Longrightarrow> P"
  53.127    unfolding image2p_def by blast
  53.128  
  53.129  lemma fun_rel_iff_geq_image2p: "(fun_rel R S) f g = (image2p f g R \<le> S)"
  53.130    unfolding fun_rel_def image2p_def by auto
  53.131  
  53.132 -lemma convol_image_image2p: "<f o fst, g o snd> ` Collect (split R) \<subseteq> Collect (split (image2p f g R))"
  53.133 -  unfolding convol_def image2p_def by fastforce
  53.134 -
  53.135  lemma fun_rel_image2p: "(fun_rel R (image2p f g R)) f g"
  53.136    unfolding fun_rel_def image2p_def by auto
  53.137  
  53.138 +ML_file "Tools/bnf_gfp_rec_sugar_tactics.ML"
  53.139 +ML_file "Tools/bnf_gfp_rec_sugar.ML"
  53.140  ML_file "Tools/bnf_gfp_util.ML"
  53.141  ML_file "Tools/bnf_gfp_tactics.ML"
  53.142  ML_file "Tools/bnf_gfp.ML"
    54.1 --- a/src/HOL/BNF/BNF_LFP.thy	Thu Dec 05 17:52:12 2013 +0100
    54.2 +++ b/src/HOL/BNF/BNF_LFP.thy	Thu Dec 05 17:58:03 2013 +0100
    54.3 @@ -230,6 +230,7 @@
    54.4  lemma predicate2D_vimage2p: "\<lbrakk>R \<le> vimage2p f g S; R x y\<rbrakk> \<Longrightarrow> S (f x) (g y)"
    54.5    unfolding vimage2p_def by auto
    54.6  
    54.7 +ML_file "Tools/bnf_lfp_rec_sugar.ML"
    54.8  ML_file "Tools/bnf_lfp_util.ML"
    54.9  ML_file "Tools/bnf_lfp_tactics.ML"
   54.10  ML_file "Tools/bnf_lfp.ML"
    55.1 --- a/src/HOL/BNF/BNF_Util.thy	Thu Dec 05 17:52:12 2013 +0100
    55.2 +++ b/src/HOL/BNF/BNF_Util.thy	Thu Dec 05 17:58:03 2013 +0100
    55.3 @@ -9,15 +9,11 @@
    55.4  header {* Library for Bounded Natural Functors *}
    55.5  
    55.6  theory BNF_Util
    55.7 -imports Ctr_Sugar "../Cardinals/Cardinal_Arithmetic"
    55.8 +imports "../Cardinals/Cardinal_Arithmetic_FP"
    55.9 +   (*FIXME: define fun_rel here, reuse in Transfer once this theory is in HOL*)
   55.10 +  Transfer
   55.11  begin
   55.12  
   55.13 -lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
   55.14 -by blast
   55.15 -
   55.16 -lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
   55.17 -by blast
   55.18 -
   55.19  definition collect where
   55.20  "collect F x = (\<Union>f \<in> F. f x)"
   55.21  
   55.22 @@ -32,12 +28,6 @@
   55.23   (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow>
   55.24             (\<exists> a \<in> A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2))"
   55.25  
   55.26 -lemma fst_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> fst (snd x) = y"
   55.27 -by simp
   55.28 -
   55.29 -lemma snd_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> snd (snd x) = z"
   55.30 -by simp
   55.31 -
   55.32  lemma fstI: "x = (y, z) \<Longrightarrow> fst x = y"
   55.33  by simp
   55.34  
   55.35 @@ -47,9 +37,6 @@
   55.36  lemma bijI: "\<lbrakk>\<And>x y. (f x = f y) = (x = y); \<And>y. \<exists>x. y = f x\<rbrakk> \<Longrightarrow> bij f"
   55.37  unfolding bij_def inj_on_def by auto blast
   55.38  
   55.39 -lemma Collect_pair_mem_eq: "{(x, y). (x, y) \<in> R} = R"
   55.40 -by simp
   55.41 -
   55.42  (* Operator: *)
   55.43  definition "Gr A f = {(a, f a) | a. a \<in> A}"
   55.44  
    56.1 --- a/src/HOL/BNF/Basic_BNFs.thy	Thu Dec 05 17:52:12 2013 +0100
    56.2 +++ b/src/HOL/BNF/Basic_BNFs.thy	Thu Dec 05 17:58:03 2013 +0100
    56.3 @@ -11,31 +11,29 @@
    56.4  
    56.5  theory Basic_BNFs
    56.6  imports BNF_Def
    56.7 +   (*FIXME: define relators here, reuse in Lifting_* once this theory is in HOL*)
    56.8 +  Lifting_Sum
    56.9 +  Lifting_Product
   56.10 +  Main
   56.11  begin
   56.12  
   56.13 -lemma wpull_id: "wpull UNIV B1 B2 id id id id"
   56.14 -unfolding wpull_def by simp
   56.15 -
   56.16 -lemmas natLeq_card_order = natLeq_Card_order[unfolded Field_natLeq]
   56.17 -
   56.18 -lemma ctwo_card_order: "card_order ctwo"
   56.19 -using Card_order_ctwo by (unfold ctwo_def Field_card_of)
   56.20 -
   56.21 -lemma natLeq_cinfinite: "cinfinite natLeq"
   56.22 -unfolding cinfinite_def Field_natLeq by (rule nat_infinite)
   56.23 -
   56.24  lemma wpull_Grp_def: "wpull A B1 B2 f1 f2 p1 p2 \<longleftrightarrow> Grp B1 f1 OO (Grp B2 f2)\<inverse>\<inverse> \<le> (Grp A p1)\<inverse>\<inverse> OO Grp A p2"
   56.25    unfolding wpull_def Grp_def by auto
   56.26  
   56.27 -bnf ID: "id :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ["\<lambda>x. {x}"] "\<lambda>_:: 'a. natLeq" ["id :: 'a \<Rightarrow> 'a"]
   56.28 -  "id :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
   56.29 +bnf ID: 'a
   56.30 +  map: "id :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
   56.31 +  sets: "\<lambda>x. {x}"
   56.32 +  bd: natLeq
   56.33 +  rel: "id :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
   56.34  apply (auto simp: Grp_def fun_eq_iff relcompp.simps natLeq_card_order natLeq_cinfinite)
   56.35  apply (rule ordLess_imp_ordLeq[OF finite_ordLess_infinite[OF _ natLeq_Well_order]])
   56.36  apply (auto simp add: Field_card_of Field_natLeq card_of_well_order_on)[3]
   56.37  done
   56.38  
   56.39 -bnf DEADID: "id :: 'a \<Rightarrow> 'a" [] "\<lambda>_:: 'a. natLeq +c |UNIV :: 'a set|" ["SOME x :: 'a. True"]
   56.40 -  "op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
   56.41 +bnf DEADID: 'a
   56.42 +  map: "id :: 'a \<Rightarrow> 'a"
   56.43 +  bd: "natLeq +c |UNIV :: 'a set|"
   56.44 +  rel: "op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
   56.45  by (auto simp add: wpull_Grp_def Grp_def
   56.46    card_order_csum natLeq_card_order card_of_card_order_on
   56.47    cinfinite_csum natLeq_cinfinite)
   56.48 @@ -48,15 +46,20 @@
   56.49  
   56.50  lemmas sum_set_defs = setl_def[abs_def] setr_def[abs_def]
   56.51  
   56.52 -bnf sum_map [setl, setr] "\<lambda>_::'a + 'b. natLeq" [Inl, Inr] sum_rel
   56.53 +bnf "'a + 'b"
   56.54 +  map: sum_map
   56.55 +  sets: setl setr
   56.56 +  bd: natLeq
   56.57 +  wits: Inl Inr
   56.58 +  rel: sum_rel
   56.59  proof -
   56.60    show "sum_map id id = id" by (rule sum_map.id)
   56.61  next
   56.62 -  fix f1 f2 g1 g2
   56.63 +  fix f1 :: "'o \<Rightarrow> 's" and f2 :: "'p \<Rightarrow> 't" and g1 :: "'s \<Rightarrow> 'q" and g2 :: "'t \<Rightarrow> 'r"
   56.64    show "sum_map (g1 o f1) (g2 o f2) = sum_map g1 g2 o sum_map f1 f2"
   56.65      by (rule sum_map.comp[symmetric])
   56.66  next
   56.67 -  fix x f1 f2 g1 g2
   56.68 +  fix x and f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r" and g1 g2
   56.69    assume a1: "\<And>z. z \<in> setl x \<Longrightarrow> f1 z = g1 z" and
   56.70           a2: "\<And>z. z \<in> setr x \<Longrightarrow> f2 z = g2 z"
   56.71    thus "sum_map f1 f2 x = sum_map g1 g2 x"
   56.72 @@ -66,11 +69,11 @@
   56.73      case Inr thus ?thesis using a2 by (clarsimp simp: setr_def)
   56.74    qed
   56.75  next
   56.76 -  fix f1 f2
   56.77 +  fix f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r"
   56.78    show "setl o sum_map f1 f2 = image f1 o setl"
   56.79      by (rule ext, unfold o_apply) (simp add: setl_def split: sum.split)
   56.80  next
   56.81 -  fix f1 f2
   56.82 +  fix f1 :: "'o \<Rightarrow> 'q" and f2 :: "'p \<Rightarrow> 'r"
   56.83    show "setr o sum_map f1 f2 = image f2 o setr"
   56.84      by (rule ext, unfold o_apply) (simp add: setr_def split: sum.split)
   56.85  next
   56.86 @@ -78,13 +81,13 @@
   56.87  next
   56.88    show "cinfinite natLeq" by (rule natLeq_cinfinite)
   56.89  next
   56.90 -  fix x
   56.91 +  fix x :: "'o + 'p"
   56.92    show "|setl x| \<le>o natLeq"
   56.93      apply (rule ordLess_imp_ordLeq)
   56.94      apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
   56.95      by (simp add: setl_def split: sum.split)
   56.96  next
   56.97 -  fix x
   56.98 +  fix x :: "'o + 'p"
   56.99    show "|setr x| \<le>o natLeq"
  56.100      apply (rule ordLess_imp_ordLeq)
  56.101      apply (rule finite_iff_ordLess_natLeq[THEN iffD1])
  56.102 @@ -148,7 +151,11 @@
  56.103  
  56.104  lemmas prod_set_defs = fsts_def[abs_def] snds_def[abs_def]
  56.105  
  56.106 -bnf map_pair [fsts, snds] "\<lambda>_::'a \<times> 'b. natLeq" [Pair] prod_rel
  56.107 +bnf "'a \<times> 'b"
  56.108 +  map: map_pair
  56.109 +  sets: fsts snds
  56.110 +  bd: natLeq
  56.111 +  rel: prod_rel
  56.112  proof (unfold prod_set_defs)
  56.113    show "map_pair id id = id" by (rule map_pair.id)
  56.114  next
  56.115 @@ -193,7 +200,7 @@
  56.116          Grp {x. {fst x} \<subseteq> Collect (split R) \<and> {snd x} \<subseteq> Collect (split S)} (map_pair snd snd)"
  56.117    unfolding prod_set_defs prod_rel_def Grp_def relcompp.simps conversep.simps fun_eq_iff
  56.118    by auto
  56.119 -qed simp+
  56.120 +qed
  56.121  
  56.122  (* Categorical version of pullback: *)
  56.123  lemma wpull_cat:
  56.124 @@ -215,24 +222,11 @@
  56.125    thus ?thesis using that by fastforce
  56.126  qed
  56.127  
  56.128 -lemma card_of_bounded_range:
  56.129 -  "|{f :: 'd \<Rightarrow> 'a. range f \<subseteq> B}| \<le>o |Func (UNIV :: 'd set) B|" (is "|?LHS| \<le>o |?RHS|")
  56.130 -proof -
  56.131 -  let ?f = "\<lambda>f. %x. if f x \<in> B then f x else undefined"
  56.132 -  have "inj_on ?f ?LHS" unfolding inj_on_def
  56.133 -  proof (unfold fun_eq_iff, safe)
  56.134 -    fix g :: "'d \<Rightarrow> 'a" and f :: "'d \<Rightarrow> 'a" and x
  56.135 -    assume "range f \<subseteq> B" "range g \<subseteq> B" and eq: "\<forall>x. ?f f x = ?f g x"
  56.136 -    hence "f x \<in> B" "g x \<in> B" by auto
  56.137 -    with eq have "Some (f x) = Some (g x)" by metis
  56.138 -    thus "f x = g x" by simp
  56.139 -  qed
  56.140 -  moreover have "?f ` ?LHS \<subseteq> ?RHS" unfolding Func_def by fastforce
  56.141 -  ultimately show ?thesis using card_of_ordLeq by fast
  56.142 -qed
  56.143 -
  56.144 -bnf "op \<circ>" [range] "\<lambda>_:: 'a \<Rightarrow> 'b. natLeq +c |UNIV :: 'a set|" ["%c x::'b::type. c::'a::type"]
  56.145 -  "fun_rel op ="
  56.146 +bnf "'a \<Rightarrow> 'b"
  56.147 +  map: "op \<circ>"
  56.148 +  sets: range
  56.149 +  bd: "natLeq +c |UNIV :: 'a set|"
  56.150 +  rel: "fun_rel op ="
  56.151  proof
  56.152    fix f show "id \<circ> f = id f" by simp
  56.153  next
  56.154 @@ -258,7 +252,7 @@
  56.155  next
  56.156    fix f :: "'d => 'a"
  56.157    have "|range f| \<le>o | (UNIV::'d set) |" (is "_ \<le>o ?U") by (rule card_of_image)
  56.158 -  also have "?U \<le>o natLeq +c ?U"  by (rule ordLeq_csum2) (rule card_of_Card_order)
  56.159 +  also have "?U \<le>o natLeq +c ?U" by (rule ordLeq_csum2) (rule card_of_Card_order)
  56.160    finally show "|range f| \<le>o natLeq +c ?U" .
  56.161  next
  56.162    fix A B1 B2 f1 f2 p1 p2 assume p: "wpull A B1 B2 f1 f2 p1 p2"
  56.163 @@ -277,7 +271,7 @@
  56.164          (Grp {x. range x \<subseteq> Collect (split R)} (op \<circ> fst))\<inverse>\<inverse> OO
  56.165           Grp {x. range x \<subseteq> Collect (split R)} (op \<circ> snd)"
  56.166    unfolding fun_rel_def Grp_def fun_eq_iff relcompp.simps conversep.simps  subset_iff image_iff
  56.167 -  by auto (force, metis pair_collapse)
  56.168 -qed auto
  56.169 +  by auto (force, metis (no_types) pair_collapse)
  56.170 +qed
  56.171  
  56.172  end
    57.1 --- a/src/HOL/BNF/Coinduction.thy	Thu Dec 05 17:52:12 2013 +0100
    57.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    57.3 @@ -1,19 +0,0 @@
    57.4 -(*  Title:      HOL/BNF/Coinduction.thy
    57.5 -    Author:     Johannes Hölzl, TU Muenchen
    57.6 -    Author:     Dmitriy Traytel, TU Muenchen
    57.7 -    Copyright   2013
    57.8 -
    57.9 -Coinduction method that avoids some boilerplate compared to coinduct.
   57.10 -*)
   57.11 -
   57.12 -header {* Coinduction Method *}
   57.13 -
   57.14 -theory Coinduction
   57.15 -imports BNF_Util
   57.16 -begin
   57.17 -
   57.18 -ML_file "Tools/coinduction.ML"
   57.19 -
   57.20 -setup Coinduction.setup
   57.21 -
   57.22 -end
    58.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    58.2 +++ b/src/HOL/BNF/Countable_Set_Type.thy	Thu Dec 05 17:58:03 2013 +0100
    58.3 @@ -0,0 +1,212 @@
    58.4 +(*  Title:      HOL/BNF/Countable_Set_Type.thy
    58.5 +    Author:     Andrei Popescu, TU Muenchen
    58.6 +    Copyright   2012
    58.7 +
    58.8 +Type of (at most) countable sets.
    58.9 +*)
   58.10 +
   58.11 +header {* Type of (at Most) Countable Sets *}
   58.12 +
   58.13 +theory Countable_Set_Type
   58.14 +imports
   58.15 +  More_BNFs
   58.16 +  "~~/src/HOL/Cardinals/Cardinals"
   58.17 +  "~~/src/HOL/Library/Countable_Set"
   58.18 +begin
   58.19 +
   58.20 +subsection{* Cardinal stuff *}
   58.21 +
   58.22 +lemma countable_card_of_nat: "countable A \<longleftrightarrow> |A| \<le>o |UNIV::nat set|"
   58.23 +  unfolding countable_def card_of_ordLeq[symmetric] by auto
   58.24 +
   58.25 +lemma countable_card_le_natLeq: "countable A \<longleftrightarrow> |A| \<le>o natLeq"
   58.26 +  unfolding countable_card_of_nat using card_of_nat ordLeq_ordIso_trans ordIso_symmetric by blast
   58.27 +
   58.28 +lemma countable_or_card_of:
   58.29 +assumes "countable A"
   58.30 +shows "(finite A \<and> |A| <o |UNIV::nat set| ) \<or>
   58.31 +       (infinite A  \<and> |A| =o |UNIV::nat set| )"
   58.32 +proof (cases "finite A")
   58.33 +  case True thus ?thesis by (metis finite_iff_cardOf_nat)
   58.34 +next
   58.35 +  case False with assms show ?thesis
   58.36 +    by (metis countable_card_of_nat infinite_iff_card_of_nat ordIso_iff_ordLeq)
   58.37 +qed
   58.38 +
   58.39 +lemma countable_cases_card_of[elim]:
   58.40 +  assumes "countable A"
   58.41 +  obtains (Fin) "finite A" "|A| <o |UNIV::nat set|"
   58.42 +        | (Inf) "infinite A" "|A| =o |UNIV::nat set|"
   58.43 +  using assms countable_or_card_of by blast
   58.44 +
   58.45 +lemma countable_or:
   58.46 +  "countable A \<Longrightarrow> (\<exists> f::'a\<Rightarrow>nat. finite A \<and> inj_on f A) \<or> (\<exists> f::'a\<Rightarrow>nat. infinite A \<and> bij_betw f A UNIV)"
   58.47 +  by (elim countable_enum_cases) fastforce+
   58.48 +
   58.49 +lemma countable_cases[elim]:
   58.50 +  assumes "countable A"
   58.51 +  obtains (Fin) f :: "'a\<Rightarrow>nat" where "finite A" "inj_on f A"
   58.52 +        | (Inf) f :: "'a\<Rightarrow>nat" where "infinite A" "bij_betw f A UNIV"
   58.53 +  using assms countable_or by metis
   58.54 +
   58.55 +lemma countable_ordLeq:
   58.56 +assumes "|A| \<le>o |B|" and "countable B"
   58.57 +shows "countable A"
   58.58 +using assms unfolding countable_card_of_nat by(rule ordLeq_transitive)
   58.59 +
   58.60 +lemma countable_ordLess:
   58.61 +assumes AB: "|A| <o |B|" and B: "countable B"
   58.62 +shows "countable A"
   58.63 +using countable_ordLeq[OF ordLess_imp_ordLeq[OF AB] B] .
   58.64 +
   58.65 +subsection {* The type of countable sets *}
   58.66 +
   58.67 +typedef 'a cset = "{A :: 'a set. countable A}" morphisms rcset acset
   58.68 +  by (rule exI[of _ "{}"]) simp
   58.69 +
   58.70 +setup_lifting type_definition_cset
   58.71 +
   58.72 +declare
   58.73 +  rcset_inverse[simp]
   58.74 +  acset_inverse[Transfer.transferred, unfolded mem_Collect_eq, simp]
   58.75 +  acset_inject[Transfer.transferred, unfolded mem_Collect_eq, simp]
   58.76 +  rcset[Transfer.transferred, unfolded mem_Collect_eq, simp]
   58.77 +
   58.78 +lift_definition cin :: "'a \<Rightarrow> 'a cset \<Rightarrow> bool" is "op \<in>" parametric member_transfer
   58.79 +  ..
   58.80 +lift_definition cempty :: "'a cset" is "{}" parametric empty_transfer
   58.81 +  by (rule countable_empty)
   58.82 +lift_definition cinsert :: "'a \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is insert parametric Lifting_Set.insert_transfer
   58.83 +  by (rule countable_insert)
   58.84 +lift_definition csingle :: "'a \<Rightarrow> 'a cset" is "\<lambda>x. {x}"
   58.85 +  by (rule countable_insert[OF countable_empty])
   58.86 +lift_definition cUn :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op \<union>" parametric union_transfer
   58.87 +  by (rule countable_Un)
   58.88 +lift_definition cInt :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op \<inter>" parametric inter_transfer
   58.89 +  by (rule countable_Int1)
   58.90 +lift_definition cDiff :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op -" parametric Diff_transfer
   58.91 +  by (rule countable_Diff)
   58.92 +lift_definition cimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a cset \<Rightarrow> 'b cset" is "op `" parametric image_transfer
   58.93 +  by (rule countable_image)
   58.94 +
   58.95 +subsection {* Registration as BNF *}
   58.96 +
   58.97 +lemma card_of_countable_sets_range:
   58.98 +fixes A :: "'a set"
   58.99 +shows "|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |{f::nat \<Rightarrow> 'a. range f \<subseteq> A}|"
  58.100 +apply(rule card_of_ordLeqI[of from_nat_into]) using inj_on_from_nat_into
  58.101 +unfolding inj_on_def by auto
  58.102 +
  58.103 +lemma card_of_countable_sets_Func:
  58.104 +"|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |A| ^c natLeq"
  58.105 +using card_of_countable_sets_range card_of_Func_UNIV[THEN ordIso_symmetric]
  58.106 +unfolding cexp_def Field_natLeq Field_card_of
  58.107 +by (rule ordLeq_ordIso_trans)
  58.108 +
  58.109 +lemma ordLeq_countable_subsets:
  58.110 +"|A| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
  58.111 +apply (rule card_of_ordLeqI[of "\<lambda> a. {a}"]) unfolding inj_on_def by auto
  58.112 +
  58.113 +lemma finite_countable_subset:
  58.114 +"finite {X. X \<subseteq> A \<and> countable X} \<longleftrightarrow> finite A"
  58.115 +apply default
  58.116 + apply (erule contrapos_pp)
  58.117 + apply (rule card_of_ordLeq_infinite)
  58.118 + apply (rule ordLeq_countable_subsets)
  58.119 + apply assumption
  58.120 +apply (rule finite_Collect_conjI)
  58.121 +apply (rule disjI1)
  58.122 +by (erule finite_Collect_subsets)
  58.123 +
  58.124 +lemma rcset_to_rcset: "countable A \<Longrightarrow> rcset (the_inv rcset A) = A"
  58.125 +  apply (rule f_the_inv_into_f[unfolded inj_on_def image_iff])
  58.126 +   apply transfer' apply simp
  58.127 +  apply transfer' apply simp
  58.128 +  done
  58.129 +
  58.130 +lemma Collect_Int_Times:
  58.131 +"{(x, y). R x y} \<inter> A \<times> B = {(x, y). R x y \<and> x \<in> A \<and> y \<in> B}"
  58.132 +by auto
  58.133 +
  58.134 +definition cset_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a cset \<Rightarrow> 'b cset \<Rightarrow> bool" where
  58.135 +"cset_rel R a b \<longleftrightarrow>
  58.136 + (\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and>
  58.137 + (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t)"
  58.138 +
  58.139 +lemma cset_rel_aux:
  58.140 +"(\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and> (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t) \<longleftrightarrow>
  58.141 + ((Grp {x. rcset x \<subseteq> {(a, b). R a b}} (cimage fst))\<inverse>\<inverse> OO
  58.142 +          Grp {x. rcset x \<subseteq> {(a, b). R a b}} (cimage snd)) a b" (is "?L = ?R")
  58.143 +proof
  58.144 +  assume ?L
  58.145 +  def R' \<equiv> "the_inv rcset (Collect (split R) \<inter> (rcset a \<times> rcset b))"
  58.146 +  (is "the_inv rcset ?L'")
  58.147 +  have L: "countable ?L'" by auto
  58.148 +  hence *: "rcset R' = ?L'" unfolding R'_def using fset_to_fset by (intro rcset_to_rcset)
  58.149 +  thus ?R unfolding Grp_def relcompp.simps conversep.simps
  58.150 +  proof (intro CollectI prod_caseI exI[of _ a] exI[of _ b] exI[of _ R'] conjI refl)
  58.151 +    from * `?L` show "a = cimage fst R'" by transfer (auto simp: image_def Collect_Int_Times)
  58.152 +  next
  58.153 +    from * `?L` show "b = cimage snd R'" by transfer (auto simp: image_def Collect_Int_Times)
  58.154 +  qed simp_all
  58.155 +next
  58.156 +  assume ?R thus ?L unfolding Grp_def relcompp.simps conversep.simps
  58.157 +    by transfer force
  58.158 +qed
  58.159 +
  58.160 +bnf "'a cset"
  58.161 +  map: cimage
  58.162 +  sets: rcset
  58.163 +  bd: natLeq
  58.164 +  wits: "cempty"
  58.165 +  rel: cset_rel
  58.166 +proof -
  58.167 +  show "cimage id = id" by transfer' simp
  58.168 +next
  58.169 +  fix f g show "cimage (g \<circ> f) = cimage g \<circ> cimage f" by transfer' fastforce
  58.170 +next
  58.171 +  fix C f g assume eq: "\<And>a. a \<in> rcset C \<Longrightarrow> f a = g a"
  58.172 +  thus "cimage f C = cimage g C" by transfer force
  58.173 +next
  58.174 +  fix f show "rcset \<circ> cimage f = op ` f \<circ> rcset" by transfer' fastforce
  58.175 +next
  58.176 +  show "card_order natLeq" by (rule natLeq_card_order)
  58.177 +next
  58.178 +  show "cinfinite natLeq" by (rule natLeq_cinfinite)
  58.179 +next
  58.180 +  fix C show "|rcset C| \<le>o natLeq" by transfer (unfold countable_card_le_natLeq)
  58.181 +next
  58.182 +  fix A B1 B2 f1 f2 p1 p2
  58.183 +  assume wp: "wpull A B1 B2 f1 f2 p1 p2"
  58.184 +  show "wpull {x. rcset x \<subseteq> A} {x. rcset x \<subseteq> B1} {x. rcset x \<subseteq> B2}
  58.185 +              (cimage f1) (cimage f2) (cimage p1) (cimage p2)"
  58.186 +  unfolding wpull_def proof safe
  58.187 +    fix y1 y2
  58.188 +    assume Y1: "rcset y1 \<subseteq> B1" and Y2: "rcset y2 \<subseteq> B2"
  58.189 +    assume "cimage f1 y1 = cimage f2 y2"
  58.190 +    hence EQ: "f1 ` (rcset y1) = f2 ` (rcset y2)" by transfer
  58.191 +    with Y1 Y2 obtain X where X: "X \<subseteq> A"
  58.192 +    and Y1: "p1 ` X = rcset y1" and Y2: "p2 ` X = rcset y2"
  58.193 +    using wpull_image[OF wp] unfolding wpull_def Pow_def Bex_def mem_Collect_eq
  58.194 +      by (auto elim!: allE[of _ "rcset y1"] allE[of _ "rcset y2"])
  58.195 +    have "\<forall> y1' \<in> rcset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
  58.196 +    then obtain q1 where q1: "\<forall> y1' \<in> rcset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
  58.197 +    have "\<forall> y2' \<in> rcset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
  58.198 +    then obtain q2 where q2: "\<forall> y2' \<in> rcset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
  58.199 +    def X' \<equiv> "q1 ` (rcset y1) \<union> q2 ` (rcset y2)"
  58.200 +    have X': "X' \<subseteq> A" and Y1: "p1 ` X' = rcset y1" and Y2: "p2 ` X' = rcset y2"
  58.201 +    using X Y1 Y2 q1 q2 unfolding X'_def by fast+
  58.202 +    have fX': "countable X'" unfolding X'_def by simp
  58.203 +    then obtain x where X'eq: "X' = rcset x" by transfer blast
  58.204 +    show "\<exists>x\<in>{x. rcset x \<subseteq> A}. cimage p1 x = y1 \<and> cimage p2 x = y2"
  58.205 +      using X' Y1 Y2 unfolding X'eq by (intro bexI[of _ "x"]) (transfer, auto)
  58.206 +  qed
  58.207 +next
  58.208 +  fix R
  58.209 +  show "cset_rel R =
  58.210 +        (Grp {x. rcset x \<subseteq> Collect (split R)} (cimage fst))\<inverse>\<inverse> OO
  58.211 +         Grp {x. rcset x \<subseteq> Collect (split R)} (cimage snd)"
  58.212 +  unfolding cset_rel_def[abs_def] cset_rel_aux by simp
  58.213 +qed (transfer, simp)
  58.214 +
  58.215 +end
    59.1 --- a/src/HOL/BNF/Countable_Type.thy	Thu Dec 05 17:52:12 2013 +0100
    59.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    59.3 @@ -1,91 +0,0 @@
    59.4 -(*  Title:      HOL/BNF/Countable_Type.thy
    59.5 -    Author:     Andrei Popescu, TU Muenchen
    59.6 -    Copyright   2012
    59.7 -
    59.8 -(At most) countable sets.
    59.9 -*)
   59.10 -
   59.11 -header {* (At Most) Countable Sets *}
   59.12 -
   59.13 -theory Countable_Type
   59.14 -imports
   59.15 -  "~~/src/HOL/Cardinals/Cardinals"
   59.16 -  "~~/src/HOL/Library/Countable_Set"
   59.17 -begin
   59.18 -
   59.19 -subsection{* Cardinal stuff *}
   59.20 -
   59.21 -lemma countable_card_of_nat: "countable A \<longleftrightarrow> |A| \<le>o |UNIV::nat set|"
   59.22 -  unfolding countable_def card_of_ordLeq[symmetric] by auto
   59.23 -
   59.24 -lemma countable_card_le_natLeq: "countable A \<longleftrightarrow> |A| \<le>o natLeq"
   59.25 -  unfolding countable_card_of_nat using card_of_nat ordLeq_ordIso_trans ordIso_symmetric by blast
   59.26 -
   59.27 -lemma countable_or_card_of:
   59.28 -assumes "countable A"
   59.29 -shows "(finite A \<and> |A| <o |UNIV::nat set| ) \<or>
   59.30 -       (infinite A  \<and> |A| =o |UNIV::nat set| )"
   59.31 -proof (cases "finite A")
   59.32 -  case True thus ?thesis by (metis finite_iff_cardOf_nat)
   59.33 -next
   59.34 -  case False with assms show ?thesis
   59.35 -    by (metis countable_card_of_nat infinite_iff_card_of_nat ordIso_iff_ordLeq)
   59.36 -qed
   59.37 -
   59.38 -lemma countable_cases_card_of[elim]:
   59.39 -  assumes "countable A"
   59.40 -  obtains (Fin) "finite A" "|A| <o |UNIV::nat set|"
   59.41 -        | (Inf) "infinite A" "|A| =o |UNIV::nat set|"
   59.42 -  using assms countable_or_card_of by blast
   59.43 -
   59.44 -lemma countable_or:
   59.45 -  "countable A \<Longrightarrow> (\<exists> f::'a\<Rightarrow>nat. finite A \<and> inj_on f A) \<or> (\<exists> f::'a\<Rightarrow>nat. infinite A \<and> bij_betw f A UNIV)"
   59.46 -  by (elim countable_enum_cases) fastforce+
   59.47 -
   59.48 -lemma countable_cases[elim]:
   59.49 -  assumes "countable A"
   59.50 -  obtains (Fin) f :: "'a\<Rightarrow>nat" where "finite A" "inj_on f A"
   59.51 -        | (Inf) f :: "'a\<Rightarrow>nat" where "infinite A" "bij_betw f A UNIV"
   59.52 -  using assms countable_or by metis
   59.53 -
   59.54 -lemma countable_ordLeq:
   59.55 -assumes "|A| \<le>o |B|" and "countable B"
   59.56 -shows "countable A"
   59.57 -using assms unfolding countable_card_of_nat by(rule ordLeq_transitive)
   59.58 -
   59.59 -lemma countable_ordLess:
   59.60 -assumes AB: "|A| <o |B|" and B: "countable B"
   59.61 -shows "countable A"
   59.62 -using countable_ordLeq[OF ordLess_imp_ordLeq[OF AB] B] .
   59.63 -
   59.64 -subsection{*  The type of countable sets *}
   59.65 -
   59.66 -typedef 'a cset = "{A :: 'a set. countable A}" morphisms rcset acset
   59.67 -  by (rule exI[of _ "{}"]) simp
   59.68 -
   59.69 -setup_lifting type_definition_cset
   59.70 -
   59.71 -declare
   59.72 -  rcset_inverse[simp]
   59.73 -  acset_inverse[Transfer.transferred, unfolded mem_Collect_eq, simp]
   59.74 -  acset_inject[Transfer.transferred, unfolded mem_Collect_eq, simp]
   59.75 -  rcset[Transfer.transferred, unfolded mem_Collect_eq, simp]
   59.76 -
   59.77 -lift_definition cin :: "'a \<Rightarrow> 'a cset \<Rightarrow> bool" is "op \<in>" parametric member_transfer
   59.78 -  ..
   59.79 -lift_definition cempty :: "'a cset" is "{}" parametric empty_transfer
   59.80 -  by (rule countable_empty)
   59.81 -lift_definition cinsert :: "'a \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is insert parametric Lifting_Set.insert_transfer
   59.82 -  by (rule countable_insert)
   59.83 -lift_definition csingle :: "'a \<Rightarrow> 'a cset" is "\<lambda>x. {x}"
   59.84 -  by (rule countable_insert[OF countable_empty])
   59.85 -lift_definition cUn :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op \<union>" parametric union_transfer
   59.86 -  by (rule countable_Un)
   59.87 -lift_definition cInt :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op \<inter>" parametric inter_transfer
   59.88 -  by (rule countable_Int1)
   59.89 -lift_definition cDiff :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op -" parametric Diff_transfer
   59.90 -  by (rule countable_Diff)
   59.91 -lift_definition cimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a cset \<Rightarrow> 'b cset" is "op `" parametric image_transfer
   59.92 -  by (rule countable_image)
   59.93 -
   59.94 -end
    60.1 --- a/src/HOL/BNF/Ctr_Sugar.thy	Thu Dec 05 17:52:12 2013 +0100
    60.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    60.3 @@ -1,30 +0,0 @@
    60.4 -(*  Title:      HOL/BNF/Ctr_Sugar.thy
    60.5 -    Author:     Jasmin Blanchette, TU Muenchen
    60.6 -    Copyright   2012
    60.7 -
    60.8 -Wrapping existing freely generated type's constructors.
    60.9 -*)
   60.10 -
   60.11 -header {* Wrapping Existing Freely Generated Type's Constructors *}
   60.12 -
   60.13 -theory Ctr_Sugar
   60.14 -imports Main
   60.15 -keywords
   60.16 -  "wrap_free_constructors" :: thy_goal and
   60.17 -  "no_discs_sels" and
   60.18 -  "rep_compat"
   60.19 -begin
   60.20 -
   60.21 -lemma iffI_np: "\<lbrakk>x \<Longrightarrow> \<not> y; \<not> x \<Longrightarrow> y\<rbrakk> \<Longrightarrow> \<not> x \<longleftrightarrow> y"
   60.22 -by (erule iffI) (erule contrapos_pn)
   60.23 -
   60.24 -lemma iff_contradict:
   60.25 -"\<not> P \<Longrightarrow> P \<longleftrightarrow> Q \<Longrightarrow> Q \<Longrightarrow> R"
   60.26 -"\<not> Q \<Longrightarrow> P \<longleftrightarrow> Q \<Longrightarrow> P \<Longrightarrow> R"
   60.27 -by blast+
   60.28 -
   60.29 -ML_file "Tools/ctr_sugar_util.ML"
   60.30 -ML_file "Tools/ctr_sugar_tactics.ML"
   60.31 -ML_file "Tools/ctr_sugar.ML"
   60.32 -
   60.33 -end
    61.1 --- a/src/HOL/BNF/Equiv_Relations_More.thy	Thu Dec 05 17:52:12 2013 +0100
    61.2 +++ b/src/HOL/BNF/Equiv_Relations_More.thy	Thu Dec 05 17:58:03 2013 +0100
    61.3 @@ -59,7 +59,7 @@
    61.4  
    61.5  lemma in_quotient_imp_in_rel:
    61.6  "\<lbrakk>equiv A r; X \<in> A//r; {x,y} \<subseteq> X\<rbrakk> \<Longrightarrow> (x,y) \<in> r"
    61.7 -using quotient_eq_iff by fastforce
    61.8 +using quotient_eq_iff[THEN iffD1] by fastforce
    61.9  
   61.10  lemma in_quotient_imp_closed:
   61.11  "\<lbrakk>equiv A r; X \<in> A//r; x \<in> X; (x,y) \<in> r\<rbrakk> \<Longrightarrow> y \<in> X"
    62.1 --- a/src/HOL/BNF/Examples/Derivation_Trees/DTree.thy	Thu Dec 05 17:52:12 2013 +0100
    62.2 +++ b/src/HOL/BNF/Examples/Derivation_Trees/DTree.thy	Thu Dec 05 17:58:03 2013 +0100
    62.3 @@ -11,8 +11,6 @@
    62.4  imports Prelim
    62.5  begin
    62.6  
    62.7 -hide_fact (open) Lifting_Product.prod_rel_def
    62.8 -
    62.9  typedecl N
   62.10  typedecl T
   62.11  
   62.12 @@ -22,8 +20,8 @@
   62.13  
   62.14  definition "Node n as \<equiv> NNode n (the_inv fset as)"
   62.15  definition "cont \<equiv> fset o ccont"
   62.16 -definition "unfold rt ct \<equiv> dtree_unfold rt (the_inv fset o ct)"
   62.17 -definition "corec rt ct \<equiv> dtree_corec rt (the_inv fset o ct)"
   62.18 +definition "unfold rt ct \<equiv> unfold_dtree rt (the_inv fset o ct)"
   62.19 +definition "corec rt ct \<equiv> corec_dtree rt (the_inv fset o ct)"
   62.20  
   62.21  lemma finite_cont[simp]: "finite (cont tr)"
   62.22    unfolding cont_def o_apply by (cases tr, clarsimp)
    63.1 --- a/src/HOL/BNF/Examples/Derivation_Trees/Parallel.thy	Thu Dec 05 17:52:12 2013 +0100
    63.2 +++ b/src/HOL/BNF/Examples/Derivation_Trees/Parallel.thy	Thu Dec 05 17:58:03 2013 +0100
    63.3 @@ -12,7 +12,6 @@
    63.4  begin
    63.5  
    63.6  no_notation plus_class.plus (infixl "+" 65)
    63.7 -no_notation Sublist.parallel (infixl "\<parallel>" 50)
    63.8  
    63.9  consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)
   63.10  
   63.11 @@ -145,4 +144,4 @@
   63.12    thus ?thesis by blast
   63.13  qed
   63.14  
   63.15 -end
   63.16 \ No newline at end of file
   63.17 +end
    64.1 --- a/src/HOL/BNF/Examples/Koenig.thy	Thu Dec 05 17:52:12 2013 +0100
    64.2 +++ b/src/HOL/BNF/Examples/Koenig.thy	Thu Dec 05 17:58:03 2013 +0100
    64.3 @@ -12,44 +12,33 @@
    64.4  imports TreeFI Stream
    64.5  begin
    64.6  
    64.7 -(* selectors for streams *)
    64.8 -lemma shd_def': "shd as = fst (stream_dtor as)"
    64.9 -apply (case_tac as)
   64.10 -apply (auto simp add: shd_def)
   64.11 -by (simp add: Stream_def stream.dtor_ctor)
   64.12 -
   64.13 -lemma stl_def': "stl as = snd (stream_dtor as)"
   64.14 -apply (case_tac as)
   64.15 -apply (auto simp add: stl_def)
   64.16 -by (simp add: Stream_def stream.dtor_ctor)
   64.17 -
   64.18  (* infinite trees: *)
   64.19  coinductive infiniteTr where
   64.20 -"\<lbrakk>tr' \<in> listF_set (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
   64.21 +"\<lbrakk>tr' \<in> set_listF (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
   64.22  
   64.23  lemma infiniteTr_strong_coind[consumes 1, case_names sub]:
   64.24  assumes *: "phi tr" and
   64.25 -**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr' \<or> infiniteTr tr'"
   64.26 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set_listF (sub tr). phi tr' \<or> infiniteTr tr'"
   64.27  shows "infiniteTr tr"
   64.28  using assms by (elim infiniteTr.coinduct) blast
   64.29  
   64.30  lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
   64.31  assumes *: "phi tr" and
   64.32 -**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> listF_set (sub tr). phi tr'"
   64.33 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set_listF (sub tr). phi tr'"
   64.34  shows "infiniteTr tr"
   64.35  using assms by (elim infiniteTr.coinduct) blast
   64.36  
   64.37  lemma infiniteTr_sub[simp]:
   64.38 -"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> listF_set (sub tr). infiniteTr tr')"
   64.39 +"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> set_listF (sub tr). infiniteTr tr')"
   64.40  by (erule infiniteTr.cases) blast
   64.41  
   64.42  primcorec konigPath where
   64.43    "shd (konigPath t) = lab t"
   64.44 -| "stl (konigPath t) = konigPath (SOME tr. tr \<in> listF_set (sub t) \<and> infiniteTr tr)"
   64.45 +| "stl (konigPath t) = konigPath (SOME tr. tr \<in> set_listF (sub t) \<and> infiniteTr tr)"
   64.46  
   64.47  (* proper paths in trees: *)
   64.48  coinductive properPath where
   64.49 -"\<lbrakk>shd as = lab tr; tr' \<in> listF_set (sub tr); properPath (stl as) tr'\<rbrakk> \<Longrightarrow>
   64.50 +"\<lbrakk>shd as = lab tr; tr' \<in> set_listF (sub tr); properPath (stl as) tr'\<rbrakk> \<Longrightarrow>
   64.51   properPath as tr"
   64.52  
   64.53  lemma properPath_strong_coind[consumes 1, case_names shd_lab sub]:
   64.54 @@ -57,7 +46,7 @@
   64.55  **: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
   64.56  ***: "\<And> as tr.
   64.57           phi as tr \<Longrightarrow>
   64.58 -         \<exists> tr' \<in> listF_set (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
   64.59 +         \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
   64.60  shows "properPath as tr"
   64.61  using assms by (elim properPath.coinduct) blast
   64.62  
   64.63 @@ -66,7 +55,7 @@
   64.64  **: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
   64.65  ***: "\<And> as tr.
   64.66           phi as tr \<Longrightarrow>
   64.67 -         \<exists> tr' \<in> listF_set (sub tr). phi (stl as) tr'"
   64.68 +         \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr'"
   64.69  shows "properPath as tr"
   64.70  using properPath_strong_coind[of phi, OF * **] *** by blast
   64.71  
   64.72 @@ -76,7 +65,7 @@
   64.73  
   64.74  lemma properPath_sub:
   64.75  "properPath as tr \<Longrightarrow>
   64.76 - \<exists> tr' \<in> listF_set (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
   64.77 + \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
   64.78  by (erule properPath.cases) blast
   64.79  
   64.80  (* prove the following by coinduction *)
   64.81 @@ -88,10 +77,10 @@
   64.82     assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
   64.83     proof (coinduction arbitrary: tr as rule: properPath_coind)
   64.84       case (sub tr as)
   64.85 -     let ?t = "SOME t'. t' \<in> listF_set (sub tr) \<and> infiniteTr t'"
   64.86 -     from sub have "\<exists>t' \<in> listF_set (sub tr). infiniteTr t'" by simp
   64.87 -     then have "\<exists>t'. t' \<in> listF_set (sub tr) \<and> infiniteTr t'" by blast
   64.88 -     then have "?t \<in> listF_set (sub tr) \<and> infiniteTr ?t" by (rule someI_ex)
   64.89 +     let ?t = "SOME t'. t' \<in> set_listF (sub tr) \<and> infiniteTr t'"
   64.90 +     from sub have "\<exists>t' \<in> set_listF (sub tr). infiniteTr t'" by simp
   64.91 +     then have "\<exists>t'. t' \<in> set_listF (sub tr) \<and> infiniteTr t'" by blast
   64.92 +     then have "?t \<in> set_listF (sub tr) \<and> infiniteTr ?t" by (rule someI_ex)
   64.93       moreover have "stl (konigPath tr) = konigPath ?t" by simp
   64.94       ultimately show ?case using sub by blast
   64.95     qed simp
    65.1 --- a/src/HOL/BNF/Examples/ListF.thy	Thu Dec 05 17:52:12 2013 +0100
    65.2 +++ b/src/HOL/BNF/Examples/ListF.thy	Thu Dec 05 17:58:03 2013 +0100
    65.3 @@ -62,7 +62,7 @@
    65.4    "i < lengthh xs \<Longrightarrow> nthh (mapF f xs) i = f (nthh xs i)"
    65.5    by (induct rule: nthh.induct) auto
    65.6  
    65.7 -lemma nthh_listF_set[simp]: "i < lengthh xs \<Longrightarrow> nthh xs i \<in> listF_set xs"
    65.8 +lemma nthh_listF_set[simp]: "i < lengthh xs \<Longrightarrow> nthh xs i \<in> set_listF xs"
    65.9    by (induct rule: nthh.induct) auto
   65.10  
   65.11  lemma NilF_iff[iff]: "(lengthh xs = 0) = (xs = NilF)"
   65.12 @@ -105,7 +105,7 @@
   65.13  qed simp
   65.14  
   65.15  lemma list_set_nthh[simp]:
   65.16 -  "(x \<in> listF_set xs) \<Longrightarrow> (\<exists>i < lengthh xs. nthh xs i = x)"
   65.17 +  "(x \<in> set_listF xs) \<Longrightarrow> (\<exists>i < lengthh xs. nthh xs i = x)"
   65.18    by (induct xs) (auto, induct rule: nthh.induct, auto)
   65.19  
   65.20  end
    66.1 --- a/src/HOL/BNF/Examples/Misc_Codatatype.thy	Thu Dec 05 17:52:12 2013 +0100
    66.2 +++ b/src/HOL/BNF/Examples/Misc_Codatatype.thy	Thu Dec 05 17:58:03 2013 +0100
    66.3 @@ -19,9 +19,9 @@
    66.4  
    66.5  codatatype simple'' = X1'' nat int | X2''
    66.6  
    66.7 -codatatype 'a stream = Stream 'a "'a stream"
    66.8 +codatatype 'a stream = Stream (shd: 'a) (stl: "'a stream")
    66.9  
   66.10 -codatatype 'a mylist = MyNil | MyCons 'a "'a mylist"
   66.11 +codatatype 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
   66.12  
   66.13  codatatype ('b, 'c, 'd, 'e) some_passive =
   66.14    SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
    67.1 --- a/src/HOL/BNF/Examples/Misc_Datatype.thy	Thu Dec 05 17:52:12 2013 +0100
    67.2 +++ b/src/HOL/BNF/Examples/Misc_Datatype.thy	Thu Dec 05 17:58:03 2013 +0100
    67.3 @@ -19,7 +19,7 @@
    67.4  
    67.5  datatype_new simple'' = X1'' nat int | X2''
    67.6  
    67.7 -datatype_new 'a mylist = MyNil | MyCons 'a "'a mylist"
    67.8 +datatype_new 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
    67.9  
   67.10  datatype_new ('b, 'c, 'd, 'e) some_passive =
   67.11    SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
    68.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    68.2 +++ b/src/HOL/BNF/Examples/Misc_Primcorec.thy	Thu Dec 05 17:58:03 2013 +0100
    68.3 @@ -0,0 +1,112 @@
    68.4 +(*  Title:      HOL/BNF/Examples/Misc_Primcorec.thy
    68.5 +    Author:     Jasmin Blanchette, TU Muenchen
    68.6 +    Copyright   2013
    68.7 +
    68.8 +Miscellaneous primitive corecursive function definitions.
    68.9 +*)
   68.10 +
   68.11 +header {* Miscellaneous Primitive Corecursive Function Definitions *}
   68.12 +
   68.13 +theory Misc_Primcorec
   68.14 +imports Misc_Codatatype
   68.15 +begin
   68.16 +
   68.17 +primcorec simple_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple" where
   68.18 +  "simple_of_bools b b' = (if b then if b' then X1 else X2 else if b' then X3 else X4)"
   68.19 +
   68.20 +primcorec simple'_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple'" where
   68.21 +  "simple'_of_bools b b' =
   68.22 +     (if b then if b' then X1' () else X2' () else if b' then X3' () else X4' ())"
   68.23 +
   68.24 +primcorec inc_simple'' :: "nat \<Rightarrow> simple'' \<Rightarrow> simple''" where
   68.25 +  "inc_simple'' k s = (case s of X1'' n i \<Rightarrow> X1'' (n + k) (i + int k) | X2'' \<Rightarrow> X2'')"
   68.26 +
   68.27 +primcorec sinterleave :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
   68.28 +  "sinterleave s s' = Stream (shd s) (sinterleave s' (stl s))"
   68.29 +
   68.30 +primcorec myapp :: "'a mylist \<Rightarrow> 'a mylist \<Rightarrow> 'a mylist" where
   68.31 +  "myapp xs ys =
   68.32 +     (if xs = MyNil then ys
   68.33 +      else if ys = MyNil then xs
   68.34 +      else MyCons (myhd xs) (myapp (mytl xs) ys))"
   68.35 +
   68.36 +primcorec shuffle_sp :: "('a, 'b, 'c, 'd) some_passive \<Rightarrow> ('d, 'a, 'b, 'c) some_passive" where
   68.37 +  "shuffle_sp sp =
   68.38 +     (case sp of
   68.39 +       SP1 sp' \<Rightarrow> SP1 (shuffle_sp sp')
   68.40 +     | SP2 a \<Rightarrow> SP3 a
   68.41 +     | SP3 b \<Rightarrow> SP4 b
   68.42 +     | SP4 c \<Rightarrow> SP5 c
   68.43 +     | SP5 d \<Rightarrow> SP2 d)"
   68.44 +
   68.45 +primcorec rename_lam :: "(string \<Rightarrow> string) \<Rightarrow> lambda \<Rightarrow> lambda" where
   68.46 +  "rename_lam f l =
   68.47 +     (case l of
   68.48 +       Var s \<Rightarrow> Var (f s)
   68.49 +     | App l l' \<Rightarrow> App (rename_lam f l) (rename_lam f l')
   68.50 +     | Abs s l \<Rightarrow> Abs (f s) (rename_lam f l)
   68.51 +     | Let SL l \<Rightarrow> Let (fimage (map_pair f (rename_lam f)) SL) (rename_lam f l))"
   68.52 +
   68.53 +primcorec
   68.54 +  j1_sum :: "('a\<Colon>{zero,one,plus}) \<Rightarrow> 'a J1" and
   68.55 +  j2_sum :: "'a \<Rightarrow> 'a J2"
   68.56 +where
   68.57 +  "n = 0 \<Longrightarrow> is_J11 (j1_sum n)" |
   68.58 +  "un_J111 (j1_sum _) = 0" |
   68.59 +  "un_J112 (j1_sum _) = j1_sum 0" |
   68.60 +  "un_J121 (j1_sum n) = n + 1" |
   68.61 +  "un_J122 (j1_sum n) = j2_sum (n + 1)" |
   68.62 +  "n = 0 \<Longrightarrow> is_J21 (j2_sum n)" |
   68.63 +  "un_J221 (j2_sum n) = j1_sum (n + 1)" |
   68.64 +  "un_J222 (j2_sum n) = j2_sum (n + 1)"
   68.65 +
   68.66 +primcorec forest_of_mylist :: "'a tree mylist \<Rightarrow> 'a forest" where
   68.67 +  "forest_of_mylist ts =
   68.68 +     (case ts of
   68.69 +       MyNil \<Rightarrow> FNil
   68.70 +     | MyCons t ts \<Rightarrow> FCons t (forest_of_mylist ts))"
   68.71 +
   68.72 +primcorec mylist_of_forest :: "'a forest \<Rightarrow> 'a tree mylist" where
   68.73 +  "mylist_of_forest f =
   68.74 +     (case f of
   68.75 +       FNil \<Rightarrow> MyNil
   68.76 +     | FCons t ts \<Rightarrow> MyCons t (mylist_of_forest ts))"
   68.77 +
   68.78 +primcorec semi_stream :: "'a stream \<Rightarrow> 'a stream" where
   68.79 +  "semi_stream s = Stream (shd s) (semi_stream (stl (stl s)))"
   68.80 +
   68.81 +primcorec
   68.82 +  tree'_of_stream :: "'a stream \<Rightarrow> 'a tree'" and
   68.83 +  branch_of_stream :: "'a stream \<Rightarrow> 'a branch"
   68.84 +where
   68.85 +  "tree'_of_stream s =
   68.86 +     TNode' (branch_of_stream (semi_stream s)) (branch_of_stream (semi_stream (stl s)))" |
   68.87 +  "branch_of_stream s = (case s of Stream h t \<Rightarrow> Branch h (tree'_of_stream t))"
   68.88 +
   68.89 +primcorec
   68.90 +  freeze_exp :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) exp \<Rightarrow> ('a, 'b) exp" and
   68.91 +  freeze_trm :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) trm \<Rightarrow> ('a, 'b) trm" and
   68.92 +  freeze_factor :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) factor \<Rightarrow> ('a, 'b) factor"
   68.93 +where
   68.94 +  "freeze_exp g e =
   68.95 +     (case e of
   68.96 +       Term t \<Rightarrow> Term (freeze_trm g t)
   68.97 +     | Sum t e \<Rightarrow> Sum (freeze_trm g t) (freeze_exp g e))" |
   68.98 +  "freeze_trm g t =
   68.99 +     (case t of
  68.100 +       Factor f \<Rightarrow> Factor (freeze_factor g f)
  68.101 +     | Prod f t \<Rightarrow> Prod (freeze_factor g f) (freeze_trm g t))" |
  68.102 +  "freeze_factor g f =
  68.103 +     (case f of
  68.104 +       C a \<Rightarrow> C a
  68.105 +     | V b \<Rightarrow> C (g b)
  68.106 +     | Paren e \<Rightarrow> Paren (freeze_exp g e))"
  68.107 +
  68.108 +primcorec poly_unity :: "'a poly_unit" where
  68.109 +  "poly_unity = U (\<lambda>_. poly_unity)"
  68.110 +
  68.111 +primcorec build_cps :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool stream) \<Rightarrow> 'a \<Rightarrow> bool stream \<Rightarrow> 'a cps" where
  68.112 +  "shd b \<Longrightarrow> build_cps f g a b = CPS1 a" |
  68.113 +  "_ \<Longrightarrow> build_cps f g a b = CPS2 (\<lambda>a. build_cps f g (f a) (g a))"
  68.114 +
  68.115 +end
    69.1 --- a/src/HOL/BNF/Examples/Misc_Primrec.thy	Thu Dec 05 17:52:12 2013 +0100
    69.2 +++ b/src/HOL/BNF/Examples/Misc_Primrec.thy	Thu Dec 05 17:58:03 2013 +0100
    69.3 @@ -14,7 +14,7 @@
    69.4  primrec_new nat_of_simple :: "simple \<Rightarrow> nat" where
    69.5    "nat_of_simple X1 = 1" |
    69.6    "nat_of_simple X2 = 2" |
    69.7 -  "nat_of_simple X3 = 2" |
    69.8 +  "nat_of_simple X3 = 3" |
    69.9    "nat_of_simple X4 = 4"
   69.10  
   69.11  primrec_new simple_of_simple' :: "simple' \<Rightarrow> simple" where
    70.1 --- a/src/HOL/BNF/Examples/Process.thy	Thu Dec 05 17:52:12 2013 +0100
    70.2 +++ b/src/HOL/BNF/Examples/Process.thy	Thu Dec 05 17:58:03 2013 +0100
    70.3 @@ -22,7 +22,7 @@
    70.4  subsection {* Basic properties *}
    70.5  
    70.6  declare
    70.7 -  pre_process_rel_def[simp]
    70.8 +  rel_pre_process_def[simp]
    70.9    sum_rel_def[simp]
   70.10    prod_rel_def[simp]
   70.11  
   70.12 @@ -81,24 +81,17 @@
   70.13  
   70.14  datatype x_y_ax = x | y | ax
   70.15  
   70.16 -definition "isA \<equiv> \<lambda> K. case K of x \<Rightarrow> False     |y \<Rightarrow> True  |ax \<Rightarrow> True"
   70.17 -definition "pr  \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> ''b'' |ax \<Rightarrow> ''a''"
   70.18 -definition "co  \<equiv> \<lambda> K. case K of x \<Rightarrow> undefined |y \<Rightarrow> x    |ax \<Rightarrow> x"
   70.19 -lemmas Action_defs = isA_def pr_def co_def
   70.20 +primcorec F :: "x_y_ax \<Rightarrow> char list process" where
   70.21 +  "xyax = x \<Longrightarrow> isChoice (F xyax)"
   70.22 +| "ch1Of (F xyax) = F ax"
   70.23 +| "ch2Of (F xyax) = F y"
   70.24 +| "prefOf (F xyax) = (if xyax = y then ''b'' else ''a'')"
   70.25 +| "contOf (F xyax) = F x"
   70.26  
   70.27 -definition "c1  \<equiv> \<lambda> K. case K of x \<Rightarrow> ax   |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
   70.28 -definition "c2  \<equiv> \<lambda> K. case K of x \<Rightarrow> y    |y \<Rightarrow> undefined |ax \<Rightarrow> undefined"
   70.29 -lemmas Choice_defs = c1_def c2_def
   70.30 -
   70.31 -definition "F \<equiv> process_unfold isA pr co c1 c2"
   70.32  definition "X = F x"  definition "Y = F y"  definition "AX = F ax"
   70.33  
   70.34  lemma X_Y_AX: "X = Choice AX Y"  "Y = Action ''b'' X"  "AX = Action ''a'' X"
   70.35 -unfolding X_def Y_def AX_def F_def
   70.36 -using process.unfold(2)[of isA x "pr" co c1 c2]
   70.37 -      process.unfold(1)[of isA y "pr" co c1 c2]
   70.38 -      process.unfold(1)[of isA ax "pr" co c1 c2]
   70.39 -unfolding Action_defs Choice_defs by simp_all
   70.40 +unfolding X_def Y_def AX_def by (subst F.code, simp)+
   70.41  
   70.42  (* end product: *)
   70.43  lemma X_AX:
    71.1 --- a/src/HOL/BNF/Examples/Stream.thy	Thu Dec 05 17:52:12 2013 +0100
    71.2 +++ b/src/HOL/BNF/Examples/Stream.thy	Thu Dec 05 17:58:03 2013 +0100
    71.3 @@ -18,7 +18,7 @@
    71.4  code_datatype Stream
    71.5  
    71.6  lemma stream_case_cert:
    71.7 -  assumes "CASE \<equiv> stream_case c"
    71.8 +  assumes "CASE \<equiv> case_stream c"
    71.9    shows "CASE (a ## s) \<equiv> c a s"
   71.10    using assms by simp_all
   71.11  
   71.12 @@ -87,10 +87,10 @@
   71.13    by (induct xs) auto
   71.14  
   71.15  
   71.16 -subsection {* set of streams with elements in some fixes set *}
   71.17 +subsection {* set of streams with elements in some fixed set *}
   71.18  
   71.19  coinductive_set
   71.20 -  streams :: "'a set => 'a stream set"
   71.21 +  streams :: "'a set \<Rightarrow> 'a stream set"
   71.22    for A :: "'a set"
   71.23  where
   71.24    Stream[intro!, simp, no_atp]: "\<lbrakk>a \<in> A; s \<in> streams A\<rbrakk> \<Longrightarrow> a ## s \<in> streams A"
   71.25 @@ -98,6 +98,15 @@
   71.26  lemma shift_streams: "\<lbrakk>w \<in> lists A; s \<in> streams A\<rbrakk> \<Longrightarrow> w @- s \<in> streams A"
   71.27    by (induct w) auto
   71.28  
   71.29 +lemma streams_Stream: "x ## s \<in> streams A \<longleftrightarrow> x \<in> A \<and> s \<in> streams A"
   71.30 +  by (auto elim: streams.cases)
   71.31 +
   71.32 +lemma streams_stl: "s \<in> streams A \<Longrightarrow> stl s \<in> streams A"
   71.33 +  by (cases s) (auto simp: streams_Stream)
   71.34 +
   71.35 +lemma streams_shd: "s \<in> streams A \<Longrightarrow> shd s \<in> A"
   71.36 +  by (cases s) (auto simp: streams_Stream)
   71.37 +
   71.38  lemma sset_streams:
   71.39    assumes "sset s \<subseteq> A"
   71.40    shows "s \<in> streams A"
   71.41 @@ -105,6 +114,28 @@
   71.42    case streams then show ?case by (cases s) simp
   71.43  qed
   71.44  
   71.45 +lemma streams_sset:
   71.46 +  assumes "s \<in> streams A"
   71.47 +  shows "sset s \<subseteq> A"
   71.48 +proof
   71.49 +  fix x assume "x \<in> sset s" from this `s \<in> streams A` show "x \<in> A"
   71.50 +    by (induct s) (auto intro: streams_shd streams_stl)
   71.51 +qed
   71.52 +
   71.53 +lemma streams_iff_sset: "s \<in> streams A \<longleftrightarrow> sset s \<subseteq> A"
   71.54 +  by (metis sset_streams streams_sset)
   71.55 +
   71.56 +lemma streams_mono:  "s \<in> streams A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> s \<in> streams B"
   71.57 +  unfolding streams_iff_sset by auto
   71.58 +
   71.59 +lemma smap_streams: "s \<in> streams A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> smap f s \<in> streams B"
   71.60 +  unfolding streams_iff_sset stream.set_map by auto
   71.61 +
   71.62 +lemma streams_empty: "streams {} = {}"
   71.63 +  by (auto elim: streams.cases)
   71.64 +
   71.65 +lemma streams_UNIV[simp]: "streams UNIV = UNIV"
   71.66 +  by (auto simp: streams_iff_sset)
   71.67  
   71.68  subsection {* nth, take, drop for streams *}
   71.69  
   71.70 @@ -234,6 +265,9 @@
   71.71  lemma stream_all_shift[simp]: "stream_all P (xs @- s) = (list_all P xs \<and> stream_all P s)"
   71.72    unfolding stream_all_iff list_all_iff by auto
   71.73  
   71.74 +lemma stream_all_Stream: "stream_all P (x ## X) \<longleftrightarrow> P x \<and> stream_all P X"
   71.75 +  by simp
   71.76 +
   71.77  
   71.78  subsection {* recurring stream out of a list *}
   71.79  
   71.80 @@ -285,59 +319,60 @@
   71.81    by (induct n arbitrary: u) (auto simp: rotate1_rotate_swap rotate1_hd_tl rotate_conv_mod[symmetric])
   71.82  
   71.83  
   71.84 +subsection {* iterated application of a function *}
   71.85 +
   71.86 +primcorec siterate where
   71.87 +  "shd (siterate f x) = x"
   71.88 +| "stl (siterate f x) = siterate f (f x)"
   71.89 +
   71.90 +lemma stake_Suc: "stake (Suc n) s = stake n s @ [s !! n]"
   71.91 +  by (induct n arbitrary: s) auto
   71.92 +
   71.93 +lemma snth_siterate[simp]: "siterate f x !! n = (f^^n) x"
   71.94 +  by (induct n arbitrary: x) (auto simp: funpow_swap1)
   71.95 +
   71.96 +lemma sdrop_siterate[simp]: "sdrop n (siterate f x) = siterate f ((f^^n) x)"
   71.97 +  by (induct n arbitrary: x) (auto simp: funpow_swap1)
   71.98 +
   71.99 +lemma stake_siterate[simp]: "stake n (siterate f x) = map (\<lambda>n. (f^^n) x) [0 ..< n]"
  71.100 +  by (induct n arbitrary: x) (auto simp del: stake.simps(2) simp: stake_Suc)
  71.101 +
  71.102 +lemma sset_siterate: "sset (siterate f x) = {(f^^n) x | n. True}"
  71.103 +  by (auto simp: sset_range)
  71.104 +
  71.105 +lemma smap_siterate: "smap f (siterate f x) = siterate f (f x)"
  71.106 +  by (coinduction arbitrary: x) auto
  71.107 +
  71.108 +
  71.109  subsection {* stream repeating a single element *}
  71.110  
  71.111 -primcorec same where
  71.112 -  "shd (same x) = x"
  71.113 -| "stl (same x) = same x"
  71.114 +abbreviation "sconst \<equiv> siterate id"
  71.115  
  71.116 -lemma snth_same[simp]: "same x !! n = x"
  71.117 -  unfolding same_def by (induct n) auto
  71.118 +lemma shift_replicate_sconst[simp]: "replicate n x @- sconst x = sconst x"
  71.119 +  by (subst (3) stake_sdrop[symmetric]) (simp add: map_replicate_trivial)
  71.120  
  71.121 -lemma stake_same[simp]: "stake n (same x) = replicate n x"
  71.122 -  unfolding same_def by (induct n) (auto simp: upt_rec)
  71.123 +lemma stream_all_same[simp]: "sset (sconst x) = {x}"
  71.124 +  by (simp add: sset_siterate)
  71.125  
  71.126 -lemma sdrop_same[simp]: "sdrop n (same x) = same x"
  71.127 -  unfolding same_def by (induct n) auto
  71.128 -
  71.129 -lemma shift_replicate_same[simp]: "replicate n x @- same x = same x"
  71.130 -  by (metis sdrop_same stake_same stake_sdrop)
  71.131 +lemma same_cycle: "sconst x = cycle [x]"
  71.132 +  by coinduction auto
  71.133  
  71.134 -lemma stream_all_same[simp]: "stream_all P (same x) \<longleftrightarrow> P x"
  71.135 -  unfolding stream_all_def by auto
  71.136 +lemma smap_sconst: "smap f (sconst x) = sconst (f x)"
  71.137 +  by coinduction auto
  71.138  
  71.139 -lemma same_cycle: "same x = cycle [x]"
  71.140 -  by coinduction auto
  71.141 +lemma sconst_streams: "x \<in> A \<Longrightarrow> sconst x \<in> streams A"
  71.142 +  by (simp add: streams_iff_sset)
  71.143  
  71.144  
  71.145  subsection {* stream of natural numbers *}
  71.146  
  71.147 -primcorec fromN :: "nat \<Rightarrow> nat stream" where
  71.148 -  "fromN n = n ## fromN (n + 1)"
  71.149 -
  71.150 -lemma snth_fromN[simp]: "fromN n !! m = n + m"
  71.151 -  unfolding fromN_def by (induct m arbitrary: n) auto
  71.152 -
  71.153 -lemma stake_fromN[simp]: "stake m (fromN n) = [n ..< m + n]"
  71.154 -  unfolding fromN_def by (induct m arbitrary: n) (auto simp: upt_rec)
  71.155 -
  71.156 -lemma sdrop_fromN[simp]: "sdrop m (fromN n) = fromN (n + m)"
  71.157 -  unfolding fromN_def by (induct m arbitrary: n) auto
  71.158 -
  71.159 -lemma sset_fromN[simp]: "sset (fromN n) = {n ..}" (is "?L = ?R")
  71.160 -proof safe
  71.161 -  fix m assume "m \<in> ?L"
  71.162 -  moreover
  71.163 -  { fix s assume "m \<in> sset s" "\<exists>n'\<ge>n. s = fromN n'"
  71.164 -    hence "n \<le> m"  by (induct arbitrary: n rule: sset_induct1) fastforce+
  71.165 -  }
  71.166 -  ultimately show "n \<le> m" by auto
  71.167 -next
  71.168 -  fix m assume "n \<le> m" thus "m \<in> ?L" by (metis le_iff_add snth_fromN snth_sset)
  71.169 -qed
  71.170 +abbreviation "fromN \<equiv> siterate Suc"
  71.171  
  71.172  abbreviation "nats \<equiv> fromN 0"
  71.173  
  71.174 +lemma sset_fromN[simp]: "sset (fromN n) = {n ..}"
  71.175 +  by (auto simp add: sset_siterate) arith
  71.176 +
  71.177  
  71.178  subsection {* flatten a stream of lists *}
  71.179  
  71.180 @@ -498,26 +533,4 @@
  71.181    "smap2 f s1 s2 = smap (split f) (szip s1 s2)"
  71.182    by (coinduction arbitrary: s1 s2) auto
  71.183  
  71.184 -
  71.185 -subsection {* iterated application of a function *}
  71.186 -
  71.187 -primcorec siterate where
  71.188 -  "shd (siterate f x) = x"
  71.189 -| "stl (siterate f x) = siterate f (f x)"
  71.190 -
  71.191 -lemma stake_Suc: "stake (Suc n) s = stake n s @ [s !! n]"
  71.192 -  by (induct n arbitrary: s) auto
  71.193 -
  71.194 -lemma snth_siterate[simp]: "siterate f x !! n = (f^^n) x"
  71.195 -  by (induct n arbitrary: x) (auto simp: funpow_swap1)
  71.196 -
  71.197 -lemma sdrop_siterate[simp]: "sdrop n (siterate f x) = siterate f ((f^^n) x)"
  71.198 -  by (induct n arbitrary: x) (auto simp: funpow_swap1)
  71.199 -
  71.200 -lemma stake_siterate[simp]: "stake n (siterate f x) = map (\<lambda>n. (f^^n) x) [0 ..< n]"
  71.201 -  by (induct n arbitrary: x) (auto simp del: stake.simps(2) simp: stake_Suc)
  71.202 -
  71.203 -lemma sset_siterate: "sset (siterate f x) = {(f^^n) x | n. True}"
  71.204 -  by (auto simp: sset_range)
  71.205 -
  71.206  end
    72.1 --- a/src/HOL/BNF/More_BNFs.thy	Thu Dec 05 17:52:12 2013 +0100
    72.2 +++ b/src/HOL/BNF/More_BNFs.thy	Thu Dec 05 17:58:03 2013 +0100
    72.3 @@ -15,13 +15,17 @@
    72.4    Basic_BNFs
    72.5    "~~/src/HOL/Library/FSet"
    72.6    "~~/src/HOL/Library/Multiset"
    72.7 -  Countable_Type
    72.8  begin
    72.9  
   72.10  lemma option_rec_conv_option_case: "option_rec = option_case"
   72.11  by (simp add: fun_eq_iff split: option.split)
   72.12  
   72.13 -bnf Option.map [Option.set] "\<lambda>_::'a option. natLeq" ["None"] option_rel
   72.14 +bnf "'a option"
   72.15 +  map: Option.map
   72.16 +  sets: Option.set
   72.17 +  bd: natLeq 
   72.18 +  wits: None
   72.19 +  rel: option_rel
   72.20  proof -
   72.21    show "Option.map id = id" by (simp add: fun_eq_iff Option.map_def split: option.split)
   72.22  next
   72.23 @@ -94,7 +98,12 @@
   72.24      (\<exists>zs \<in> ?A. map p1 zs = as \<and> map p2 zs = bs)" by blast
   72.25  qed
   72.26  
   72.27 -bnf map [set] "\<lambda>_::'a list. natLeq" ["[]"]
   72.28 +bnf "'a list"
   72.29 +  map: map
   72.30 +  sets: set
   72.31 +  bd: natLeq
   72.32 +  wits: Nil
   72.33 +  rel: list_all2
   72.34  proof -
   72.35    show "map id = id" by (rule List.map.id)
   72.36  next
   72.37 @@ -115,8 +124,16 @@
   72.38    fix x
   72.39    show "|set x| \<le>o natLeq"
   72.40      by (metis List.finite_set finite_iff_ordLess_natLeq ordLess_imp_ordLeq)
   72.41 +next
   72.42 +  fix R
   72.43 +  show "list_all2 R =
   72.44 +         (Grp {x. set x \<subseteq> {(x, y). R x y}} (map fst))\<inverse>\<inverse> OO
   72.45 +         Grp {x. set x \<subseteq> {(x, y). R x y}} (map snd)"
   72.46 +    unfolding list_all2_def[abs_def] Grp_def fun_eq_iff relcompp.simps conversep.simps
   72.47 +    by (force simp: zip_map_fst_snd)
   72.48  qed (simp add: wpull_map)+
   72.49  
   72.50 +
   72.51  (* Finite sets *)
   72.52  
   72.53  lemma wpull_image:
   72.54 @@ -189,7 +206,7 @@
   72.55    by (transfer, clarsimp, metis fst_conv)
   72.56  qed
   72.57  
   72.58 -lemma wpull_fmap:
   72.59 +lemma wpull_fimage:
   72.60    assumes "wpull A B1 B2 f1 f2 p1 p2"
   72.61    shows "wpull {x. fset x \<subseteq> A} {x. fset x \<subseteq> B1} {x. fset x \<subseteq> B2}
   72.62                (fimage f1) (fimage f2) (fimage p1) (fimage p2)"
   72.63 @@ -214,7 +231,12 @@
   72.64       using X' Y1 Y2 by (auto simp: X'eq intro!: exI[of _ "x"]) (transfer, blast)+
   72.65  qed
   72.66  
   72.67 -bnf fimage [fset] "\<lambda>_::'a fset. natLeq" ["{||}"] fset_rel
   72.68 +bnf "'a fset"
   72.69 +  map: fimage
   72.70 +  sets: fset 
   72.71 +  bd: natLeq
   72.72 +  wits: "{||}"
   72.73 +  rel: fset_rel
   72.74  apply -
   72.75            apply transfer' apply simp
   72.76           apply transfer' apply force
   72.77 @@ -223,7 +245,7 @@
   72.78        apply (rule natLeq_card_order)
   72.79       apply (rule natLeq_cinfinite)
   72.80      apply transfer apply (metis ordLess_imp_ordLeq finite_iff_ordLess_natLeq)
   72.81 -  apply (erule wpull_fmap)
   72.82 +  apply (erule wpull_fimage)
   72.83   apply (simp add: Grp_def relcompp.simps conversep.simps fun_eq_iff fset_rel_alt fset_rel_aux) 
   72.84  apply transfer apply simp
   72.85  done
   72.86 @@ -235,121 +257,6 @@
   72.87  
   72.88  lemmas [simp] = fset.map_comp fset.map_id fset.set_map
   72.89  
   72.90 -(* Countable sets *)
   72.91 -
   72.92 -lemma card_of_countable_sets_range:
   72.93 -fixes A :: "'a set"
   72.94 -shows "|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |{f::nat \<Rightarrow> 'a. range f \<subseteq> A}|"
   72.95 -apply(rule card_of_ordLeqI[of from_nat_into]) using inj_on_from_nat_into
   72.96 -unfolding inj_on_def by auto
   72.97 -
   72.98 -lemma card_of_countable_sets_Func:
   72.99 -"|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |A| ^c natLeq"
  72.100 -using card_of_countable_sets_range card_of_Func_UNIV[THEN ordIso_symmetric]
  72.101 -unfolding cexp_def Field_natLeq Field_card_of
  72.102 -by (rule ordLeq_ordIso_trans)
  72.103 -
  72.104 -lemma ordLeq_countable_subsets:
  72.105 -"|A| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
  72.106 -apply (rule card_of_ordLeqI[of "\<lambda> a. {a}"]) unfolding inj_on_def by auto
  72.107 -
  72.108 -lemma finite_countable_subset:
  72.109 -"finite {X. X \<subseteq> A \<and> countable X} \<longleftrightarrow> finite A"
  72.110 -apply default
  72.111 - apply (erule contrapos_pp)
  72.112 - apply (rule card_of_ordLeq_infinite)
  72.113 - apply (rule ordLeq_countable_subsets)
  72.114 - apply assumption
  72.115 -apply (rule finite_Collect_conjI)
  72.116 -apply (rule disjI1)
  72.117 -by (erule finite_Collect_subsets)
  72.118 -
  72.119 -lemma rcset_to_rcset: "countable A \<Longrightarrow> rcset (the_inv rcset A) = A"
  72.120 -  apply (rule f_the_inv_into_f[unfolded inj_on_def image_iff])
  72.121 -   apply transfer' apply simp
  72.122 -  apply transfer' apply simp
  72.123 -  done
  72.124 -
  72.125 -lemma Collect_Int_Times:
  72.126 -"{(x, y). R x y} \<inter> A \<times> B = {(x, y). R x y \<and> x \<in> A \<and> y \<in> B}"
  72.127 -by auto
  72.128 -
  72.129 -definition cset_rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a cset \<Rightarrow> 'b cset \<Rightarrow> bool" where
  72.130 -"cset_rel R a b \<longleftrightarrow>
  72.131 - (\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and>
  72.132 - (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t)"
  72.133 -
  72.134 -lemma cset_rel_aux:
  72.135 -"(\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and> (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t) \<longleftrightarrow>
  72.136 - ((Grp {x. rcset x \<subseteq> {(a, b). R a b}} (cimage fst))\<inverse>\<inverse> OO
  72.137 -          Grp {x. rcset x \<subseteq> {(a, b). R a b}} (cimage snd)) a b" (is "?L = ?R")
  72.138 -proof
  72.139 -  assume ?L
  72.140 -  def R' \<equiv> "the_inv rcset (Collect (split R) \<inter> (rcset a \<times> rcset b))"
  72.141 -  (is "the_inv rcset ?L'")
  72.142 -  have L: "countable ?L'" by auto
  72.143 -  hence *: "rcset R' = ?L'" unfolding R'_def using fset_to_fset by (intro rcset_to_rcset)
  72.144 -  thus ?R unfolding Grp_def relcompp.simps conversep.simps
  72.145 -  proof (intro CollectI prod_caseI exI[of _ a] exI[of _ b] exI[of _ R'] conjI refl)
  72.146 -    from * `?L` show "a = cimage fst R'" by transfer (auto simp: image_def Collect_Int_Times)
  72.147 -  next
  72.148 -    from * `?L` show "b = cimage snd R'" by transfer (auto simp: image_def Collect_Int_Times)
  72.149 -  qed simp_all
  72.150 -next
  72.151 -  assume ?R thus ?L unfolding Grp_def relcompp.simps conversep.simps
  72.152 -    by transfer force
  72.153 -qed
  72.154 -
  72.155 -bnf cimage [rcset] "\<lambda>_::'a cset. natLeq" ["cempty"] cset_rel
  72.156 -proof -
  72.157 -  show "cimage id = id" by transfer' simp
  72.158 -next
  72.159 -  fix f g show "cimage (g \<circ> f) = cimage g \<circ> cimage f" by transfer' fastforce
  72.160 -next
  72.161 -  fix C f g assume eq: "\<And>a. a \<in> rcset C \<Longrightarrow> f a = g a"
  72.162 -  thus "cimage f C = cimage g C" by transfer force
  72.163 -next
  72.164 -  fix f show "rcset \<circ> cimage f = op ` f \<circ> rcset" by transfer' fastforce
  72.165 -next
  72.166 -  show "card_order natLeq" by (rule natLeq_card_order)
  72.167 -next
  72.168 -  show "cinfinite natLeq" by (rule natLeq_cinfinite)
  72.169 -next
  72.170 -  fix C show "|rcset C| \<le>o natLeq" by transfer (unfold countable_card_le_natLeq)
  72.171 -next
  72.172 -  fix A B1 B2 f1 f2 p1 p2
  72.173 -  assume wp: "wpull A B1 B2 f1 f2 p1 p2"
  72.174 -  show "wpull {x. rcset x \<subseteq> A} {x. rcset x \<subseteq> B1} {x. rcset x \<subseteq> B2}
  72.175 -              (cimage f1) (cimage f2) (cimage p1) (cimage p2)"
  72.176 -  unfolding wpull_def proof safe
  72.177 -    fix y1 y2
  72.178 -    assume Y1: "rcset y1 \<subseteq> B1" and Y2: "rcset y2 \<subseteq> B2"
  72.179 -    assume "cimage f1 y1 = cimage f2 y2"
  72.180 -    hence EQ: "f1 ` (rcset y1) = f2 ` (rcset y2)" by transfer
  72.181 -    with Y1 Y2 obtain X where X: "X \<subseteq> A"
  72.182 -    and Y1: "p1 ` X = rcset y1" and Y2: "p2 ` X = rcset y2"
  72.183 -    using wpull_image[OF wp] unfolding wpull_def Pow_def Bex_def mem_Collect_eq
  72.184 -      by (auto elim!: allE[of _ "rcset y1"] allE[of _ "rcset y2"])
  72.185 -    have "\<forall> y1' \<in> rcset y1. \<exists> x. x \<in> X \<and> y1' = p1 x" using Y1 by auto
  72.186 -    then obtain q1 where q1: "\<forall> y1' \<in> rcset y1. q1 y1' \<in> X \<and> y1' = p1 (q1 y1')" by metis
  72.187 -    have "\<forall> y2' \<in> rcset y2. \<exists> x. x \<in> X \<and> y2' = p2 x" using Y2 by auto
  72.188 -    then obtain q2 where q2: "\<forall> y2' \<in> rcset y2. q2 y2' \<in> X \<and> y2' = p2 (q2 y2')" by metis
  72.189 -    def X' \<equiv> "q1 ` (rcset y1) \<union> q2 ` (rcset y2)"
  72.190 -    have X': "X' \<subseteq> A" and Y1: "p1 ` X' = rcset y1" and Y2: "p2 ` X' = rcset y2"
  72.191 -    using X Y1 Y2 q1 q2 unfolding X'_def by fast+
  72.192 -    have fX': "countable X'" unfolding X'_def by simp
  72.193 -    then obtain x where X'eq: "X' = rcset x" by transfer blast
  72.194 -    show "\<exists>x\<in>{x. rcset x \<subseteq> A}. cimage p1 x = y1 \<and> cimage p2 x = y2"
  72.195 -      using X' Y1 Y2 unfolding X'eq by (intro bexI[of _ "x"]) (transfer, auto)
  72.196 -  qed
  72.197 -next
  72.198 -  fix R
  72.199 -  show "cset_rel R =
  72.200 -        (Grp {x. rcset x \<subseteq> Collect (split R)} (cimage fst))\<inverse>\<inverse> OO
  72.201 -         Grp {x. rcset x \<subseteq> Collect (split R)} (cimage snd)"
  72.202 -  unfolding cset_rel_def[abs_def] cset_rel_aux by simp
  72.203 -qed (transfer, simp)
  72.204 -
  72.205  
  72.206  (* Multisets *)
  72.207  
  72.208 @@ -874,22 +781,26 @@
  72.209    by transfer
  72.210      (auto intro!: ordLess_imp_ordLeq simp: finite_iff_ordLess_natLeq[symmetric] multiset_def)
  72.211  
  72.212 -bnf mmap [set_of] "\<lambda>_::'a multiset. natLeq" ["{#}"]
  72.213 +bnf "'a multiset"
  72.214 +  map: mmap
  72.215 +  sets: set_of 
  72.216 +  bd: natLeq
  72.217 +  wits: "{#}"
  72.218  by (auto simp add: mmap_id0 mmap_comp set_of_mmap natLeq_card_order natLeq_cinfinite set_of_bd
  72.219    intro: mmap_cong wpull_mmap)
  72.220  
  72.221 -inductive multiset_rel' where
  72.222 -Zero: "multiset_rel' R {#} {#}"
  72.223 +inductive rel_multiset' where
  72.224 +Zero: "rel_multiset' R {#} {#}"
  72.225  |
  72.226 -Plus: "\<lbrakk>R a b; multiset_rel' R M N\<rbrakk> \<Longrightarrow> multiset_rel' R (M + {#a#}) (N + {#b#})"
  72.227 +Plus: "\<lbrakk>R a b; rel_multiset' R M N\<rbrakk> \<Longrightarrow> rel_multiset' R (M + {#a#}) (N + {#b#})"
  72.228  
  72.229 -lemma multiset_map_Zero_iff[simp]: "mmap f M = {#} \<longleftrightarrow> M = {#}"
  72.230 +lemma map_multiset_Zero_iff[simp]: "mmap f M = {#} \<longleftrightarrow> M = {#}"
  72.231  by (metis image_is_empty multiset.set_map set_of_eq_empty_iff)
  72.232  
  72.233 -lemma multiset_map_Zero[simp]: "mmap f {#} = {#}" by simp
  72.234 +lemma map_multiset_Zero[simp]: "mmap f {#} = {#}" by simp
  72.235  
  72.236 -lemma multiset_rel_Zero: "multiset_rel R {#} {#}"
  72.237 -unfolding multiset_rel_def Grp_def by auto
  72.238 +lemma rel_multiset_Zero: "rel_multiset R {#} {#}"
  72.239 +unfolding rel_multiset_def Grp_def by auto
  72.240  
  72.241  declare multiset.count[simp]
  72.242  declare Abs_multiset_inverse[simp]
  72.243 @@ -897,7 +808,7 @@
  72.244  declare union_preserves_multiset[simp]
  72.245  
  72.246  
  72.247 -lemma multiset_map_Plus[simp]: "mmap f (M1 + M2) = mmap f M1 + mmap f M2"
  72.248 +lemma map_multiset_Plus[simp]: "mmap f (M1 + M2) = mmap f M1 + mmap f M2"
  72.249  proof (intro multiset_eqI, transfer fixing: f)
  72.250    fix x :: 'a and M1 M2 :: "'b \<Rightarrow> nat"
  72.251    assume "M1 \<in> multiset" "M2 \<in> multiset"
  72.252 @@ -910,12 +821,12 @@
  72.253      by (auto simp: setsum.distrib[symmetric])
  72.254  qed
  72.255  
  72.256 -lemma multiset_map_singl[simp]: "mmap f {#a#} = {#f a#}"
  72.257 +lemma map_multiset_singl[simp]: "mmap f {#a#} = {#f a#}"
  72.258    by transfer auto
  72.259  
  72.260 -lemma multiset_rel_Plus:
  72.261 -assumes ab: "R a b" and MN: "multiset_rel R M N"
  72.262 -shows "multiset_rel R (M + {#a#}) (N + {#b#})"
  72.263 +lemma rel_multiset_Plus:
  72.264 +assumes ab: "R a b" and MN: "rel_multiset R M N"
  72.265 +shows "rel_multiset R (M + {#a#}) (N + {#b#})"
  72.266  proof-
  72.267    {fix y assume "R a b" and "set_of y \<subseteq> {(x, y). R x y}"
  72.268     hence "\<exists>ya. mmap fst y + {#a#} = mmap fst ya \<and>
  72.269 @@ -925,13 +836,13 @@
  72.270    }
  72.271    thus ?thesis
  72.272    using assms
  72.273 -  unfolding multiset_rel_def Grp_def by force
  72.274 +  unfolding rel_multiset_def Grp_def by force
  72.275  qed
  72.276  
  72.277 -lemma multiset_rel'_imp_multiset_rel:
  72.278 -"multiset_rel' R M N \<Longrightarrow> multiset_rel R M N"
  72.279 -apply(induct rule: multiset_rel'.induct)
  72.280 -using multiset_rel_Zero multiset_rel_Plus by auto
  72.281 +lemma rel_multiset'_imp_rel_multiset:
  72.282 +"rel_multiset' R M N \<Longrightarrow> rel_multiset R M N"
  72.283 +apply(induct rule: rel_multiset'.induct)
  72.284 +using rel_multiset_Zero rel_multiset_Plus by auto
  72.285  
  72.286  lemma mcard_mmap[simp]: "mcard (mmap f M) = mcard M"
  72.287  proof -
  72.288 @@ -942,8 +853,7 @@
  72.289    using finite_Collect_mem .
  72.290    ultimately have fin: "finite {b. \<exists>a. f a = b \<and> a \<in># M}" by(rule finite_subset)
  72.291    have i: "inj_on A ?B" unfolding inj_on_def A_def apply clarsimp
  72.292 -  by (metis (lifting, mono_tags) mem_Collect_eq rel_simps(54)
  72.293 -                                 setsum_gt_0_iff setsum_infinite)
  72.294 +    by (metis (lifting, full_types) mem_Collect_eq neq0_conv setsum.neutral)
  72.295    have 0: "\<And> b. 0 < setsum (count M) (A b) \<longleftrightarrow> (\<exists> a \<in> A b. count M a > 0)"
  72.296    apply safe
  72.297      apply (metis less_not_refl setsum_gt_0_iff setsum_infinite)
  72.298 @@ -964,10 +874,10 @@
  72.299    then show ?thesis unfolding mcard_unfold_setsum A_def by transfer
  72.300  qed
  72.301  
  72.302 -lemma multiset_rel_mcard:
  72.303 -assumes "multiset_rel R M N"
  72.304 +lemma rel_multiset_mcard:
  72.305 +assumes "rel_multiset R M N"
  72.306  shows "mcard M = mcard N"
  72.307 -using assms unfolding multiset_rel_def Grp_def by auto
  72.308 +using assms unfolding rel_multiset_def Grp_def by auto
  72.309  
  72.310  lemma multiset_induct2[case_names empty addL addR]:
  72.311  assumes empty: "P {#} {#}"
  72.312 @@ -1022,68 +932,67 @@
  72.313  qed
  72.314  
  72.315  lemma msed_rel_invL:
  72.316 -assumes "multiset_rel R (M + {#a#}) N"
  72.317 -shows "\<exists> N1 b. N = N1 + {#b#} \<and> R a b \<and> multiset_rel R M N1"
  72.318 +assumes "rel_multiset R (M + {#a#}) N"
  72.319 +shows "\<exists> N1 b. N = N1 + {#b#} \<and> R a b \<and> rel_multiset R M N1"
  72.320  proof-
  72.321    obtain K where KM: "mmap fst K = M + {#a#}"
  72.322    and KN: "mmap snd K = N" and sK: "set_of K \<subseteq> {(a, b). R a b}"
  72.323    using assms
  72.324 -  unfolding multiset_rel_def Grp_def by auto
  72.325 +  unfolding rel_multiset_def Grp_def by auto
  72.326    obtain K1 ab where K: "K = K1 + {#ab#}" and a: "fst ab = a"
  72.327    and K1M: "mmap fst K1 = M" using msed_map_invR[OF KM] by auto
  72.328    obtain N1 where N: "N = N1 + {#snd ab#}" and K1N1: "mmap snd K1 = N1"
  72.329    using msed_map_invL[OF KN[unfolded K]] by auto
  72.330    have Rab: "R a (snd ab)" using sK a unfolding K by auto
  72.331 -  have "multiset_rel R M N1" using sK K1M K1N1
  72.332 -  unfolding K multiset_rel_def Grp_def by auto
  72.333 +  have "rel_multiset R M N1" using sK K1M K1N1
  72.334 +  unfolding K rel_multiset_def Grp_def by auto
  72.335    thus ?thesis using N Rab by auto
  72.336  qed
  72.337  
  72.338  lemma msed_rel_invR:
  72.339 -assumes "multiset_rel R M (N + {#b#})"
  72.340 -shows "\<exists> M1 a. M = M1 + {#a#} \<and> R a b \<and> multiset_rel R M1 N"
  72.341 +assumes "rel_multiset R M (N + {#b#})"
  72.342 +shows "\<exists> M1 a. M = M1 + {#a#} \<and> R a b \<and> rel_multiset R M1 N"
  72.343  proof-
  72.344    obtain K where KN: "mmap snd K = N + {#b#}"
  72.345    and KM: "mmap fst K = M" and sK: "set_of K \<subseteq> {(a, b). R a b}"
  72.346    using assms
  72.347 -  unfolding multiset_rel_def Grp_def by auto
  72.348 +  unfolding rel_multiset_def Grp_def by auto
  72.349    obtain K1 ab where K: "K = K1 + {#ab#}" and b: "snd ab = b"
  72.350    and K1N: "mmap snd K1 = N" using msed_map_invR[OF KN] by auto
  72.351    obtain M1 where M: "M = M1 + {#fst ab#}" and K1M1: "mmap fst K1 = M1"
  72.352    using msed_map_invL[OF KM[unfolded K]] by auto
  72.353    have Rab: "R (fst ab) b" using sK b unfolding K by auto
  72.354 -  have "multiset_rel R M1 N" using sK K1N K1M1
  72.355 -  unfolding K multiset_rel_def Grp_def by auto
  72.356 +  have "rel_multiset R M1 N" using sK K1N K1M1
  72.357 +  unfolding K rel_multiset_def Grp_def by auto
  72.358    thus ?thesis using M Rab by auto
  72.359  qed
  72.360  
  72.361 -lemma multiset_rel_imp_multiset_rel':
  72.362 -assumes "multiset_rel R M N"
  72.363 -shows "multiset_rel' R M N"
  72.364 +lemma rel_multiset_imp_rel_multiset':
  72.365 +assumes "rel_multiset R M N"
  72.366 +shows "rel_multiset' R M N"
  72.367  using assms proof(induct M arbitrary: N rule: measure_induct_rule[of mcard])
  72.368    case (less M)
  72.369 -  have c: "mcard M = mcard N" using multiset_rel_mcard[OF less.prems] .
  72.370 +  have c: "mcard M = mcard N" using rel_multiset_mcard[OF less.prems] .
  72.371    show ?case
  72.372    proof(cases "M = {#}")
  72.373      case True hence "N = {#}" using c by simp
  72.374 -    thus ?thesis using True multiset_rel'.Zero by auto
  72.375 +    thus ?thesis using True rel_multiset'.Zero by auto
  72.376    next
  72.377      case False then obtain M1 a where M: "M = M1 + {#a#}" by (metis multi_nonempty_split)
  72.378 -    obtain N1 b where N: "N = N1 + {#b#}" and R: "R a b" and ms: "multiset_rel R M1 N1"
  72.379 +    obtain N1 b where N: "N = N1 + {#b#}" and R: "R a b" and ms: "rel_multiset R M1 N1"
  72.380      using msed_rel_invL[OF less.prems[unfolded M]] by auto
  72.381 -    have "multiset_rel' R M1 N1" using less.hyps[of M1 N1] ms unfolding M by simp
  72.382 -    thus ?thesis using multiset_rel'.Plus[of R a b, OF R] unfolding M N by simp
  72.383 +    have "rel_multiset' R M1 N1" using less.hyps[of M1 N1] ms unfolding M by simp
  72.384 +    thus ?thesis using rel_multiset'.Plus[of R a b, OF R] unfolding M N by simp
  72.385    qed
  72.386  qed
  72.387  
  72.388 -lemma multiset_rel_multiset_rel':
  72.389 -"multiset_rel R M N = multiset_rel' R M N"
  72.390 -using  multiset_rel_imp_multiset_rel' multiset_rel'_imp_multiset_rel by auto
  72.391 +lemma rel_multiset_rel_multiset':
  72.392 +"rel_multiset R M N = rel_multiset' R M N"
  72.393 +using  rel_multiset_imp_rel_multiset' rel_multiset'_imp_rel_multiset by auto
  72.394  
  72.395 -(* The main end product for multiset_rel: inductive characterization *)
  72.396 -theorems multiset_rel_induct[case_names empty add, induct pred: multiset_rel] =
  72.397 -         multiset_rel'.induct[unfolded multiset_rel_multiset_rel'[symmetric]]
  72.398 -
  72.399 +(* The main end product for rel_multiset: inductive characterization *)
  72.400 +theorems rel_multiset_induct[case_names empty add, induct pred: rel_multiset] =
  72.401 +         rel_multiset'.induct[unfolded rel_multiset_rel_multiset'[symmetric]]
  72.402  
  72.403  
  72.404  (* Advanced relator customization *)
  72.405 @@ -1153,5 +1062,4 @@
  72.406    qed
  72.407  qed
  72.408  
  72.409 -
  72.410  end
    73.1 --- a/src/HOL/BNF/README.html	Thu Dec 05 17:52:12 2013 +0100
    73.2 +++ b/src/HOL/BNF/README.html	Thu Dec 05 17:58:03 2013 +0100
    73.3 @@ -20,7 +20,8 @@
    73.4  possibly infinite depth. The framework draws heavily from category theory.
    73.5  
    73.6  <p>
    73.7 -The package is described in the following paper:
    73.8 +The package is described in <tt>isabelle doc datatypes</tt> and in the following
    73.9 +paper:
   73.10  
   73.11  <ul>
   73.12    <li><a href="http://www21.in.tum.de/~traytel/papers/lics12-codatatypes/index.html">Foundational, Compositional (Co)datatypes for Higher-Order Logic&mdash;Category Theory Applied to Theorem Proving</a>, <br>
   73.13 @@ -37,17 +38,10 @@
   73.14  The key notion underlying the package is that of a <i>bounded natural functor</i>
   73.15  (<i>BNF</i>)&mdash;an enriched type constructor satisfying specific properties
   73.16  preserved by interesting categorical operations (composition, least fixed point,
   73.17 -and greatest fixed point). The <tt>Basic_BNFs.thy</tt> and <tt>More_BNFs.thy</tt>
   73.18 -files register various basic types, notably for sums, products, function spaces,
   73.19 -finite sets, multisets, and countable sets. Custom BNFs can be registered as well.
   73.20 -
   73.21 -<p>
   73.22 -<b>Warning:</b> The package is under development. Please contact any nonempty
   73.23 -subset of
   73.24 -<a href="mailto:traytel@in.tum.de">the</a>
   73.25 -<a href="mailto:popescua@in.tum.de">above</a>
   73.26 -<a href="mailto:blanchette@in.tum.de">authors</a>
   73.27 -if you have questions or comments.
   73.28 +and greatest fixed point). The <tt>Basic_BNFs.thy</tt>, <tt>More_BNFs.thy</tt>,
   73.29 +and <tt>Countable_Set_Type.thy</tt> files register various basic types, notably
   73.30 +for sums, products, function spaces, finite sets, multisets, and countable sets.
   73.31 +Custom BNFs can be registered as well.
   73.32  
   73.33  </body>
   73.34  
    74.1 --- a/src/HOL/BNF/Tools/bnf_comp.ML	Thu Dec 05 17:52:12 2013 +0100
    74.2 +++ b/src/HOL/BNF/Tools/bnf_comp.ML	Thu Dec 05 17:58:03 2013 +0100
    74.3 @@ -147,7 +147,7 @@
    74.4      val (sets, sets_alt) = map_split mk_set (0 upto ilive - 1);
    74.5  
    74.6      (*(inner_1.bd +c ... +c inner_m.bd) *c outer.bd*)
    74.7 -    val bd = Term.absdummy CCA (mk_cprod (Library.foldr1 (uncurry mk_csum) inner_bds) outer_bd);
    74.8 +    val bd = mk_cprod (Library.foldr1 (uncurry mk_csum) inner_bds) outer_bd;
    74.9  
   74.10      fun map_id0_tac _ =
   74.11        mk_comp_map_id0_tac (map_id0_of_bnf outer) (map_cong0_of_bnf outer)
   74.12 @@ -257,7 +257,7 @@
   74.13  
   74.14      val (bnf', lthy') =
   74.15        bnf_def const_policy (K Dont_Note) qualify tacs wit_tac (SOME (oDs @ flat Dss)) Binding.empty
   74.16 -        Binding.empty [] (((((b, mapx), sets), bd), wits), SOME rel) lthy;
   74.17 +        Binding.empty [] ((((((b, CCA), mapx), sets), bd), wits), SOME rel) lthy;
   74.18    in
   74.19      (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
   74.20    end;
   74.21 @@ -351,7 +351,7 @@
   74.22  
   74.23      val (bnf', lthy') =
   74.24        bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME (killedAs @ Ds)) Binding.empty
   74.25 -        Binding.empty [] (((((b, mapx), sets), Term.absdummy T bd), wits), SOME rel) lthy;
   74.26 +        Binding.empty [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
   74.27    in
   74.28      (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
   74.29    end;
   74.30 @@ -433,7 +433,7 @@
   74.31  
   74.32      val (bnf', lthy') =
   74.33        bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME Ds) Binding.empty Binding.empty
   74.34 -        [] (((((b, mapx), sets), Term.absdummy T bd), wits), SOME rel) lthy;
   74.35 +        [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
   74.36    in
   74.37      (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
   74.38    end;
   74.39 @@ -506,7 +506,7 @@
   74.40  
   74.41      val (bnf', lthy') =
   74.42        bnf_def Smart_Inline (K Dont_Note) qualify tacs wit_tac (SOME Ds) Binding.empty Binding.empty
   74.43 -        [] (((((b, mapx), sets), Term.absdummy T bd), wits), SOME rel) lthy;
   74.44 +        [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
   74.45    in
   74.46      (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
   74.47    end;
   74.48 @@ -643,7 +643,7 @@
   74.49      val (bnf', lthy') =
   74.50        bnf_def Hardly_Inline (user_policy Dont_Note) qualify tacs wit_tac (SOME deads)
   74.51          Binding.empty Binding.empty []
   74.52 -        (((((b, bnf_map), bnf_sets), Term.absdummy T bnf_bd'), bnf_wits), SOME bnf_rel) lthy;
   74.53 +        ((((((b, T), bnf_map), bnf_sets), bnf_bd'), bnf_wits), SOME bnf_rel) lthy;
   74.54    in
   74.55      ((bnf', deads), lthy')
   74.56    end;
    75.1 --- a/src/HOL/BNF/Tools/bnf_comp_tactics.ML	Thu Dec 05 17:52:12 2013 +0100
    75.2 +++ b/src/HOL/BNF/Tools/bnf_comp_tactics.ML	Thu Dec 05 17:58:03 2013 +0100
    75.3 @@ -164,10 +164,9 @@
    75.4  fun mk_comp_wit_tac ctxt Gwit_thms collect_set_map Fwit_thms =
    75.5    ALLGOALS (dtac @{thm in_Union_o_assoc}) THEN
    75.6    unfold_thms_tac ctxt (collect_set_map :: comp_wit_thms) THEN
    75.7 -  REPEAT_DETERM (
    75.8 -    atac 1 ORELSE
    75.9 -    REPEAT_DETERM (eresolve_tac @{thms UnionE UnE imageE} 1) THEN
   75.10 -    (TRY o dresolve_tac Gwit_thms THEN'
   75.11 +  REPEAT_DETERM ((atac ORELSE'
   75.12 +    REPEAT_DETERM o eresolve_tac @{thms UnionE UnE} THEN'
   75.13 +    etac imageE THEN' TRY o dresolve_tac Gwit_thms THEN'
   75.14      (etac FalseE ORELSE'
   75.15      hyp_subst_tac ctxt THEN'
   75.16      dresolve_tac Fwit_thms THEN'
    76.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    76.2 +++ b/src/HOL/BNF/Tools/bnf_decl.ML	Thu Dec 05 17:58:03 2013 +0100
    76.3 @@ -0,0 +1,96 @@
    76.4 +(*  Title:      HOL/BNF/Tools/bnf_decl.ML
    76.5 +    Author:     Dmitriy Traytel, TU Muenchen
    76.6 +    Copyright   2013
    76.7 +
    76.8 +Axiomatic declaration of bounded natural functors.
    76.9 +*)
   76.10 +
   76.11 +signature BNF_DECL =
   76.12 +sig
   76.13 +  val bnf_decl: (binding option * (typ * sort)) list -> binding -> mixfix -> binding -> binding ->
   76.14 +    local_theory -> BNF_Def.bnf * local_theory
   76.15 +end
   76.16 +
   76.17 +structure BNF_Decl : BNF_DECL =
   76.18 +struct
   76.19 +
   76.20 +open BNF_Util
   76.21 +open BNF_Def
   76.22 +
   76.23 +fun prepare_decl prepare_constraint prepare_typ raw_vars b mx user_mapb user_relb lthy =
   76.24 +  let
   76.25 +   fun prepare_type_arg (set_opt, (ty, c)) =
   76.26 +      let val s = fst (dest_TFree (prepare_typ lthy ty)) in
   76.27 +        (set_opt, (s, prepare_constraint lthy c))
   76.28 +      end;
   76.29 +    val ((user_setbs, vars), raw_vars') =
   76.30 +      map prepare_type_arg raw_vars
   76.31 +      |> `split_list
   76.32 +      |>> apfst (map_filter I);
   76.33 +    val deads = map_filter (fn (NONE, x) => SOME x | _ => NONE) raw_vars';
   76.34 +
   76.35 +    fun mk_b name user_b =
   76.36 +      (if Binding.is_empty user_b then Binding.prefix_name (name ^ "_") b else user_b)
   76.37 +      |> Binding.qualify false (Binding.name_of b);
   76.38 +    val (Tname, lthy) = Typedecl.basic_typedecl (b, length vars, mx) lthy;
   76.39 +    val (bd_type_Tname, lthy) =
   76.40 +      Typedecl.basic_typedecl (mk_b "bd_type" Binding.empty, length deads, NoSyn) lthy;
   76.41 +    val T = Type (Tname, map TFree vars);
   76.42 +    val bd_type_T = Type (bd_type_Tname, map TFree deads);
   76.43 +    val lives = map TFree (filter_out (member (op =) deads) vars);
   76.44 +    val live = length lives;
   76.45 +    val _ = "Trying to declare a BNF with no live variables" |> null lives ? error;
   76.46 +    val (lives', _) = BNF_Util.mk_TFrees (length lives)
   76.47 +      (fold Variable.declare_typ (map TFree vars) lthy);
   76.48 +    val T' = Term.typ_subst_atomic (lives ~~ lives') T;
   76.49 +    val mapT = map2 (curry op -->) lives lives' ---> T --> T';
   76.50 +    val setTs = map (fn U => T --> HOLogic.mk_setT U) lives;
   76.51 +    val bdT = BNF_Util.mk_relT (bd_type_T, bd_type_T);
   76.52 +    val mapb = mk_b BNF_Def.mapN user_mapb;
   76.53 +    val bdb = mk_b "bd" Binding.empty;
   76.54 +    val setbs = map2 (fn b => fn i => mk_b (BNF_Def.mk_setN i) b) user_setbs
   76.55 +      (if live = 1 then [0] else 1 upto live);
   76.56 +    val lthy = Local_Theory.background_theory
   76.57 +      (Sign.add_consts_i ((mapb, mapT, NoSyn) :: (bdb, bdT, NoSyn) ::
   76.58 +        map2 (fn b => fn T => (b, T, NoSyn)) setbs setTs))
   76.59 +      lthy;
   76.60 +    val Fmap = Const (Local_Theory.full_name lthy mapb, mapT);
   76.61 +    val Fsets = map2 (fn setb => fn setT =>
   76.62 +      Const (Local_Theory.full_name lthy setb, setT)) setbs setTs;
   76.63 +    val Fbd = Const (Local_Theory.full_name lthy bdb, bdT);
   76.64 +    val (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, _) =
   76.65 +      prepare_def Do_Inline (user_policy Note_Some) I (K I) (K I) (SOME (map TFree deads))
   76.66 +      user_mapb user_relb user_setbs ((((((Binding.empty, T), Fmap), Fsets), Fbd), []), NONE) lthy;
   76.67 +
   76.68 +    fun mk_wits_tac set_maps = K (TRYALL Goal.conjunction_tac) THEN' the triv_tac_opt set_maps;
   76.69 +    val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
   76.70 +    fun mk_wit_thms set_maps =
   76.71 +      Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) (mk_wits_tac set_maps)
   76.72 +        |> Conjunction.elim_balanced (length wit_goals)
   76.73 +        |> map2 (Conjunction.elim_balanced o length) wit_goalss
   76.74 +        |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
   76.75 +
   76.76 +    val ((_, [thms]), (lthy_old, lthy)) = Local_Theory.background_theory_result
   76.77 +      (Specification.axiomatization [] [((mk_b "axioms" Binding.empty, []), goals)]) lthy
   76.78 +      ||> `Local_Theory.restore;
   76.79 +    val phi = Proof_Context.export_morphism lthy_old lthy;
   76.80 +  in
   76.81 +    BNF_Def.register_bnf key (after_qed mk_wit_thms (map single  (Morphism.fact phi thms)) lthy)
   76.82 +  end;
   76.83 +
   76.84 +val bnf_decl = prepare_decl (K I) (K I);
   76.85 +
   76.86 +fun read_constraint _ NONE = HOLogic.typeS
   76.87 +  | read_constraint ctxt (SOME s) = Syntax.read_sort ctxt s;
   76.88 +
   76.89 +val bnf_decl_cmd = prepare_decl read_constraint Syntax.parse_typ;
   76.90 +
   76.91 +val parse_bnf_decl =
   76.92 +  parse_type_args_named_constrained -- parse_binding -- parse_map_rel_bindings -- Parse.opt_mixfix;
   76.93 +
   76.94 +val _ =
   76.95 +  Outer_Syntax.local_theory @{command_spec "bnf_decl"} "bnf declaration"
   76.96 +    (parse_bnf_decl >> 
   76.97 +      (fn (((bsTs, b), (mapb, relb)), mx) => bnf_decl_cmd bsTs b mx mapb relb #> snd));
   76.98 +
   76.99 +end;
    77.1 --- a/src/HOL/BNF/Tools/bnf_def.ML	Thu Dec 05 17:52:12 2013 +0100
    77.2 +++ b/src/HOL/BNF/Tools/bnf_def.ML	Thu Dec 05 17:58:03 2013 +0100
    77.3 @@ -77,14 +77,20 @@
    77.4    val wit_thms_of_bnf: bnf -> thm list
    77.5    val wit_thmss_of_bnf: bnf -> thm list list
    77.6  
    77.7 +  val mk_map: int -> typ list -> typ list -> term -> term
    77.8 +  val mk_rel: int -> typ list -> typ list -> term -> term
    77.9 +  val build_map: Proof.context -> (typ * typ -> term) -> typ * typ -> term
   77.10 +  val build_rel: Proof.context -> (typ * typ -> term) -> typ * typ -> term
   77.11 +  val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list
   77.12 +  val map_flattened_map_args: Proof.context -> string -> (term list -> 'a list) -> term list ->
   77.13 +    'a list
   77.14 +
   77.15    val mk_witness: int list * term -> thm list -> nonemptiness_witness
   77.16    val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
   77.17    val wits_of_bnf: bnf -> nonemptiness_witness list
   77.18  
   77.19    val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list
   77.20  
   77.21 -  val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list
   77.22 -
   77.23    datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
   77.24    datatype fact_policy = Dont_Note | Note_Some | Note_All
   77.25  
   77.26 @@ -95,11 +101,20 @@
   77.27      Proof.context
   77.28  
   77.29    val print_bnfs: Proof.context -> unit
   77.30 +  val prepare_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
   77.31 +    (Proof.context -> 'a -> typ) -> (Proof.context -> 'b -> term) -> typ list option ->
   77.32 +    binding -> binding -> binding list ->
   77.33 +    (((((binding * 'a) * 'b) * 'b list) * 'b) * 'b list) * 'b option -> Proof.context ->
   77.34 +    string * term list *
   77.35 +    ((thm list -> {context: Proof.context, prems: thm list} -> tactic) option * term list list) *
   77.36 +    ((thm list -> thm list list) -> thm list list -> Proof.context -> bnf * local_theory) *
   77.37 +    local_theory * thm list
   77.38 +
   77.39    val bnf_def: const_policy -> (Proof.context -> fact_policy) -> (binding -> binding) ->
   77.40      ({prems: thm list, context: Proof.context} -> tactic) list ->
   77.41      ({prems: thm list, context: Proof.context} -> tactic) -> typ list option -> binding ->
   77.42      binding -> binding list ->
   77.43 -    ((((binding * term) * term list) * term) * term list) * term option ->
   77.44 +    (((((binding * typ) * term) * term list) * term) * term list) * term option ->
   77.45      local_theory -> bnf * local_theory
   77.46  end;
   77.47  
   77.48 @@ -110,7 +125,7 @@
   77.49  open BNF_Tactics
   77.50  open BNF_Def_Tactics
   77.51  
   77.52 -val fundef_cong_attrs = @{attributes [fundef_cong]};
   77.53 +val fundefcong_attrs = @{attributes [fundef_cong]};
   77.54  
   77.55  type axioms = {
   77.56    map_id0: thm,
   77.57 @@ -447,7 +462,6 @@
   77.58    #> Option.map (morph_bnf (Morphism.thm_morphism (Thm.transfer (Proof_Context.theory_of ctxt))));
   77.59  
   77.60  
   77.61 -
   77.62  (* Utilities *)
   77.63  
   77.64  fun normalize_set insts instA set =
   77.65 @@ -487,6 +501,46 @@
   77.66         else minimize ((I, wit) :: done) todo;
   77.67   in minimize [] wits end;
   77.68  
   77.69 +fun mk_map live Ts Us t =
   77.70 +  let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
   77.71 +    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   77.72 +  end;
   77.73 +
   77.74 +fun mk_rel live Ts Us t =
   77.75 +  let val [Type (_, Ts0), Type (_, Us0)] = binder_types (snd (strip_typeN live (fastype_of t))) in
   77.76 +    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   77.77 +  end;
   77.78 +
   77.79 +fun build_map_or_rel mk const of_bnf dest ctxt build_simple =
   77.80 +  let
   77.81 +    fun build (TU as (T, U)) =
   77.82 +      if T = U then
   77.83 +        const T
   77.84 +      else
   77.85 +        (case TU of
   77.86 +          (Type (s, Ts), Type (s', Us)) =>
   77.87 +          if s = s' then
   77.88 +            let
   77.89 +              val bnf = the (bnf_of ctxt s);
   77.90 +              val live = live_of_bnf bnf;
   77.91 +              val mapx = mk live Ts Us (of_bnf bnf);
   77.92 +              val TUs' = map dest (fst (strip_typeN live (fastype_of mapx)));
   77.93 +            in Term.list_comb (mapx, map build TUs') end
   77.94 +          else
   77.95 +            build_simple TU
   77.96 +        | _ => build_simple TU);
   77.97 +  in build end;
   77.98 +
   77.99 +val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT;
  77.100 +val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T;
  77.101 +
  77.102 +fun map_flattened_map_args ctxt s map_args fs =
  77.103 +  let
  77.104 +    val flat_fs = flatten_type_args_of_bnf (the (bnf_of ctxt s)) Term.dummy fs;
  77.105 +    val flat_fs' = map_args flat_fs;
  77.106 +  in
  77.107 +    permute_like (op aconv) flat_fs fs flat_fs'
  77.108 +  end;
  77.109  
  77.110  
  77.111  (* Names *)
  77.112 @@ -525,8 +579,8 @@
  77.113  val rel_conversepN = "rel_conversep";
  77.114  val rel_monoN = "rel_mono"
  77.115  val rel_mono_strongN = "rel_mono_strong"
  77.116 -val rel_OON = "rel_compp";
  77.117 -val rel_OO_GrpN = "rel_compp_Grp";
  77.118 +val rel_comppN = "rel_compp";
  77.119 +val rel_compp_GrpN = "rel_compp_Grp";
  77.120  
  77.121  datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
  77.122  
  77.123 @@ -582,16 +636,16 @@
  77.124            val notes =
  77.125              [(map_compN, [Lazy.force (#map_comp facts)], []),
  77.126              (map_cong0N, [#map_cong0 axioms], []),
  77.127 -            (map_congN, [Lazy.force (#map_cong facts)], fundef_cong_attrs),
  77.128 +            (map_congN, [Lazy.force (#map_cong facts)], fundefcong_attrs),
  77.129              (map_idN, [Lazy.force (#map_id facts)], []),
  77.130 +            (rel_comppN, [Lazy.force (#rel_OO facts)], []),
  77.131 +            (rel_compp_GrpN, no_refl [#rel_OO_Grp axioms], []),
  77.132 +            (rel_conversepN, [Lazy.force (#rel_conversep facts)], []),
  77.133              (rel_eqN, [Lazy.force (#rel_eq facts)], []),
  77.134              (rel_flipN, [Lazy.force (#rel_flip facts)], []),
  77.135 -            (set_mapN, map Lazy.force (#set_map facts), []),
  77.136 -            (rel_OO_GrpN, no_refl [#rel_OO_Grp axioms], []),
  77.137              (rel_GrpN, [Lazy.force (#rel_Grp facts)], []),
  77.138 -            (rel_conversepN, [Lazy.force (#rel_conversep facts)], []),
  77.139              (rel_monoN, [Lazy.force (#rel_mono facts)], []),
  77.140 -            (rel_OON, [Lazy.force (#rel_OO facts)], [])]
  77.141 +            (set_mapN, map Lazy.force (#set_map facts), [])]
  77.142              |> filter_out (null o #2)
  77.143              |> map (fn (thmN, thms, attrs) =>
  77.144                ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)),
  77.145 @@ -606,20 +660,18 @@
  77.146  
  77.147  (* Define new BNFs *)
  77.148  
  77.149 -fun prepare_def const_policy mk_fact_policy qualify prep_term Ds_opt map_b rel_b set_bs
  77.150 -  (((((raw_bnf_b, raw_map), raw_sets), raw_bd_Abs), raw_wits), raw_rel_opt) no_defs_lthy =
  77.151 +fun prepare_def const_policy mk_fact_policy qualify prep_typ prep_term Ds_opt map_b rel_b set_bs
  77.152 +  ((((((raw_bnf_b, raw_bnf_T), raw_map), raw_sets), raw_bd), raw_wits), raw_rel_opt)
  77.153 +  no_defs_lthy =
  77.154    let
  77.155      val fact_policy = mk_fact_policy no_defs_lthy;
  77.156      val bnf_b = qualify raw_bnf_b;
  77.157      val live = length raw_sets;
  77.158 -    val nwits = length raw_wits;
  77.159  
  77.160 +    val T_rhs = prep_typ no_defs_lthy raw_bnf_T;
  77.161      val map_rhs = prep_term no_defs_lthy raw_map;
  77.162      val set_rhss = map (prep_term no_defs_lthy) raw_sets;
  77.163 -    val (bd_rhsT, bd_rhs) = (case prep_term no_defs_lthy raw_bd_Abs of
  77.164 -      Abs (_, T, t) => (T, t)
  77.165 -    | _ => error "Bad bound constant");
  77.166 -    val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
  77.167 +    val bd_rhs = prep_term no_defs_lthy raw_bd;
  77.168  
  77.169      fun err T =
  77.170        error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
  77.171 @@ -627,15 +679,15 @@
  77.172  
  77.173      val (bnf_b, key) =
  77.174        if Binding.eq_name (bnf_b, Binding.empty) then
  77.175 -        (case bd_rhsT of
  77.176 +        (case T_rhs of
  77.177            Type (C, Ts) => if forall (can dest_TFree) Ts
  77.178 -            then (Binding.qualified_name C, C) else err bd_rhsT
  77.179 +            then (Binding.qualified_name C, C) else err T_rhs
  77.180          | T => err T)
  77.181        else (bnf_b, Local_Theory.full_name no_defs_lthy bnf_b);
  77.182  
  77.183 -    val def_qualify = Binding.qualify false (Binding.name_of bnf_b);
  77.184 +    val def_qualify = Binding.conceal o Binding.qualify false (Binding.name_of bnf_b);
  77.185  
  77.186 -    fun mk_suffix_binding suf = Binding.suffix_name ("_" ^ suf) bnf_b;
  77.187 +    fun mk_prefix_binding pre = Binding.prefix_name (pre ^ "_") bnf_b;
  77.188  
  77.189      fun maybe_define user_specified (b, rhs) lthy =
  77.190        let
  77.191 @@ -660,7 +712,7 @@
  77.192        lthy |> not (pointer_eq (lthy_old, lthy)) ? Local_Theory.restore;
  77.193  
  77.194      val map_bind_def =
  77.195 -      (fn () => def_qualify (if Binding.is_empty map_b then mk_suffix_binding mapN else map_b),
  77.196 +      (fn () => def_qualify (if Binding.is_empty map_b then mk_prefix_binding mapN else map_b),
  77.197           map_rhs);
  77.198      val set_binds_defs =
  77.199        let
  77.200 @@ -668,25 +720,18 @@
  77.201            (case try (nth set_bs) (i - 1) of
  77.202              SOME b => if Binding.is_empty b then get_b else K b
  77.203            | NONE => get_b) #> def_qualify;
  77.204 -        val bs = if live = 1 then [set_name 1 (fn () => mk_suffix_binding setN)]
  77.205 -          else map (fn i => set_name i (fn () => mk_suffix_binding (mk_setN i))) (1 upto live);
  77.206 +        val bs = if live = 1 then [set_name 1 (fn () => mk_prefix_binding setN)]
  77.207 +          else map (fn i => set_name i (fn () => mk_prefix_binding (mk_setN i))) (1 upto live);
  77.208        in bs ~~ set_rhss end;
  77.209 -    val bd_bind_def = (fn () => def_qualify (mk_suffix_binding bdN), bd_rhs);
  77.210 -    val wit_binds_defs =
  77.211 -      let
  77.212 -        val bs = if nwits = 1 then [fn () => def_qualify (mk_suffix_binding witN)]
  77.213 -          else map (fn i => fn () => def_qualify (mk_suffix_binding (mk_witN i))) (1 upto nwits);
  77.214 -      in bs ~~ wit_rhss end;
  77.215 +    val bd_bind_def = (fn () => def_qualify (mk_prefix_binding bdN), bd_rhs);
  77.216  
  77.217 -    val (((((bnf_map_term, raw_map_def),
  77.218 +    val ((((bnf_map_term, raw_map_def),
  77.219        (bnf_set_terms, raw_set_defs)),
  77.220 -      (bnf_bd_term, raw_bd_def)),
  77.221 -      (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
  77.222 +      (bnf_bd_term, raw_bd_def)), (lthy, lthy_old)) =
  77.223          no_defs_lthy
  77.224          |> maybe_define true map_bind_def
  77.225          ||>> apfst split_list o fold_map (maybe_define true) set_binds_defs
  77.226          ||>> maybe_define true bd_bind_def
  77.227 -        ||>> apfst split_list o fold_map (maybe_define true) wit_binds_defs
  77.228          ||> `(maybe_restore no_defs_lthy);
  77.229  
  77.230      val phi = Proof_Context.export_morphism lthy_old lthy;
  77.231 @@ -694,7 +739,6 @@
  77.232      val bnf_map_def = Morphism.thm phi raw_map_def;
  77.233      val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
  77.234      val bnf_bd_def = Morphism.thm phi raw_bd_def;
  77.235 -    val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
  77.236  
  77.237      val bnf_map = Morphism.term phi bnf_map_term;
  77.238  
  77.239 @@ -709,11 +753,14 @@
  77.240  
  77.241      val CA_params = map TVar (Term.add_tvarsT CA []);
  77.242  
  77.243 +    val bnf_T = Morphism.typ phi T_rhs;
  77.244 +    val bad_args = Term.add_tfreesT bnf_T [];
  77.245 +    val _ = if null bad_args then () else error ("Locally fixed type arguments " ^
  77.246 +      commas_quote (map (Syntax.string_of_typ no_defs_lthy o TFree) bad_args));
  77.247 +
  77.248      val bnf_sets = map2 (normalize_set CA_params) alphas (map (Morphism.term phi) bnf_set_terms);
  77.249 -    val bdT = Morphism.typ phi bd_rhsT;
  77.250      val bnf_bd =
  77.251 -      Term.subst_TVars (Term.add_tvar_namesT bdT [] ~~ CA_params) (Morphism.term phi bnf_bd_term);
  77.252 -    val bnf_wits = map (normalize_wit CA_params CA alphas o Morphism.term phi) bnf_wit_terms;
  77.253 +      Term.subst_TVars (Term.add_tvar_namesT bnf_T [] ~~ CA_params) (Morphism.term phi bnf_bd_term);
  77.254  
  77.255      (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
  77.256      val deads = (case Ds_opt of
  77.257 @@ -770,7 +817,6 @@
  77.258      val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
  77.259      val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
  77.260      val bnf_bd_As = mk_bnf_t As' bnf_bd;
  77.261 -    val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
  77.262  
  77.263      val pre_names_lthy = lthy;
  77.264      val ((((((((((((((((((((((((fs, gs), hs), x), y), zs), ys), As),
  77.265 @@ -824,12 +870,26 @@
  77.266        | SOME raw_rel => prep_term no_defs_lthy raw_rel);
  77.267  
  77.268      val rel_bind_def =
  77.269 -      (fn () => def_qualify (if Binding.is_empty rel_b then mk_suffix_binding relN else rel_b),
  77.270 +      (fn () => def_qualify (if Binding.is_empty rel_b then mk_prefix_binding relN else rel_b),
  77.271           rel_rhs);
  77.272  
  77.273 -    val ((bnf_rel_term, raw_rel_def), (lthy, lthy_old)) =
  77.274 +    val wit_rhss =
  77.275 +      if null raw_wits then
  77.276 +        [fold_rev Term.absdummy As' (Term.list_comb (bnf_map_AsAs,
  77.277 +          map2 (fn T => fn i => Term.absdummy T (Bound i)) As' (live downto 1)) $
  77.278 +          Const (@{const_name undefined}, CA'))]
  77.279 +      else map (prep_term no_defs_lthy) raw_wits;
  77.280 +    val nwits = length wit_rhss;
  77.281 +    val wit_binds_defs =
  77.282 +      let
  77.283 +        val bs = if nwits = 1 then [fn () => def_qualify (mk_prefix_binding witN)]
  77.284 +          else map (fn i => fn () => def_qualify (mk_prefix_binding (mk_witN i))) (1 upto nwits);
  77.285 +      in bs ~~ wit_rhss end;
  77.286 +
  77.287 +    val (((bnf_rel_term, raw_rel_def), (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
  77.288        lthy
  77.289        |> maybe_define (is_some raw_rel_opt) rel_bind_def
  77.290 +      ||>> apfst split_list o fold_map (maybe_define (not (null raw_wits))) wit_binds_defs
  77.291        ||> `(maybe_restore lthy);
  77.292  
  77.293      val phi = Proof_Context.export_morphism lthy_old lthy;
  77.294 @@ -841,11 +901,9 @@
  77.295      val rel = mk_bnf_rel pred2RTs CA' CB';
  77.296      val relAsAs = mk_bnf_rel self_pred2RTs CA' CA';
  77.297  
  77.298 -    val _ = case no_reflexive (raw_map_def :: raw_set_defs @ [raw_bd_def] @
  77.299 -        raw_wit_defs @ [raw_rel_def]) of
  77.300 -        [] => ()
  77.301 -      | defs => Proof_Display.print_consts true lthy_old (K false)
  77.302 -          (map (dest_Free o fst o Logic.dest_equals o prop_of) defs);
  77.303 +    val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
  77.304 +    val bnf_wits = map (normalize_wit CA_params CA alphas o Morphism.term phi) bnf_wit_terms;
  77.305 +    val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
  77.306  
  77.307      val map_id0_goal =
  77.308        let val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As') in
  77.309 @@ -945,11 +1003,14 @@
  77.310          map wit_goal (0 upto live - 1)
  77.311        end;
  77.312  
  77.313 -    val wit_goalss = map mk_wit_goals bnf_wit_As;
  77.314 +    val trivial_wit_tac = mk_trivial_wit_tac bnf_wit_defs;
  77.315  
  77.316 -    fun after_qed thms lthy =
  77.317 +    val wit_goalss =
  77.318 +      (if null raw_wits then SOME trivial_wit_tac else NONE, map mk_wit_goals bnf_wit_As);
  77.319 +
  77.320 +    fun after_qed mk_wit_thms thms lthy =
  77.321        let
  77.322 -        val (axioms, wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
  77.323 +        val (axioms, nontriv_wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
  77.324  
  77.325          val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
  77.326          val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
  77.327 @@ -1022,6 +1083,9 @@
  77.328  
  77.329          val set_map = map (fn thm => Lazy.lazy (fn () => mk_set_map thm)) (#set_map0 axioms);
  77.330  
  77.331 +        val wit_thms =
  77.332 +          if null nontriv_wit_thms then mk_wit_thms (map Lazy.force set_map) else nontriv_wit_thms;
  77.333 +
  77.334          fun mk_in_bd () =
  77.335            let
  77.336              val bdT = fst (dest_relT (fastype_of bnf_bd_As));
  77.337 @@ -1265,35 +1329,45 @@
  77.338    (bnf, Local_Theory.declaration {syntax = false, pervasive = true}
  77.339      (fn phi => Data.map (Symtab.default (key, morph_bnf phi bnf))) lthy);
  77.340  
  77.341 -(* TODO: Once the invariant "nwits > 0" holds, remove "mk_conjunction_balanced'" and "rtac TrueI"
  77.342 -   below *)
  77.343 -fun mk_conjunction_balanced' [] = @{prop True}
  77.344 -  | mk_conjunction_balanced' ts = Logic.mk_conjunction_balanced ts;
  77.345 -
  77.346  fun bnf_def const_policy fact_policy qualify tacs wit_tac Ds map_b rel_b set_bs =
  77.347 -  (fn (_, goals, wit_goalss, after_qed, lthy, one_step_defs) =>
  77.348 +  (fn (_, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, one_step_defs) =>
  77.349    let
  77.350 -    val wits_tac =
  77.351 -      K (TRYALL Goal.conjunction_tac) THEN' K (TRYALL (rtac TrueI)) THEN'
  77.352 -      mk_unfold_thms_then_tac lthy one_step_defs wit_tac;
  77.353 -    val wit_goals = map mk_conjunction_balanced' wit_goalss;
  77.354 -    val wit_thms =
  77.355 -      Goal.prove_sorry lthy [] [] (mk_conjunction_balanced' wit_goals) wits_tac
  77.356 -      |> Conjunction.elim_balanced (length wit_goals)
  77.357 -      |> map2 (Conjunction.elim_balanced o length) wit_goalss
  77.358 -      |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
  77.359 +    fun mk_wits_tac set_maps =
  77.360 +      K (TRYALL Goal.conjunction_tac) THEN'
  77.361 +      (case triv_tac_opt of
  77.362 +        SOME tac => tac set_maps
  77.363 +      | NONE => mk_unfold_thms_then_tac lthy one_step_defs wit_tac);
  77.364 +    val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
  77.365 +    fun mk_wit_thms set_maps =
  77.366 +      Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) (mk_wits_tac set_maps)
  77.367 +        |> Conjunction.elim_balanced (length wit_goals)
  77.368 +        |> map2 (Conjunction.elim_balanced o length) wit_goalss
  77.369 +        |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
  77.370    in
  77.371      map2 (Thm.close_derivation oo Goal.prove_sorry lthy [] [])
  77.372        goals (map (mk_unfold_thms_then_tac lthy one_step_defs) tacs)
  77.373 -    |> (fn thms => after_qed (map single thms @ wit_thms) lthy)
  77.374 -  end) oo prepare_def const_policy fact_policy qualify (K I) Ds map_b rel_b set_bs;
  77.375 +    |> (fn thms => after_qed mk_wit_thms (map single thms) lthy)
  77.376 +  end) oo prepare_def const_policy fact_policy qualify (K I) (K I) Ds map_b rel_b set_bs;
  77.377  
  77.378 -val bnf_cmd = (fn (key, goals, wit_goals, after_qed, lthy, defs) =>
  77.379 -  Proof.unfolding ([[(defs, [])]])
  77.380 -    (Proof.theorem NONE (snd o register_bnf key oo after_qed)
  77.381 -      (map (single o rpair []) goals @ map (map (rpair [])) wit_goals) lthy)) oo
  77.382 -  prepare_def Do_Inline (user_policy Note_Some) I Syntax.read_term NONE Binding.empty Binding.empty
  77.383 -    [];
  77.384 +val bnf_cmd = (fn (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, defs) =>
  77.385 +  let
  77.386 +    val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
  77.387 +    fun mk_triv_wit_thms tac set_maps =
  77.388 +      Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals)
  77.389 +        (K (TRYALL Goal.conjunction_tac) THEN' tac set_maps)
  77.390 +        |> Conjunction.elim_balanced (length wit_goals)
  77.391 +        |> map2 (Conjunction.elim_balanced o length) wit_goalss
  77.392 +        |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
  77.393 +    val (mk_wit_thms, nontriv_wit_goals) = 
  77.394 +      (case triv_tac_opt of
  77.395 +        NONE => (fn _ => [], map (map (rpair [])) wit_goalss)
  77.396 +      | SOME tac => (mk_triv_wit_thms tac, []));
  77.397 +  in
  77.398 +    Proof.unfolding ([[(defs, [])]])
  77.399 +      (Proof.theorem NONE (snd o register_bnf key oo after_qed mk_wit_thms)
  77.400 +        (map (single o rpair []) goals @ nontriv_wit_goals) lthy)
  77.401 +  end) oo prepare_def Do_Inline (user_policy Note_Some) I Syntax.read_typ Syntax.read_term NONE
  77.402 +    Binding.empty Binding.empty [];
  77.403  
  77.404  fun print_bnfs ctxt =
  77.405    let
  77.406 @@ -1328,9 +1402,14 @@
  77.407  val _ =
  77.408    Outer_Syntax.local_theory_to_proof @{command_spec "bnf"}
  77.409      "register a type as a bounded natural functor"
  77.410 -    ((parse_opt_binding_colon -- Parse.term --
  77.411 -       (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) -- Parse.term --
  77.412 -       (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) -- Scan.option Parse.term)
  77.413 +    (parse_opt_binding_colon -- Parse.typ --|
  77.414 +       (Parse.reserved "map" -- @{keyword ":"}) -- Parse.term --
  77.415 +       (Scan.option ((Parse.reserved "sets" -- @{keyword ":"}) |--
  77.416 +         Scan.repeat1 (Scan.unless (Parse.reserved "bd") Parse.term)) >> the_default []) --|
  77.417 +       (Parse.reserved "bd" -- @{keyword ":"}) -- Parse.term --
  77.418 +       (Scan.option ((Parse.reserved "wits" -- @{keyword ":"}) |--
  77.419 +         Scan.repeat1 (Scan.unless (Parse.reserved "rel") Parse.term)) >> the_default []) --
  77.420 +       Scan.option ((Parse.reserved "rel" -- @{keyword ":"}) |-- Parse.term)
  77.421         >> bnf_cmd);
  77.422  
  77.423  end;
    78.1 --- a/src/HOL/BNF/Tools/bnf_def_tactics.ML	Thu Dec 05 17:52:12 2013 +0100
    78.2 +++ b/src/HOL/BNF/Tools/bnf_def_tactics.ML	Thu Dec 05 17:58:03 2013 +0100
    78.3 @@ -31,7 +31,10 @@
    78.4      {prems: thm list, context: Proof.context} -> tactic
    78.5  
    78.6    val mk_in_bd_tac: int -> thm -> thm -> thm -> thm -> thm list -> thm list -> thm -> thm -> thm ->
    78.7 -    thm -> {prems: 'a, context: Proof.context} -> tactic
    78.8 +    thm -> {prems: thm list, context: Proof.context} -> tactic
    78.9 +
   78.10 +  val mk_trivial_wit_tac: thm list -> thm list -> {prems: thm list, context: Proof.context} ->
   78.11 +    tactic
   78.12  end;
   78.13  
   78.14  structure BNF_Def_Tactics : BNF_DEF_TACTICS =
   78.15 @@ -302,4 +305,8 @@
   78.16             map_comp RS sym, map_id])] 1
   78.17    end;
   78.18  
   78.19 +fun mk_trivial_wit_tac wit_defs set_maps {context = ctxt, prems = _} =
   78.20 +  unfold_thms_tac ctxt wit_defs THEN HEADGOAL (EVERY' (map (fn thm =>
   78.21 +    dtac (thm RS equalityD1 RS set_mp) THEN' etac imageE THEN' atac) set_maps)) THEN ALLGOALS atac;
   78.22 +
   78.23  end;
    79.1 --- a/src/HOL/BNF/Tools/bnf_fp_def_sugar.ML	Thu Dec 05 17:52:12 2013 +0100
    79.2 +++ b/src/HOL/BNF/Tools/bnf_fp_def_sugar.ML	Thu Dec 05 17:58:03 2013 +0100
    79.3 @@ -25,7 +25,9 @@
    79.4       sel_co_iterssss: thm list list list list};
    79.5  
    79.6    val of_fp_sugar: (fp_sugar -> 'a list) -> fp_sugar -> 'a
    79.7 +  val eq_fp_sugar: fp_sugar * fp_sugar -> bool
    79.8    val morph_fp_sugar: morphism -> fp_sugar -> fp_sugar
    79.9 +  val transfer_fp_sugar: Proof.context -> fp_sugar -> fp_sugar
   79.10    val fp_sugar_of: Proof.context -> string -> fp_sugar option
   79.11    val fp_sugars_of: Proof.context -> fp_sugar list
   79.12  
   79.13 @@ -39,17 +41,14 @@
   79.14      'a list
   79.15    val mk_co_iter: theory -> BNF_FP_Util.fp_kind -> typ -> typ list -> term -> term
   79.16    val nesty_bnfs: Proof.context -> typ list list list -> typ list -> BNF_Def.bnf list
   79.17 -  val mk_map: int -> typ list -> typ list -> term -> term
   79.18 -  val mk_rel: int -> typ list -> typ list -> term -> term
   79.19 -  val build_map: local_theory -> (typ * typ -> term) -> typ * typ -> term
   79.20 -  val build_rel: local_theory -> (typ * typ -> term) -> typ * typ -> term
   79.21 -  val dest_map: Proof.context -> string -> term -> term * term list
   79.22 -  val dest_ctr: Proof.context -> string -> term -> term * term list
   79.23  
   79.24    type lfp_sugar_thms =
   79.25      (thm list * thm * Args.src list)
   79.26      * (thm list list * thm list list * Args.src list)
   79.27  
   79.28 +  val morph_lfp_sugar_thms: morphism -> lfp_sugar_thms -> lfp_sugar_thms
   79.29 +  val transfer_lfp_sugar_thms: Proof.context -> lfp_sugar_thms -> lfp_sugar_thms
   79.30 +
   79.31    type gfp_sugar_thms =
   79.32      ((thm list * thm) list * Args.src list)
   79.33      * (thm list list * thm list list * Args.src list)
   79.34 @@ -57,6 +56,9 @@
   79.35      * (thm list list * thm list list * Args.src list)
   79.36      * (thm list list list * thm list list list * Args.src list)
   79.37  
   79.38 +  val morph_gfp_sugar_thms: morphism -> gfp_sugar_thms -> gfp_sugar_thms
   79.39 +  val transfer_gfp_sugar_thms: Proof.context -> gfp_sugar_thms -> gfp_sugar_thms
   79.40 +
   79.41    val mk_co_iters_prelims: BNF_FP_Util.fp_kind -> typ list list list -> typ list -> typ list ->
   79.42      int list -> int list list -> term list list -> Proof.context ->
   79.43      (term list list
   79.44 @@ -87,13 +89,14 @@
   79.45      string * term list * term list list * ((term list list * term list list list)
   79.46        * (typ list * typ list list)) list ->
   79.47      thm -> thm list -> thm list -> thm list list -> BNF_Def.bnf list -> typ list -> typ list ->
   79.48 -    int list list -> int list list -> int list -> thm list list -> Ctr_Sugar.ctr_sugar list ->
   79.49 -    term list list -> thm list list -> (thm list -> thm list) -> local_theory -> gfp_sugar_thms
   79.50 +    typ list -> typ list list list -> int list list -> int list list -> int list -> thm list list ->
   79.51 +    Ctr_Sugar.ctr_sugar list -> term list list -> thm list list -> (thm list -> thm list) ->
   79.52 +    local_theory -> gfp_sugar_thms
   79.53    val co_datatypes: BNF_FP_Util.fp_kind -> (mixfix list -> binding list -> binding list ->
   79.54        binding list list -> binding list -> (string * sort) list -> typ list * typ list list ->
   79.55        BNF_Def.bnf list -> local_theory -> BNF_FP_Util.fp_result * local_theory) ->
   79.56 -    (bool * bool) * (((((binding * (typ * sort)) list * binding) * (binding * binding)) * mixfix) *
   79.57 -      ((((binding * binding) * (binding * typ) list) * (binding * term) list) *
   79.58 +    (bool * (bool * bool)) * (((((binding * (typ * sort)) list * binding) * (binding * binding))
   79.59 +      * mixfix) * ((((binding * binding) * (binding * typ) list) * (binding * term) list) *
   79.60          mixfix) list) list ->
   79.61      local_theory -> local_theory
   79.62    val parse_co_datatype_cmd: BNF_FP_Util.fp_kind -> (mixfix list -> binding list -> binding list ->
   79.63 @@ -207,8 +210,8 @@
   79.64  val id_def = @{thm id_def};
   79.65  val mp_conj = @{thm mp_conj};
   79.66  
   79.67 -val nitpick_attrs = @{attributes [nitpick_simp]};
   79.68 -val code_nitpick_simp_attrs = Code.add_default_eqn_attrib :: nitpick_attrs;
   79.69 +val nitpicksimp_attrs = @{attributes [nitpick_simp]};
   79.70 +val code_nitpicksimp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs;
   79.71  val simp_attrs = @{attributes [simp]};
   79.72  
   79.73  fun tvar_subst thy Ts Us =
   79.74 @@ -232,7 +235,9 @@
   79.75    | flat_corec_preds_predsss_gettersss (p :: ps) (qss :: qsss) (fss :: fsss) =
   79.76      p :: flat_corec_predss_getterss qss fss @ flat_corec_preds_predsss_gettersss ps qsss fsss;
   79.77  
   79.78 -fun mk_tupled_fun x f xs = HOLogic.tupled_lambda x (Term.list_comb (f, xs));
   79.79 +fun mk_tupled_fun x f xs =
   79.80 +  if xs = [x] then f else HOLogic.tupled_lambda x (Term.list_comb (f, xs));
   79.81 +
   79.82  fun mk_uncurried2_fun f xss =
   79.83    mk_tupled_fun (HOLogic.mk_tuple (map HOLogic.mk_tuple xss)) f (flat_rec_arg_args xss);
   79.84  
   79.85 @@ -287,66 +292,6 @@
   79.86    | unzip_corecT _ (Type (@{type_name sum}, Ts)) = Ts
   79.87    | unzip_corecT _ T = [T];
   79.88  
   79.89 -fun mk_map live Ts Us t =
   79.90 -  let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
   79.91 -    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   79.92 -  end;
   79.93 -
   79.94 -fun mk_rel live Ts Us t =
   79.95 -  let val [Type (_, Ts0), Type (_, Us0)] = binder_types (snd (strip_typeN live (fastype_of t))) in
   79.96 -    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   79.97 -  end;
   79.98 -
   79.99 -local
  79.100 -
  79.101 -fun build_map_or_rel mk const of_bnf dest lthy build_simple =
  79.102 -  let
  79.103 -    fun build (TU as (T, U)) =
  79.104 -      if T = U then
  79.105 -        const T
  79.106 -      else
  79.107 -        (case TU of
  79.108 -          (Type (s, Ts), Type (s', Us)) =>
  79.109 -          if s = s' then
  79.110 -            let
  79.111 -              val bnf = the (bnf_of lthy s);
  79.112 -              val live = live_of_bnf bnf;
  79.113 -              val mapx = mk live Ts Us (of_bnf bnf);
  79.114 -              val TUs' = map dest (fst (strip_typeN live (fastype_of mapx)));
  79.115 -            in Term.list_comb (mapx, map build TUs') end
  79.116 -          else
  79.117 -            build_simple TU
  79.118 -        | _ => build_simple TU);
  79.119 -  in build end;
  79.120 -
  79.121 -in
  79.122 -
  79.123 -val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT;
  79.124 -val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T;
  79.125 -
  79.126 -end;
  79.127 -
  79.128 -val dummy_var_name = "?f"
  79.129 -
  79.130 -fun mk_map_pattern ctxt s =
  79.131 -  let
  79.132 -    val bnf = the (bnf_of ctxt s);
  79.133 -    val mapx = map_of_bnf bnf;
  79.134 -    val live = live_of_bnf bnf;
  79.135 -    val (f_Ts, _) = strip_typeN live (fastype_of mapx);
  79.136 -    val fs = map_index (fn (i, T) => Var ((dummy_var_name, i), T)) f_Ts;
  79.137 -  in
  79.138 -    (mapx, betapplys (mapx, fs))
  79.139 -  end;
  79.140 -
  79.141 -fun dest_map ctxt s call =
  79.142 -  let
  79.143 -    val (map0, pat) = mk_map_pattern ctxt s;
  79.144 -    val (_, tenv) = fo_match ctxt call pat;
  79.145 -  in
  79.146 -    (map0, Vartab.fold_rev (fn (_, (_, f)) => cons f) tenv [])
  79.147 -  end;
  79.148 -
  79.149  fun liveness_of_fp_bnf n bnf =
  79.150    (case T_of_bnf bnf of
  79.151      Type (_, Ts) => map (not o member (op =) (deads_of_bnf bnf)) Ts
  79.152 @@ -388,12 +333,19 @@
  79.153  fun nesty_bnfs ctxt ctr_Tsss Us =
  79.154    map_filter (bnf_of ctxt) (fold (fold (fold (add_nesty_bnf_names Us))) ctr_Tsss []);
  79.155  
  79.156 -fun indexify proj xs f p = f (find_index (curry op = (proj p)) xs) p;
  79.157 +fun indexify proj xs f p = f (find_index (curry (op =) (proj p)) xs) p;
  79.158  
  79.159  type lfp_sugar_thms =
  79.160    (thm list * thm * Args.src list)
  79.161    * (thm list list * thm list list * Args.src list)
  79.162  
  79.163 +fun morph_lfp_sugar_thms phi ((inducts, induct, induct_attrs), (foldss, recss, iter_attrs)) =
  79.164 +  ((map (Morphism.thm phi) inducts, Morphism.thm phi induct, induct_attrs),
  79.165 +   (map (map (Morphism.thm phi)) foldss, map (map (Morphism.thm phi)) recss, iter_attrs));
  79.166 +
  79.167 +val transfer_lfp_sugar_thms =
  79.168 +  morph_lfp_sugar_thms o Morphism.thm_morphism o Thm.transfer o Proof_Context.theory_of;
  79.169 +
  79.170  type gfp_sugar_thms =
  79.171    ((thm list * thm) list * Args.src list)
  79.172    * (thm list list * thm list list * Args.src list)
  79.173 @@ -401,6 +353,23 @@
  79.174    * (thm list list * thm list list * Args.src list)
  79.175    * (thm list list list * thm list list list * Args.src list);
  79.176  
  79.177 +fun morph_gfp_sugar_thms phi ((coinducts_pairs, coinduct_attrs),
  79.178 +    (unfoldss, corecss, coiter_attrs), (disc_unfoldss, disc_corecss, disc_iter_attrs),
  79.179 +    (disc_unfold_iffss, disc_corec_iffss, disc_iter_iff_attrs),
  79.180 +    (sel_unfoldsss, sel_corecsss, sel_iter_attrs)) =
  79.181 +  ((map (apfst (map (Morphism.thm phi)) o apsnd (Morphism.thm phi)) coinducts_pairs,
  79.182 +    coinduct_attrs),
  79.183 +   (map (map (Morphism.thm phi)) unfoldss, map (map (Morphism.thm phi)) corecss, coiter_attrs),
  79.184 +   (map (map (Morphism.thm phi)) disc_unfoldss, map (map (Morphism.thm phi)) disc_corecss,
  79.185 +    disc_iter_attrs),
  79.186 +   (map (map (Morphism.thm phi)) disc_unfold_iffss, map (map (Morphism.thm phi)) disc_corec_iffss,
  79.187 +    disc_iter_iff_attrs),
  79.188 +   (map (map (map (Morphism.thm phi))) sel_unfoldsss,
  79.189 +    map (map (map (Morphism.thm phi))) sel_corecsss, sel_iter_attrs));
  79.190 +
  79.191 +val transfer_gfp_sugar_thms =
  79.192 +  morph_gfp_sugar_thms o Morphism.thm_morphism o Thm.transfer o Proof_Context.theory_of;
  79.193 +
  79.194  fun mk_iter_fun_arg_types0 n ms = map2 dest_tupleT ms o dest_sumTN_balanced n o domain_type;
  79.195  
  79.196  fun mk_iter_fun_arg_types ctr_Tsss ns mss =
  79.197 @@ -430,7 +399,7 @@
  79.198          ns mss ctr_Tsss ctor_iter_fun_Tss;
  79.199  
  79.200      val z_Tsss' = map (map flat_rec_arg_args) z_Tssss;
  79.201 -    val h_Tss = map2 (map2 (curry op --->)) z_Tsss' Css;
  79.202 +    val h_Tss = map2 (map2 (curry (op --->))) z_Tsss' Css;
  79.203  
  79.204      val hss = map2 (map2 retype_free) h_Tss gss;
  79.205      val zssss_hd = map2 (map2 (map2 (retype_free o hd))) z_Tssss ysss;
  79.206 @@ -452,7 +421,7 @@
  79.207      val f_sum_prod_Ts = map range_type fun_Ts;
  79.208      val f_prod_Tss = map2 dest_sumTN_balanced ns f_sum_prod_Ts;
  79.209      val f_Tsss = map2 (map2 (dest_tupleT o length)) ctr_Tsss' f_prod_Tss;
  79.210 -    val f_Tssss = map3 (fn C => map2 (map2 (map (curry op --> C) oo unzip_corecT)))
  79.211 +    val f_Tssss = map3 (fn C => map2 (map2 (map (curry (op -->) C) oo unzip_corecT)))
  79.212        Cs ctr_Tsss' f_Tsss;
  79.213      val q_Tssss = map (map (map (fn [_] => [] | [_, T] => [mk_pred1T (domain_type T)]))) f_Tssss;
  79.214    in
  79.215 @@ -536,18 +505,12 @@
  79.216      ((xtor_co_iterss, iters_args_types, coiters_args_types), lthy')
  79.217    end;
  79.218  
  79.219 -fun mk_iter_body ctor_iter fss xssss =
  79.220 -  Term.list_comb (ctor_iter, map2 (mk_sum_caseN_balanced oo map2 mk_uncurried2_fun) fss xssss);
  79.221 -
  79.222  fun mk_preds_getterss_join c cps sum_prod_T cqfss =
  79.223    let val n = length cqfss in
  79.224      Term.lambda c (mk_IfN sum_prod_T cps
  79.225        (map2 (mk_InN_balanced sum_prod_T n) (map HOLogic.mk_tuple cqfss) (1 upto n)))
  79.226    end;
  79.227  
  79.228 -fun mk_coiter_body cs cpss f_sum_prod_Ts cqfsss dtor_coiter =
  79.229 -  Term.list_comb (dtor_coiter, map4 mk_preds_getterss_join cs cpss f_sum_prod_Ts cqfsss);
  79.230 -
  79.231  fun define_co_iters fp fpT Cs binding_specs lthy0 =
  79.232    let
  79.233      val thy = Proof_Context.theory_of lthy0;
  79.234 @@ -556,8 +519,8 @@
  79.235        #> Config.get lthy0 bnf_note_all = false ? Binding.conceal;
  79.236  
  79.237      val ((csts, defs), (lthy', lthy)) = lthy0
  79.238 -      |> apfst split_list o fold_map (fn (b, spec) =>
  79.239 -        Specification.definition (SOME (b, NONE, NoSyn), ((maybe_conceal_def_binding b, []), spec))
  79.240 +      |> apfst split_list o fold_map (fn (b, rhs) =>
  79.241 +        Local_Theory.define ((b, NoSyn), ((maybe_conceal_def_binding b, []), rhs))
  79.242          #>> apsnd snd) binding_specs
  79.243        ||> `Local_Theory.restore;
  79.244  
  79.245 @@ -575,14 +538,10 @@
  79.246  
  79.247      val fpT_to_C as Type (_, [fpT, _]) = snd (strip_typeN nn (fastype_of (hd ctor_iters)));
  79.248  
  79.249 -    fun generate_iter suf (f_Tss, _, fss, xssss) ctor_iter =
  79.250 -      let
  79.251 -        val res_T = fold_rev (curry op --->) f_Tss fpT_to_C;
  79.252 -        val b = mk_binding suf;
  79.253 -        val spec =
  79.254 -          mk_Trueprop_eq (lists_bmoc fss (Free (Binding.name_of b, res_T)),
  79.255 -            mk_iter_body ctor_iter fss xssss);
  79.256 -      in (b, spec) end;
  79.257 +    fun generate_iter pre (_, _, fss, xssss) ctor_iter =
  79.258 +      (mk_binding pre,
  79.259 +       fold_rev (fold_rev Term.lambda) fss (Term.list_comb (ctor_iter,
  79.260 +         map2 (mk_sum_caseN_balanced oo map2 mk_uncurried2_fun) fss xssss)));
  79.261    in
  79.262      define_co_iters Least_FP fpT Cs (map3 generate_iter iterNs iter_args_typess' ctor_iters) lthy
  79.263    end;
  79.264 @@ -594,14 +553,10 @@
  79.265  
  79.266      val C_to_fpT as Type (_, [_, fpT]) = snd (strip_typeN nn (fastype_of (hd dtor_coiters)));
  79.267  
  79.268 -    fun generate_coiter suf ((pfss, cqfsss), (f_sum_prod_Ts, pf_Tss)) dtor_coiter =
  79.269 -      let
  79.270 -        val res_T = fold_rev (curry op --->) pf_Tss C_to_fpT;
  79.271 -        val b = mk_binding suf;
  79.272 -        val spec =
  79.273 -          mk_Trueprop_eq (lists_bmoc pfss (Free (Binding.name_of b, res_T)),
  79.274 -            mk_coiter_body cs cpss f_sum_prod_Ts cqfsss dtor_coiter);
  79.275 -      in (b, spec) end;
  79.276 +    fun generate_coiter pre ((pfss, cqfsss), (f_sum_prod_Ts, pf_Tss)) dtor_coiter =
  79.277 +      (mk_binding pre,
  79.278 +       fold_rev (fold_rev Term.lambda) pfss (Term.list_comb (dtor_coiter,
  79.279 +         map4 mk_preds_getterss_join cs cpss f_sum_prod_Ts cqfsss)));
  79.280    in
  79.281      define_co_iters Greatest_FP fpT Cs
  79.282        (map3 generate_coiter coiterNs coiter_args_typess' dtor_coiters) lthy
  79.283 @@ -645,7 +600,7 @@
  79.284          val lives = lives_of_bnf bnf;
  79.285          val sets = sets_of_bnf bnf;
  79.286          fun mk_set U =
  79.287 -          (case find_index (curry op = U) lives of
  79.288 +          (case find_index (curry (op =) U) lives of
  79.289              ~1 => Term.dummy
  79.290            | i => nth sets i);
  79.291        in
  79.292 @@ -662,7 +617,7 @@
  79.293            end;
  79.294  
  79.295          fun mk_raw_prem_prems _ (x as Free (_, Type _)) (X as TFree _) =
  79.296 -            [([], (find_index (curry op = X) Xs + 1, x))]
  79.297 +            [([], (find_index (curry (op =) X) Xs + 1, x))]
  79.298            | mk_raw_prem_prems names_lthy (x as Free (s, Type (T_name, Ts0))) (Type (_, Xs_Ts0)) =
  79.299              (case AList.lookup (op =) setss_nested T_name of
  79.300                NONE => []
  79.301 @@ -702,7 +657,7 @@
  79.302  
  79.303          val goal =
  79.304            Library.foldr (Logic.list_implies o apfst (map mk_prem)) (raw_premss,
  79.305 -            HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry op $) ps us)));
  79.306 +            HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry (op $)) ps us)));
  79.307  
  79.308          val kksss = map (map (map (fst o snd) o #2)) raw_premss;
  79.309  
  79.310 @@ -763,13 +718,13 @@
  79.311      val rec_thmss = mk_iter_thmss rec_args_types recs rec_defs (map co_rec_of ctor_iter_thmss);
  79.312    in
  79.313      ((induct_thms, induct_thm, [induct_case_names_attr]),
  79.314 -     (fold_thmss, rec_thmss, code_nitpick_simp_attrs @ simp_attrs))
  79.315 +     (fold_thmss, rec_thmss, code_nitpicksimp_attrs @ simp_attrs))
  79.316    end;
  79.317  
  79.318  fun derive_coinduct_coiters_thms_for_types pre_bnfs (z, cs, cpss,
  79.319        coiters_args_types as [((pgss, crgsss), _), ((phss, cshsss), _)])
  79.320 -    dtor_coinduct dtor_injects dtor_ctors dtor_coiter_thmss nesting_bnfs fpTs Cs kss mss ns
  79.321 -    ctr_defss (ctr_sugars : ctr_sugar list) coiterss coiter_defss export_args lthy =
  79.322 +    dtor_coinduct dtor_injects dtor_ctors dtor_coiter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss
  79.323 +    mss ns ctr_defss (ctr_sugars : ctr_sugar list) coiterss coiter_defss export_args lthy =
  79.324    let
  79.325      fun mk_ctor_dtor_coiter_thm dtor_inject dtor_ctor coiter =
  79.326        iffD1 OF [dtor_inject, trans OF [coiter, dtor_ctor RS sym]];
  79.327 @@ -821,40 +776,29 @@
  79.328            map4 (fn u => fn v => fn uvr => fn uv_eq =>
  79.329              fold_rev Term.lambda [u, v] (HOLogic.mk_disj (uvr, uv_eq))) us vs uvrs uv_eqs;
  79.330  
  79.331 -        (* TODO: generalize (cf. "build_map") *)
  79.332 -        fun build_rel rs' T =
  79.333 -          (case find_index (curry op = T) fpTs of
  79.334 -            ~1 =>
  79.335 -            if exists_subtype_in fpTs T then
  79.336 -              let
  79.337 -                val Type (s, Ts) = T
  79.338 -                val bnf = the (bnf_of lthy s);
  79.339 -                val live = live_of_bnf bnf;
  79.340 -                val rel = mk_rel live Ts Ts (rel_of_bnf bnf);
  79.341 -                val Ts' = map domain_type (fst (strip_typeN live (fastype_of rel)));
  79.342 -              in Term.list_comb (rel, map (build_rel rs') Ts') end
  79.343 -            else
  79.344 -              HOLogic.eq_const T
  79.345 -          | kk => nth rs' kk);
  79.346 +        fun build_the_rel rs' T Xs_T =
  79.347 +          build_rel lthy (fn (_, X) => nth rs' (find_index (curry (op =) X) Xs)) (T, Xs_T)
  79.348 +          |> Term.subst_atomic_types (Xs ~~ fpTs);
  79.349  
  79.350 -        fun build_rel_app rs' usel vsel = fold rapp [usel, vsel] (build_rel rs' (fastype_of usel));
  79.351 +        fun build_rel_app rs' usel vsel Xs_T =
  79.352 +          fold rapp [usel, vsel] (build_the_rel rs' (fastype_of usel) Xs_T);
  79.353  
  79.354 -        fun mk_prem_ctr_concls rs' n k udisc usels vdisc vsels =
  79.355 +        fun mk_prem_ctr_concls rs' n k udisc usels vdisc vsels ctrXs_Ts =
  79.356            (if k = n then [] else [HOLogic.mk_eq (udisc, vdisc)]) @
  79.357            (if null usels then
  79.358               []
  79.359             else
  79.360               [Library.foldr HOLogic.mk_imp (if n = 1 then [] else [udisc, vdisc],
  79.361 -                Library.foldr1 HOLogic.mk_conj (map2 (build_rel_app rs') usels vsels))]);
  79.362 +                Library.foldr1 HOLogic.mk_conj (map3 (build_rel_app rs') usels vsels ctrXs_Ts))]);
  79.363  
  79.364 -        fun mk_prem_concl rs' n udiscs uselss vdiscs vselss =
  79.365 -          Library.foldr1 HOLogic.mk_conj
  79.366 -            (flat (map5 (mk_prem_ctr_concls rs' n) (1 upto n) udiscs uselss vdiscs vselss))
  79.367 +        fun mk_prem_concl rs' n udiscs uselss vdiscs vselss ctrXs_Tss =
  79.368 +          Library.foldr1 HOLogic.mk_conj (flat (map6 (mk_prem_ctr_concls rs' n)
  79.369 +            (1 upto n) udiscs uselss vdiscs vselss ctrXs_Tss))
  79.370            handle List.Empty => @{term True};
  79.371  
  79.372 -        fun mk_prem rs' uvr u v n udiscs uselss vdiscs vselss =
  79.373 +        fun mk_prem rs' uvr u v n udiscs uselss vdiscs vselss ctrXs_Tss =
  79.374            fold_rev Logic.all [u, v] (Logic.mk_implies (HOLogic.mk_Trueprop uvr,
  79.375 -            HOLogic.mk_Trueprop (mk_prem_concl rs' n udiscs uselss vdiscs vselss)));
  79.376 +            HOLogic.mk_Trueprop (mk_prem_concl rs' n udiscs uselss vdiscs vselss ctrXs_Tss)));
  79.377  
  79.378          val concl =
  79.379            HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
  79.380 @@ -862,8 +806,8 @@
  79.381                 uvrs us vs));
  79.382  
  79.383          fun mk_goal rs' =
  79.384 -          Logic.list_implies (map8 (mk_prem rs') uvrs us vs ns udiscss uselsss vdiscss vselsss,
  79.385 -            concl);
  79.386 +          Logic.list_implies (map9 (mk_prem rs') uvrs us vs ns udiscss uselsss vdiscss vselsss
  79.387 +            ctrXs_Tsss, concl);
  79.388  
  79.389          val goals = map mk_goal [rs, strong_rs];
  79.390  
  79.391 @@ -1024,14 +968,14 @@
  79.392        coinduct_consumes_attr :: coinduct_case_names_attr :: coinduct_case_concl_attrs;
  79.393    in
  79.394      ((coinduct_thms_pairs, coinduct_case_attrs),
  79.395 -     (unfold_thmss, corec_thmss, code_nitpick_simp_attrs),
  79.396 +     (unfold_thmss, corec_thmss, code_nitpicksimp_attrs),
  79.397       (disc_unfold_thmss, disc_corec_thmss, []),
  79.398       (disc_unfold_iff_thmss, disc_corec_iff_thmss, simp_attrs),
  79.399       (sel_unfold_thmsss, sel_corec_thmsss, simp_attrs))
  79.400    end;
  79.401  
  79.402  fun define_co_datatypes prepare_constraint prepare_typ prepare_term fp construct_fp
  79.403 -    (wrap_opts as (no_discs_sels, rep_compat), specs) no_defs_lthy0 =
  79.404 +    (wrap_opts as (no_discs_sels, (_, rep_compat)), specs) no_defs_lthy0 =
  79.405    let
  79.406      (* TODO: sanity checks on arguments *)
  79.407  
  79.408 @@ -1074,7 +1018,7 @@
  79.409  
  79.410      val qsoty = quote o Syntax.string_of_typ fake_lthy;
  79.411  
  79.412 -    val _ = (case duplicates (op =) unsorted_As of [] => ()
  79.413 +    val _ = (case Library.duplicates (op =) unsorted_As of [] => ()
  79.414        | A :: _ => error ("Duplicate type parameter " ^ qsoty A ^ " in " ^ co_prefix fp ^
  79.415            "datatype specification"));
  79.416  
  79.417 @@ -1087,7 +1031,7 @@
  79.418  
  79.419      val mixfixes = map mixfix_of specs;
  79.420  
  79.421 -    val _ = (case duplicates Binding.eq_name fp_bs of [] => ()
  79.422 +    val _ = (case Library.duplicates Binding.eq_name fp_bs of [] => ()
  79.423        | b :: _ => error ("Duplicate type name declaration " ^ quote (Binding.name_of b)));
  79.424  
  79.425      val ctr_specss = map ctr_specs_of specs;
  79.426 @@ -1380,18 +1324,25 @@
  79.427                val (rel_distinct_thms, _) =
  79.428                  join_halves n half_rel_distinct_thmss other_half_rel_distinct_thmss;
  79.429  
  79.430 +              val anonymous_notes =
  79.431 +                [(map (fn th => th RS @{thm eq_False[THEN iffD2]}) rel_distinct_thms,
  79.432 +                  code_nitpicksimp_attrs),
  79.433 +                 (map2 (fn th => fn 0 => th RS @{thm eq_True[THEN iffD2]} | _ => th)
  79.434 +                    rel_inject_thms ms, code_nitpicksimp_attrs)]
  79.435 +                |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
  79.436 +
  79.437                val notes =
  79.438 -                [(mapN, map_thms, code_nitpick_simp_attrs @ simp_attrs),
  79.439 -                 (rel_distinctN, rel_distinct_thms, code_nitpick_simp_attrs @ simp_attrs),
  79.440 -                 (rel_injectN, rel_inject_thms, code_nitpick_simp_attrs @ simp_attrs),
  79.441 -                 (setN, flat set_thmss, code_nitpick_simp_attrs @ simp_attrs)]
  79.442 +                [(mapN, map_thms, code_nitpicksimp_attrs @ simp_attrs),
  79.443 +                 (rel_distinctN, rel_distinct_thms, simp_attrs),
  79.444 +                 (rel_injectN, rel_inject_thms, simp_attrs),
  79.445 +                 (setN, flat set_thmss, code_nitpicksimp_attrs @ simp_attrs)]
  79.446                  |> massage_simple_notes fp_b_name;
  79.447              in
  79.448                (((map_thms, rel_inject_thms, rel_distinct_thms, set_thmss), ctr_sugar),
  79.449 -               lthy |> Local_Theory.notes notes |> snd)
  79.450 +               lthy |> Local_Theory.notes (anonymous_notes @ notes) |> snd)
  79.451              end;
  79.452  
  79.453 -        fun mk_binding suf = qualify false fp_b_name (Binding.suffix_name ("_" ^ suf) fp_b);
  79.454 +        fun mk_binding pre = qualify false fp_b_name (Binding.prefix_name (pre ^ "_") fp_b);
  79.455  
  79.456          fun massage_res (((maps_sets_rels, ctr_sugar), co_iter_res), lthy) =
  79.457            (((maps_sets_rels, (ctrs, xss, ctr_defs, ctr_sugar)), co_iter_res), lthy);
  79.458 @@ -1457,8 +1408,9 @@
  79.459               (disc_unfold_iff_thmss, disc_corec_iff_thmss, disc_coiter_iff_attrs),
  79.460               (sel_unfold_thmsss, sel_corec_thmsss, sel_coiter_attrs)) =
  79.461            derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
  79.462 -            dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs kss mss ns ctr_defss
  79.463 -            ctr_sugars coiterss coiter_defss (Proof_Context.export lthy' no_defs_lthy) lthy;
  79.464 +            dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss ns
  79.465 +            ctr_defss ctr_sugars coiterss coiter_defss (Proof_Context.export lthy' no_defs_lthy)
  79.466 +            lthy;
  79.467  
  79.468          val sel_unfold_thmss = map flat sel_unfold_thmsss;
  79.469          val sel_corec_thmss = map flat sel_corec_thmsss;
  79.470 @@ -1496,6 +1448,12 @@
  79.471             (unfoldN, unfold_thmss, K coiter_attrs)]
  79.472            |> massage_multi_notes;
  79.473  
  79.474 +        fun is_codatatype (Type (s, _)) =
  79.475 +            (case fp_sugar_of lthy s of SOME {fp = Greatest_FP, ...} => true | _ => false)
  79.476 +          | is_codatatype _ = false;
  79.477 +
  79.478 +        val nitpick_supported = forall (is_codatatype o T_of_bnf) nested_bnfs;
  79.479 +
  79.480          fun register_nitpick fpT ({ctrs, casex, ...} : ctr_sugar) =
  79.481            Nitpick_HOL.register_codatatype fpT (fst (dest_Const casex))
  79.482              (map (dest_Const o mk_ctr As) ctrs)
  79.483 @@ -1507,7 +1465,7 @@
  79.484            ctr_sugars coiterss mapss [coinduct_thm, strong_coinduct_thm]
  79.485            (transpose [unfold_thmss, corec_thmss]) (transpose [disc_unfold_thmss, disc_corec_thmss])
  79.486            (transpose [sel_unfold_thmsss, sel_corec_thmsss])
  79.487 -        |> fold2 register_nitpick fpTs ctr_sugars
  79.488 +        |> nitpick_supported ? fold2 register_nitpick fpTs ctr_sugars
  79.489        end;
  79.490  
  79.491      val lthy'' = lthy'
  79.492 @@ -1543,24 +1501,13 @@
  79.493  
  79.494  val parse_type_arg_named_constrained = parse_opt_binding_colon -- parse_type_arg_constrained;
  79.495  
  79.496 +(*FIXME: use parse_type_args_named_constrained from BNF_Util and thus 
  79.497 +  allow users to kill certain arguments of a (co)datatype*)
  79.498  val parse_type_args_named_constrained =
  79.499    parse_type_arg_constrained >> (single o pair Binding.empty) ||
  79.500    @{keyword "("} |-- Parse.!!! (Parse.list1 parse_type_arg_named_constrained --| @{keyword ")"}) ||
  79.501    Scan.succeed [];
  79.502  
  79.503 -val parse_map_rel_binding = Parse.short_ident --| @{keyword ":"} -- parse_binding;
  79.504 -
  79.505 -val no_map_rel = (Binding.empty, Binding.empty);
  79.506 -
  79.507 -fun extract_map_rel ("map", b) = apfst (K b)
  79.508 -  | extract_map_rel ("rel", b) = apsnd (K b)
  79.509 -  | extract_map_rel (s, _) = error ("Unknown label " ^ quote s ^ " (expected \"map\" or \"rel\")");
  79.510 -
  79.511 -val parse_map_rel_bindings =
  79.512 -  @{keyword "("} |-- Scan.repeat parse_map_rel_binding --| @{keyword ")"}
  79.513 -    >> (fn ps => fold extract_map_rel ps no_map_rel) ||
  79.514 -  Scan.succeed no_map_rel;
  79.515 -
  79.516  val parse_ctr_spec =
  79.517    parse_opt_binding_colon -- parse_binding -- Scan.repeat parse_ctr_arg --
  79.518    Scan.optional parse_defaults [] -- Parse.opt_mixfix;
    80.1 --- a/src/HOL/BNF/Tools/bnf_fp_def_sugar_tactics.ML	Thu Dec 05 17:52:12 2013 +0100
    80.2 +++ b/src/HOL/BNF/Tools/bnf_fp_def_sugar_tactics.ML	Thu Dec 05 17:58:03 2013 +0100
    80.3 @@ -151,12 +151,17 @@
    80.4    (atac ORELSE' REPEAT o etac conjE THEN'
    80.5       full_simp_tac
    80.6         (ss_only (@{thm prod.inject} :: no_refl discs @ rel_eqs @ more_simp_thms) ctxt) THEN'
    80.7 -     REPEAT o etac conjE THEN_MAYBE' REPEAT o hyp_subst_tac ctxt THEN' REPEAT o rtac conjI THEN'
    80.8 -     REPEAT o (rtac refl ORELSE' atac));
    80.9 +     REPEAT o etac conjE THEN_MAYBE' REPEAT o hyp_subst_tac ctxt THEN'
   80.10 +     REPEAT o (resolve_tac [refl, conjI] ORELSE' atac));
   80.11  
   80.12  fun mk_coinduct_distinct_ctrs_tac ctxt discs discs' =
   80.13 -  hyp_subst_tac ctxt THEN' REPEAT o etac conjE THEN'
   80.14 -  full_simp_tac (ss_only (refl :: no_refl (union Thm.eq_thm discs discs') @ basic_simp_thms) ctxt);
   80.15 +  let
   80.16 +    val discs'' = map (perhaps (try (fn th => th RS @{thm notnotD}))) (discs @ discs')
   80.17 +      |> distinct Thm.eq_thm_prop;
   80.18 +  in
   80.19 +    hyp_subst_tac ctxt THEN' REPEAT o etac conjE THEN'
   80.20 +    full_simp_tac (ss_only (refl :: no_refl discs'' @ basic_simp_thms) ctxt)
   80.21 +  end;
   80.22  
   80.23  fun mk_coinduct_discharge_prem_tac ctxt rel_eqs' nn kk n pre_rel_def dtor_ctor exhaust ctr_defs
   80.24      discss selss =
    81.1 --- a/src/HOL/BNF/Tools/bnf_fp_n2m.ML	Thu Dec 05 17:52:12 2013 +0100
    81.2 +++ b/src/HOL/BNF/Tools/bnf_fp_n2m.ML	Thu Dec 05 17:58:03 2013 +0100
    81.3 @@ -23,7 +23,7 @@
    81.4  open BNF_FP_N2M_Tactics
    81.5  
    81.6  fun force_typ ctxt T =
    81.7 -  map_types Type_Infer.paramify_vars 
    81.8 +  map_types Type_Infer.paramify_vars
    81.9    #> Type.constraint T
   81.10    #> Syntax.check_term ctxt
   81.11    #> singleton (Variable.polymorphic ctxt);
   81.12 @@ -99,10 +99,6 @@
   81.13      val fp_nesty_bnfss = fp_bnfs :: nesty_bnfss;
   81.14      val fp_nesty_bnfs = distinct eq_bnf (flat fp_nesty_bnfss);
   81.15  
   81.16 -    fun abstract t =
   81.17 -      let val Ts = Term.add_frees t [];
   81.18 -      in fold_rev Term.absfree (filter (member op = Ts) phis') t end;
   81.19 -
   81.20      val rels =
   81.21        let
   81.22          fun find_rel T As Bs = fp_nesty_bnfss
   81.23 @@ -121,10 +117,11 @@
   81.24                in
   81.25                  Term.list_comb (rel, rels)
   81.26                end
   81.27 -          | mk_rel (T as TFree _) _ = nth phis (find_index (curry op = T) As)
   81.28 +          | mk_rel (T as TFree _) _ = (nth phis (find_index (curry op = T) As)
   81.29 +              handle General.Subscript => HOLogic.eq_const T)
   81.30            | mk_rel _ _ = raise Fail "fpTs contains schematic type variables";
   81.31        in
   81.32 -        map2 (abstract oo mk_rel) fpTs fpTs'
   81.33 +        map2 (fold_rev Term.absfree phis' oo mk_rel) fpTs fpTs'
   81.34        end;
   81.35  
   81.36      val pre_rels = map2 (fn Ds => mk_rel_of_bnf Ds (As @ fpTs) (Bs @ fpTs')) Dss bnfs;
   81.37 @@ -224,7 +221,7 @@
   81.38          fun mk_s TU' =
   81.39            let
   81.40              val i = find_index (fn T => co_alg_argT TU' = T) Xs;
   81.41 -            val sF = co_alg_funT TU'; 
   81.42 +            val sF = co_alg_funT TU';
   81.43              val F = nth iter_preTs i;
   81.44              val s = nth iter_strs i;
   81.45            in
   81.46 @@ -238,7 +235,7 @@
   81.47                    |> force_typ names_lthy smapT
   81.48                    |> hidden_to_unit;
   81.49                  val smap_argTs = strip_typeN live (fastype_of smap) |> fst;
   81.50 -                fun mk_smap_arg TU =              
   81.51 +                fun mk_smap_arg TU =
   81.52                    (if domain_type TU = range_type TU then
   81.53                      HOLogic.id_const (domain_type TU)
   81.54                    else if is_rec then
   81.55 @@ -265,7 +262,7 @@
   81.56        in
   81.57          (case b_opt of
   81.58            NONE => ((t, Drule.dummy_thm), lthy)
   81.59 -        | SOME b => Local_Theory.define ((b, NoSyn), ((Thm.def_binding b, []), 
   81.60 +        | SOME b => Local_Theory.define ((b, NoSyn), ((Binding.conceal (Thm.def_binding b), []),
   81.61              fold_rev Term.absfree (if is_rec then rec_strs' else fold_strs') t)) lthy |>> apsnd snd)
   81.62        end;
   81.63  
   81.64 @@ -376,6 +373,6 @@
   81.65         |> morph_fp_result (Morphism.term_morphism (singleton (Variable.polymorphic lthy))));
   81.66    in
   81.67      (fp_res, lthy)
   81.68 -  end
   81.69 +  end;
   81.70  
   81.71  end;
    82.1 --- a/src/HOL/BNF/Tools/bnf_fp_n2m_sugar.ML	Thu Dec 05 17:52:12 2013 +0100
    82.2 +++ b/src/HOL/BNF/Tools/bnf_fp_n2m_sugar.ML	Thu Dec 05 17:58:03 2013 +0100
    82.3 @@ -7,14 +7,16 @@
    82.4  
    82.5  signature BNF_FP_N2M_SUGAR =
    82.6  sig
    82.7 -  val mutualize_fp_sugars: bool -> BNF_FP_Util.fp_kind -> binding list -> typ list ->
    82.8 -    (term -> int list) -> term list list list list -> BNF_FP_Def_Sugar.fp_sugar list ->
    82.9 -    local_theory ->
   82.10 +  val unfold_let: term -> term
   82.11 +  val dest_map: Proof.context -> string -> term -> term * term list
   82.12 +
   82.13 +  val mutualize_fp_sugars: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) ->
   82.14 +    term list list list list -> BNF_FP_Def_Sugar.fp_sugar list -> local_theory ->
   82.15      (BNF_FP_Def_Sugar.fp_sugar list
   82.16       * (BNF_FP_Def_Sugar.lfp_sugar_thms option * BNF_FP_Def_Sugar.gfp_sugar_thms option))
   82.17      * local_theory
   82.18 -  val pad_and_indexify_calls: BNF_FP_Def_Sugar.fp_sugar list -> int ->
   82.19 -    (term * term list list) list list -> term list list list list
   82.20 +  val indexify_callsss: BNF_FP_Def_Sugar.fp_sugar -> (term * term list list) list ->
   82.21 +    term list list list
   82.22    val nested_to_mutual_fps: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) ->
   82.23      (term * term list list) list list -> local_theory ->
   82.24      (typ list * int list * BNF_FP_Def_Sugar.fp_sugar list
   82.25 @@ -34,171 +36,245 @@
   82.26  
   82.27  val n2mN = "n2m_"
   82.28  
   82.29 -(* TODO: test with sort constraints on As *)
   82.30 -(* TODO: use right sorting order for "fp_sort" w.r.t. original BNFs (?) -- treat new variables
   82.31 -   as deads? *)
   82.32 -fun mutualize_fp_sugars mutualize fp bs fpTs get_indices callssss fp_sugars0 no_defs_lthy0 =
   82.33 -  if mutualize orelse has_duplicates (op =) fpTs then
   82.34 -    let
   82.35 -      val thy = Proof_Context.theory_of no_defs_lthy0;
   82.36 +type n2m_sugar = fp_sugar list * (lfp_sugar_thms option * gfp_sugar_thms option);
   82.37 +
   82.38 +structure Data = Generic_Data
   82.39 +(
   82.40 +  type T = n2m_sugar Typtab.table;
   82.41 +  val empty = Typtab.empty;
   82.42 +  val extend = I;
   82.43 +  val merge = Typtab.merge (eq_fst (eq_list eq_fp_sugar));
   82.44 +);
   82.45  
   82.46 -      val qsotm = quote o Syntax.string_of_term no_defs_lthy0;
   82.47 +fun morph_n2m_sugar phi (fp_sugars, (lfp_sugar_thms_opt, gfp_sugar_thms_opt)) =
   82.48 +  (map (morph_fp_sugar phi) fp_sugars,
   82.49 +   (Option.map (morph_lfp_sugar_thms phi) lfp_sugar_thms_opt,
   82.50 +    Option.map (morph_gfp_sugar_thms phi) gfp_sugar_thms_opt));
   82.51 +
   82.52 +val transfer_n2m_sugar =
   82.53 +  morph_n2m_sugar o Morphism.thm_morphism o Thm.transfer o Proof_Context.theory_of;
   82.54  
   82.55 -      fun heterogeneous_call t = error ("Heterogeneous recursive call: " ^ qsotm t);
   82.56 -      fun incompatible_calls t1 t2 =
   82.57 -        error ("Incompatible recursive calls: " ^ qsotm t1 ^ " vs. " ^ qsotm t2);
   82.58 +fun n2m_sugar_of ctxt =
   82.59 +  Typtab.lookup (Data.get (Context.Proof ctxt))
   82.60 +  #> Option.map (transfer_n2m_sugar ctxt);
   82.61  
   82.62 -      val b_names = map Binding.name_of bs;
   82.63 -      val fp_b_names = map base_name_of_typ fpTs;
   82.64 +fun register_n2m_sugar key n2m_sugar =
   82.65 +  Local_Theory.declaration {syntax = false, pervasive = false}
   82.66 +    (fn phi => Data.map (Typtab.default (key, morph_n2m_sugar phi n2m_sugar)));
   82.67  
   82.68 -      val nn = length fpTs;
   82.69 +fun unfold_let (Const (@{const_name Let}, _) $ arg1 $ arg2) = unfold_let (betapply (arg2, arg1))
   82.70 +  | unfold_let (Const (@{const_name prod_case}, _) $ t) =
   82.71 +    (case unfold_let t of
   82.72 +      t' as Abs (s1, T1, Abs (s2, T2, _)) =>
   82.73 +      let
   82.74 +        val x = (s1 ^ s2, Term.maxidx_of_term t + 1);
   82.75 +        val v = Var (x, HOLogic.mk_prodT (T1, T2));
   82.76 +      in
   82.77 +        lambda v (unfold_let (betapplys (t', [HOLogic.mk_fst v, HOLogic.mk_snd v])))
   82.78 +      end
   82.79 +    | _ => t)
   82.80 +  | unfold_let (t $ u) = betapply (unfold_let t, unfold_let u)
   82.81 +  | unfold_let (Abs (s, T, t)) = Abs (s, T, unfold_let t)
   82.82 +  | unfold_let t = t;
   82.83  
   82.84 -      fun target_ctr_sugar_of_fp_sugar fpT ({T, index, ctr_sugars, ...} : fp_sugar) =
   82.85 -        let
   82.86 -          val rho = Vartab.fold (cons o apsnd snd) (Sign.typ_match thy (T, fpT) Vartab.empty) [];
   82.87 -          val phi = Morphism.term_morphism (Term.subst_TVars rho);
   82.88 -        in
   82.89 -          morph_ctr_sugar phi (nth ctr_sugars index)
   82.90 -        end;
   82.91 -
   82.92 -      val ctr_defss = map (of_fp_sugar #ctr_defss) fp_sugars0;
   82.93 -      val mapss = map (of_fp_sugar #mapss) fp_sugars0;
   82.94 -      val ctr_sugars0 = map2 target_ctr_sugar_of_fp_sugar fpTs fp_sugars0;
   82.95 -
   82.96 -      val ctrss = map #ctrs ctr_sugars0;
   82.97 -      val ctr_Tss = map (map fastype_of) ctrss;
   82.98 +fun mk_map_pattern ctxt s =
   82.99 +  let
  82.100 +    val bnf = the (bnf_of ctxt s);
  82.101 +    val mapx = map_of_bnf bnf;
  82.102 +    val live = live_of_bnf bnf;
  82.103 +    val (f_Ts, _) = strip_typeN live (fastype_of mapx);
  82.104 +    val fs = map_index (fn (i, T) => Var (("?f", i), T)) f_Ts;
  82.105 +  in
  82.106 +    (mapx, betapplys (mapx, fs))
  82.107 +  end;
  82.108  
  82.109 -      val As' = fold (fold Term.add_tfreesT) ctr_Tss [];
  82.110 -      val As = map TFree As';
  82.111 +fun dest_map ctxt s call =
  82.112 +  let
  82.113 +    val (map0, pat) = mk_map_pattern ctxt s;
  82.114 +    val (_, tenv) = fo_match ctxt call pat;
  82.115 +  in
  82.116 +    (map0, Vartab.fold_rev (fn (_, (_, f)) => cons f) tenv [])
  82.117 +  end;
  82.118 +
  82.119 +fun dest_abs_or_applied_map _ _ (Abs (_, _, t)) = (Term.dummy, [t])
  82.120 +  | dest_abs_or_applied_map ctxt s (t1 $ _) = dest_map ctxt s t1;
  82.121  
  82.122 -      val ((Cs, Xs), no_defs_lthy) =
  82.123 -        no_defs_lthy0
  82.124 -        |> fold Variable.declare_typ As
  82.125 -        |> mk_TFrees nn
  82.126 -        ||>> variant_tfrees fp_b_names;
  82.127 +fun map_partition f xs =
  82.128 +  fold_rev (fn x => fn (ys, (good, bad)) =>
  82.129 +      case f x of SOME y => (y :: ys, (x :: good, bad)) | NONE => (ys, (good, x :: bad)))
  82.130 +    xs ([], ([], []));
  82.131  
  82.132 -      fun freeze_fp_default (T as Type (s, Ts)) =
  82.133 -          (case find_index (curry (op =) T) fpTs of
  82.134 -            ~1 => Type (s, map freeze_fp_default Ts)
  82.135 -          | kk => nth Xs kk)
  82.136 -        | freeze_fp_default T = T;
  82.137 +fun key_of_fp_eqs fp fpTs fp_eqs =
  82.138 +  Type (fp_case fp "l" "g", fpTs @ maps (fn (x, T) => [TFree x, T]) fp_eqs);
  82.139 +
  82.140 +(* TODO: test with sort constraints on As *)
  82.141 +fun mutualize_fp_sugars fp bs fpTs get_indices callssss fp_sugars0 no_defs_lthy0 =
  82.142 +  let
  82.143 +    val thy = Proof_Context.theory_of no_defs_lthy0;
  82.144 +
  82.145 +    val qsotm = quote o Syntax.string_of_term no_defs_lthy0;
  82.146  
  82.147 -      fun get_indices_checked call =
  82.148 -        (case get_indices call of
  82.149 -          _ :: _ :: _ => heterogeneous_call call
  82.150 -        | kks => kks);
  82.151 +    fun incompatible_calls t1 t2 =
  82.152 +      error ("Incompatible " ^ co_prefix fp ^ "recursive calls: " ^ qsotm t1 ^ " vs. " ^ qsotm t2);
  82.153 +    fun nested_self_call t =
  82.154 +      error ("Unsupported nested self-call " ^ qsotm t);
  82.155 +
  82.156 +    val b_names = map Binding.name_of bs;
  82.157 +    val fp_b_names = map base_name_of_typ fpTs;
  82.158 +
  82.159 +    val nn = length fpTs;
  82.160  
  82.161 -      fun freeze_fp calls (T as Type (s, Ts)) =
  82.162 -          (case map_filter (try (snd o dest_map no_defs_lthy s)) calls of
  82.163 -            [] =>
  82.164 -            (case union (op = o pairself fst)
  82.165 -                (maps (fn call => map (rpair call) (get_indices_checked call)) calls) [] of
  82.166 -              [] => freeze_fp_default T
  82.167 -            | [(kk, _)] => nth Xs kk
  82.168 -            | (_, call1) :: (_, call2) :: _ => incompatible_calls call1 call2)
  82.169 -          | callss =>
  82.170 -            Type (s, map2 freeze_fp (flatten_type_args_of_bnf (the (bnf_of no_defs_lthy s)) []
  82.171 -              (transpose callss)) Ts))
  82.172 -        | freeze_fp _ T = T;
  82.173 +    fun target_ctr_sugar_of_fp_sugar fpT ({T, index, ctr_sugars, ...} : fp_sugar) =
  82.174 +      let
  82.175 +        val rho = Vartab.fold (cons o apsnd snd) (Sign.typ_match thy (T, fpT) Vartab.empty) [];
  82.176 +        val phi = Morphism.term_morphism (Term.subst_TVars rho);
  82.177 +      in
  82.178 +        morph_ctr_sugar phi (nth ctr_sugars index)
  82.179 +      end;
  82.180  
  82.181 -      val ctr_Tsss = map (map binder_types) ctr_Tss;
  82.182 -      val ctrXs_Tsss = map2 (map2 (map2 freeze_fp)) callssss ctr_Tsss;
  82.183 -      val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss;
  82.184 -      val Ts = map (body_type o hd) ctr_Tss;
  82.185 +    val ctr_defss = map (of_fp_sugar #ctr_defss) fp_sugars0;
  82.186 +    val mapss = map (of_fp_sugar #mapss) fp_sugars0;
  82.187 +    val ctr_sugars = map2 target_ctr_sugar_of_fp_sugar fpTs fp_sugars0;
  82.188 +
  82.189 +    val ctrss = map #ctrs ctr_sugars;
  82.190 +    val ctr_Tss = map (map fastype_of) ctrss;
  82.191 +
  82.192 +    val As' = fold (fold Term.add_tfreesT) ctr_Tss [];
  82.193 +    val As = map TFree As';
  82.194  
  82.195 -      val ns = map length ctr_Tsss;
  82.196 -      val kss = map (fn n => 1 upto n) ns;
  82.197 -      val mss = map (map length) ctr_Tsss;
  82.198 -
  82.199 -      val fp_eqs = map dest_TFree Xs ~~ ctrXs_sum_prod_Ts;
  82.200 +    val ((Cs, Xs), no_defs_lthy) =
  82.201 +      no_defs_lthy0
  82.202 +      |> fold Variable.declare_typ As
  82.203 +      |> mk_TFrees nn
  82.204 +      ||>> variant_tfrees fp_b_names;
  82.205  
  82.206 -      val base_fp_names = Name.variant_list [] fp_b_names;
  82.207 -      val fp_bs = map2 (fn b_name => fn base_fp_name =>
  82.208 -          Binding.qualify true b_name (Binding.name (n2mN ^ base_fp_name)))
  82.209 -        b_names base_fp_names;
  82.210 +    fun check_call_dead live_call call =
  82.211 +      if null (get_indices call) then () else incompatible_calls live_call call;
  82.212  
  82.213 -      val (pre_bnfs, (fp_res as {xtor_co_iterss = xtor_co_iterss0, xtor_co_induct,
  82.214 -             dtor_injects, dtor_ctors, xtor_co_iter_thmss, ...}, lthy)) =
  82.215 -        fp_bnf (construct_mutualized_fp fp fpTs fp_sugars0) fp_bs As' fp_eqs no_defs_lthy;
  82.216 -
  82.217 -      val nesting_bnfs = nesty_bnfs lthy ctrXs_Tsss As;
  82.218 -      val nested_bnfs = nesty_bnfs lthy ctrXs_Tsss Xs;
  82.219 +    fun freeze_fpTs_simple (T as Type (s, Ts)) =
  82.220 +        (case find_index (curry (op =) T) fpTs of
  82.221 +          ~1 => Type (s, map freeze_fpTs_simple Ts)
  82.222 +        | kk => nth Xs kk)
  82.223 +      | freeze_fpTs_simple T = T;
  82.224  
  82.225 -      val ((xtor_co_iterss, iters_args_types, coiters_args_types), _) =
  82.226 -        mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy;
  82.227 -
  82.228 -      fun mk_binding b suf = Binding.suffix_name ("_" ^ suf) b;
  82.229 +    fun freeze_fpTs_map (fpT as Type (_, Ts')) (callss, (live_call :: _, dead_calls))
  82.230 +        (T as Type (s, Ts)) =
  82.231 +      if Ts' = Ts then
  82.232 +        nested_self_call live_call
  82.233 +      else
  82.234 +        (List.app (check_call_dead live_call) dead_calls;
  82.235 +         Type (s, map2 (freeze_fpTs fpT) (flatten_type_args_of_bnf (the (bnf_of no_defs_lthy s)) []
  82.236 +           (transpose callss)) Ts))
  82.237 +    and freeze_fpTs fpT calls (T as Type (s, _)) =
  82.238 +        (case map_partition (try (snd o dest_map no_defs_lthy s)) calls of
  82.239 +          ([], _) =>
  82.240 +          (case map_partition (try (snd o dest_abs_or_applied_map no_defs_lthy s)) calls of
  82.241 +            ([], _) => freeze_fpTs_simple T
  82.242 +          | callsp => freeze_fpTs_map fpT callsp T)
  82.243 +        | callsp => freeze_fpTs_map fpT callsp T)
  82.244 +      | freeze_fpTs _ _ T = T;
  82.245  
  82.246 -      val ((co_iterss, co_iter_defss), lthy) =
  82.247 -        fold_map2 (fn b =>
  82.248 -          (if fp = Least_FP then define_iters [foldN, recN] (the iters_args_types)
  82.249 -           else define_coiters [unfoldN, corecN] (the coiters_args_types))
  82.250 -            (mk_binding b) fpTs Cs) fp_bs xtor_co_iterss lthy
  82.251 -        |>> split_list;
  82.252 +    val ctr_Tsss = map (map binder_types) ctr_Tss;
  82.253 +    val ctrXs_Tsss = map3 (map2 o map2 o freeze_fpTs) fpTs callssss ctr_Tsss;
  82.254 +    val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss;
  82.255 +    val ctr_Ts = map (body_type o hd) ctr_Tss;
  82.256 +
  82.257 +    val ns = map length ctr_Tsss;
  82.258 +    val kss = map (fn n => 1 upto n) ns;
  82.259 +    val mss = map (map length) ctr_Tsss;
  82.260  
  82.261 -      val rho = tvar_subst thy Ts fpTs;
  82.262 -      val ctr_sugar_phi =
  82.263 -        Morphism.compose (Morphism.typ_morphism (Term.typ_subst_TVars rho))
  82.264 -          (Morphism.term_morphism (Term.subst_TVars rho));
  82.265 -      val inst_ctr_sugar = morph_ctr_sugar ctr_sugar_phi;
  82.266 +    val fp_eqs = map dest_TFree Xs ~~ ctrXs_sum_prod_Ts;
  82.267 +    val key = key_of_fp_eqs fp fpTs fp_eqs;
  82.268 +  in
  82.269 +    (case n2m_sugar_of no_defs_lthy key of
  82.270 +      SOME n2m_sugar => (n2m_sugar, no_defs_lthy)
  82.271 +    | NONE =>
  82.272 +      let
  82.273 +        val base_fp_names = Name.variant_list [] fp_b_names;
  82.274 +        val fp_bs = map2 (fn b_name => fn base_fp_name =>
  82.275 +            Binding.qualify true b_name (Binding.name (n2mN ^ base_fp_name)))
  82.276 +          b_names base_fp_names;
  82.277  
  82.278 -      val ctr_sugars = map inst_ctr_sugar ctr_sugars0;
  82.279 +        val (pre_bnfs, (fp_res as {xtor_co_iterss = xtor_co_iterss0, xtor_co_induct, dtor_injects,
  82.280 +               dtor_ctors, xtor_co_iter_thmss, ...}, lthy)) =
  82.281 +          fp_bnf (construct_mutualized_fp fp fpTs fp_sugars0) fp_bs As' fp_eqs no_defs_lthy;
  82.282 +
  82.283 +        val nesting_bnfs = nesty_bnfs lthy ctrXs_Tsss As;
  82.284 +        val nested_bnfs = nesty_bnfs lthy ctrXs_Tsss Xs;
  82.285 +
  82.286 +        val ((xtor_co_iterss, iters_args_types, coiters_args_types), _) =
  82.287 +          mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy;
  82.288 +
  82.289 +        fun mk_binding b suf = Binding.suffix_name ("_" ^ suf) b;
  82.290 +
  82.291 +        val ((co_iterss, co_iter_defss), lthy) =
  82.292 +          fold_map2 (fn b =>
  82.293 +            (if fp = Least_FP then define_iters [foldN, recN] (the iters_args_types)
  82.294 +             else define_coiters [unfoldN, corecN] (the coiters_args_types))
  82.295 +              (mk_binding b) fpTs Cs) fp_bs xtor_co_iterss lthy
  82.296 +          |>> split_list;
  82.297  
  82.298 -      val ((co_inducts, un_fold_thmss, co_rec_thmss, disc_unfold_thmss, disc_corec_thmss,
  82.299 -            sel_unfold_thmsss, sel_corec_thmsss), fp_sugar_thms) =
  82.300 -        if fp = Least_FP then
  82.301 -          derive_induct_iters_thms_for_types pre_bnfs (the iters_args_types) xtor_co_induct
  82.302 -            xtor_co_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss
  82.303 -            co_iterss co_iter_defss lthy
  82.304 -          |> `(fn ((_, induct, _), (fold_thmss, rec_thmss, _)) =>
  82.305 -            ([induct], fold_thmss, rec_thmss, [], [], [], []))
  82.306 -          ||> (fn info => (SOME info, NONE))
  82.307 -        else
  82.308 -          derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
  82.309 -            dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs kss mss ns ctr_defss
  82.310 -            ctr_sugars co_iterss co_iter_defss (Proof_Context.export lthy no_defs_lthy) lthy
  82.311 -          |> `(fn ((coinduct_thms_pairs, _), (unfold_thmss, corec_thmss, _),
  82.312 -                  (disc_unfold_thmss, disc_corec_thmss, _), _,
  82.313 -                  (sel_unfold_thmsss, sel_corec_thmsss, _)) =>
  82.314 -            (map snd coinduct_thms_pairs, unfold_thmss, corec_thmss, disc_unfold_thmss,
  82.315 -             disc_corec_thmss, sel_unfold_thmsss, sel_corec_thmsss))
  82.316 -          ||> (fn info => (NONE, SOME info));
  82.317 +        val ((co_inducts, un_fold_thmss, co_rec_thmss, disc_unfold_thmss, disc_corec_thmss,
  82.318 +              sel_unfold_thmsss, sel_corec_thmsss), fp_sugar_thms) =
  82.319 +          if fp = Least_FP then
  82.320 +            derive_induct_iters_thms_for_types pre_bnfs (the iters_args_types) xtor_co_induct
  82.321 +              xtor_co_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss
  82.322 +              co_iterss co_iter_defss lthy
  82.323 +            |> `(fn ((_, induct, _), (fold_thmss, rec_thmss, _)) =>
  82.324 +              ([induct], fold_thmss, rec_thmss, [], [], [], []))
  82.325 +            ||> (fn info => (SOME info, NONE))
  82.326 +          else
  82.327 +            derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
  82.328 +              dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss
  82.329 +              ns ctr_defss ctr_sugars co_iterss co_iter_defss
  82.330 +              (Proof_Context.export lthy no_defs_lthy) lthy
  82.331 +            |> `(fn ((coinduct_thms_pairs, _), (unfold_thmss, corec_thmss, _),
  82.332 +                    (disc_unfold_thmss, disc_corec_thmss, _), _,
  82.333 +                    (sel_unfold_thmsss, sel_corec_thmsss, _)) =>
  82.334 +              (map snd coinduct_thms_pairs, unfold_thmss, corec_thmss, disc_unfold_thmss,
  82.335 +               disc_corec_thmss, sel_unfold_thmsss, sel_corec_thmsss))
  82.336 +            ||> (fn info => (NONE, SOME info));
  82.337  
  82.338 -      val phi = Proof_Context.export_morphism no_defs_lthy no_defs_lthy0;
  82.339 +        val phi = Proof_Context.export_morphism no_defs_lthy no_defs_lthy0;
  82.340  
  82.341 -      fun mk_target_fp_sugar (kk, T) =
  82.342 -        {T = T, fp = fp, index = kk, pre_bnfs = pre_bnfs, nested_bnfs = nested_bnfs,
  82.343 -         nesting_bnfs = nesting_bnfs, fp_res = fp_res, ctr_defss = ctr_defss,
  82.344 -         ctr_sugars = ctr_sugars, co_iterss = co_iterss, mapss = mapss, co_inducts = co_inducts,
  82.345 -         co_iter_thmsss = transpose [un_fold_thmss, co_rec_thmss],
  82.346 -         disc_co_itersss = transpose [disc_unfold_thmss, disc_corec_thmss],
  82.347 -         sel_co_iterssss = transpose [sel_unfold_thmsss, sel_corec_thmsss]}
  82.348 -        |> morph_fp_sugar phi;
  82.349 -    in
  82.350 -      ((map_index mk_target_fp_sugar fpTs, fp_sugar_thms), lthy)
  82.351 -    end
  82.352 -  else
  82.353 -    (* TODO: reorder hypotheses and predicates in (co)induction rules? *)
  82.354 -    ((fp_sugars0, (NONE, NONE)), no_defs_lthy0);
  82.355 +        fun mk_target_fp_sugar (kk, T) =
  82.356 +          {T = T, fp = fp, index = kk, pre_bnfs = pre_bnfs, nested_bnfs = nested_bnfs,
  82.357 +           nesting_bnfs = nesting_bnfs, fp_res = fp_res, ctr_defss = ctr_defss,
  82.358 +           ctr_sugars = ctr_sugars, co_iterss = co_iterss, mapss = mapss, co_inducts = co_inducts,
  82.359 +           co_iter_thmsss = transpose [un_fold_thmss, co_rec_thmss],
  82.360 +           disc_co_itersss = transpose [disc_unfold_thmss, disc_corec_thmss],
  82.361 +           sel_co_iterssss = transpose [sel_unfold_thmsss, sel_corec_thmsss]}
  82.362 +          |> morph_fp_sugar phi;
  82.363 +
  82.364 +        val n2m_sugar = (map_index mk_target_fp_sugar fpTs, fp_sugar_thms);
  82.365 +      in
  82.366 +        (n2m_sugar, lthy |> register_n2m_sugar key n2m_sugar)
  82.367 +      end)
  82.368 +  end;
  82.369  
  82.370  fun indexify_callsss fp_sugar callsss =
  82.371    let
  82.372      val {ctrs, ...} = of_fp_sugar #ctr_sugars fp_sugar;
  82.373 -    fun do_ctr ctr =
  82.374 +    fun indexify_ctr ctr =
  82.375        (case AList.lookup Term.aconv_untyped callsss ctr of
  82.376          NONE => replicate (num_binder_types (fastype_of ctr)) []
  82.377 -      | SOME callss => map (map Envir.beta_eta_contract) callss);
  82.378 +      | SOME callss => map (map (Envir.beta_eta_contract o unfold_let)) callss);
  82.379    in
  82.380 -    map do_ctr ctrs
  82.381 +    map indexify_ctr ctrs
  82.382    end;
  82.383  
  82.384 -fun pad_and_indexify_calls fp_sugars0 = map2 indexify_callsss fp_sugars0 oo pad_list [];
  82.385 +fun retypargs tyargs (Type (s, _)) = Type (s, tyargs);
  82.386 +
  82.387 +fun fold_subtype_pairs f (T as Type (s, Ts), U as Type (s', Us)) =
  82.388 +    f (T, U) #> (if s = s' then fold (fold_subtype_pairs f) (Ts ~~ Us) else I)
  82.389 +  | fold_subtype_pairs f TU = f TU;
  82.390  
  82.391  fun nested_to_mutual_fps fp actual_bs actual_Ts get_indices actual_callssss0 lthy =
  82.392    let
  82.393      val qsoty = quote o Syntax.string_of_typ lthy;
  82.394      val qsotys = space_implode " or " o map qsoty;
  82.395  
  82.396 +    fun duplicate_datatype T = error (qsoty T ^ " is not mutually recursive with itself");
  82.397      fun not_co_datatype0 T = error (qsoty T ^ " is not a " ^ co_prefix fp ^ "datatype");
  82.398      fun not_co_datatype (T as Type (s, _)) =
  82.399          if fp = Least_FP andalso
  82.400 @@ -208,32 +284,80 @@
  82.401            not_co_datatype0 T
  82.402        | not_co_datatype T = not_co_datatype0 T;
  82.403      fun not_mutually_nested_rec Ts1 Ts2 =
  82.404 -      error (qsotys Ts1 ^ " is neither mutually recursive with nor nested recursive via " ^
  82.405 -        qsotys Ts2);
  82.406 +      error (qsotys Ts1 ^ " is neither mutually recursive with " ^ qsotys Ts2 ^
  82.407 +        " nor nested recursive via " ^ qsotys Ts2);
  82.408 +
  82.409 +    val _ = (case Library.duplicates (op =) actual_Ts of [] => () | T :: _ => duplicate_datatype T);
  82.410  
  82.411 -    val perm_actual_Ts as Type (_, ty_args0) :: _ =
  82.412 -      sort (int_ord o pairself Term.size_of_typ) actual_Ts;
  82.413 +    val perm_actual_Ts =
  82.414 +      sort (prod_ord int_ord Term_Ord.typ_ord o pairself (`Term.size_of_typ)) actual_Ts;
  82.415 +
  82.416 +    fun the_ctrs_of (Type (s, Ts)) = map (mk_ctr Ts) (#ctrs (the (ctr_sugar_of lthy s)));
  82.417 +
  82.418 +    fun the_fp_sugar_of (T as Type (T_name, _)) =
  82.419 +      (case fp_sugar_of lthy T_name of
  82.420 +        SOME (fp_sugar as {fp = fp', ...}) => if fp = fp' then fp_sugar else not_co_datatype T
  82.421 +      | NONE => not_co_datatype T);
  82.422  
  82.423 -    fun check_enrich_with_mutuals _ [] = []
  82.424 -      | check_enrich_with_mutuals seen ((T as Type (T_name, ty_args)) :: Ts) =
  82.425 -        (case fp_sugar_of lthy T_name of
  82.426 -          SOME ({fp = fp', fp_res = {Ts = Ts', ...}, ...}) =>
  82.427 -          if fp = fp' then
  82.428 +    fun gen_rhss_in gen_Ts rho subTs =
  82.429 +      let
  82.430 +        fun maybe_insert (T, Type (_, gen_tyargs)) =
  82.431 +            if member (op =) subTs T then insert (op =) gen_tyargs else I
  82.432 +          | maybe_insert _ = I;
  82.433 +
  82.434 +        val ctrs = maps the_ctrs_of gen_Ts;
  82.435 +        val gen_ctr_Ts = maps (binder_types o fastype_of) ctrs;
  82.436 +        val ctr_Ts = map (Term.typ_subst_atomic rho) gen_ctr_Ts;
  82.437 +      in
  82.438 +        fold (fold_subtype_pairs maybe_insert) (ctr_Ts ~~ gen_ctr_Ts) []
  82.439 +      end;
  82.440 +
  82.441 +    fun gather_types _ _ num_groups seen gen_seen [] = (num_groups, seen, gen_seen)
  82.442 +      | gather_types lthy rho num_groups seen gen_seen ((T as Type (_, tyargs)) :: Ts) =
  82.443 +        let
  82.444 +          val {fp_res = {Ts = mutual_Ts0, ...}, ...} = the_fp_sugar_of T;
  82.445 +          val mutual_Ts = map (retypargs tyargs) mutual_Ts0;
  82.446 +
  82.447 +          val _ = seen = [] orelse exists (exists_subtype_in seen) mutual_Ts orelse
  82.448 +            not_mutually_nested_rec mutual_Ts seen;
  82.449 +
  82.450 +          fun fresh_tyargs () =
  82.451              let
  82.452 -              val mutual_Ts = map (fn Type (s, _) => Type (s, ty_args)) Ts';
  82.453 -              val _ =
  82.454 -                seen = [] orelse exists (exists_subtype_in seen) mutual_Ts orelse
  82.455 -                not_mutually_nested_rec mutual_Ts seen;
  82.456 -              val (seen', Ts') = List.partition (member (op =) mutual_Ts) Ts;
  82.457 +              (* The name "'z" is unlikely to clash with the context, yielding more cache hits. *)
  82.458 +              val (gen_tyargs, lthy') =
  82.459 +                variant_tfrees (replicate (length tyargs) "z") lthy
  82.460 +                |>> map Logic.varifyT_global;
  82.461 +              val rho' = (gen_tyargs ~~ tyargs) @ rho;
  82.462              in
  82.463 -              mutual_Ts @ check_enrich_with_mutuals (seen @ T :: seen') Ts'
  82.464 -            end
  82.465 -          else
  82.466 -            not_co_datatype T
  82.467 -        | NONE => not_co_datatype T)
  82.468 -      | check_enrich_with_mutuals _ (T :: _) = not_co_datatype T;
  82.469 +              (rho', gen_tyargs, gen_seen, lthy')
  82.470 +            end;
  82.471  
  82.472 -    val perm_Ts = check_enrich_with_mutuals [] perm_actual_Ts;
  82.473 +          val (rho', gen_tyargs, gen_seen', lthy') =
  82.474 +            if exists (exists_subtype_in seen) mutual_Ts then
  82.475 +              (case gen_rhss_in gen_seen rho mutual_Ts of
  82.476 +                [] => fresh_tyargs ()
  82.477 +              | gen_tyargss as gen_tyargs :: gen_tyargss_tl =>
  82.478 +                let
  82.479 +                  val unify_pairs = split_list (maps (curry (op ~~) gen_tyargs) gen_tyargss_tl);
  82.480 +                  val mgu = Type.raw_unifys unify_pairs Vartab.empty;
  82.481 +                  val gen_tyargs' = map (Envir.subst_type mgu) gen_tyargs;
  82.482 +                  val gen_seen' = map (Envir.subst_type mgu) gen_seen;
  82.483 +                in
  82.484 +                  (rho, gen_tyargs', gen_seen', lthy)
  82.485 +                end)
  82.486 +            else
  82.487 +              fresh_tyargs ();
  82.488 +
  82.489 +          val gen_mutual_Ts = map (retypargs gen_tyargs) mutual_Ts0;
  82.490 +          val Ts' = filter_out (member (op =) mutual_Ts) Ts;
  82.491 +        in
  82.492 +          gather_types lthy' rho' (num_groups + 1) (seen @ mutual_Ts) (gen_seen' @ gen_mutual_Ts)
  82.493 +            Ts'
  82.494 +        end
  82.495 +      | gather_types _ _ _ _ _ (T :: _) = not_co_datatype T;
  82.496 +
  82.497 +    val (num_groups, perm_Ts, perm_gen_Ts) = gather_types lthy [] 0 [] [] perm_actual_Ts;
  82.498 +    val perm_frozen_gen_Ts = map Logic.unvarifyT_global perm_gen_Ts;
  82.499  
  82.500      val missing_Ts = perm_Ts |> subtract (op =) actual_Ts;
  82.501      val Ts = actual_Ts @ missing_Ts;
  82.502 @@ -241,6 +365,8 @@
  82.503      val nn = length Ts;
  82.504      val kks = 0 upto nn - 1;
  82.505  
  82.506 +    val callssss0 = pad_list [] nn actual_callssss0;
  82.507 +
  82.508      val common_name = mk_common_name (map Binding.name_of actual_bs);
  82.509      val bs = pad_list (Binding.name common_name) nn actual_bs;
  82.510  
  82.511 @@ -249,16 +375,19 @@
  82.512  
  82.513      val perm_bs = permute bs;
  82.514      val perm_kks = permute kks;
  82.515 +    val perm_callssss0 = permute callssss0;
  82.516      val perm_fp_sugars0 = map (the o fp_sugar_of lthy o fst o dest_Type) perm_Ts;
  82.517  
  82.518 -    val mutualize = exists (fn Type (_, ty_args) => ty_args <> ty_args0) Ts;
  82.519 -    val perm_callssss = pad_and_indexify_calls perm_fp_sugars0 nn actual_callssss0;
  82.520 +    val perm_callssss = map2 indexify_callsss perm_fp_sugars0 perm_callssss0;
  82.521  
  82.522      val get_perm_indices = map (fn kk => find_index (curry (op =) kk) perm_kks) o get_indices;
  82.523  
  82.524      val ((perm_fp_sugars, fp_sugar_thms), lthy) =
  82.525 -      mutualize_fp_sugars mutualize fp perm_bs perm_Ts get_perm_indices perm_callssss
  82.526 -        perm_fp_sugars0 lthy;
  82.527 +      if num_groups > 1 then
  82.528 +        mutualize_fp_sugars fp perm_bs perm_frozen_gen_Ts get_perm_indices perm_callssss
  82.529 +          perm_fp_sugars0 lthy
  82.530 +      else
  82.531 +        ((perm_fp_sugars0, (NONE, NONE)), lthy);
  82.532  
  82.533      val fp_sugars = unpermute perm_fp_sugars;
  82.534    in
    83.1 --- a/src/HOL/BNF/Tools/bnf_fp_rec_sugar.ML	Thu Dec 05 17:52:12 2013 +0100
    83.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    83.3 @@ -1,986 +0,0 @@
    83.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_rec_sugar.ML
    83.5 -    Author:     Lorenz Panny, TU Muenchen
    83.6 -    Copyright   2013
    83.7 -
    83.8 -Recursor and corecursor sugar.
    83.9 -*)
   83.10 -
   83.11 -signature BNF_FP_REC_SUGAR =
   83.12 -sig
   83.13 -  val add_primrec: (binding * typ option * mixfix) list ->
   83.14 -    (Attrib.binding * term) list -> local_theory -> (term list * thm list list) * local_theory
   83.15 -  val add_primrec_cmd: (binding * string option * mixfix) list ->
   83.16 -    (Attrib.binding * string) list -> local_theory -> (term list * thm list list) * local_theory
   83.17 -  val add_primrec_global: (binding * typ option * mixfix) list ->
   83.18 -    (Attrib.binding * term) list -> theory -> (term list * thm list list) * theory
   83.19 -  val add_primrec_overloaded: (string * (string * typ) * bool) list ->
   83.20 -    (binding * typ option * mixfix) list ->
   83.21 -    (Attrib.binding * term) list -> theory -> (term list * thm list list) * theory
   83.22 -  val add_primrec_simple: ((binding * typ) * mixfix) list -> term list ->
   83.23 -    local_theory -> (string list * (term list * (int list list * thm list list))) * local_theory
   83.24 -  val add_primcorecursive_cmd: bool ->
   83.25 -    (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list ->
   83.26 -    Proof.context -> Proof.state
   83.27 -  val add_primcorec_cmd: bool ->
   83.28 -    (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list ->
   83.29 -    local_theory -> local_theory
   83.30 -end;
   83.31 -
   83.32 -structure BNF_FP_Rec_Sugar : BNF_FP_REC_SUGAR =
   83.33 -struct
   83.34 -
   83.35 -open BNF_Util
   83.36 -open BNF_FP_Util
   83.37 -open BNF_FP_Rec_Sugar_Util
   83.38 -open BNF_FP_Rec_Sugar_Tactics
   83.39 -
   83.40 -val codeN = "code"
   83.41 -val ctrN = "ctr"
   83.42 -val discN = "disc"
   83.43 -val selN = "sel"
   83.44 -
   83.45 -val nitpick_attrs = @{attributes [nitpick_simp]};
   83.46 -val simp_attrs = @{attributes [simp]};
   83.47 -val code_nitpick_attrs = Code.add_default_eqn_attrib :: nitpick_attrs;
   83.48 -val code_nitpick_simp_attrs = Code.add_default_eqn_attrib :: nitpick_attrs @ simp_attrs;
   83.49 -
   83.50 -exception Primrec_Error of string * term list;
   83.51 -
   83.52 -fun primrec_error str = raise Primrec_Error (str, []);
   83.53 -fun primrec_error_eqn str eqn = raise Primrec_Error (str, [eqn]);
   83.54 -fun primrec_error_eqns str eqns = raise Primrec_Error (str, eqns);
   83.55 -
   83.56 -fun finds eq = fold_map (fn x => List.partition (curry eq x) #>> pair x);
   83.57 -
   83.58 -val free_name = try (fn Free (v, _) => v);
   83.59 -val const_name = try (fn Const (v, _) => v);
   83.60 -val undef_const = Const (@{const_name undefined}, dummyT);
   83.61 -
   83.62 -fun permute_args n t = list_comb (t, map Bound (0 :: (n downto 1)))
   83.63 -  |> fold (K (Term.abs (Name.uu, dummyT))) (0 upto n);
   83.64 -val abs_tuple = HOLogic.tupled_lambda o HOLogic.mk_tuple;
   83.65 -fun drop_All t = subst_bounds (strip_qnt_vars @{const_name all} t |> map Free |> rev,
   83.66 -  strip_qnt_body @{const_name all} t)
   83.67 -fun abstract vs =
   83.68 -  let fun a n (t $ u) = a n t $ a n u
   83.69 -        | a n (Abs (v, T, b)) = Abs (v, T, a (n + 1) b)
   83.70 -        | a n t = let val idx = find_index (equal t) vs in
   83.71 -            if idx < 0 then t else Bound (n + idx) end
   83.72 -  in a 0 end;
   83.73 -fun mk_prod1 Ts (t, u) = HOLogic.pair_const (fastype_of1 (Ts, t)) (fastype_of1 (Ts, u)) $ t $ u;
   83.74 -fun mk_tuple1 Ts = the_default HOLogic.unit o try (foldr1 (mk_prod1 Ts));
   83.75 -
   83.76 -fun get_indices fixes t = map (fst #>> Binding.name_of #> Free) fixes
   83.77 -  |> map_index (fn (i, v) => if exists_subterm (equal v) t then SOME i else NONE)
   83.78 -  |> map_filter I;
   83.79 -
   83.80 -
   83.81 -(* Primrec *)
   83.82 -
   83.83 -type eqn_data = {
   83.84 -  fun_name: string,
   83.85 -  rec_type: typ,
   83.86 -  ctr: term,
   83.87 -  ctr_args: term list,
   83.88 -  left_args: term list,
   83.89 -  right_args: term list,
   83.90 -  res_type: typ,
   83.91 -  rhs_term: term,
   83.92 -  user_eqn: term
   83.93 -};
   83.94 -
   83.95 -fun dissect_eqn lthy fun_names eqn' =
   83.96 -  let
   83.97 -    val eqn = drop_All eqn' |> HOLogic.dest_Trueprop
   83.98 -      handle TERM _ =>
   83.99 -        primrec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn';
  83.100 -    val (lhs, rhs) = HOLogic.dest_eq eqn
  83.101 -        handle TERM _ =>
  83.102 -          primrec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn';
  83.103 -    val (fun_name, args) = strip_comb lhs
  83.104 -      |>> (fn x => if is_Free x then fst (dest_Free x)
  83.105 -          else primrec_error_eqn "malformed function equation (does not start with free)" eqn);
  83.106 -    val (left_args, rest) = take_prefix is_Free args;
  83.107 -    val (nonfrees, right_args) = take_suffix is_Free rest;
  83.108 -    val num_nonfrees = length nonfrees;
  83.109 -    val _ = num_nonfrees = 1 orelse if num_nonfrees = 0 then
  83.110 -      primrec_error_eqn "constructor pattern missing in left-hand side" eqn else
  83.111 -      primrec_error_eqn "more than one non-variable argument in left-hand side" eqn;
  83.112 -    val _ = member (op =) fun_names fun_name orelse
  83.113 -      primrec_error_eqn "malformed function equation (does not start with function name)" eqn
  83.114 -
  83.115 -    val (ctr, ctr_args) = strip_comb (the_single nonfrees);
  83.116 -    val _ = try (num_binder_types o fastype_of) ctr = SOME (length ctr_args) orelse
  83.117 -      primrec_error_eqn "partially applied constructor in pattern" eqn;
  83.118 -    val _ = let val d = duplicates (op =) (left_args @ ctr_args @ right_args) in null d orelse
  83.119 -      primrec_error_eqn ("duplicate variable \"" ^ Syntax.string_of_term lthy (hd d) ^
  83.120 -        "\" in left-hand side") eqn end;
  83.121 -    val _ = forall is_Free ctr_args orelse
  83.122 -      primrec_error_eqn "non-primitive pattern in left-hand side" eqn;
  83.123 -    val _ =
  83.124 -      let val b = fold_aterms (fn x as Free (v, _) =>
  83.125 -        if (not (member (op =) (left_args @ ctr_args @ right_args) x) andalso
  83.126 -        not (member (op =) fun_names v) andalso
  83.127 -        not (Variable.is_fixed lthy v)) then cons x else I | _ => I) rhs []
  83.128 -      in
  83.129 -        null b orelse
  83.130 -        primrec_error_eqn ("extra variable(s) in right-hand side: " ^
  83.131 -          commas (map (Syntax.string_of_term lthy) b)) eqn
  83.132 -      end;
  83.133 -  in
  83.134 -    {fun_name = fun_name,
  83.135 -     rec_type = body_type (type_of ctr),
  83.136 -     ctr = ctr,
  83.137 -     ctr_args = ctr_args,
  83.138 -     left_args = left_args,
  83.139 -     right_args = right_args,
  83.140 -     res_type = map fastype_of (left_args @ right_args) ---> fastype_of rhs,
  83.141 -     rhs_term = rhs,
  83.142 -     user_eqn = eqn'}
  83.143 -  end;
  83.144 -
  83.145 -fun rewrite_map_arg get_ctr_pos rec_type res_type =
  83.146 -  let
  83.147 -    val pT = HOLogic.mk_prodT (rec_type, res_type);
  83.148 -
  83.149 -    val maybe_suc = Option.map (fn x => x + 1);
  83.150 -    fun subst d (t as Bound d') = t |> d = SOME d' ? curry (op $) (fst_const pT)
  83.151 -      | subst d (Abs (v, T, b)) = Abs (v, if d = SOME ~1 then pT else T, subst (maybe_suc d) b)
  83.152 -      | subst d t =
  83.153 -        let
  83.154 -          val (u, vs) = strip_comb t;
  83.155 -          val ctr_pos = try (get_ctr_pos o the) (free_name u) |> the_default ~1;
  83.156 -        in
  83.157 -          if ctr_pos >= 0 then
  83.158 -            if d = SOME ~1 andalso length vs = ctr_pos then
  83.159 -              list_comb (permute_args ctr_pos (snd_const pT), vs)
  83.160 -            else if length vs > ctr_pos andalso is_some d
  83.161 -                andalso d = try (fn Bound n => n) (nth vs ctr_pos) then
  83.162 -              list_comb (snd_const pT $ nth vs ctr_pos, map (subst d) (nth_drop ctr_pos vs))
  83.163 -            else
  83.164 -              primrec_error_eqn ("recursive call not directly applied to constructor argument") t
  83.165 -          else if d = SOME ~1 andalso const_name u = SOME @{const_name comp} then
  83.166 -            list_comb (map_types (K dummyT) u, map2 subst [NONE, d] vs)
  83.167 -          else
  83.168 -            list_comb (u, map (subst (d |> d = SOME ~1 ? K NONE)) vs)
  83.169 -        end
  83.170 -  in
  83.171 -    subst (SOME ~1)
  83.172 -  end;
  83.173 -
  83.174 -fun subst_rec_calls lthy get_ctr_pos has_call ctr_args direct_calls indirect_calls t =
  83.175 -  let
  83.176 -    fun subst bound_Ts (Abs (v, T, b)) = Abs (v, T, subst (T :: bound_Ts) b)
  83.177 -      | subst bound_Ts (t as g' $ y) =
  83.178 -        let
  83.179 -          val maybe_direct_y' = AList.lookup (op =) direct_calls y;
  83.180 -          val maybe_indirect_y' = AList.lookup (op =) indirect_calls y;
  83.181 -          val (g, g_args) = strip_comb g';
  83.182 -          val ctr_pos = try (get_ctr_pos o the) (free_name g) |> the_default ~1;
  83.183 -          val _ = ctr_pos < 0 orelse length g_args >= ctr_pos orelse
  83.184 -            primrec_error_eqn "too few arguments in recursive call" t;
  83.185 -        in
  83.186 -          if not (member (op =) ctr_args y) then
  83.187 -            pairself (subst bound_Ts) (g', y) |> (op $)
  83.188 -          else if ctr_pos >= 0 then
  83.189 -            list_comb (the maybe_direct_y', g_args)
  83.190 -          else if is_some maybe_indirect_y' then
  83.191 -            (if has_call g' then t else y)
  83.192 -            |> massage_indirect_rec_call lthy has_call
  83.193 -              (rewrite_map_arg get_ctr_pos) bound_Ts y (the maybe_indirect_y')
  83.194 -            |> (if has_call g' then I else curry (op $) g')
  83.195 -          else
  83.196 -            t
  83.197 -        end
  83.198 -      | subst _ t = t
  83.199 -  in
  83.200 -    subst [] t
  83.201 -    |> tap (fn u => has_call u andalso (* FIXME detect this case earlier *)
  83.202 -      primrec_error_eqn "recursive call not directly applied to constructor argument" t)
  83.203 -  end;
  83.204 -
  83.205 -fun build_rec_arg lthy (funs_data : eqn_data list list) has_call (ctr_spec : rec_ctr_spec)
  83.206 -    (maybe_eqn_data : eqn_data option) =
  83.207 -  if is_none maybe_eqn_data then undef_const else
  83.208 -    let
  83.209 -      val eqn_data = the maybe_eqn_data;
  83.210 -      val t = #rhs_term eqn_data;
  83.211 -      val ctr_args = #ctr_args eqn_data;
  83.212 -
  83.213 -      val calls = #calls ctr_spec;
  83.214 -      val n_args = fold (curry (op +) o (fn Direct_Rec _ => 2 | _ => 1)) calls 0;
  83.215 -
  83.216 -      val no_calls' = tag_list 0 calls
  83.217 -        |> map_filter (try (apsnd (fn No_Rec n => n | Direct_Rec (n, _) => n)));
  83.218 -      val direct_calls' = tag_list 0 calls
  83.219 -        |> map_filter (try (apsnd (fn Direct_Rec (_, n) => n)));
  83.220 -      val indirect_calls' = tag_list 0 calls
  83.221 -        |> map_filter (try (apsnd (fn Indirect_Rec n => n)));
  83.222 -
  83.223 -      fun make_direct_type _ = dummyT; (* FIXME? *)
  83.224 -
  83.225 -      val rec_res_type_list = map (fn (x :: _) => (#rec_type x, #res_type x)) funs_data;
  83.226 -
  83.227 -      fun make_indirect_type (Type (Tname, Ts)) = Type (Tname, Ts |> map (fn T =>
  83.228 -        let val maybe_res_type = AList.lookup (op =) rec_res_type_list T in
  83.229 -          if is_some maybe_res_type
  83.230 -          then HOLogic.mk_prodT (T, the maybe_res_type)
  83.231 -          else make_indirect_type T end))
  83.232 -        | make_indirect_type T = T;
  83.233 -
  83.234 -      val args = replicate n_args ("", dummyT)
  83.235 -        |> Term.rename_wrt_term t
  83.236 -        |> map Free
  83.237 -        |> fold (fn (ctr_arg_idx, arg_idx) =>
  83.238 -            nth_map arg_idx (K (nth ctr_args ctr_arg_idx)))
  83.239 -          no_calls'
  83.240 -        |> fold (fn (ctr_arg_idx, arg_idx) =>
  83.241 -            nth_map arg_idx (K (nth ctr_args ctr_arg_idx |> map_types make_direct_type)))
  83.242 -          direct_calls'
  83.243 -        |> fold (fn (ctr_arg_idx, arg_idx) =>
  83.244 -            nth_map arg_idx (K (nth ctr_args ctr_arg_idx |> map_types make_indirect_type)))
  83.245 -          indirect_calls';
  83.246 -
  83.247 -      val fun_name_ctr_pos_list =
  83.248 -        map (fn (x :: _) => (#fun_name x, length (#left_args x))) funs_data;
  83.249 -      val get_ctr_pos = try (the o AList.lookup (op =) fun_name_ctr_pos_list) #> the_default ~1;
  83.250 -      val direct_calls = map (apfst (nth ctr_args) o apsnd (nth args)) direct_calls';
  83.251 -      val indirect_calls = map (apfst (nth ctr_args) o apsnd (nth args)) indirect_calls';
  83.252 -
  83.253 -      val abstractions = args @ #left_args eqn_data @ #right_args eqn_data;
  83.254 -    in
  83.255 -      t
  83.256 -      |> subst_rec_calls lthy get_ctr_pos has_call ctr_args direct_calls indirect_calls
  83.257 -      |> fold_rev lambda abstractions
  83.258 -    end;
  83.259 -
  83.260 -fun build_defs lthy bs mxs (funs_data : eqn_data list list) (rec_specs : rec_spec list) has_call =
  83.261 -  let
  83.262 -    val n_funs = length funs_data;
  83.263 -
  83.264 -    val ctr_spec_eqn_data_list' =
  83.265 -      (take n_funs rec_specs |> map #ctr_specs) ~~ funs_data
  83.266 -      |> maps (uncurry (finds (fn (x, y) => #ctr x = #ctr y))
  83.267 -          ##> (fn x => null x orelse
  83.268 -            primrec_error_eqns "excess equations in definition" (map #rhs_term x)) #> fst);
  83.269 -    val _ = ctr_spec_eqn_data_list' |> map (fn (_, x) => length x <= 1 orelse
  83.270 -      primrec_error_eqns ("multiple equations for constructor") (map #user_eqn x));
  83.271 -
  83.272 -    val ctr_spec_eqn_data_list =
  83.273 -      ctr_spec_eqn_data_list' @ (drop n_funs rec_specs |> maps #ctr_specs |> map (rpair []));
  83.274 -
  83.275 -    val recs = take n_funs rec_specs |> map #recx;
  83.276 -    val rec_args = ctr_spec_eqn_data_list
  83.277 -      |> sort ((op <) o pairself (#offset o fst) |> make_ord)
  83.278 -      |> map (uncurry (build_rec_arg lthy funs_data has_call) o apsnd (try the_single));
  83.279 -    val ctr_poss = map (fn x =>
  83.280 -      if length (distinct ((op =) o pairself (length o #left_args)) x) <> 1 then
  83.281 -        primrec_error ("inconstant constructor pattern position for function " ^
  83.282 -          quote (#fun_name (hd x)))
  83.283 -      else
  83.284 -        hd x |> #left_args |> length) funs_data;
  83.285 -  in
  83.286 -    (recs, ctr_poss)
  83.287 -    |-> map2 (fn recx => fn ctr_pos => list_comb (recx, rec_args) |> permute_args ctr_pos)
  83.288 -    |> Syntax.check_terms lthy
  83.289 -    |> map3 (fn b => fn mx => fn t => ((b, mx), ((Binding.map_name Thm.def_name b, []), t))) bs mxs
  83.290 -  end;
  83.291 -
  83.292 -fun find_rec_calls has_call (eqn_data : eqn_data) =
  83.293 -  let
  83.294 -    fun find (Abs (_, _, b)) ctr_arg = find b ctr_arg
  83.295 -      | find (t as _ $ _) ctr_arg =
  83.296 -        let
  83.297 -          val (f', args') = strip_comb t;
  83.298 -          val n = find_index (equal ctr_arg) args';
  83.299 -        in
  83.300 -          if n < 0 then
  83.301 -            find f' ctr_arg @ maps (fn x => find x ctr_arg) args'
  83.302 -          else
  83.303 -            let val (f, args) = chop n args' |>> curry list_comb f' in
  83.304 -              if has_call f then
  83.305 -                f :: maps (fn x => find x ctr_arg) args
  83.306 -              else
  83.307 -                find f ctr_arg @ maps (fn x => find x ctr_arg) args
  83.308 -            end
  83.309 -        end
  83.310 -      | find _ _ = [];
  83.311 -  in
  83.312 -    map (find (#rhs_term eqn_data)) (#ctr_args eqn_data)
  83.313 -    |> (fn [] => NONE | callss => SOME (#ctr eqn_data, callss))
  83.314 -  end;
  83.315 -
  83.316 -fun prepare_primrec fixes specs lthy =
  83.317 -  let
  83.318 -    val (bs, mxs) = map_split (apfst fst) fixes;
  83.319 -    val fun_names = map Binding.name_of bs;
  83.320 -    val eqns_data = map (dissect_eqn lthy fun_names) specs;
  83.321 -    val funs_data = eqns_data
  83.322 -      |> partition_eq ((op =) o pairself #fun_name)
  83.323 -      |> finds (fn (x, y) => x = #fun_name (hd y)) fun_names |> fst
  83.324 -      |> map (fn (x, y) => the_single y handle List.Empty =>
  83.325 -          primrec_error ("missing equations for function " ^ quote x));
  83.326 -
  83.327 -    val has_call = exists_subterm (map (fst #>> Binding.name_of #> Free) fixes |> member (op =));
  83.328 -    val arg_Ts = map (#rec_type o hd) funs_data;
  83.329 -    val res_Ts = map (#res_type o hd) funs_data;
  83.330 -    val callssss = funs_data
  83.331 -      |> map (partition_eq ((op =) o pairself #ctr))
  83.332 -      |> map (maps (map_filter (find_rec_calls has_call)));
  83.333 -
  83.334 -    val ((n2m, rec_specs, _, induct_thm, induct_thms), lthy') =
  83.335 -      rec_specs_of bs arg_Ts res_Ts (get_indices fixes) callssss lthy;
  83.336 -
  83.337 -    val actual_nn = length funs_data;
  83.338 -
  83.339 -    val _ = let val ctrs = (maps (map #ctr o #ctr_specs) rec_specs) in
  83.340 -      map (fn {ctr, user_eqn, ...} => member (op =) ctrs ctr orelse
  83.341 -        primrec_error_eqn ("argument " ^ quote (Syntax.string_of_term lthy' ctr) ^
  83.342 -          " is not a constructor in left-hand side") user_eqn) eqns_data end;
  83.343 -
  83.344 -    val defs = build_defs lthy' bs mxs funs_data rec_specs has_call;
  83.345 -
  83.346 -    fun prove lthy def_thms' ({ctr_specs, nested_map_idents, nested_map_comps, ...} : rec_spec)
  83.347 -        (fun_data : eqn_data list) =
  83.348 -      let
  83.349 -        val def_thms = map (snd o snd) def_thms';
  83.350 -        val simp_thmss = finds (fn (x, y) => #ctr x = #ctr y) fun_data ctr_specs
  83.351 -          |> fst
  83.352 -          |> map_filter (try (fn (x, [y]) =>
  83.353 -            (#user_eqn x, length (#left_args x) + length (#right_args x), #rec_thm y)))
  83.354 -          |> map (fn (user_eqn, num_extra_args, rec_thm) =>
  83.355 -            mk_primrec_tac lthy num_extra_args nested_map_idents nested_map_comps def_thms rec_thm
  83.356 -            |> K |> Goal.prove lthy [] [] user_eqn);
  83.357 -        val poss = find_indices (fn (x, y) => #ctr x = #ctr y) fun_data eqns_data;
  83.358 -      in
  83.359 -        (poss, simp_thmss)
  83.360 -      end;
  83.361 -
  83.362 -    val notes =
  83.363 -      (if n2m then map2 (fn name => fn thm =>
  83.364 -        (name, inductN, [thm], [])) fun_names (take actual_nn induct_thms) else [])
  83.365 -      |> map (fn (prefix, thmN, thms, attrs) =>
  83.366 -        ((Binding.qualify true prefix (Binding.name thmN), attrs), [(thms, [])]));
  83.367 -
  83.368 -    val common_name = mk_common_name fun_names;
  83.369 -
  83.370 -    val common_notes =
  83.371 -      (if n2m then [(inductN, [induct_thm], [])] else [])
  83.372 -      |> map (fn (thmN, thms, attrs) =>
  83.373 -        ((Binding.qualify true common_name (Binding.name thmN), attrs), [(thms, [])]));
  83.374 -  in
  83.375 -    (((fun_names, defs),
  83.376 -      fn lthy => fn defs =>
  83.377 -        split_list (map2 (prove lthy defs) (take actual_nn rec_specs) funs_data)),
  83.378 -      lthy' |> Local_Theory.notes (notes @ common_notes) |> snd)
  83.379 -  end;
  83.380 -
  83.381 -(* primrec definition *)
  83.382 -
  83.383 -fun add_primrec_simple fixes ts lthy =
  83.384 -  let
  83.385 -    val (((names, defs), prove), lthy) = prepare_primrec fixes ts lthy
  83.386 -      handle ERROR str => primrec_error str;
  83.387 -  in
  83.388 -    lthy
  83.389 -    |> fold_map Local_Theory.define defs
  83.390 -    |-> (fn defs => `(fn lthy => (names, (map fst defs, prove lthy defs))))
  83.391 -  end
  83.392 -  handle Primrec_Error (str, eqns) =>
  83.393 -    if null eqns
  83.394 -    then error ("primrec_new error:\n  " ^ str)
  83.395 -    else error ("primrec_new error:\n  " ^ str ^ "\nin\n  " ^
  83.396 -      space_implode "\n  " (map (quote o Syntax.string_of_term lthy) eqns));
  83.397 -
  83.398 -local
  83.399 -
  83.400 -fun gen_primrec prep_spec (raw_fixes : (binding * 'a option * mixfix) list) raw_spec lthy =
  83.401 -  let
  83.402 -    val d = duplicates (op =) (map (Binding.name_of o #1) raw_fixes)
  83.403 -    val _ = null d orelse primrec_error ("duplicate function name(s): " ^ commas d);
  83.404 -
  83.405 -    val (fixes, specs) = fst (prep_spec raw_fixes raw_spec lthy);
  83.406 -
  83.407 -    val mk_notes =
  83.408 -      flat ooo map3 (fn poss => fn prefix => fn thms =>
  83.409 -        let
  83.410 -          val (bs, attrss) = map_split (fst o nth specs) poss;
  83.411 -          val notes =
  83.412 -            map3 (fn b => fn attrs => fn thm =>
  83.413 -              ((Binding.qualify false prefix b, code_nitpick_simp_attrs @ attrs), [([thm], [])]))
  83.414 -            bs attrss thms;
  83.415 -        in
  83.416 -          ((Binding.qualify true prefix (Binding.name simpsN), []), [(thms, [])]) :: notes
  83.417 -        end);
  83.418 -  in
  83.419 -    lthy
  83.420 -    |> add_primrec_simple fixes (map snd specs)
  83.421 -    |-> (fn (names, (ts, (posss, simpss))) =>
  83.422 -      Spec_Rules.add Spec_Rules.Equational (ts, flat simpss)
  83.423 -      #> Local_Theory.notes (mk_notes posss names simpss)
  83.424 -      #>> pair ts o map snd)
  83.425 -  end;
  83.426 -
  83.427 -in
  83.428 -
  83.429 -val add_primrec = gen_primrec Specification.check_spec;
  83.430 -val add_primrec_cmd = gen_primrec Specification.read_spec;
  83.431 -
  83.432 -end;
  83.433 -
  83.434 -fun add_primrec_global fixes specs thy =
  83.435 -  let
  83.436 -    val lthy = Named_Target.theory_init thy;
  83.437 -    val ((ts, simps), lthy') = add_primrec fixes specs lthy;
  83.438 -    val simps' = burrow (Proof_Context.export lthy' lthy) simps;
  83.439 -  in ((ts, simps'), Local_Theory.exit_global lthy') end;
  83.440 -
  83.441 -fun add_primrec_overloaded ops fixes specs thy =
  83.442 -  let
  83.443 -    val lthy = Overloading.overloading ops thy;
  83.444 -    val ((ts, simps), lthy') = add_primrec fixes specs lthy;
  83.445 -    val simps' = burrow (Proof_Context.export lthy' lthy) simps;
  83.446 -  in ((ts, simps'), Local_Theory.exit_global lthy') end;
  83.447 -
  83.448 -
  83.449 -
  83.450 -(* Primcorec *)
  83.451 -
  83.452 -type co_eqn_data_disc = {
  83.453 -  fun_name: string,
  83.454 -  fun_T: typ,
  83.455 -  fun_args: term list,
  83.456 -  ctr: term,
  83.457 -  ctr_no: int, (*###*)
  83.458 -  disc: term,
  83.459 -  prems: term list,
  83.460 -  auto_gen: bool,
  83.461 -  user_eqn: term
  83.462 -};
  83.463 -
  83.464 -type co_eqn_data_sel = {
  83.465 -  fun_name: string,
  83.466 -  fun_T: typ,
  83.467 -  fun_args: term list,
  83.468 -  ctr: term,
  83.469 -  sel: term,
  83.470 -  rhs_term: term,
  83.471 -  user_eqn: term
  83.472 -};
  83.473 -
  83.474 -datatype co_eqn_data =
  83.475 -  Disc of co_eqn_data_disc |
  83.476 -  Sel of co_eqn_data_sel;
  83.477 -
  83.478 -fun co_dissect_eqn_disc sequential fun_names (corec_specs : corec_spec list) prems' concl
  83.479 -    matchedsss =
  83.480 -  let
  83.481 -    fun find_subterm p = let (* FIXME \<exists>? *)
  83.482 -      fun f (t as u $ v) = if p t then SOME t else merge_options (f u, f v)
  83.483 -        | f t = if p t then SOME t else NONE
  83.484 -      in f end;
  83.485 -
  83.486 -    val applied_fun = concl
  83.487 -      |> find_subterm (member ((op =) o apsnd SOME) fun_names o try (fst o dest_Free o head_of))
  83.488 -      |> the
  83.489 -      handle Option.Option => primrec_error_eqn "malformed discriminator equation" concl;
  83.490 -    val ((fun_name, fun_T), fun_args) = strip_comb applied_fun |>> dest_Free;
  83.491 -    val {ctr_specs, ...} = the (AList.lookup (op =) (fun_names ~~ corec_specs) fun_name);
  83.492 -
  83.493 -    val discs = map #disc ctr_specs;
  83.494 -    val ctrs = map #ctr ctr_specs;
  83.495 -    val not_disc = head_of concl = @{term Not};
  83.496 -    val _ = not_disc andalso length ctrs <> 2 andalso
  83.497 -      primrec_error_eqn "\<not>ed discriminator for a type with \<noteq> 2 constructors" concl;
  83.498 -    val disc = find_subterm (member (op =) discs o head_of) concl;
  83.499 -    val eq_ctr0 = concl |> perhaps (try (HOLogic.dest_not)) |> try (HOLogic.dest_eq #> snd)
  83.500 -        |> (fn SOME t => let val n = find_index (equal t) ctrs in
  83.501 -          if n >= 0 then SOME n else NONE end | _ => NONE);
  83.502 -    val _ = is_some disc orelse is_some eq_ctr0 orelse
  83.503 -      primrec_error_eqn "no discriminator in equation" concl;
  83.504 -    val ctr_no' =
  83.505 -      if is_none disc then the eq_ctr0 else find_index (equal (head_of (the disc))) discs;
  83.506 -    val ctr_no = if not_disc then 1 - ctr_no' else ctr_no';
  83.507 -    val ctr = #ctr (nth ctr_specs ctr_no);
  83.508 -
  83.509 -    val catch_all = try (fst o dest_Free o the_single) prems' = SOME Name.uu_;
  83.510 -    val matchedss = AList.lookup (op =) matchedsss fun_name |> the_default [];
  83.511 -    val prems = map (abstract (List.rev fun_args)) prems';
  83.512 -    val real_prems =
  83.513 -      (if catch_all orelse sequential then maps negate_disj matchedss else []) @
  83.514 -      (if catch_all then [] else prems);
  83.515 -
  83.516 -    val matchedsss' = AList.delete (op =) fun_name matchedsss
  83.517 -      |> cons (fun_name, if sequential then matchedss @ [prems] else matchedss @ [real_prems]);
  83.518 -
  83.519 -    val user_eqn =
  83.520 -      (real_prems, betapply (#disc (nth ctr_specs ctr_no), applied_fun))
  83.521 -      |>> map HOLogic.mk_Trueprop ||> HOLogic.mk_Trueprop
  83.522 -      |> Logic.list_implies;
  83.523 -  in
  83.524 -    (Disc {
  83.525 -      fun_name = fun_name,
  83.526 -      fun_T = fun_T,
  83.527 -      fun_args = fun_args,
  83.528 -      ctr = ctr,
  83.529 -      ctr_no = ctr_no,
  83.530 -      disc = #disc (nth ctr_specs ctr_no),
  83.531 -      prems = real_prems,
  83.532 -      auto_gen = catch_all,
  83.533 -      user_eqn = user_eqn
  83.534 -    }, matchedsss')
  83.535 -  end;
  83.536 -
  83.537 -fun co_dissect_eqn_sel fun_names (corec_specs : corec_spec list) eqn' of_spec eqn =
  83.538 -  let
  83.539 -    val (lhs, rhs) = HOLogic.dest_eq eqn
  83.540 -      handle TERM _ =>
  83.541 -        primrec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn;
  83.542 -    val sel = head_of lhs;
  83.543 -    val ((fun_name, fun_T), fun_args) = dest_comb lhs |> snd |> strip_comb |> apfst dest_Free
  83.544 -      handle TERM _ =>
  83.545 -        primrec_error_eqn "malformed selector argument in left-hand side" eqn;
  83.546 -    val corec_spec = the (AList.lookup (op =) (fun_names ~~ corec_specs) fun_name)
  83.547 -      handle Option.Option => primrec_error_eqn "malformed selector argument in left-hand side" eqn;
  83.548 -    val ctr_spec =
  83.549 -      if is_some of_spec
  83.550 -      then the (find_first (equal (the of_spec) o #ctr) (#ctr_specs corec_spec))
  83.551 -      else #ctr_specs corec_spec |> filter (exists (equal sel) o #sels) |> the_single
  83.552 -        handle List.Empty => primrec_error_eqn "ambiguous selector - use \"of\"" eqn;
  83.553 -    val user_eqn = drop_All eqn';
  83.554 -  in
  83.555 -    Sel {
  83.556 -      fun_name = fun_name,
  83.557 -      fun_T = fun_T,
  83.558 -      fun_args = fun_args,
  83.559 -      ctr = #ctr ctr_spec,
  83.560 -      sel = sel,
  83.561 -      rhs_term = rhs,
  83.562 -      user_eqn = user_eqn
  83.563 -    }
  83.564 -  end;
  83.565 -
  83.566 -fun co_dissect_eqn_ctr sequential fun_names (corec_specs : corec_spec list) eqn' imp_prems imp_rhs
  83.567 -    matchedsss =
  83.568 -  let
  83.569 -    val (lhs, rhs) = HOLogic.dest_eq imp_rhs;
  83.570 -    val fun_name = head_of lhs |> fst o dest_Free;
  83.571 -    val {ctr_specs, ...} = the (AList.lookup (op =) (fun_names ~~ corec_specs) fun_name);
  83.572 -    val (ctr, ctr_args) = strip_comb rhs;
  83.573 -    val {disc, sels, ...} = the (find_first (equal ctr o #ctr) ctr_specs)
  83.574 -      handle Option.Option => primrec_error_eqn "not a constructor" ctr;
  83.575 -
  83.576 -    val disc_imp_rhs = betapply (disc, lhs);
  83.577 -    val (maybe_eqn_data_disc, matchedsss') = if length ctr_specs = 1
  83.578 -      then (NONE, matchedsss)
  83.579 -      else apfst SOME (co_dissect_eqn_disc
  83.580 -          sequential fun_names corec_specs imp_prems disc_imp_rhs matchedsss);
  83.581 -
  83.582 -    val sel_imp_rhss = (sels ~~ ctr_args)
  83.583 -      |> map (fn (sel, ctr_arg) => HOLogic.mk_eq (betapply (sel, lhs), ctr_arg));
  83.584 -
  83.585 -(*
  83.586 -val _ = tracing ("reduced\n    " ^ Syntax.string_of_term @{context} imp_rhs ^ "\nto\n    \<cdot> " ^
  83.587 - (is_some maybe_eqn_data_disc ? K (Syntax.string_of_term @{context} disc_imp_rhs ^ "\n    \<cdot> ")) "" ^
  83.588 - space_implode "\n    \<cdot> " (map (Syntax.string_of_term @{context}) sel_imp_rhss));
  83.589 -*)
  83.590 -
  83.591 -    val eqns_data_sel =
  83.592 -      map (co_dissect_eqn_sel fun_names corec_specs eqn' (SOME ctr)) sel_imp_rhss;
  83.593 -  in
  83.594 -    (the_list maybe_eqn_data_disc @ eqns_data_sel, matchedsss')
  83.595 -  end;
  83.596 -
  83.597 -fun co_dissect_eqn sequential fun_names (corec_specs : corec_spec list) eqn' of_spec matchedsss =
  83.598 -  let
  83.599 -    val eqn = drop_All eqn'
  83.600 -      handle TERM _ => primrec_error_eqn "malformed function equation" eqn';
  83.601 -    val (imp_prems, imp_rhs) = Logic.strip_horn eqn
  83.602 -      |> apfst (map HOLogic.dest_Trueprop) o apsnd HOLogic.dest_Trueprop;
  83.603 -
  83.604 -    val head = imp_rhs
  83.605 -      |> perhaps (try HOLogic.dest_not) |> perhaps (try (fst o HOLogic.dest_eq))
  83.606 -      |> head_of;
  83.607 -
  83.608 -    val maybe_rhs = imp_rhs |> perhaps (try (HOLogic.dest_not)) |> try (snd o HOLogic.dest_eq);
  83.609 -
  83.610 -    val discs = maps #ctr_specs corec_specs |> map #disc;
  83.611 -    val sels = maps #ctr_specs corec_specs |> maps #sels;
  83.612 -    val ctrs = maps #ctr_specs corec_specs |> map #ctr;
  83.613 -  in
  83.614 -    if member (op =) discs head orelse
  83.615 -      is_some maybe_rhs andalso
  83.616 -        member (op =) (filter (null o binder_types o fastype_of) ctrs) (the maybe_rhs) then
  83.617 -      co_dissect_eqn_disc sequential fun_names corec_specs imp_prems imp_rhs matchedsss
  83.618 -      |>> single
  83.619 -    else if member (op =) sels head then
  83.620 -      ([co_dissect_eqn_sel fun_names corec_specs eqn' of_spec imp_rhs], matchedsss)
  83.621 -    else if is_Free head andalso member (op =) fun_names (fst (dest_Free head)) then
  83.622 -      co_dissect_eqn_ctr sequential fun_names corec_specs eqn' imp_prems imp_rhs matchedsss
  83.623 -    else
  83.624 -      primrec_error_eqn "malformed function equation" eqn
  83.625 -  end;
  83.626 -
  83.627 -fun build_corec_arg_disc (ctr_specs : corec_ctr_spec list)
  83.628 -    ({fun_args, ctr_no, prems, ...} : co_eqn_data_disc) =
  83.629 -  if is_none (#pred (nth ctr_specs ctr_no)) then I else
  83.630 -    mk_conjs prems
  83.631 -    |> curry subst_bounds (List.rev fun_args)
  83.632 -    |> HOLogic.tupled_lambda (HOLogic.mk_tuple fun_args)
  83.633 -    |> K |> nth_map (the (#pred (nth ctr_specs ctr_no)));
  83.634 -
  83.635 -fun build_corec_arg_no_call (sel_eqns : co_eqn_data_sel list) sel =
  83.636 -  find_first (equal sel o #sel) sel_eqns
  83.637 -  |> try (fn SOME {fun_args, rhs_term, ...} => abs_tuple fun_args rhs_term)
  83.638 -  |> the_default undef_const
  83.639 -  |> K;
  83.640 -
  83.641 -fun build_corec_args_direct_call lthy has_call (sel_eqns : co_eqn_data_sel list) sel =
  83.642 -  let
  83.643 -    val maybe_sel_eqn = find_first (equal sel o #sel) sel_eqns;
  83.644 -  in
  83.645 -    if is_none maybe_sel_eqn then (I, I, I) else
  83.646 -    let
  83.647 -      val {fun_args, rhs_term, ... } = the maybe_sel_eqn;
  83.648 -      fun rewrite_q _ t = if has_call t then @{term False} else @{term True};
  83.649 -      fun rewrite_g _ t = if has_call t then undef_const else t;
  83.650 -      fun rewrite_h bound_Ts t =
  83.651 -        if has_call t then mk_tuple1 bound_Ts (snd (strip_comb t)) else undef_const;
  83.652 -      fun massage f t = massage_direct_corec_call lthy has_call f [] rhs_term |> abs_tuple fun_args;
  83.653 -    in
  83.654 -      (massage rewrite_q,
  83.655 -       massage rewrite_g,
  83.656 -       massage rewrite_h)
  83.657 -    end
  83.658 -  end;
  83.659 -
  83.660 -fun build_corec_arg_indirect_call lthy has_call (sel_eqns : co_eqn_data_sel list) sel =
  83.661 -  let
  83.662 -    val maybe_sel_eqn = find_first (equal sel o #sel) sel_eqns;
  83.663 -  in
  83.664 -    if is_none maybe_sel_eqn then I else
  83.665 -    let
  83.666 -      val {fun_args, rhs_term, ...} = the maybe_sel_eqn;
  83.667 -      fun rewrite bound_Ts U T (Abs (v, V, b)) = Abs (v, V, rewrite (V :: bound_Ts) U T b)
  83.668 -        | rewrite bound_Ts U T (t as _ $ _) =
  83.669 -          let val (u, vs) = strip_comb t in
  83.670 -            if is_Free u andalso has_call u then
  83.671 -              Inr_const U T $ mk_tuple1 bound_Ts vs
  83.672 -            else if try (fst o dest_Const) u = SOME @{const_name prod_case} then
  83.673 -              map (rewrite bound_Ts U T) vs |> chop 1 |>> HOLogic.mk_split o the_single |> list_comb
  83.674 -            else
  83.675 -              list_comb (rewrite bound_Ts U T u, map (rewrite bound_Ts U T) vs)
  83.676 -          end
  83.677 -        | rewrite _ U T t =
  83.678 -          if is_Free t andalso has_call t then Inr_const U T $ HOLogic.unit else t;
  83.679 -      fun massage t =
  83.680 -        massage_indirect_corec_call lthy has_call rewrite [] (range_type (fastype_of t)) rhs_term
  83.681 -        |> abs_tuple fun_args;
  83.682 -    in
  83.683 -      massage
  83.684 -    end
  83.685 -  end;
  83.686 -
  83.687 -fun build_corec_args_sel lthy has_call (all_sel_eqns : co_eqn_data_sel list)
  83.688 -    (ctr_spec : corec_ctr_spec) =
  83.689 -  let val sel_eqns = filter (equal (#ctr ctr_spec) o #ctr) all_sel_eqns in
  83.690 -    if null sel_eqns then I else
  83.691 -      let
  83.692 -        val sel_call_list = #sels ctr_spec ~~ #calls ctr_spec;
  83.693 -
  83.694 -        val no_calls' = map_filter (try (apsnd (fn No_Corec n => n))) sel_call_list;
  83.695 -        val direct_calls' = map_filter (try (apsnd (fn Direct_Corec n => n))) sel_call_list;
  83.696 -        val indirect_calls' = map_filter (try (apsnd (fn Indirect_Corec n => n))) sel_call_list;
  83.697 -      in
  83.698 -        I
  83.699 -        #> fold (fn (sel, n) => nth_map n (build_corec_arg_no_call sel_eqns sel)) no_calls'
  83.700 -        #> fold (fn (sel, (q, g, h)) =>
  83.701 -          let val (fq, fg, fh) = build_corec_args_direct_call lthy has_call sel_eqns sel in
  83.702 -            nth_map q fq o nth_map g fg o nth_map h fh end) direct_calls'
  83.703 -        #> fold (fn (sel, n) => nth_map n
  83.704 -          (build_corec_arg_indirect_call lthy has_call sel_eqns sel)) indirect_calls'
  83.705 -      end
  83.706 -  end;
  83.707 -
  83.708 -fun co_build_defs lthy bs mxs has_call arg_Tss (corec_specs : corec_spec list)
  83.709 -    (disc_eqnss : co_eqn_data_disc list list) (sel_eqnss : co_eqn_data_sel list list) =
  83.710 -  let
  83.711 -    val corec_specs' = take (length bs) corec_specs;
  83.712 -    val corecs = map #corec corec_specs';
  83.713 -    val ctr_specss = map #ctr_specs corec_specs';
  83.714 -    val corec_args = hd corecs
  83.715 -      |> fst o split_last o binder_types o fastype_of
  83.716 -      |> map (Const o pair @{const_name undefined})
  83.717 -      |> fold2 (fold o build_corec_arg_disc) ctr_specss disc_eqnss
  83.718 -      |> fold2 (fold o build_corec_args_sel lthy has_call) sel_eqnss ctr_specss;
  83.719 -    fun currys [] t = t
  83.720 -      | currys Ts t = t $ mk_tuple1 (List.rev Ts) (map Bound (length Ts - 1 downto 0))
  83.721 -          |> fold_rev (Term.abs o pair Name.uu) Ts;
  83.722 -
  83.723 -(*
  83.724 -val _ = tracing ("corecursor arguments:\n    \<cdot> " ^
  83.725 - space_implode "\n    \<cdot> " (map (Syntax.string_of_term lthy) corec_args));
  83.726 -*)
  83.727 -
  83.728 -    val exclss' =
  83.729 -      disc_eqnss
  83.730 -      |> map (map (fn x => (#fun_args x, #ctr_no x, #prems x, #auto_gen x))
  83.731 -        #> fst o (fn xs => fold_map (fn x => fn ys => ((x, ys), ys @ [x])) xs [])
  83.732 -        #> maps (uncurry (map o pair)
  83.733 -          #> map (fn ((fun_args, c, x, a), (_, c', y, a')) =>
  83.734 -              ((c, c', a orelse a'), (x, s_not (mk_conjs y)))
  83.735 -            ||> apfst (map HOLogic.mk_Trueprop) o apsnd HOLogic.mk_Trueprop
  83.736 -            ||> Logic.list_implies
  83.737 -            ||> curry Logic.list_all (map dest_Free fun_args))))
  83.738 -  in
  83.739 -    map (list_comb o rpair corec_args) corecs
  83.740 -    |> map2 (fn Ts => fn t => if length Ts = 0 then t $ HOLogic.unit else t) arg_Tss
  83.741 -    |> map2 currys arg_Tss
  83.742 -    |> Syntax.check_terms lthy
  83.743 -    |> map3 (fn b => fn mx => fn t => ((b, mx), ((Binding.map_name Thm.def_name b, []), t))) bs mxs
  83.744 -    |> rpair exclss'
  83.745 -  end;
  83.746 -
  83.747 -fun mk_real_disc_eqns fun_binding arg_Ts ({ctr_specs, ...} : corec_spec)
  83.748 -    (sel_eqns : co_eqn_data_sel list) (disc_eqns : co_eqn_data_disc list) =
  83.749 -  if length disc_eqns <> length ctr_specs - 1 then disc_eqns else
  83.750 -    let
  83.751 -      val n = 0 upto length ctr_specs
  83.752 -        |> the o find_first (fn idx => not (exists (equal idx o #ctr_no) disc_eqns));
  83.753 -      val fun_args = (try (#fun_args o hd) disc_eqns, try (#fun_args o hd) sel_eqns)
  83.754 -        |> the_default (map (curry Free Name.uu) arg_Ts) o merge_options;
  83.755 -      val extra_disc_eqn = {
  83.756 -        fun_name = Binding.name_of fun_binding,
  83.757 -        fun_T = arg_Ts ---> body_type (fastype_of (#ctr (hd ctr_specs))),
  83.758 -        fun_args = fun_args,
  83.759 -        ctr = #ctr (nth ctr_specs n),
  83.760 -        ctr_no = n,
  83.761 -        disc = #disc (nth ctr_specs n),
  83.762 -        prems = maps (negate_conj o #prems) disc_eqns,
  83.763 -        auto_gen = true,
  83.764 -        user_eqn = undef_const};
  83.765 -    in
  83.766 -      chop n disc_eqns ||> cons extra_disc_eqn |> (op @)
  83.767 -    end;
  83.768 -
  83.769 -fun add_primcorec simple sequential fixes specs of_specs lthy =
  83.770 -  let
  83.771 -    val (bs, mxs) = map_split (apfst fst) fixes;
  83.772 -    val (arg_Ts, res_Ts) = map (strip_type o snd o fst #>> HOLogic.mk_tupleT) fixes |> split_list;
  83.773 -
  83.774 -    val callssss = []; (* FIXME *)
  83.775 -
  83.776 -    val ((n2m, corec_specs', _, coinduct_thm, strong_coinduct_thm, coinduct_thms,
  83.777 -          strong_coinduct_thms), lthy') =
  83.778 -      corec_specs_of bs arg_Ts res_Ts (get_indices fixes) callssss lthy;
  83.779 -
  83.780 -    val actual_nn = length bs;
  83.781 -    val fun_names = map Binding.name_of bs;
  83.782 -    val corec_specs = take actual_nn corec_specs'; (*###*)
  83.783 -
  83.784 -    val eqns_data =
  83.785 -      fold_map2 (co_dissect_eqn sequential fun_names corec_specs) (map snd specs) of_specs []
  83.786 -      |> flat o fst;
  83.787 -
  83.788 -    val disc_eqnss' = map_filter (try (fn Disc x => x)) eqns_data
  83.789 -      |> partition_eq ((op =) o pairself #fun_name)
  83.790 -      |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names
  83.791 -      |> map (sort ((op <) o pairself #ctr_no |> make_ord) o flat o snd);
  83.792 -    val _ = disc_eqnss' |> map (fn x =>
  83.793 -      let val d = duplicates ((op =) o pairself #ctr_no) x in null d orelse
  83.794 -        primrec_error_eqns "excess discriminator equations in definition"
  83.795 -          (maps (fn t => filter (equal (#ctr_no t) o #ctr_no) x) d |> map #user_eqn) end);
  83.796 -
  83.797 -    val sel_eqnss = map_filter (try (fn Sel x => x)) eqns_data
  83.798 -      |> partition_eq ((op =) o pairself #fun_name)
  83.799 -      |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names
  83.800 -      |> map (flat o snd);
  83.801 -
  83.802 -    val has_call = exists_subterm (map (fst #>> Binding.name_of #> Free) fixes |> member (op =));
  83.803 -    val arg_Tss = map (binder_types o snd o fst) fixes;
  83.804 -    val disc_eqnss = map5 mk_real_disc_eqns bs arg_Tss corec_specs sel_eqnss disc_eqnss';
  83.805 -    val (defs, exclss') =
  83.806 -      co_build_defs lthy' bs mxs has_call arg_Tss corec_specs disc_eqnss sel_eqnss;
  83.807 -
  83.808 -    fun excl_tac (c, c', a) =
  83.809 -      if a orelse c = c' orelse sequential then
  83.810 -        SOME (K (HEADGOAL (mk_primcorec_assumption_tac lthy [])))
  83.811 -      else if simple then
  83.812 -        SOME (K (auto_tac lthy))
  83.813 -      else
  83.814 -        NONE;
  83.815 -
  83.816 -(*
  83.817 -val _ = tracing ("exclusiveness properties:\n    \<cdot> " ^
  83.818 - space_implode "\n    \<cdot> " (maps (map (Syntax.string_of_term lthy o snd)) exclss'));
  83.819 -*)
  83.820 -
  83.821 -    val exclss'' = exclss' |> map (map (fn (idx, t) =>
  83.822 -      (idx, (Option.map (Goal.prove lthy [] [] t) (excl_tac idx), t))));
  83.823 -    val taut_thmss = map (map (apsnd (the o fst)) o filter (is_some o fst o snd)) exclss'';
  83.824 -    val (obligation_idxss, obligationss) = exclss''
  83.825 -      |> map (map (apsnd (rpair [] o snd)) o filter (is_none o fst o snd))
  83.826 -      |> split_list o map split_list;
  83.827 -
  83.828 -    fun prove thmss' def_thms' lthy =
  83.829 -      let
  83.830 -        val def_thms = map (snd o snd) def_thms';
  83.831 -
  83.832 -        val exclss' = map (op ~~) (obligation_idxss ~~ thmss');
  83.833 -        fun mk_exclsss excls n =
  83.834 -          (excls, map (fn k => replicate k [TrueI] @ replicate (n - k) []) (0 upto n - 1))
  83.835 -          |-> fold (fn ((c, c', _), thm) => nth_map c (nth_map c' (K [thm])));
  83.836 -        val exclssss = (exclss' ~~ taut_thmss |> map (op @), fun_names ~~ corec_specs)
  83.837 -          |-> map2 (fn excls => fn (_, {ctr_specs, ...}) => mk_exclsss excls (length ctr_specs));
  83.838 -
  83.839 -        fun prove_disc ({ctr_specs, ...} : corec_spec) exclsss
  83.840 -            ({fun_name, fun_T, fun_args, ctr_no, prems, ...} : co_eqn_data_disc) =
  83.841 -          if Term.aconv_untyped (#disc (nth ctr_specs ctr_no), @{term "\<lambda>x. x = x"}) then [] else
  83.842 -            let
  83.843 -              val {disc_corec, ...} = nth ctr_specs ctr_no;
  83.844 -              val k = 1 + ctr_no;
  83.845 -              val m = length prems;
  83.846 -              val t =
  83.847 -                list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0))
  83.848 -                |> curry betapply (#disc (nth ctr_specs ctr_no)) (*###*)
  83.849 -                |> HOLogic.mk_Trueprop
  83.850 -                |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
  83.851 -                |> curry Logic.list_all (map dest_Free fun_args);
  83.852 -            in
  83.853 -              mk_primcorec_disc_tac lthy def_thms disc_corec k m exclsss
  83.854 -              |> K |> Goal.prove lthy [] [] t
  83.855 -              |> pair (#disc (nth ctr_specs ctr_no))
  83.856 -              |> single
  83.857 -            end;
  83.858 -
  83.859 -        fun prove_sel ({nested_maps, nested_map_idents, nested_map_comps, ctr_specs, ...}
  83.860 -            : corec_spec) (disc_eqns : co_eqn_data_disc list) exclsss
  83.861 -            ({fun_name, fun_T, fun_args, ctr, sel, rhs_term, ...} : co_eqn_data_sel) =
  83.862 -          let
  83.863 -            val SOME ctr_spec = find_first (equal ctr o #ctr) ctr_specs;
  83.864 -            val ctr_no = find_index (equal ctr o #ctr) ctr_specs;
  83.865 -            val prems = the_default (maps (negate_conj o #prems) disc_eqns)
  83.866 -                (find_first (equal ctr_no o #ctr_no) disc_eqns |> Option.map #prems);
  83.867 -            val sel_corec = find_index (equal sel) (#sels ctr_spec)
  83.868 -              |> nth (#sel_corecs ctr_spec);
  83.869 -            val k = 1 + ctr_no;
  83.870 -            val m = length prems;
  83.871 -            val t =
  83.872 -              list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0))
  83.873 -              |> curry betapply sel
  83.874 -              |> rpair (abstract (List.rev fun_args) rhs_term)
  83.875 -              |> HOLogic.mk_Trueprop o HOLogic.mk_eq
  83.876 -              |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
  83.877 -              |> curry Logic.list_all (map dest_Free fun_args);
  83.878 -            val (distincts, _, sel_splits, sel_split_asms) = case_thms_of_term lthy [] rhs_term;
  83.879 -          in
  83.880 -            mk_primcorec_sel_tac lthy def_thms distincts sel_splits sel_split_asms nested_maps
  83.881 -              nested_map_idents nested_map_comps sel_corec k m exclsss
  83.882 -            |> K |> Goal.prove lthy [] [] t
  83.883 -            |> pair sel
  83.884 -          end;
  83.885 -
  83.886 -        fun prove_ctr disc_alist sel_alist (disc_eqns : co_eqn_data_disc list)
  83.887 -            (sel_eqns : co_eqn_data_sel list) ({ctr, disc, sels, collapse, ...} : corec_ctr_spec) =
  83.888 -          if not (exists (equal ctr o #ctr) disc_eqns)
  83.889 -              andalso not (exists (equal ctr o #ctr) sel_eqns)
  83.890 -            orelse (* don't try to prove theorems when some sel_eqns are missing *)
  83.891 -              filter (equal ctr o #ctr) sel_eqns
  83.892 -              |> fst o finds ((op =) o apsnd #sel) sels
  83.893 -              |> exists (null o snd)
  83.894 -          then [] else
  83.895 -            let
  83.896 -              val (fun_name, fun_T, fun_args, prems) =
  83.897 -                (find_first (equal ctr o #ctr) disc_eqns, find_first (equal ctr o #ctr) sel_eqns)
  83.898 -                |>> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, #prems x))
  83.899 -                ||> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, []))
  83.900 -                |> the o merge_options;
  83.901 -              val m = length prems;
  83.902 -              val t = filter (equal ctr o #ctr) sel_eqns
  83.903 -                |> fst o finds ((op =) o apsnd #sel) sels
  83.904 -                |> map (snd #> (fn [x] => (List.rev (#fun_args x), #rhs_term x)) #-> abstract)
  83.905 -                |> curry list_comb ctr
  83.906 -                |> curry HOLogic.mk_eq (list_comb (Free (fun_name, fun_T),
  83.907 -                  map Bound (length fun_args - 1 downto 0)))
  83.908 -                |> HOLogic.mk_Trueprop
  83.909 -                |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
  83.910 -                |> curry Logic.list_all (map dest_Free fun_args);
  83.911 -              val maybe_disc_thm = AList.lookup (op =) disc_alist disc;
  83.912 -              val sel_thms = map snd (filter (member (op =) sels o fst) sel_alist);
  83.913 -            in
  83.914 -              mk_primcorec_ctr_of_dtr_tac lthy m collapse maybe_disc_thm sel_thms
  83.915 -              |> K |> Goal.prove lthy [] [] t
  83.916 -              |> single
  83.917 -            end;
  83.918 -
  83.919 -        val disc_alists = map3 (maps oo prove_disc) corec_specs exclssss disc_eqnss;
  83.920 -        val sel_alists = map4 (map ooo prove_sel) corec_specs disc_eqnss exclssss sel_eqnss;
  83.921 -
  83.922 -        val disc_thmss = map (map snd) disc_alists;
  83.923 -        val sel_thmss = map (map snd) sel_alists;
  83.924 -        val ctr_thmss = map5 (maps oooo prove_ctr) disc_alists sel_alists disc_eqnss sel_eqnss
  83.925 -          (map #ctr_specs corec_specs);
  83.926 -
  83.927 -        val simp_thmss = map2 append disc_thmss sel_thmss
  83.928 -
  83.929 -        val common_name = mk_common_name fun_names;
  83.930 -
  83.931 -        val notes =
  83.932 -          [(coinductN, map (if n2m then single else K []) coinduct_thms, []),
  83.933 -           (codeN, ctr_thmss(*FIXME*), code_nitpick_attrs),
  83.934 -           (ctrN, ctr_thmss, []),
  83.935 -           (discN, disc_thmss, simp_attrs),
  83.936 -           (selN, sel_thmss, simp_attrs),
  83.937 -           (simpsN, simp_thmss, []),
  83.938 -           (strong_coinductN, map (if n2m then single else K []) strong_coinduct_thms, [])]
  83.939 -          |> maps (fn (thmN, thmss, attrs) =>
  83.940 -            map2 (fn fun_name => fn thms =>
  83.941 -                ((Binding.qualify true fun_name (Binding.name thmN), attrs), [(thms, [])]))
  83.942 -              fun_names (take actual_nn thmss))
  83.943 -          |> filter_out (null o fst o hd o snd);
  83.944 -
  83.945 -        val common_notes =
  83.946 -          [(coinductN, if n2m then [coinduct_thm] else [], []),
  83.947 -           (strong_coinductN, if n2m then [strong_coinduct_thm] else [], [])]
  83.948 -          |> filter_out (null o #2)
  83.949 -          |> map (fn (thmN, thms, attrs) =>
  83.950 -            ((Binding.qualify true common_name (Binding.name thmN), attrs), [(thms, [])]));
  83.951 -      in
  83.952 -        lthy |> Local_Theory.notes (notes @ common_notes) |> snd
  83.953 -      end;
  83.954 -
  83.955 -    fun after_qed thmss' = fold_map Local_Theory.define defs #-> prove thmss';
  83.956 -
  83.957 -    val _ = if not simple orelse forall null obligationss then () else
  83.958 -      primrec_error "need exclusiveness proofs - use primcorecursive instead of primcorec";
  83.959 -  in
  83.960 -    if simple then
  83.961 -      lthy'
  83.962 -      |> after_qed (map (fn [] => []) obligationss)
  83.963 -      |> pair NONE o SOME
  83.964 -    else
  83.965 -      lthy'
  83.966 -      |> Proof.theorem NONE after_qed obligationss
  83.967 -      |> Proof.refine (Method.primitive_text I)
  83.968 -      |> Seq.hd
  83.969 -      |> rpair NONE o SOME
  83.970 -  end;
  83.971 -
  83.972 -fun add_primcorec_ursive_cmd simple seq (raw_fixes, raw_specs') lthy =
  83.973 -  let
  83.974 -    val (raw_specs, of_specs) = split_list raw_specs' ||> map (Option.map (Syntax.read_term lthy));
  83.975 -    val ((fixes, specs), _) = Specification.read_spec raw_fixes raw_specs lthy;
  83.976 -  in
  83.977 -    add_primcorec simple seq fixes specs of_specs lthy
  83.978 -    handle ERROR str => primrec_error str
  83.979 -  end
  83.980 -  handle Primrec_Error (str, eqns) =>
  83.981 -    if null eqns
  83.982 -    then error ("primcorec error:\n  " ^ str)
  83.983 -    else error ("primcorec error:\n  " ^ str ^ "\nin\n  " ^
  83.984 -      space_implode "\n  " (map (quote o Syntax.string_of_term lthy) eqns));
  83.985 -
  83.986 -val add_primcorecursive_cmd = (the o fst) ooo add_primcorec_ursive_cmd false;
  83.987 -val add_primcorec_cmd = (the o snd) ooo add_primcorec_ursive_cmd true;
  83.988 -
  83.989 -end;
    84.1 --- a/src/HOL/BNF/Tools/bnf_fp_rec_sugar_tactics.ML	Thu Dec 05 17:52:12 2013 +0100
    84.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    84.3 @@ -1,116 +0,0 @@
    84.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_rec_sugar_tactics.ML
    84.5 -    Author:     Jasmin Blanchette, TU Muenchen
    84.6 -    Copyright   2013
    84.7 -
    84.8 -Tactics for recursor and corecursor sugar.
    84.9 -*)
   84.10 -
   84.11 -signature BNF_FP_REC_SUGAR_TACTICS =
   84.12 -sig
   84.13 -  val mk_primcorec_assumption_tac: Proof.context -> thm list -> int -> tactic
   84.14 -  val mk_primcorec_code_of_raw_code_tac: thm list -> thm -> tactic
   84.15 -  val mk_primcorec_ctr_of_dtr_tac: Proof.context -> int -> thm -> thm option -> thm list -> tactic
   84.16 -  val mk_primcorec_disc_tac: Proof.context -> thm list -> thm -> int -> int -> thm list list list ->
   84.17 -    tactic
   84.18 -  val mk_primcorec_raw_code_of_ctr_tac: Proof.context -> thm list -> thm list -> thm list ->
   84.19 -    thm list -> int list -> thm list -> tactic
   84.20 -  val mk_primcorec_sel_tac: Proof.context -> thm list -> thm list -> thm list -> thm list ->
   84.21 -    thm list -> thm list -> thm list -> thm -> int -> int -> thm list list list -> tactic
   84.22 -  val mk_primrec_tac: Proof.context -> int -> thm list -> thm list -> thm list -> thm -> tactic
   84.23 -end;
   84.24 -
   84.25 -structure BNF_FP_Rec_Sugar_Tactics : BNF_FP_REC_SUGAR_TACTICS =
   84.26 -struct
   84.27 -
   84.28 -open BNF_Util
   84.29 -open BNF_Tactics
   84.30 -
   84.31 -val falseEs = @{thms not_TrueE FalseE};
   84.32 -val neq_eq_eq_contradict = @{thm neq_eq_eq_contradict};
   84.33 -val split_if = @{thm split_if};
   84.34 -val split_if_asm = @{thm split_if_asm};
   84.35 -val split_connectI = @{thms allI impI conjI};
   84.36 -
   84.37 -fun mk_primrec_tac ctxt num_extra_args map_idents map_comps fun_defs recx =
   84.38 -  unfold_thms_tac ctxt fun_defs THEN
   84.39 -  HEADGOAL (rtac (funpow num_extra_args (fn thm => thm RS fun_cong) recx RS trans)) THEN
   84.40 -  unfold_thms_tac ctxt (@{thms id_def split o_def fst_conv snd_conv} @ map_comps @ map_idents) THEN
   84.41 -  HEADGOAL (rtac refl);
   84.42 -
   84.43 -fun mk_primcorec_assumption_tac ctxt discIs =
   84.44 -  SELECT_GOAL (unfold_thms_tac ctxt
   84.45 -      @{thms not_not not_False_eq_True de_Morgan_conj de_Morgan_disj} THEN
   84.46 -    SOLVE (HEADGOAL (REPEAT o (rtac refl ORELSE' atac ORELSE' etac conjE ORELSE'
   84.47 -    resolve_tac @{thms TrueI conjI disjI1 disjI2} ORELSE'
   84.48 -    dresolve_tac discIs THEN' atac ORELSE'
   84.49 -    etac notE THEN' atac ORELSE'
   84.50 -    etac disjE))));
   84.51 -
   84.52 -fun mk_primcorec_same_case_tac m =
   84.53 -  HEADGOAL (if m = 0 then rtac TrueI
   84.54 -    else REPEAT_DETERM_N (m - 1) o (rtac conjI THEN' atac) THEN' atac);
   84.55 -
   84.56 -fun mk_primcorec_different_case_tac ctxt excl =
   84.57 -  unfold_thms_tac ctxt @{thms not_not not_False_eq_True not_True_eq_False} THEN
   84.58 -  HEADGOAL (rtac excl THEN_ALL_NEW mk_primcorec_assumption_tac ctxt []);
   84.59 -
   84.60 -fun mk_primcorec_cases_tac ctxt k m exclsss =
   84.61 -  let val n = length exclsss in
   84.62 -    EVERY (map (fn [] => if k = n then all_tac else mk_primcorec_same_case_tac m
   84.63 -        | [excl] => mk_primcorec_different_case_tac ctxt excl)
   84.64 -      (take k (nth exclsss (k - 1))))
   84.65 -  end;
   84.66 -
   84.67 -fun mk_primcorec_prelude ctxt defs thm =
   84.68 -  unfold_thms_tac ctxt defs THEN HEADGOAL (rtac thm) THEN
   84.69 -  unfold_thms_tac ctxt @{thms Let_def split};
   84.70 -
   84.71 -fun mk_primcorec_disc_tac ctxt defs disc_corec k m exclsss =
   84.72 -  mk_primcorec_prelude ctxt defs disc_corec THEN mk_primcorec_cases_tac ctxt k m exclsss;
   84.73 -
   84.74 -fun mk_primcorec_sel_tac ctxt defs distincts splits split_asms maps map_idents map_comps f_sel k m
   84.75 -    exclsss =
   84.76 -  mk_primcorec_prelude ctxt defs (f_sel RS trans) THEN
   84.77 -  mk_primcorec_cases_tac ctxt k m exclsss THEN
   84.78 -  HEADGOAL (REPEAT_DETERM o (rtac refl ORELSE' rtac ext ORELSE'
   84.79 -    eresolve_tac falseEs ORELSE'
   84.80 -    resolve_tac split_connectI ORELSE'
   84.81 -    Splitter.split_asm_tac (split_if_asm :: split_asms) ORELSE'
   84.82 -    Splitter.split_tac (split_if :: splits) ORELSE'
   84.83 -    eresolve_tac (map (fn thm => thm RS neq_eq_eq_contradict) distincts) THEN' atac ORELSE'
   84.84 -    etac notE THEN' atac ORELSE'
   84.85 -    (CHANGED o SELECT_GOAL (unfold_thms_tac ctxt
   84.86 -      (@{thms id_apply o_def split_def sum.cases} @ maps @ map_comps @ map_idents)))));
   84.87 -
   84.88 -fun mk_primcorec_ctr_of_dtr_tac ctxt m collapse maybe_disc_f sel_fs =
   84.89 -  HEADGOAL (rtac ((if null sel_fs then collapse else collapse RS sym) RS trans) THEN'
   84.90 -    (the_default (K all_tac) (Option.map rtac maybe_disc_f)) THEN' REPEAT_DETERM_N m o atac) THEN
   84.91 -  unfold_thms_tac ctxt sel_fs THEN HEADGOAL (rtac refl);
   84.92 -
   84.93 -(* TODO: reduce code duplication with selector tactic above *)
   84.94 -fun mk_primcorec_raw_code_of_ctr_single_tac ctxt distincts discIs splits split_asms m f_ctr =
   84.95 -  HEADGOAL (REPEAT o (resolve_tac split_connectI ORELSE' split_tac (split_if :: splits))) THEN
   84.96 -  mk_primcorec_prelude ctxt [] (f_ctr RS trans) THEN
   84.97 -  HEADGOAL ((REPEAT_DETERM_N m o mk_primcorec_assumption_tac ctxt discIs) THEN'
   84.98 -    SELECT_GOAL (SOLVE (HEADGOAL (REPEAT_DETERM o
   84.99 -    (rtac refl ORELSE' atac ORELSE'
  84.100 -     resolve_tac split_connectI ORELSE'
  84.101 -     Splitter.split_asm_tac (split_if_asm :: split_asms) ORELSE'
  84.102 -     Splitter.split_tac (split_if :: splits) ORELSE'
  84.103 -     mk_primcorec_assumption_tac ctxt discIs ORELSE'
  84.104 -     eresolve_tac (map (fn thm => thm RS neq_eq_eq_contradict) distincts) THEN' atac ORELSE'
  84.105 -     (TRY o dresolve_tac discIs) THEN' etac notE THEN' atac)))));
  84.106 -
  84.107 -fun mk_primcorec_raw_code_of_ctr_tac ctxt distincts discIs splits split_asms ms ctr_thms =
  84.108 -  EVERY (map2 (mk_primcorec_raw_code_of_ctr_single_tac ctxt distincts discIs splits split_asms)
  84.109 -    ms ctr_thms);
  84.110 -
  84.111 -fun mk_primcorec_code_of_raw_code_tac splits raw =
  84.112 -  HEADGOAL (rtac raw ORELSE' rtac (raw RS trans) THEN' REPEAT_DETERM o
  84.113 -    (rtac refl ORELSE'
  84.114 -     (TRY o rtac sym) THEN' atac ORELSE'
  84.115 -     resolve_tac split_connectI ORELSE'
  84.116 -     Splitter.split_tac (split_if :: splits) ORELSE'
  84.117 -     etac notE THEN' atac));
  84.118 -
  84.119 -end;
    85.1 --- a/src/HOL/BNF/Tools/bnf_fp_rec_sugar_util.ML	Thu Dec 05 17:52:12 2013 +0100
    85.2 +++ b/src/HOL/BNF/Tools/bnf_fp_rec_sugar_util.ML	Thu Dec 05 17:58:03 2013 +0100
    85.3 @@ -8,616 +8,60 @@
    85.4  
    85.5  signature BNF_FP_REC_SUGAR_UTIL =
    85.6  sig
    85.7 -  datatype rec_call =
    85.8 -    No_Rec of int |
    85.9 -    Direct_Rec of int (*before*) * int (*after*) |
   85.10 -    Indirect_Rec of int
   85.11 -
   85.12 -  datatype corec_call =
   85.13 -    Dummy_No_Corec of int |
   85.14 -    No_Corec of int |
   85.15 -    Direct_Corec of int (*stop?*) * int (*end*) * int (*continue*) |
   85.16 -    Indirect_Corec of int
   85.17 -
   85.18 -  type rec_ctr_spec =
   85.19 -    {ctr: term,
   85.20 -     offset: int,
   85.21 -     calls: rec_call list,
   85.22 -     rec_thm: thm}
   85.23 -
   85.24 -  type corec_ctr_spec =
   85.25 -    {ctr: term,
   85.26 -     disc: term,
   85.27 -     sels: term list,
   85.28 -     pred: int option,
   85.29 -     calls: corec_call list,
   85.30 -     discI: thm,
   85.31 -     sel_thms: thm list,
   85.32 -     collapse: thm,
   85.33 -     corec_thm: thm,
   85.34 -     disc_corec: thm,
   85.35 -     sel_corecs: thm list}
   85.36 +  val indexed: 'a list -> int -> int list * int
   85.37 +  val indexedd: 'a list list -> int -> int list list * int
   85.38 +  val indexeddd: 'a list list list -> int -> int list list list * int
   85.39 +  val indexedddd: 'a list list list list -> int -> int list list list list * int
   85.40 +  val find_index_eq: ''a list -> ''a -> int
   85.41 +  val finds: ('a * 'b -> bool) -> 'a list -> 'b list -> ('a * 'b list) list * 'b list
   85.42  
   85.43 -  type rec_spec =
   85.44 -    {recx: term,
   85.45 -     nested_map_idents: thm list,
   85.46 -     nested_map_comps: thm list,
   85.47 -     ctr_specs: rec_ctr_spec list}
   85.48 -
   85.49 -  type corec_spec =
   85.50 -    {corec: term,
   85.51 -     nested_maps: thm list,
   85.52 -     nested_map_idents: thm list,
   85.53 -     nested_map_comps: thm list,
   85.54<