--- a/Admin/isatest/settings/at-mac-poly-5.1-para Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/at-mac-poly-5.1-para Thu Feb 11 12:26:50 2010 -0800
@@ -25,3 +25,4 @@
ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 4 -q 2"
+unset KODKODI
--- a/Admin/isatest/settings/at-poly Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/at-poly Thu Feb 11 12:26:50 2010 -0800
@@ -24,3 +24,4 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -t true"
+init_component /home/isabelle/contrib_devel/kodkodi
--- a/Admin/isatest/settings/at-poly-5.1-para-e Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/at-poly-5.1-para-e Thu Feb 11 12:26:50 2010 -0800
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -M 10"
+unset KODKODI
+
--- a/Admin/isatest/settings/at-poly-dev-e Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/at-poly-dev-e Thu Feb 11 12:26:50 2010 -0800
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/at-sml Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/at-sml Thu Feb 11 12:26:50 2010 -0800
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/at-sml-dev-e Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/at-sml-dev-e Thu Feb 11 12:26:50 2010 -0800
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/at-sml-dev-p Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/at-sml-dev-p Thu Feb 11 12:26:50 2010 -0800
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/at64-poly Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/at64-poly Thu Feb 11 12:26:50 2010 -0800
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/at64-poly-5.1-para Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/at64-poly-5.1-para Thu Feb 11 12:26:50 2010 -0800
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -M 2"
+unset KODKODI
+
--- a/Admin/isatest/settings/at64-sml-dev Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/at64-sml-dev Thu Feb 11 12:26:50 2010 -0800
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/mac-poly Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/mac-poly Thu Feb 11 12:26:50 2010 -0800
@@ -24,3 +24,4 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -g false"
+init_component /home/isabelle/contrib_devel/kodkodi
--- a/Admin/isatest/settings/mac-poly-M4 Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/mac-poly-M4 Thu Feb 11 12:26:50 2010 -0800
@@ -25,3 +25,4 @@
ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 4 -q 2"
+init_component /home/isabelle/contrib_devel/kodkodi
--- a/Admin/isatest/settings/mac-poly-M8 Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/mac-poly-M8 Thu Feb 11 12:26:50 2010 -0800
@@ -25,3 +25,5 @@
ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 8 -q 2"
+init_component /home/isabelle/contrib_devel/kodkodi
+
--- a/Admin/isatest/settings/mac-poly64-M8 Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/mac-poly64-M8 Thu Feb 11 12:26:50 2010 -0800
@@ -25,3 +25,5 @@
ISABELLE_USEDIR_OPTIONS="-i false -d false -t true -M 8 -q 2"
+unset KODKODI
+
--- a/Admin/isatest/settings/mac-sml-dev Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/mac-sml-dev Thu Feb 11 12:26:50 2010 -0800
@@ -24,3 +24,5 @@
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/sun-poly Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/sun-poly Thu Feb 11 12:26:50 2010 -0800
@@ -25,3 +25,5 @@
#ISABELLE_USEDIR_OPTIONS="-i true -d dvi -g true -v true"
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true -t true -M 6 -q 2"
+unset KODKODI
+
--- a/Admin/isatest/settings/sun-sml Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/sun-sml Thu Feb 11 12:26:50 2010 -0800
@@ -25,3 +25,5 @@
# ISABELLE_USEDIR_OPTIONS="-i true -d dvi -g true -v true"
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/Admin/isatest/settings/sun-sml-dev Thu Feb 11 12:26:07 2010 -0800
+++ b/Admin/isatest/settings/sun-sml-dev Thu Feb 11 12:26:50 2010 -0800
@@ -25,3 +25,5 @@
# ISABELLE_USEDIR_OPTIONS="-i true -d dvi -g true -v true"
ISABELLE_USEDIR_OPTIONS="-i true -d pdf -v true"
+unset KODKODI
+
--- a/NEWS Thu Feb 11 12:26:07 2010 -0800
+++ b/NEWS Thu Feb 11 12:26:50 2010 -0800
@@ -20,6 +20,17 @@
consistent names suitable for name prefixes within the HOL theories.
INCOMPATIBILITY.
+* Some generic constants have been put to appropriate theories:
+
+ less_eq, less: Orderings
+ abs, sgn: Groups
+ inverse, divide: Rings
+
+INCOMPATIBILITY.
+
+* Class division ring also requires proof of fact divide_inverse. However instantiation
+of parameter divide has also been required previously. INCOMPATIBILITY.
+
* More consistent naming of type classes involving orderings (and lattices):
lower_semilattice ~> semilattice_inf
@@ -71,13 +82,9 @@
INCOMPATIBILITY.
-* Index syntax for structures must be imported explicitly from library
-theory Structure_Syntax. INCOMPATIBILITY.
-
* New theory Algebras contains generic algebraic structures and
generic algebraic operations. INCOMPATIBILTY: constants zero, one,
-plus, minus, uminus, times, inverse, divide, abs, sgn, less_eq and
-less have been moved from HOL.thy to Algebras.thy.
+plus, minus, uminus and times have been moved from HOL.thy to Algebras.thy.
* HOLogic.strip_psplit: types are returned in syntactic order, similar
to other strip and tuple operations. INCOMPATIBILITY.
@@ -119,6 +126,9 @@
* Theory List: added transpose.
+* Renamed Library/Quotient.thy to Library/Quotient_Type.thy to avoid
+clash with new theory Quotient in Main HOL.
+
*** ML ***
--- a/doc-src/Main/Docs/Main_Doc.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/doc-src/Main/Docs/Main_Doc.thy Thu Feb 11 12:26:50 2010 -0800
@@ -297,7 +297,7 @@
\section{Algebra}
-Theories @{theory OrderedGroup}, @{theory Ring_and_Field} and @{theory
+Theories @{theory Groups}, @{theory Rings}, @{theory Fields} and @{theory
Divides} define a large collection of classes describing common algebraic
structures from semigroups up to fields. Everything is done in terms of
overloaded operators:
--- a/doc-src/Main/Docs/document/Main_Doc.tex Thu Feb 11 12:26:07 2010 -0800
+++ b/doc-src/Main/Docs/document/Main_Doc.tex Thu Feb 11 12:26:50 2010 -0800
@@ -308,7 +308,7 @@
\section{Algebra}
-Theories \isa{OrderedGroup}, \isa{Ring{\isacharunderscore}and{\isacharunderscore}Field} and \isa{Divides} define a large collection of classes describing common algebraic
+Theories \isa{Groups}, \isa{Rings}, \isa{Fields} and \isa{Divides} define a large collection of classes describing common algebraic
structures from semigroups up to fields. Everything is done in terms of
overloaded operators:
--- a/doc-src/Nitpick/nitpick.tex Thu Feb 11 12:26:07 2010 -0800
+++ b/doc-src/Nitpick/nitpick.tex Thu Feb 11 12:26:50 2010 -0800
@@ -154,7 +154,7 @@
the line
\prew
-\textbf{nitpick\_params} [\textit{sat\_solver}~= \textit{MiniSatJNI}, \,\textit{max\_threads}~= 1]
+\textbf{nitpick\_params} [\textit{sat\_solver}~= \textit{MiniSat\_JNI}, \,\textit{max\_threads}~= 1]
\postw
after the \textbf{begin} keyword. The JNI version of MiniSat is bundled with
@@ -311,9 +311,9 @@
\slshape Constant: \nopagebreak \\
\hbox{}\qquad $\mathit{The} = \undef{}
(\!\begin{aligned}[t]%
- & \{\} := a_3,\> \{a_3\} := a_3,\> \{a_2\} := a_2, \\[-2pt] %% TYPESETTING
- & \{a_2, a_3\} := a_1,\> \{a_1\} := a_1,\> \{a_1, a_3\} := a_3, \\[-2pt]
- & \{a_1, a_2\} := a_3,\> \{a_1, a_2, a_3\} := a_3)\end{aligned}$
+ & \{a_1, a_2, a_3\} := a_3,\> \{a_1, a_2\} := a_3,\> \{a_1, a_3\} := a_3, \\[-2pt] %% TYPESETTING
+ & \{a_1\} := a_1,\> \{a_2, a_3\} := a_1,\> \{a_2\} := a_2, \\[-2pt]
+ & \{a_3\} := a_3,\> \{\} := a_3)\end{aligned}$
\postw
Notice that $\textit{The}~(\lambda y.\;P~y) = \textit{The}~\{a_2, a_3\} = a_1$,
@@ -550,7 +550,7 @@
\slshape Nitpick found a counterexample for \textit{card} $'a$~= 3: \\[2\smallskipamount]
\hbox{}\qquad Free variables: \nopagebreak \\
\hbox{}\qquad\qquad $\textit{xs} = []$ \\
-\hbox{}\qquad\qquad $\textit{y} = a_3$
+\hbox{}\qquad\qquad $\textit{y} = a_1$
\postw
To see why the counterexample is genuine, we enable \textit{show\_consts}
@@ -558,21 +558,21 @@
\prew
{\slshape Datatype:} \\
-\hbox{}\qquad $'a$~\textit{list}~= $\{[],\, [a_3, a_3],\, [a_3],\, \unr\}$ \\
+\hbox{}\qquad $'a$~\textit{list}~= $\{[],\, [a_1],\, [a_1, a_1],\, \unr\}$ \\
{\slshape Constants:} \\
-\hbox{}\qquad $\lambda x_1.\; x_1 \mathbin{@} [y, y] = \undef([] := [a_3, a_3])$ \\
-\hbox{}\qquad $\textit{hd} = \undef([] := a_2,\> [a_3, a_3] := a_3,\> [a_3] := a_3)$
+\hbox{}\qquad $\lambda x_1.\; x_1 \mathbin{@} [y, y] = \undef([] := [a_1, a_1])$ \\
+\hbox{}\qquad $\textit{hd} = \undef([] := a_2,\> [a_1] := a_1,\> [a_1, a_1] := a_1)$
\postw
Since $\mathit{hd}~[]$ is undefined in the logic, it may be given any value,
including $a_2$.
The second constant, $\lambda x_1.\; x_1 \mathbin{@} [y, y]$, is simply the
-append operator whose second argument is fixed to be $[y, y]$. Appending $[a_3,
-a_3]$ to $[a_3]$ would normally give $[a_3, a_3, a_3]$, but this value is not
+append operator whose second argument is fixed to be $[y, y]$. Appending $[a_1,
+a_1]$ to $[a_1]$ would normally give $[a_1, a_1, a_1]$, but this value is not
representable in the subset of $'a$~\textit{list} considered by Nitpick, which
is shown under the ``Datatype'' heading; hence the result is $\unk$. Similarly,
-appending $[a_3, a_3]$ to itself gives $\unk$.
+appending $[a_1, a_1]$ to itself gives $\unk$.
Given \textit{card}~$'a = 3$ and \textit{card}~$'a~\textit{list} = 3$, Nitpick
considers the following subsets:
@@ -600,8 +600,8 @@
All subterm-closed subsets of $'a~\textit{list}$ consisting of three values
are listed and only those. As an example of a non-subterm-closed subset,
-consider $\mathcal{S} = \{[],\, [a_1],\,\allowbreak [a_1, a_3]\}$, and observe
-that $[a_1, a_3]$ (i.e., $a_1 \mathbin{\#} [a_3]$) has $[a_3] \notin
+consider $\mathcal{S} = \{[],\, [a_1],\,\allowbreak [a_1, a_2]\}$, and observe
+that $[a_1, a_2]$ (i.e., $a_1 \mathbin{\#} [a_2]$) has $[a_2] \notin
\mathcal{S}$ as a subterm.
Here's another m\"ochtegern-lemma that Nitpick can refute without a blink:
@@ -613,11 +613,11 @@
\textbf{nitpick} [\textit{show\_datatypes}] \\[2\smallskipamount]
\slshape Nitpick found a counterexample for \textit{card} $'a$~= 3: \\[2\smallskipamount]
\hbox{}\qquad Free variables: \nopagebreak \\
-\hbox{}\qquad\qquad $\textit{xs} = [a_2]$ \\
-\hbox{}\qquad\qquad $\textit{ys} = [a_3]$ \\
+\hbox{}\qquad\qquad $\textit{xs} = [a_1]$ \\
+\hbox{}\qquad\qquad $\textit{ys} = [a_2]$ \\
\hbox{}\qquad Datatypes: \\
\hbox{}\qquad\qquad $\textit{nat} = \{0,\, 1,\, 2,\, \unr\}$ \\
-\hbox{}\qquad\qquad $'a$~\textit{list} = $\{[],\, [a_3],\, [a_2],\, \unr\}$
+\hbox{}\qquad\qquad $'a$~\textit{list} = $\{[],\, [a_1],\, [a_2],\, \unr\}$
\postw
Because datatypes are approximated using a three-valued logic, there is usually
@@ -642,11 +642,11 @@
\textbf{nitpick} [\textit{show\_datatypes}] \\[2\smallskipamount]
\slshape Nitpick found a counterexample: \\[2\smallskipamount]
\hbox{}\qquad Free variables: \nopagebreak \\
-\hbox{}\qquad\qquad $P = \{\Abs{1},\, \Abs{0}\}$ \\
+\hbox{}\qquad\qquad $P = \{\Abs{0},\, \Abs{1}\}$ \\
\hbox{}\qquad\qquad $x = \Abs{2}$ \\
\hbox{}\qquad Datatypes: \\
\hbox{}\qquad\qquad $\textit{nat} = \{0,\, 1,\, 2,\, \unr\}$ \\
-\hbox{}\qquad\qquad $\textit{three} = \{\Abs{2},\, \Abs{1},\, \Abs{0},\, \unr\}$
+\hbox{}\qquad\qquad $\textit{three} = \{\Abs{0},\, \Abs{1},\, \Abs{2},\, \unr\}$
\postw
%% MARK
@@ -664,12 +664,13 @@
\textbf{nitpick} [\textit{show\_datatypes}] \\[2\smallskipamount]
\slshape Nitpick found a counterexample: \\[2\smallskipamount]
\hbox{}\qquad Free variables: \nopagebreak \\
-\hbox{}\qquad\qquad $p = \lparr\textit{Xcoord} = 0,\> \textit{Ycoord} = 0\rparr$ \\
-\hbox{}\qquad\qquad $q = \lparr\textit{Xcoord} = 1,\> \textit{Ycoord} = 1\rparr$ \\
+\hbox{}\qquad\qquad $p = \lparr\textit{Xcoord} = 1,\> \textit{Ycoord} = 1\rparr$ \\
+\hbox{}\qquad\qquad $q = \lparr\textit{Xcoord} = 0,\> \textit{Ycoord} = 0\rparr$ \\
\hbox{}\qquad Datatypes: \\
\hbox{}\qquad\qquad $\textit{int} = \{0,\, 1,\, \unr\}$ \\
-\hbox{}\qquad\qquad $\textit{point} = \{\lparr\textit{Xcoord} = 1,\>
-\textit{Ycoord} = 1\rparr,\> \lparr\textit{Xcoord} = 0,\> \textit{Ycoord} = 0\rparr,\, \unr\}$\kern-1pt %% QUIET
+\hbox{}\qquad\qquad $\textit{point} = \{\!\begin{aligned}[t]
+& \lparr\textit{Xcoord} = 0,\> \textit{Ycoord} = 0\rparr, \\[-2pt] %% TYPESETTING
+& \lparr\textit{Xcoord} = 1,\> \textit{Ycoord} = 1\rparr,\, \unr\}\end{aligned}$
\postw
Finally, Nitpick provides rudimentary support for rationals and reals using a
@@ -956,16 +957,16 @@
depth}~= 1:
\\[2\smallskipamount]
\hbox{}\qquad Free variables: \nopagebreak \\
-\hbox{}\qquad\qquad $\textit{a} = a_2$ \\
-\hbox{}\qquad\qquad $\textit{b} = a_1$ \\
-\hbox{}\qquad\qquad $\textit{xs} = \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega$ \\
-\hbox{}\qquad\qquad $\textit{ys} = \textit{LCons}~a_1~(\textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega)$ \\[2\smallskipamount]
+\hbox{}\qquad\qquad $\textit{a} = a_1$ \\
+\hbox{}\qquad\qquad $\textit{b} = a_2$ \\
+\hbox{}\qquad\qquad $\textit{xs} = \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\omega$ \\
+\hbox{}\qquad\qquad $\textit{ys} = \textit{LCons}~a_2~(\textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\omega)$ \\[2\smallskipamount]
Total time: 726 ms.
\postw
-The lazy list $\textit{xs}$ is simply $[a_2, a_2, a_2, \ldots]$, whereas
-$\textit{ys}$ is $[a_1, a_2, a_2, a_2, \ldots]$, i.e., a lasso-shaped list with
-$[a_1]$ as its stem and $[a_2]$ as its cycle. In general, the list segment
+The lazy list $\textit{xs}$ is simply $[a_1, a_1, a_1, \ldots]$, whereas
+$\textit{ys}$ is $[a_2, a_1, a_1, a_1, \ldots]$, i.e., a lasso-shaped list with
+$[a_2]$ as its stem and $[a_1]$ as its cycle. In general, the list segment
within the scope of the {THE} binder corresponds to the lasso's cycle, whereas
the segment leading to the binder is the stem.
@@ -1000,15 +1001,15 @@
\textbf{nitpick} [\textit{bisim\_depth} = $-1$, \textit{show\_datatypes}] \\[2\smallskipamount]
\slshape Nitpick found a likely genuine counterexample for $\textit{card}~'a$ = 2: \\[2\smallskipamount]
\hbox{}\qquad Free variables: \nopagebreak \\
-\hbox{}\qquad\qquad $a = a_2$ \\
+\hbox{}\qquad\qquad $a = a_1$ \\
\hbox{}\qquad\qquad $\textit{xs} = \textsl{THE}~\omega.\; \omega =
-\textit{LCons}~a_2~\omega$ \\
-\hbox{}\qquad\qquad $\textit{ys} = \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega$ \\
+\textit{LCons}~a_1~\omega$ \\
+\hbox{}\qquad\qquad $\textit{ys} = \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\omega$ \\
\hbox{}\qquad Codatatype:\strut \nopagebreak \\
\hbox{}\qquad\qquad $'a~\textit{llist} =
\{\!\begin{aligned}[t]
- & \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega, \\[-2pt]
- & \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega,\> \unr\}\end{aligned}$
+ & \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\omega, \\[-2pt]
+ & \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\omega,\> \unr\}\end{aligned}$
\\[2\smallskipamount]
Try again with ``\textit{bisim\_depth}'' set to a nonnegative value to confirm
that the counterexample is genuine. \\[2\smallskipamount]
@@ -1198,8 +1199,8 @@
\textit{card} ``\kern1pt$'b$ \textit{list}''~= 5:
\\[2\smallskipamount]
\hbox{}\qquad Free variables: \nopagebreak \\
-\hbox{}\qquad\qquad $\textit{xs} = [a_4, a_5]$ \\
-\hbox{}\qquad\qquad $\textit{ys} = [b_3, b_3]$ \\[2\smallskipamount]
+\hbox{}\qquad\qquad $\textit{xs} = [a_1, a_2]$ \\
+\hbox{}\qquad\qquad $\textit{ys} = [b_1, b_1]$ \\[2\smallskipamount]
Total time: 1636 ms.
\postw
@@ -1377,21 +1378,21 @@
\prew
\slshape Nitpick found a nonstandard counterexample for \textit{card} $'a$ = 4: \\[2\smallskipamount]
\hbox{}\qquad Free variables: \nopagebreak \\
-\hbox{}\qquad\qquad $a = a_4$ \\
-\hbox{}\qquad\qquad $b = a_3$ \\
-\hbox{}\qquad\qquad $t = \xi_3$ \\
-\hbox{}\qquad\qquad $u = \xi_4$ \\
+\hbox{}\qquad\qquad $a = a_1$ \\
+\hbox{}\qquad\qquad $b = a_2$ \\
+\hbox{}\qquad\qquad $t = \xi_1$ \\
+\hbox{}\qquad\qquad $u = \xi_2$ \\
\hbox{}\qquad {\slshape Constants:} \nopagebreak \\
\hbox{}\qquad\qquad $\textit{labels} = \undef
(\!\begin{aligned}[t]%
- & \xi_3 := \{a_4\},\> \xi_4 := \{a_1, a_3\}, \\[-2pt] %% TYPESETTING
- & \textit{Branch}~\xi_3~\xi_3 := \{a_4\}, \\[-2pt]
- & \textit{Branch}~\xi_3~\xi_4 := \{a_1, a_3, a_4\})\end{aligned}$ \\
+ & \xi_1 := \{a_1, a_4, a_3^\Q\},\> \xi_2 := \{a_2, a_3^\Q\}, \\[-2pt] %% TYPESETTING
+ & \textit{Branch}~\xi_1~\xi_2 := \{a_1, a_2, a_4, a_3^\Q\}, \\[-2pt]
+ & \textit{Branch}~\xi_2~\xi_2 := \{a_2, a_3^\Q\})\end{aligned}$ \\
\hbox{}\qquad\qquad $\lambda x_1.\> \textit{swap}~x_1~a~b = \undef
(\!\begin{aligned}[t]%
- & \xi_3 := \xi_3,\> \xi_4 := \xi_3, \\[-2pt]
- & \textit{Branch}~\xi_3~\xi_3 := \textit{Branch}~\xi_3~\xi_3, \\[-2pt]
- & \textit{Branch}~\xi_4~\xi_3 := \textit{Branch}~\xi_3~\xi_3)\end{aligned}$ \\[2\smallskipamount]
+ & \xi_1 := \xi_2,\> \xi_2 := \xi_2, \\[-2pt]
+ & \textit{Branch}~\xi_1~\xi_2 := \textit{Branch}~\xi_2~\xi_2, \\[-2pt]
+ & \textit{Branch}~\xi_2~\xi_2 := \textit{Branch}~\xi_2~\xi_2)\end{aligned}$ \\[2\smallskipamount]
The existence of a nonstandard model suggests that the induction hypothesis is not general enough or perhaps
even wrong. See the ``Inductive Properties'' section of the Nitpick manual for details (``\textit{isabelle doc nitpick}'').
\postw
@@ -1406,7 +1407,7 @@
allowing unreachable states in the preceding example (by removing the ``$n \in
\textit{reach\/}$'' assumption). In both cases, we effectively enlarge the
set of objects over which the induction is performed while doing the step
-so as to test the induction hypothesis's strength.}
+in order to test the induction hypothesis's strength.}
The new trees are so nonstandard that we know nothing about them, except what
the induction hypothesis states and what can be proved about all trees without
relying on induction or case distinction. The key observation is,
@@ -1417,8 +1418,8 @@
objects, and Nitpick won't find any nonstandard counterexample.}
\end{quote}
%
-But here, Nitpick did find some nonstandard trees $t = \xi_3$
-and $u = \xi_4$ such that $a \in \textit{labels}~t$, $b \notin
+But here, Nitpick did find some nonstandard trees $t = \xi_1$
+and $u = \xi_2$ such that $a \in \textit{labels}~t$, $b \notin
\textit{labels}~t$, $a \notin \textit{labels}~u$, and $b \in \textit{labels}~u$.
Because neither tree contains both $a$ and $b$, the induction hypothesis tells
us nothing about the labels of $\textit{swap}~t~a~b$ and $\textit{swap}~u~a~b$,
@@ -1441,7 +1442,7 @@
\postw
This time, Nitpick won't find any nonstandard counterexample, and we can perform
-the induction step using \textbf{auto}.
+the induction step using \textit{auto}.
\section{Case Studies}
\label{case-studies}
@@ -1694,7 +1695,7 @@
``$\textit{dataset}~(\textit{skew}~t) = \textit{dataset}~t$'' \\
``$\textit{dataset}~(\textit{split}~t) = \textit{dataset}~t$'' \\
\textbf{nitpick} \\[2\smallskipamount]
-{\slshape Nitpick ran out of time after checking 7 of 8 scopes.}
+{\slshape Nitpick found no counterexample.}
\postw
Furthermore, applying \textit{skew} or \textit{split} to a well-formed tree
@@ -1726,8 +1727,8 @@
\textbf{nitpick} \\[2\smallskipamount]
\slshape Nitpick found a counterexample for \textit{card} $'a$ = 4: \\[2\smallskipamount]
\hbox{}\qquad Free variables: \nopagebreak \\
-\hbox{}\qquad\qquad $t = N~a_3~1~\Lambda~\Lambda$ \\
-\hbox{}\qquad\qquad $x = a_4$
+\hbox{}\qquad\qquad $t = N~a_1~1~\Lambda~\Lambda$ \\
+\hbox{}\qquad\qquad $x = a_2$
\postw
It's hard to see why this is a counterexample. To improve readability, we will
@@ -1756,7 +1757,7 @@
\prew
\textbf{theorem}~\textit{wf\_insort}:\kern.4em ``$\textit{wf}~t\,\Longrightarrow\, \textit{wf}~(\textit{insort}~t~x)$'' \\
\textbf{nitpick} \\[2\smallskipamount]
-{\slshape Nitpick ran out of time after checking 6 of 8 scopes.}
+{\slshape Nitpick ran out of time after checking 7 of 8 scopes.}
\postw
Insertion should transform the set of elements represented by the tree in the
@@ -1766,14 +1767,14 @@
\textbf{theorem} \textit{dataset\_insort}:\kern.4em
``$\textit{dataset}~(\textit{insort}~t~x) = \{x\} \cup \textit{dataset}~t$'' \\
\textbf{nitpick} \\[2\smallskipamount]
-{\slshape Nitpick ran out of time after checking 5 of 8 scopes.}
+{\slshape Nitpick ran out of time after checking 6 of 8 scopes.}
\postw
-We could continue like this and sketch a complete theory of AA trees without
-performing a single proof. Once the definitions and main theorems are in place
-and have been thoroughly tested using Nitpick, we could start working on the
-proofs. Developing theories this way usually saves time, because faulty theorems
-and definitions are discovered much earlier in the process.
+We could continue like this and sketch a complete theory of AA trees. Once the
+definitions and main theorems are in place and have been thoroughly tested using
+Nitpick, we could start working on the proofs. Developing theories this way
+usually saves time, because faulty theorems and definitions are discovered much
+earlier in the process.
\section{Option Reference}
\label{option-reference}
@@ -2138,7 +2139,7 @@
is implicitly set to 0 for automatic runs. If you set this option to a value
greater than 1, you will need an incremental SAT solver: For efficiency, it is
recommended to install the JNI version of MiniSat and set \textit{sat\_solver} =
-\textit{MiniSatJNI}. Also be aware that many of the counterexamples may look
+\textit{MiniSat\_JNI}. Also be aware that many of the counterexamples may look
identical, unless the \textit{show\_all} (\S\ref{output-format}) option is
enabled.
@@ -2150,7 +2151,7 @@
Specifies the maximum number of genuine counterexamples to display. If you set
this option to a value greater than 1, you will need an incremental SAT solver:
For efficiency, it is recommended to install the JNI version of MiniSat and set
-\textit{sat\_solver} = \textit{MiniSatJNI}. Also be aware that many of the
+\textit{sat\_solver} = \textit{MiniSat\_JNI}. Also be aware that many of the
counterexamples may look identical, unless the \textit{show\_all}
(\S\ref{output-format}) option is enabled.
@@ -2243,7 +2244,7 @@
to be faster than their Java counterparts, but they can be more difficult to
install. Also, if you set the \textit{max\_potential} (\S\ref{output-format}) or
\textit{max\_genuine} (\S\ref{output-format}) option to a value greater than 1,
-you will need an incremental SAT solver, such as \textit{MiniSatJNI}
+you will need an incremental SAT solver, such as \textit{MiniSat\_JNI}
(recommended) or \textit{SAT4J}.
The supported solvers are listed below:
@@ -2257,7 +2258,7 @@
\url{http://minisat.se/MiniSat.html}. Nitpick has been tested with versions 1.14
and 2.0 beta (2007-07-21).
-\item[$\bullet$] \textbf{\textit{MiniSatJNI}}: The JNI (Java Native Interface)
+\item[$\bullet$] \textbf{\textit{MiniSat\_JNI}}: The JNI (Java Native Interface)
version of MiniSat is bundled in \texttt{nativesolver.\allowbreak tgz}, which
you will find on Kodkod's web site \cite{kodkod-2009}. Unlike the standard
version of MiniSat, the JNI version can be used incrementally.
@@ -2279,7 +2280,7 @@
\url{http://www.princeton.edu/~chaff/zchaff.html}. Nitpick has been tested with
versions 2004-05-13, 2004-11-15, and 2007-03-12.
-\item[$\bullet$] \textbf{\textit{zChaffJNI}}: The JNI version of zChaff is
+\item[$\bullet$] \textbf{\textit{zChaff\_JNI}}: The JNI version of zChaff is
bundled in \texttt{native\-solver.\allowbreak tgz}, which you will find on
Kodkod's web site \cite{kodkod-2009}.
@@ -2295,7 +2296,7 @@
executable. The BerkMin executables are available at
\url{http://eigold.tripod.com/BerkMin.html}.
-\item[$\bullet$] \textbf{\textit{BerkMinAlloy}}: Variant of BerkMin that is
+\item[$\bullet$] \textbf{\textit{BerkMin\_Alloy}}: Variant of BerkMin that is
included with Alloy 4 and calls itself ``sat56'' in its banner text. To use this
version of BerkMin, set the environment variable
\texttt{BERKMINALLOY\_HOME} to the directory that contains the \texttt{berkmin}
@@ -2313,7 +2314,7 @@
install the official SAT4J packages, because their API is incompatible with
Kodkod.
-\item[$\bullet$] \textbf{\textit{SAT4JLight}}: Variant of SAT4J that is
+\item[$\bullet$] \textbf{\textit{SAT4J\_Light}}: Variant of SAT4J that is
optimized for small problems. It can also be used incrementally.
\item[$\bullet$] \textbf{\textit{HaifaSat}}: HaifaSat 1.0 beta is an
@@ -2324,7 +2325,7 @@
\item[$\bullet$] \textbf{\textit{smart}}: If \textit{sat\_solver} is set to
\textit{smart}, Nitpick selects the first solver among MiniSat,
-PicoSAT, zChaff, RSat, BerkMin, BerkMinAlloy, Jerusat, MiniSatJNI, and zChaffJNI
+PicoSAT, zChaff, RSat, BerkMin, BerkMin\_Alloy, Jerusat, MiniSat\_JNI, and zChaff\_JNI
that is recognized by Isabelle. If none is found, it falls back on SAT4J, which
should always be available. If \textit{verbose} (\S\ref{output-format}) is
enabled, Nitpick displays which SAT solver was chosen.
--- a/doc-src/TutorialI/Inductive/Mutual.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/doc-src/TutorialI/Inductive/Mutual.thy Thu Feb 11 12:26:50 2010 -0800
@@ -67,13 +67,13 @@
text{*\noindent Everything works as before, except that
you write \commdx{inductive} instead of \isacommand{inductive\_set} and
-@{prop"evn n"} instead of @{prop"n : even"}. The notation is more
-lightweight but the usual set-theoretic operations, e.g. @{term"Even \<union> Odd"},
-are not directly available on predicates.
+@{prop"evn n"} instead of @{prop"n : even"}.
+When defining an n-ary relation as a predicate, it is recommended to curry
+the predicate: its type should be \mbox{@{text"\<tau>\<^isub>1 \<Rightarrow> \<dots> \<Rightarrow> \<tau>\<^isub>n \<Rightarrow> bool"}}
+rather than
+@{text"\<tau>\<^isub>1 \<times> \<dots> \<times> \<tau>\<^isub>n \<Rightarrow> bool"}. The curried version facilitates inductions.
-When defining an n-ary relation as a predicate it is recommended to curry
-the predicate: its type should be @{text"\<tau>\<^isub>1 \<Rightarrow> \<dots> \<Rightarrow> \<tau>\<^isub>n \<Rightarrow> bool"} rather than
-@{text"\<tau>\<^isub>1 \<times> \<dots> \<times> \<tau>\<^isub>n \<Rightarrow> bool"}. The curried version facilitates inductions.
+When should you choose sets and when predicates? If you intend to combine your notion with set theoretic notation, define it as an inductive set. If not, define it as an inductive predicate, thus avoiding the @{text"\<in>"} notation. But note that predicates of more than one argument cannot be combined with the usual set theoretic operators: @{term"P \<union> Q"} is not well-typed if @{text"P, Q :: \<tau>\<^isub>1 \<Rightarrow> \<tau>\<^isub>2 \<Rightarrow> bool"}, you have to write @{term"%x y. P x y & Q x y"} instead.
\index{inductive predicates|)}
*}
--- a/doc-src/TutorialI/Inductive/document/Mutual.tex Thu Feb 11 12:26:07 2010 -0800
+++ b/doc-src/TutorialI/Inductive/document/Mutual.tex Thu Feb 11 12:26:50 2010 -0800
@@ -101,13 +101,13 @@
\begin{isamarkuptext}%
\noindent Everything works as before, except that
you write \commdx{inductive} instead of \isacommand{inductive\_set} and
-\isa{evn\ n} instead of \isa{n\ {\isasymin}\ even}. The notation is more
-lightweight but the usual set-theoretic operations, e.g. \isa{Even\ {\isasymunion}\ Odd},
-are not directly available on predicates.
+\isa{evn\ n} instead of \isa{n\ {\isasymin}\ even}.
+When defining an n-ary relation as a predicate, it is recommended to curry
+the predicate: its type should be \mbox{\isa{{\isasymtau}\isactrlisub {\isadigit{1}}\ {\isasymRightarrow}\ {\isasymdots}\ {\isasymRightarrow}\ {\isasymtau}\isactrlisub n\ {\isasymRightarrow}\ bool}}
+rather than
+\isa{{\isasymtau}\isactrlisub {\isadigit{1}}\ {\isasymtimes}\ {\isasymdots}\ {\isasymtimes}\ {\isasymtau}\isactrlisub n\ {\isasymRightarrow}\ bool}. The curried version facilitates inductions.
-When defining an n-ary relation as a predicate it is recommended to curry
-the predicate: its type should be \isa{{\isasymtau}\isactrlisub {\isadigit{1}}\ {\isasymRightarrow}\ {\isasymdots}\ {\isasymRightarrow}\ {\isasymtau}\isactrlisub n\ {\isasymRightarrow}\ bool} rather than
-\isa{{\isasymtau}\isactrlisub {\isadigit{1}}\ {\isasymtimes}\ {\isasymdots}\ {\isasymtimes}\ {\isasymtau}\isactrlisub n\ {\isasymRightarrow}\ bool}. The curried version facilitates inductions.
+When should you choose sets and when predicates? If you intend to combine your notion with set theoretic notation, define it as an inductive set. If not, define it as an inductive predicate, thus avoiding the \isa{{\isasymin}} notation. But note that predicates of more than one argument cannot be combined with the usual set theoretic operators: \isa{P\ {\isasymunion}\ Q} is not well-typed if \isa{P{\isacharcomma}\ Q\ {\isacharcolon}{\isacharcolon}\ {\isasymtau}\isactrlisub {\isadigit{1}}\ {\isasymRightarrow}\ {\isasymtau}\isactrlisub {\isadigit{2}}\ {\isasymRightarrow}\ bool}, you have to write \isa{{\isasymlambda}x\ y{\isachardot}\ P\ x\ y\ {\isasymand}\ Q\ x\ y} instead.
\index{inductive predicates|)}%
\end{isamarkuptext}%
\isamarkuptrue%
--- a/doc-src/TutorialI/Types/document/Numbers.tex Thu Feb 11 12:26:07 2010 -0800
+++ b/doc-src/TutorialI/Types/document/Numbers.tex Thu Feb 11 12:26:50 2010 -0800
@@ -107,7 +107,7 @@
\rulename{add_commute}
\begin{isabelle}%
-a\ {\isacharplus}\ {\isacharparenleft}b\ {\isacharplus}\ c{\isacharparenright}\ {\isacharequal}\ b\ {\isacharplus}\ {\isacharparenleft}a\ {\isacharplus}\ c{\isacharparenright}%
+b\ {\isacharplus}\ {\isacharparenleft}a\ {\isacharplus}\ c{\isacharparenright}\ {\isacharequal}\ a\ {\isacharplus}\ {\isacharparenleft}b\ {\isacharplus}\ c{\isacharparenright}%
\end{isabelle}
\rulename{add_left_commute}
--- a/doc-src/manual.bib Thu Feb 11 12:26:07 2010 -0800
+++ b/doc-src/manual.bib Thu Feb 11 12:26:50 2010 -0800
@@ -3,7 +3,7 @@
%publishers
@string{AP="Academic Press"}
@string{CUP="Cambridge University Press"}
-@string{IEEE="{\sc ieee} Computer Society Press"}
+@string{IEEE="IEEE Computer Society Press"}
@string{LNCS="Lecture Notes in Computer Science"}
@string{MIT="MIT Press"}
@string{NH="North-Holland"}
--- a/src/HOL/Algebras.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Algebras.thy Thu Feb 11 12:26:50 2010 -0800
@@ -55,7 +55,7 @@
end
-subsection {* Generic algebraic operations *}
+subsection {* Generic syntactic operations *}
class zero =
fixes zero :: 'a ("0")
@@ -63,6 +63,13 @@
class one =
fixes one :: 'a ("1")
+hide (open) const zero one
+
+syntax
+ "_index1" :: index ("\<^sub>1")
+translations
+ (index) "\<^sub>1" => (index) "\<^bsub>\<struct>\<^esub>"
+
lemma Let_0 [simp]: "Let 0 f = f 0"
unfolding Let_def ..
@@ -89,8 +96,6 @@
in map tr' [@{const_syntax Algebras.one}, @{const_syntax Algebras.zero}] end;
*} -- {* show types that are presumably too general *}
-hide (open) const zero one
-
class plus =
fixes plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "+" 65)
@@ -103,55 +108,4 @@
class times =
fixes times :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "*" 70)
-class inverse =
- fixes inverse :: "'a \<Rightarrow> 'a"
- and divide :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "'/" 70)
-
-class abs =
- fixes abs :: "'a \<Rightarrow> 'a"
-begin
-
-notation (xsymbols)
- abs ("\<bar>_\<bar>")
-
-notation (HTML output)
- abs ("\<bar>_\<bar>")
-
-end
-
-class sgn =
- fixes sgn :: "'a \<Rightarrow> 'a"
-
-class ord =
- fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
- and less :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
-begin
-
-notation
- less_eq ("op <=") and
- less_eq ("(_/ <= _)" [51, 51] 50) and
- less ("op <") and
- less ("(_/ < _)" [51, 51] 50)
-
-notation (xsymbols)
- less_eq ("op \<le>") and
- less_eq ("(_/ \<le> _)" [51, 51] 50)
-
-notation (HTML output)
- less_eq ("op \<le>") and
- less_eq ("(_/ \<le> _)" [51, 51] 50)
-
-abbreviation (input)
- greater_eq (infix ">=" 50) where
- "x >= y \<equiv> y <= x"
-
-notation (input)
- greater_eq (infix "\<ge>" 50)
-
-abbreviation (input)
- greater (infix ">" 50) where
- "x > y \<equiv> y < x"
-
-end
-
end
\ No newline at end of file
--- a/src/HOL/Bali/AxCompl.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/AxCompl.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/AxCompl.thy
- ID: $Id$
Author: David von Oheimb and Norbert Schirmer
*)
--- a/src/HOL/Bali/AxExample.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/AxExample.thy Thu Feb 11 12:26:50 2010 -0800
@@ -166,7 +166,7 @@
apply (tactic "ax_tac 1" (* NewC *))
apply (tactic "ax_tac 1" (* ax_Alloc *))
(* just for clarification: *)
-apply (rule_tac Q' = "Normal ((\<lambda>Y s Z. arr_inv (store s) \<and> vf=lvar (VName e) (store s)) \<and>. heap_free tree \<and>. initd Ext)" in conseq2)
+apply (rule_tac Q' = "Normal ((\<lambda>Y s Z. arr_inv (store s) \<and> vf=lvar (VName e) (store s)) \<and>. heap_free three \<and>. initd Ext)" in conseq2)
prefer 2
apply (simp add: invocation_declclass_def dynmethd_def)
apply (unfold dynlookup_def)
--- a/src/HOL/Bali/AxSem.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/AxSem.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,12 +1,10 @@
(* Title: HOL/Bali/AxSem.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* Axiomatic semantics of Java expressions and statements
(see also Eval.thy)
*}
-
theory AxSem imports Evaln TypeSafe begin
text {*
@@ -39,14 +37,15 @@
*}
types res = vals --{* result entry *}
-syntax
- Val :: "val \<Rightarrow> res"
- Var :: "var \<Rightarrow> res"
- Vals :: "val list \<Rightarrow> res"
-translations
- "Val x" => "(In1 x)"
- "Var x" => "(In2 x)"
- "Vals x" => "(In3 x)"
+
+abbreviation (input)
+ Val where "Val x == In1 x"
+
+abbreviation (input)
+ Var where "Var x == In2 x"
+
+abbreviation (input)
+ Vals where "Vals x == In3 x"
syntax
"_Val" :: "[pttrn] => pttrn" ("Val:_" [951] 950)
@@ -54,9 +53,9 @@
"_Vals" :: "[pttrn] => pttrn" ("Vals:_" [951] 950)
translations
- "\<lambda>Val:v . b" == "(\<lambda>v. b) \<circ> the_In1"
- "\<lambda>Var:v . b" == "(\<lambda>v. b) \<circ> the_In2"
- "\<lambda>Vals:v. b" == "(\<lambda>v. b) \<circ> the_In3"
+ "\<lambda>Val:v . b" == "(\<lambda>v. b) \<circ> CONST the_In1"
+ "\<lambda>Var:v . b" == "(\<lambda>v. b) \<circ> CONST the_In2"
+ "\<lambda>Vals:v. b" == "(\<lambda>v. b) \<circ> CONST the_In3"
--{* relation on result values, state and auxiliary variables *}
types 'a assn = "res \<Rightarrow> state \<Rightarrow> 'a \<Rightarrow> bool"
@@ -105,10 +104,9 @@
apply auto
done
-syntax
- Normal :: "'a assn \<Rightarrow> 'a assn"
-translations
- "Normal P" == "P \<and>. normal"
+abbreviation
+ Normal :: "'a assn \<Rightarrow> 'a assn"
+ where "Normal P == P \<and>. normal"
lemma peek_and_Normal [simp]: "peek_and (Normal P) p = Normal (peek_and P p)"
apply (rule ext)
@@ -207,9 +205,9 @@
"peek_res Pf \<equiv> \<lambda>Y. Pf Y Y"
syntax
-"@peek_res" :: "pttrn \<Rightarrow> 'a assn \<Rightarrow> 'a assn" ("\<lambda>_:. _" [0,3] 3)
+ "_peek_res" :: "pttrn \<Rightarrow> 'a assn \<Rightarrow> 'a assn" ("\<lambda>_:. _" [0,3] 3)
translations
- "\<lambda>w:. P" == "peek_res (\<lambda>w. P)"
+ "\<lambda>w:. P" == "CONST peek_res (\<lambda>w. P)"
lemma peek_res_def2 [simp]: "peek_res P Y = P Y Y"
apply (unfold peek_res_def)
@@ -268,9 +266,9 @@
"peek_st P \<equiv> \<lambda>Y s. P (store s) Y s"
syntax
-"@peek_st" :: "pttrn \<Rightarrow> 'a assn \<Rightarrow> 'a assn" ("\<lambda>_.. _" [0,3] 3)
+ "_peek_st" :: "pttrn \<Rightarrow> 'a assn \<Rightarrow> 'a assn" ("\<lambda>_.. _" [0,3] 3)
translations
- "\<lambda>s.. P" == "peek_st (\<lambda>s. P)"
+ "\<lambda>s.. P" == "CONST peek_st (\<lambda>s. P)"
lemma peek_st_def2 [simp]: "(\<lambda>s.. Pf s) Y s = Pf (store s) Y s"
apply (unfold peek_st_def)
@@ -386,33 +384,31 @@
("{(1_)}/ _>/ {(1_)}" [3,65,3]75)
types 'a triples = "'a triple set"
-syntax
-
+abbreviation
var_triple :: "['a assn, var ,'a assn] \<Rightarrow> 'a triple"
("{(1_)}/ _=>/ {(1_)}" [3,80,3] 75)
+ where "{P} e=> {Q} == {P} In2 e> {Q}"
+
+abbreviation
expr_triple :: "['a assn, expr ,'a assn] \<Rightarrow> 'a triple"
("{(1_)}/ _->/ {(1_)}" [3,80,3] 75)
+ where "{P} e-> {Q} == {P} In1l e> {Q}"
+
+abbreviation
exprs_triple :: "['a assn, expr list ,'a assn] \<Rightarrow> 'a triple"
("{(1_)}/ _#>/ {(1_)}" [3,65,3] 75)
+ where "{P} e#> {Q} == {P} In3 e> {Q}"
+
+abbreviation
stmt_triple :: "['a assn, stmt, 'a assn] \<Rightarrow> 'a triple"
("{(1_)}/ ._./ {(1_)}" [3,65,3] 75)
-
-syntax (xsymbols)
+ where "{P} .c. {Q} == {P} In1r c> {Q}"
- triple :: "['a assn, term ,'a assn] \<Rightarrow> 'a triple"
- ("{(1_)}/ _\<succ>/ {(1_)}" [3,65,3] 75)
- var_triple :: "['a assn, var ,'a assn] \<Rightarrow> 'a triple"
- ("{(1_)}/ _=\<succ>/ {(1_)}" [3,80,3] 75)
- expr_triple :: "['a assn, expr ,'a assn] \<Rightarrow> 'a triple"
- ("{(1_)}/ _-\<succ>/ {(1_)}" [3,80,3] 75)
- exprs_triple :: "['a assn, expr list ,'a assn] \<Rightarrow> 'a triple"
- ("{(1_)}/ _\<doteq>\<succ>/ {(1_)}" [3,65,3] 75)
-
-translations
- "{P} e-\<succ> {Q}" == "{P} In1l e\<succ> {Q}"
- "{P} e=\<succ> {Q}" == "{P} In2 e\<succ> {Q}"
- "{P} e\<doteq>\<succ> {Q}" == "{P} In3 e\<succ> {Q}"
- "{P} .c. {Q}" == "{P} In1r c\<succ> {Q}"
+notation (xsymbols)
+ triple ("{(1_)}/ _\<succ>/ {(1_)}" [3,65,3] 75) and
+ var_triple ("{(1_)}/ _=\<succ>/ {(1_)}" [3,80,3] 75) and
+ expr_triple ("{(1_)}/ _-\<succ>/ {(1_)}" [3,80,3] 75) and
+ exprs_triple ("{(1_)}/ _\<doteq>\<succ>/ {(1_)}" [3,65,3] 75)
lemma inj_triple: "inj (\<lambda>(P,t,Q). {P} t\<succ> {Q})"
apply (rule inj_onI)
@@ -436,26 +432,25 @@
ax_valids :: "prog \<Rightarrow> 'b triples \<Rightarrow> 'a triples \<Rightarrow> bool"
("_,_|\<Turnstile>_" [61,58,58] 57)
-syntax
-
+abbreviation
triples_valid:: "prog \<Rightarrow> nat \<Rightarrow> 'a triples \<Rightarrow> bool"
( "_||=_:_" [61,0, 58] 57)
- ax_valid :: "prog \<Rightarrow> 'b triples \<Rightarrow> 'a triple \<Rightarrow> bool"
- ( "_,_|=_" [61,58,58] 57)
-
-syntax (xsymbols)
+ where "G||=n:ts == Ball ts (triple_valid G n)"
- triples_valid:: "prog \<Rightarrow> nat \<Rightarrow> 'a triples \<Rightarrow> bool"
- ( "_|\<Turnstile>_:_" [61,0, 58] 57)
- ax_valid :: "prog \<Rightarrow> 'b triples \<Rightarrow> 'a triple \<Rightarrow> bool"
- ( "_,_\<Turnstile>_" [61,58,58] 57)
+abbreviation
+ ax_valid :: "prog \<Rightarrow> 'b triples \<Rightarrow> 'a triple \<Rightarrow> bool"
+ ( "_,_|=_" [61,58,58] 57)
+ where "G,A |=t == G,A|\<Turnstile>{t}"
+
+notation (xsymbols)
+ triples_valid ("_|\<Turnstile>_:_" [61,0, 58] 57) and
+ ax_valid ("_,_\<Turnstile>_" [61,58,58] 57)
defs triple_valid_def: "G\<Turnstile>n:t \<equiv> case t of {P} t\<succ> {Q} \<Rightarrow>
\<forall>Y s Z. P Y s Z \<longrightarrow> type_ok G t s \<longrightarrow>
(\<forall>Y' s'. G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (Y',s') \<longrightarrow> Q Y' s' Z)"
-translations "G|\<Turnstile>n:ts" == "Ball ts (triple_valid G n)"
-defs ax_valids_def:"G,A|\<Turnstile>ts \<equiv> \<forall>n. G|\<Turnstile>n:A \<longrightarrow> G|\<Turnstile>n:ts"
-translations "G,A \<Turnstile>t" == "G,A|\<Turnstile>{t}"
+
+defs ax_valids_def:"G,A|\<Turnstile>ts \<equiv> \<forall>n. G|\<Turnstile>n:A \<longrightarrow> G|\<Turnstile>n:ts"
lemma triple_valid_def2: "G\<Turnstile>n:{P} t\<succ> {Q} =
(\<forall>Y s Z. P Y s Z
--- a/src/HOL/Bali/AxSound.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/AxSound.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/AxSound.thy
- ID: $Id$
Author: David von Oheimb and Norbert Schirmer
*)
header {* Soundness proof for Axiomatic semantics of Java expressions and
--- a/src/HOL/Bali/Basis.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/Basis.thy Thu Feb 11 12:26:50 2010 -0800
@@ -27,12 +27,8 @@
apply fast+
done
-syntax
- "3" :: nat ("3")
- "4" :: nat ("4")
-translations
- "3" == "Suc 2"
- "4" == "Suc 3"
+abbreviation nat3 :: nat ("3") where "3 == Suc 2"
+abbreviation nat4 :: nat ("4") where "4 == Suc 3"
(*unused*)
lemma range_bool_domain: "range f = {f True, f False}"
@@ -182,10 +178,7 @@
hide const In0 In1
-syntax
- fun_sum :: "('a => 'c) => ('b => 'c) => (('a+'b) => 'c)" (infixr "'(+')"80)
-translations
- "fun_sum" == "CONST sum_case"
+notation sum_case (infixr "'(+')"80)
consts the_Inl :: "'a + 'b \<Rightarrow> 'a"
the_Inr :: "'a + 'b \<Rightarrow> 'b"
@@ -201,18 +194,17 @@
primrec "the_In2 (In2 b) = b"
primrec "the_In3 (In3 c) = c"
-syntax
- In1l :: "'al \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
- In1r :: "'ar \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
-translations
- "In1l e" == "In1 (CONST Inl e)"
- "In1r c" == "In1 (CONST Inr c)"
+abbreviation In1l :: "'al \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
+ where "In1l e == In1 (Inl e)"
+
+abbreviation In1r :: "'ar \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
+ where "In1r c == In1 (Inr c)"
-syntax the_In1l :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'al"
- the_In1r :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'ar"
-translations
- "the_In1l" == "the_Inl \<circ> the_In1"
- "the_In1r" == "the_Inr \<circ> the_In1"
+abbreviation the_In1l :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'al"
+ where "the_In1l == the_Inl \<circ> the_In1"
+
+abbreviation the_In1r :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'ar"
+ where "the_In1r == the_Inr \<circ> the_In1"
ML {*
fun sum3_instantiate ctxt thm = map (fn s =>
@@ -319,8 +311,8 @@
syntax
"_lpttrn" :: "[pttrn,pttrn] => pttrn" ("_#/_" [901,900] 900)
translations
- "%y#x#xs. b" == "lsplit (%y x#xs. b)"
- "%x#xs . b" == "lsplit (%x xs . b)"
+ "%y#x#xs. b" == "CONST lsplit (%y x#xs. b)"
+ "%x#xs . b" == "CONST lsplit (%x xs . b)"
lemma lsplit [simp]: "lsplit c (x#xs) = c x xs"
apply (unfold lsplit_def)
--- a/src/HOL/Bali/Conform.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/Conform.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Conform.thy
- ID: $Id$
Author: David von Oheimb
*)
--- a/src/HOL/Bali/Decl.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/Decl.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Decl.thy
- ID: $Id$
Author: David von Oheimb and Norbert Schirmer
*)
header {* Field, method, interface, and class declarations, whole Java programs
@@ -402,17 +401,21 @@
"prog"<= (type) "\<lparr>ifaces::idecl list,classes::cdecl list\<rparr>"
"prog"<= (type) "\<lparr>ifaces::idecl list,classes::cdecl list,\<dots>::'a\<rparr>"
-syntax
- iface :: "prog \<Rightarrow> (qtname, iface) table"
- "class" :: "prog \<Rightarrow> (qtname, class) table"
- is_iface :: "prog \<Rightarrow> qtname \<Rightarrow> bool"
- is_class :: "prog \<Rightarrow> qtname \<Rightarrow> bool"
+abbreviation
+ iface :: "prog \<Rightarrow> (qtname, iface) table"
+ where "iface G I == table_of (ifaces G) I"
+
+abbreviation
+ "class" :: "prog \<Rightarrow> (qtname, class) table"
+ where "class G C == table_of (classes G) C"
-translations
- "iface G I" == "table_of (ifaces G) I"
- "class G C" == "table_of (classes G) C"
- "is_iface G I" == "iface G I \<noteq> None"
- "is_class G C" == "class G C \<noteq> None"
+abbreviation
+ is_iface :: "prog \<Rightarrow> qtname \<Rightarrow> bool"
+ where "is_iface G I == iface G I \<noteq> None"
+
+abbreviation
+ is_class :: "prog \<Rightarrow> qtname \<Rightarrow> bool"
+ where "is_class G C == class G C \<noteq> None"
section "is type"
@@ -445,21 +448,22 @@
subint1_def: "subint1 G \<equiv> {(I,J). \<exists>i\<in>iface G I: J\<in>set (isuperIfs i)}"
subcls1_def: "subcls1 G \<equiv> {(C,D). C\<noteq>Object \<and> (\<exists>c\<in>class G C: super c = D)}"
-syntax
- "_subcls1" :: "prog => [qtname, qtname] => bool" ("_|-_<:C1_" [71,71,71] 70)
- "_subclseq":: "prog => [qtname, qtname] => bool" ("_|-_<=:C _"[71,71,71] 70)
- "_subcls" :: "prog => [qtname, qtname] => bool" ("_|-_<:C _"[71,71,71] 70)
+abbreviation
+ subcls1_syntax :: "prog => [qtname, qtname] => bool" ("_|-_<:C1_" [71,71,71] 70)
+ where "G|-C <:C1 D == (C,D) \<in> subcls1 G"
+
+abbreviation
+ subclseq_syntax :: "prog => [qtname, qtname] => bool" ("_|-_<=:C _"[71,71,71] 70)
+ where "G|-C <=:C D == (C,D) \<in>(subcls1 G)^*" (* cf. 8.1.3 *)
-syntax (xsymbols)
- "_subcls1" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<prec>\<^sub>C\<^sub>1_" [71,71,71] 70)
- "_subclseq":: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<preceq>\<^sub>C _" [71,71,71] 70)
- "_subcls" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<prec>\<^sub>C _" [71,71,71] 70)
+abbreviation
+ subcls_syntax :: "prog => [qtname, qtname] => bool" ("_|-_<:C _"[71,71,71] 70)
+ where "G|-C <:C D == (C,D) \<in>(subcls1 G)^+"
-translations
- "G\<turnstile>C \<prec>\<^sub>C\<^sub>1 D" == "(C,D) \<in> subcls1 G"
- "G\<turnstile>C \<preceq>\<^sub>C D" == "(C,D) \<in>(subcls1 G)^*" (* cf. 8.1.3 *)
- "G\<turnstile>C \<prec>\<^sub>C D" == "(C,D) \<in>(subcls1 G)^+"
-
+notation (xsymbols)
+ subcls1_syntax ("_\<turnstile>_\<prec>\<^sub>C\<^sub>1_" [71,71,71] 70) and
+ subclseq_syntax ("_\<turnstile>_\<preceq>\<^sub>C _" [71,71,71] 70) and
+ subcls_syntax ("_\<turnstile>_\<prec>\<^sub>C _" [71,71,71] 70)
lemma subint1I: "\<lbrakk>iface G I = Some i; J \<in> set (isuperIfs i)\<rbrakk>
\<Longrightarrow> (I,J) \<in> subint1 G"
--- a/src/HOL/Bali/DeclConcepts.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/DeclConcepts.thy Thu Feb 11 12:26:50 2010 -0800
@@ -13,8 +13,8 @@
"is_public G qn \<equiv> (case class G qn of
None \<Rightarrow> (case iface G qn of
None \<Rightarrow> False
- | Some iface \<Rightarrow> access iface = Public)
- | Some class \<Rightarrow> access class = Public)"
+ | Some i \<Rightarrow> access i = Public)
+ | Some c \<Rightarrow> access c = Public)"
subsection "accessibility of types (cf. 6.6.1)"
text {*
@@ -445,21 +445,17 @@
| Protected \<Rightarrow> True
| Public \<Rightarrow> True)"
-syntax
-Method_inheritable_in::
+abbreviation
+Method_inheritable_in_syntax::
"prog \<Rightarrow> (qtname \<times> mdecl) \<Rightarrow> pname \<Rightarrow> bool"
("_ \<turnstile>Method _ inheritable'_in _ " [61,61,61] 60)
+ where "G\<turnstile>Method m inheritable_in p == G\<turnstile>methdMembr m inheritable_in p"
-translations
-"G\<turnstile>Method m inheritable_in p" == "G\<turnstile>methdMembr m inheritable_in p"
-
-syntax
+abbreviation
Methd_inheritable_in::
"prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> pname \<Rightarrow> bool"
("_ \<turnstile>Methd _ _ inheritable'_in _ " [61,61,61,61] 60)
-
-translations
-"G\<turnstile>Methd s m inheritable_in p" == "G\<turnstile>(method s m) inheritable_in p"
+ where "G\<turnstile>Methd s m inheritable_in p == G\<turnstile>(method s m) inheritable_in p"
subsubsection "declared-in/undeclared-in"
@@ -486,17 +482,15 @@
fdecl (fn,f ) \<Rightarrow> cdeclaredfield G C fn = Some f
| mdecl (sig,m) \<Rightarrow> cdeclaredmethd G C sig = Some m)"
-syntax
+abbreviation
method_declared_in:: "prog \<Rightarrow> (qtname \<times> mdecl) \<Rightarrow> qtname \<Rightarrow> bool"
("_\<turnstile>Method _ declared'_in _" [61,61,61] 60)
-translations
-"G\<turnstile>Method m declared_in C" == "G\<turnstile>mdecl (mthd m) declared_in C"
+ where "G\<turnstile>Method m declared_in C == G\<turnstile>mdecl (mthd m) declared_in C"
-syntax
+abbreviation
methd_declared_in:: "prog \<Rightarrow> sig \<Rightarrow>(qtname \<times> methd) \<Rightarrow> qtname \<Rightarrow> bool"
("_\<turnstile>Methd _ _ declared'_in _" [61,61,61,61] 60)
-translations
-"G\<turnstile>Methd s m declared_in C" == "G\<turnstile>mdecl (s,mthd m) declared_in C"
+ where "G\<turnstile>Methd s m declared_in C == G\<turnstile>mdecl (s,mthd m) declared_in C"
lemma declared_in_classD:
"G\<turnstile>m declared_in C \<Longrightarrow> is_class G C"
@@ -538,26 +532,20 @@
of S will not inherit the member, regardless if they are in the same
package as A or not.*}
-syntax
+abbreviation
method_member_of:: "prog \<Rightarrow> (qtname \<times> mdecl) \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Method _ member'_of _" [61,61,61] 60)
+ where "G\<turnstile>Method m member_of C == G\<turnstile>(methdMembr m) member_of C"
-translations
- "G\<turnstile>Method m member_of C" \<rightleftharpoons> "G\<turnstile>(methdMembr m) member_of C"
-
-syntax
+abbreviation
methd_member_of:: "prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Methd _ _ member'_of _" [61,61,61,61] 60)
+ where "G\<turnstile>Methd s m member_of C == G\<turnstile>(method s m) member_of C"
-translations
- "G\<turnstile>Methd s m member_of C" \<rightleftharpoons> "G\<turnstile>(method s m) member_of C"
-
-syntax
+abbreviation
fieldm_member_of:: "prog \<Rightarrow> vname \<Rightarrow> (qtname \<times> field) \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Field _ _ member'_of _" [61,61,61] 60)
-
-translations
- "G\<turnstile>Field n f member_of C" \<rightleftharpoons> "G\<turnstile>fieldm n f member_of C"
+ where "G\<turnstile>Field n f member_of C == G\<turnstile>fieldm n f member_of C"
constdefs
inherits:: "prog \<Rightarrow> qtname \<Rightarrow> (qtname \<times> memberdecl) \<Rightarrow> bool"
@@ -578,19 +566,15 @@
is necessary since not all members are inherited to subclasses. So such
members are not member-of the subclass but member-in the subclass.*}
-syntax
+abbreviation
method_member_in:: "prog \<Rightarrow> (qtname \<times> mdecl) \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Method _ member'_in _" [61,61,61] 60)
+ where "G\<turnstile>Method m member_in C == G\<turnstile>(methdMembr m) member_in C"
-translations
- "G\<turnstile>Method m member_in C" \<rightleftharpoons> "G\<turnstile>(methdMembr m) member_in C"
-
-syntax
+abbreviation
methd_member_in:: "prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Methd _ _ member'_in _" [61,61,61,61] 60)
-
-translations
- "G\<turnstile>Methd s m member_in C" \<rightleftharpoons> "G\<turnstile>(method s m) member_in C"
+ where "G\<turnstile>Methd s m member_in C == G\<turnstile>(method s m) member_in C"
lemma member_inD: "G\<turnstile>m member_in C
\<Longrightarrow> \<exists> provC. G\<turnstile> C \<preceq>\<^sub>C provC \<and> G \<turnstile> m member_of provC"
@@ -649,18 +633,16 @@
| Indirect: "\<lbrakk>G\<turnstile>new overrides intr; G\<turnstile>intr overrides old\<rbrakk>
\<Longrightarrow> G\<turnstile>new overrides old"
-syntax
+abbreviation (input)
sig_stat_overrides::
"prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> (qtname \<times> methd) \<Rightarrow> bool"
("_,_\<turnstile> _ overrides\<^sub>S _" [61,61,61,61] 60)
-translations
- "G,s\<turnstile>new overrides\<^sub>S old" \<rightharpoonup> "G\<turnstile>(qmdecl s new) overrides\<^sub>S (qmdecl s old)"
+ where "G,s\<turnstile>new overrides\<^sub>S old == G\<turnstile>(qmdecl s new) overrides\<^sub>S (qmdecl s old)"
-syntax
+abbreviation (input)
sig_overrides:: "prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> (qtname \<times> methd) \<Rightarrow> bool"
("_,_\<turnstile> _ overrides _" [61,61,61,61] 60)
-translations
- "G,s\<turnstile>new overrides old" \<rightharpoonup> "G\<turnstile>(qmdecl s new) overrides (qmdecl s old)"
+ where "G,s\<turnstile>new overrides old == G\<turnstile>(qmdecl s new) overrides (qmdecl s old)"
subsubsection "Hiding"
@@ -674,11 +656,10 @@
G\<turnstile>Method old declared_in (declclass old) \<and>
G\<turnstile>Method old inheritable_in pid (declclass new)"
-syntax
-sig_hides:: "prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> mdecl) \<Rightarrow> (qtname \<times> mdecl) \<Rightarrow> bool"
+abbreviation
+sig_hides:: "prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> (qtname \<times> methd) \<Rightarrow> bool"
("_,_\<turnstile> _ hides _" [61,61,61,61] 60)
-translations
- "G,s\<turnstile>new hides old" \<rightharpoonup> "G\<turnstile>(qmdecl s new) hides (qmdecl s old)"
+ where "G,s\<turnstile>new hides old == G\<turnstile>(qmdecl s new) hides (qmdecl s old)"
lemma hidesI:
"\<lbrakk>is_static new; msig new = msig old;
@@ -731,14 +712,14 @@
"prog \<Rightarrow> (qtname \<times> memberdecl) \<Rightarrow> qtname \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile> _ in _ permits'_acc'_from _" [61,61,61,61] 60)
-"G\<turnstile>membr in class permits_acc_from accclass
+"G\<turnstile>membr in cls permits_acc_from accclass
\<equiv> (case (accmodi membr) of
Private \<Rightarrow> (declclass membr = accclass)
| Package \<Rightarrow> (pid (declclass membr) = pid accclass)
| Protected \<Rightarrow> (pid (declclass membr) = pid accclass)
\<or>
(G\<turnstile>accclass \<prec>\<^sub>C declclass membr
- \<and> (G\<turnstile>class \<preceq>\<^sub>C accclass \<or> is_static membr))
+ \<and> (G\<turnstile>cls \<preceq>\<^sub>C accclass \<or> is_static membr))
| Public \<Rightarrow> True)"
text {*
The subcondition of the @{term "Protected"} case:
@@ -774,12 +755,14 @@
| "G\<turnstile>Method m of cls accessible_from accclass \<equiv> accessible_fromR G accclass (methdMembr m) cls"
-| Immediate: "\<lbrakk>G\<turnstile>membr member_of class;
+| Immediate: "!!membr class.
+ \<lbrakk>G\<turnstile>membr member_of class;
G\<turnstile>(Class class) accessible_in (pid accclass);
G\<turnstile>membr in class permits_acc_from accclass
\<rbrakk> \<Longrightarrow> G\<turnstile>membr of class accessible_from accclass"
-| Overriding: "\<lbrakk>G\<turnstile>membr member_of class;
+| Overriding: "!!membr class C new old supr.
+ \<lbrakk>G\<turnstile>membr member_of class;
G\<turnstile>(Class class) accessible_in (pid accclass);
membr=(C,mdecl new);
G\<turnstile>(C,new) overrides\<^sub>S old;
@@ -787,23 +770,21 @@
G\<turnstile>Method old of supr accessible_from accclass
\<rbrakk>\<Longrightarrow> G\<turnstile>membr of class accessible_from accclass"
-syntax
+abbreviation
methd_accessible_from::
"prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> qtname \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Methd _ _ of _ accessible'_from _" [61,61,61,61,61] 60)
+ where
+ "G\<turnstile>Methd s m of cls accessible_from accclass ==
+ G\<turnstile>(method s m) of cls accessible_from accclass"
-translations
-"G\<turnstile>Methd s m of cls accessible_from accclass"
- \<rightleftharpoons> "G\<turnstile>(method s m) of cls accessible_from accclass"
-
-syntax
+abbreviation
field_accessible_from::
"prog \<Rightarrow> vname \<Rightarrow> (qtname \<times> field) \<Rightarrow> qtname \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Field _ _ of _ accessible'_from _" [61,61,61,61,61] 60)
-
-translations
-"G\<turnstile>Field fn f of C accessible_from accclass"
- \<rightleftharpoons> "G\<turnstile>(fieldm fn f) of C accessible_from accclass"
+ where
+ "G\<turnstile>Field fn f of C accessible_from accclass ==
+ G\<turnstile>(fieldm fn f) of C accessible_from accclass"
inductive
dyn_accessible_fromR :: "prog \<Rightarrow> qtname \<Rightarrow> (qtname \<times> memberdecl) \<Rightarrow> qtname \<Rightarrow> bool"
@@ -817,34 +798,32 @@
| "G\<turnstile>Method m in C dyn_accessible_from accC \<equiv> dyn_accessible_fromR G accC (methdMembr m) C"
-| Immediate: "\<lbrakk>G\<turnstile>membr member_in class;
+| Immediate: "!!class. \<lbrakk>G\<turnstile>membr member_in class;
G\<turnstile>membr in class permits_acc_from accclass
\<rbrakk> \<Longrightarrow> G\<turnstile>membr in class dyn_accessible_from accclass"
-| Overriding: "\<lbrakk>G\<turnstile>membr member_in class;
+| Overriding: "!!class. \<lbrakk>G\<turnstile>membr member_in class;
membr=(C,mdecl new);
G\<turnstile>(C,new) overrides old;
G\<turnstile>class \<prec>\<^sub>C supr;
G\<turnstile>Method old in supr dyn_accessible_from accclass
\<rbrakk>\<Longrightarrow> G\<turnstile>membr in class dyn_accessible_from accclass"
-syntax
+abbreviation
methd_dyn_accessible_from::
"prog \<Rightarrow> sig \<Rightarrow> (qtname \<times> methd) \<Rightarrow> qtname \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Methd _ _ in _ dyn'_accessible'_from _" [61,61,61,61,61] 60)
+ where
+ "G\<turnstile>Methd s m in C dyn_accessible_from accC ==
+ G\<turnstile>(method s m) in C dyn_accessible_from accC"
-translations
-"G\<turnstile>Methd s m in C dyn_accessible_from accC"
- \<rightleftharpoons> "G\<turnstile>(method s m) in C dyn_accessible_from accC"
-
-syntax
+abbreviation
field_dyn_accessible_from::
"prog \<Rightarrow> vname \<Rightarrow> (qtname \<times> field) \<Rightarrow> qtname \<Rightarrow> qtname \<Rightarrow> bool"
("_ \<turnstile>Field _ _ in _ dyn'_accessible'_from _" [61,61,61,61,61] 60)
-
-translations
-"G\<turnstile>Field fn f in dynC dyn_accessible_from accC"
- \<rightleftharpoons> "G\<turnstile>(fieldm fn f) in dynC dyn_accessible_from accC"
+ where
+ "G\<turnstile>Field fn f in dynC dyn_accessible_from accC ==
+ G\<turnstile>(fieldm fn f) in dynC dyn_accessible_from accC"
lemma accessible_from_commonD: "G\<turnstile>m of C accessible_from S
--- a/src/HOL/Bali/DefiniteAssignmentCorrect.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/DefiniteAssignmentCorrect.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,3 @@
-(* $Id$ *)
-
header {* Correctness of Definite Assignment *}
theory DefiniteAssignmentCorrect imports WellForm Eval begin
--- a/src/HOL/Bali/Eval.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/Eval.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Eval.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* Operational evaluation (big-step) semantics of Java expressions and
@@ -125,20 +124,21 @@
assignment.
*}
-syntax (xsymbols)
+abbreviation (xsymbols)
dummy_res :: "vals" ("\<diamondsuit>")
-translations
- "\<diamondsuit>" == "In1 Unit"
+ where "\<diamondsuit> == In1 Unit"
+
+abbreviation (input)
+ val_inj_vals ("\<lfloor>_\<rfloor>\<^sub>e" 1000)
+ where "\<lfloor>e\<rfloor>\<^sub>e == In1 e"
-syntax
- val_inj_vals:: "expr \<Rightarrow> term" ("\<lfloor>_\<rfloor>\<^sub>e" 1000)
- var_inj_vals:: "var \<Rightarrow> term" ("\<lfloor>_\<rfloor>\<^sub>v" 1000)
- lst_inj_vals:: "expr list \<Rightarrow> term" ("\<lfloor>_\<rfloor>\<^sub>l" 1000)
+abbreviation (input)
+ var_inj_vals ("\<lfloor>_\<rfloor>\<^sub>v" 1000)
+ where "\<lfloor>v\<rfloor>\<^sub>v == In2 v"
-translations
- "\<lfloor>e\<rfloor>\<^sub>e" \<rightharpoonup> "In1 e"
- "\<lfloor>v\<rfloor>\<^sub>v" \<rightharpoonup> "In2 v"
- "\<lfloor>es\<rfloor>\<^sub>l" \<rightharpoonup> "In3 es"
+abbreviation (input)
+ lst_inj_vals ("\<lfloor>_\<rfloor>\<^sub>l" 1000)
+ where "\<lfloor>es\<rfloor>\<^sub>l == In3 es"
constdefs
undefined3 :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> vals"
--- a/src/HOL/Bali/Evaln.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/Evaln.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Evaln.thy
- ID: $Id$
Author: David von Oheimb and Norbert Schirmer
*)
header {* Operational evaluation (big-step) semantics of Java expressions and
--- a/src/HOL/Bali/Example.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/Example.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1202,74 +1202,52 @@
abbreviation "one == Suc 0"
abbreviation "two == Suc one"
-abbreviation "tree == Suc two"
-abbreviation "four == Suc tree"
+abbreviation "three == Suc two"
+abbreviation "four == Suc three"
+
+abbreviation
+ "obj_a == \<lparr>tag=Arr (PrimT Boolean) 2
+ ,values= empty(Inr 0\<mapsto>Bool False)(Inr 1\<mapsto>Bool False)\<rparr>"
-syntax
- obj_a :: obj
- obj_b :: obj
- obj_c :: obj
- arr_N :: "(vn, val) table"
- arr_a :: "(vn, val) table"
- globs1 :: globs
- globs2 :: globs
- globs3 :: globs
- globs8 :: globs
- locs3 :: locals
- locs4 :: locals
- locs8 :: locals
- s0 :: state
- s0' :: state
- s9' :: state
- s1 :: state
- s1' :: state
- s2 :: state
- s2' :: state
- s3 :: state
- s3' :: state
- s4 :: state
- s4' :: state
- s6' :: state
- s7' :: state
- s8 :: state
- s8' :: state
+abbreviation
+ "obj_b == \<lparr>tag=CInst Ext
+ ,values=(empty(Inl (vee, Base)\<mapsto>Null )
+ (Inl (vee, Ext )\<mapsto>Intg 0))\<rparr>"
+
+abbreviation
+ "obj_c == \<lparr>tag=CInst (SXcpt NullPointer),values=CONST empty\<rparr>"
+
+abbreviation "arr_N == empty(Inl (arr, Base)\<mapsto>Null)"
+abbreviation "arr_a == empty(Inl (arr, Base)\<mapsto>Addr a)"
+
+abbreviation
+ "globs1 == empty(Inr Ext \<mapsto>\<lparr>tag=undefined, values=empty\<rparr>)
+ (Inr Base \<mapsto>\<lparr>tag=undefined, values=arr_N\<rparr>)
+ (Inr Object\<mapsto>\<lparr>tag=undefined, values=empty\<rparr>)"
-translations
- "obj_a" <= "\<lparr>tag=Arr (PrimT Boolean) (CONST two)
- ,values=CONST empty(CONST Inr 0\<mapsto>Bool False)(CONST Inr (CONST one)\<mapsto>Bool False)\<rparr>"
- "obj_b" <= "\<lparr>tag=CInst (CONST Ext)
- ,values=(CONST empty(CONST Inl (CONST vee, CONST Base)\<mapsto>Null )
- (CONST Inl (CONST vee, CONST Ext )\<mapsto>Intg 0))\<rparr>"
- "obj_c" == "\<lparr>tag=CInst (SXcpt NullPointer),values=CONST empty\<rparr>"
- "arr_N" == "CONST empty(CONST Inl (CONST arr, CONST Base)\<mapsto>Null)"
- "arr_a" == "CONST empty(CONST Inl (CONST arr, CONST Base)\<mapsto>Addr a)"
- "globs1" == "CONST empty(CONST Inr (CONST Ext) \<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)
- (CONST Inr (CONST Base) \<mapsto>\<lparr>tag=CONST undefined, values=arr_N\<rparr>)
- (CONST Inr Object\<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)"
- "globs2" == "CONST empty(CONST Inr (CONST Ext) \<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)
- (CONST Inr Object\<mapsto>\<lparr>tag=CONST undefined, values=CONST empty\<rparr>)
- (CONST Inl a\<mapsto>obj_a)
- (CONST Inr (CONST Base) \<mapsto>\<lparr>tag=CONST undefined, values=arr_a\<rparr>)"
- "globs3" == "globs2(CONST Inl b\<mapsto>obj_b)"
- "globs8" == "globs3(CONST Inl c\<mapsto>obj_c)"
- "locs3" == "CONST empty(VName (CONST e)\<mapsto>Addr b)"
- "locs4" == "CONST empty(VName (CONST z)\<mapsto>Null)(CONST Inr()\<mapsto>Addr b)"
- "locs8" == "locs3(VName (CONST z)\<mapsto>Addr c)"
- "s0" == " st (CONST empty) (CONST empty)"
- "s0'" == " Norm s0"
- "s1" == " st globs1 (CONST empty)"
- "s1'" == " Norm s1"
- "s2" == " st globs2 (CONST empty)"
- "s2'" == " Norm s2"
- "s3" == " st globs3 locs3 "
- "s3'" == " Norm s3"
- "s4" == " st globs3 locs4"
- "s4'" == " Norm s4"
- "s6'" == "(Some (Xcpt (Std NullPointer)), s4)"
- "s7'" == "(Some (Xcpt (Std NullPointer)), s3)"
- "s8" == " st globs8 locs8"
- "s8'" == " Norm s8"
- "s9'" == "(Some (Xcpt (Std IndOutBound)), s8)"
+abbreviation
+ "globs2 == empty(Inr Ext \<mapsto>\<lparr>tag=undefined, values=empty\<rparr>)
+ (Inr Object\<mapsto>\<lparr>tag=undefined, values=empty\<rparr>)
+ (Inl a\<mapsto>obj_a)
+ (Inr Base \<mapsto>\<lparr>tag=undefined, values=arr_a\<rparr>)"
+
+abbreviation "globs3 == globs2(Inl b\<mapsto>obj_b)"
+abbreviation "globs8 == globs3(Inl c\<mapsto>obj_c)"
+abbreviation "locs3 == empty(VName e\<mapsto>Addr b)"
+abbreviation "locs8 == locs3(VName z\<mapsto>Addr c)"
+
+abbreviation "s0 == st empty empty"
+abbreviation "s0' == Norm s0"
+abbreviation "s1 == st globs1 empty"
+abbreviation "s1' == Norm s1"
+abbreviation "s2 == st globs2 empty"
+abbreviation "s2' == Norm s2"
+abbreviation "s3 == st globs3 locs3"
+abbreviation "s3' == Norm s3"
+abbreviation "s7' == (Some (Xcpt (Std NullPointer)), s3)"
+abbreviation "s8 == st globs8 locs8"
+abbreviation "s8' == Norm s8"
+abbreviation "s9' == (Some (Xcpt (Std IndOutBound)), s8)"
declare Pair_eq [simp del]
@@ -1293,7 +1271,7 @@
apply (rule eval_Is (* NewC *))
(* begin init Ext *)
apply (erule_tac V = "the (new_Addr ?h) = b" in thin_rl)
-apply (erule_tac V = "atleast_free ?h tree" in thin_rl)
+apply (erule_tac V = "atleast_free ?h three" in thin_rl)
apply (erule_tac [2] V = "atleast_free ?h four" in thin_rl)
apply (erule_tac [2] V = "new_Addr ?h = Some a" in thin_rl)
apply (rule eval_Is (* Init Ext *))
@@ -1336,7 +1314,7 @@
apply (drule alloc_one)
apply (simp (no_asm_simp))
apply clarsimp
-apply (erule_tac V = "atleast_free ?h tree" in thin_rl)
+apply (erule_tac V = "atleast_free ?h three" in thin_rl)
apply (drule_tac x = "a" in new_AddrD2 [THEN spec])
apply (simp (no_asm_use))
apply (rule eval_Is (* Try *))
--- a/src/HOL/Bali/Name.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/Name.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Name.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* Java names *}
@@ -20,13 +19,11 @@
datatype lname --{* names for local variables and the This pointer *}
= EName ename
| This
-syntax
- VName :: "vname \<Rightarrow> lname"
- Result :: lname
+abbreviation VName :: "vname \<Rightarrow> lname"
+ where "VName n == EName (VNam n)"
-translations
- "VName n" == "EName (VNam n)"
- "Result" == "EName Res"
+abbreviation Result :: lname
+ where "Result == EName Res"
datatype xname --{* names of standard exceptions *}
= Throwable
--- a/src/HOL/Bali/State.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/State.thy Thu Feb 11 12:26:50 2010 -0800
@@ -254,13 +254,11 @@
by (simp add: heap_def)
-syntax
- val_this :: "st \<Rightarrow> val"
- lookup_obj :: "st \<Rightarrow> val \<Rightarrow> obj"
+abbreviation val_this :: "st \<Rightarrow> val"
+ where "val_this s == the (locals s This)"
-translations
- "val_this s" == "CONST the (locals s This)"
- "lookup_obj s a'" == "CONST the (heap s (the_Addr a'))"
+abbreviation lookup_obj :: "st \<Rightarrow> val \<Rightarrow> obj"
+ where "lookup_obj s a' == the (heap s (the_Addr a'))"
subsection "memory allocation"
@@ -286,12 +284,8 @@
subsection "initialization"
-syntax
-
- init_vals :: "('a, ty) table \<Rightarrow> ('a, val) table"
-
-translations
- "init_vals vs" == "CONST Option.map default_val \<circ> vs"
+abbreviation init_vals :: "('a, ty) table \<Rightarrow> ('a, val) table"
+ where "init_vals vs == Option.map default_val \<circ> vs"
lemma init_arr_comps_base [simp]: "init_vals (arr_comps T 0) = empty"
apply (unfold arr_comps_def in_bounds_def)
@@ -325,11 +319,9 @@
init_obj :: "prog \<Rightarrow> obj_tag \<Rightarrow> oref \<Rightarrow> st \<Rightarrow> st"
"init_obj G oi r \<equiv> gupd(r\<mapsto>\<lparr>tag=oi, values=init_vals (var_tys G oi r)\<rparr>)"
-syntax
+abbreviation
init_class_obj :: "prog \<Rightarrow> qtname \<Rightarrow> st \<Rightarrow> st"
-
-translations
- "init_class_obj G C" == "init_obj G CONST undefined (CONST Inr C)"
+ where "init_class_obj G C == init_obj G undefined (Inr C)"
lemma gupd_def2 [simp]: "gupd(r\<mapsto>obj) (st g l) = st (g(r\<mapsto>obj)) l"
apply (unfold gupd_def)
@@ -513,19 +505,17 @@
apply auto
done
-syntax
+abbreviation raise_if :: "bool \<Rightarrow> xname \<Rightarrow> abopt \<Rightarrow> abopt"
+ where "raise_if c xn == abrupt_if c (Some (Xcpt (Std xn)))"
+
+abbreviation np :: "val \<Rightarrow> abopt \<Rightarrow> abopt"
+ where "np v == raise_if (v = Null) NullPointer"
- raise_if :: "bool \<Rightarrow> xname \<Rightarrow> abopt \<Rightarrow> abopt"
- np :: "val \<spacespace> \<Rightarrow> abopt \<Rightarrow> abopt"
- check_neg:: "val \<spacespace> \<Rightarrow> abopt \<Rightarrow> abopt"
- error_if :: "bool \<Rightarrow> error \<Rightarrow> abopt \<Rightarrow> abopt"
-
-translations
+abbreviation check_neg :: "val \<Rightarrow> abopt \<Rightarrow> abopt"
+ where "check_neg i' == raise_if (the_Intg i'<0) NegArrSize"
- "raise_if c xn" == "abrupt_if c (Some (Xcpt (Std xn)))"
- "np v" == "raise_if (v = Null) NullPointer"
- "check_neg i'" == "raise_if (the_Intg i'<0) NegArrSize"
- "error_if c e" == "abrupt_if c (Some (Error e))"
+abbreviation error_if :: "bool \<Rightarrow> error \<Rightarrow> abopt \<Rightarrow> abopt"
+ where "error_if c e == abrupt_if c (Some (Error e))"
lemma raise_if_None [simp]: "(raise_if c x y = None) = (\<not>c \<and> y = None)"
apply (simp add: abrupt_if_def)
@@ -592,22 +582,23 @@
types
state = "abopt \<times> st" --{* state including abruption information *}
-syntax
- Norm :: "st \<Rightarrow> state"
- abrupt :: "state \<Rightarrow> abopt"
- store :: "state \<Rightarrow> st"
-
translations
-
- "Norm s" == "(None,s)"
- "abrupt" => "fst"
- "store" => "snd"
"abopt" <= (type) "State.abrupt option"
"abopt" <= (type) "abrupt option"
"state" <= (type) "abopt \<times> State.st"
"state" <= (type) "abopt \<times> st"
+abbreviation
+ Norm :: "st \<Rightarrow> state"
+ where "Norm s == (None, s)"
+abbreviation (input)
+ abrupt :: "state \<Rightarrow> abopt"
+ where "abrupt == fst"
+
+abbreviation (input)
+ store :: "state \<Rightarrow> st"
+ where "store == snd"
lemma single_stateE: "\<forall>Z. Z = (s::state) \<Longrightarrow> False"
apply (erule_tac x = "(Some k,y)" in all_dupE)
@@ -683,15 +674,11 @@
lemma supd_abrupt_invariant [simp]: "abrupt (supd f s) = abrupt s"
by (cases s) simp
-syntax
+abbreviation set_lvars :: "locals \<Rightarrow> state \<Rightarrow> state"
+ where "set_lvars l == supd (set_locals l)"
- set_lvars :: "locals \<Rightarrow> state \<Rightarrow> state"
- restore_lvars :: "state \<Rightarrow> state \<Rightarrow> state"
-
-translations
-
- "set_lvars l" == "supd (set_locals l)"
- "restore_lvars s' s" == "set_lvars (locals (store s')) s"
+abbreviation restore_lvars :: "state \<Rightarrow> state \<Rightarrow> state"
+ where "restore_lvars s' s == set_lvars (locals (store s')) s"
lemma set_set_lvars [simp]: "\<And> s. set_lvars l (set_lvars l' s) = set_lvars l s"
apply (simp (no_asm_simp) only: split_tupled_all)
--- a/src/HOL/Bali/Term.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/Term.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Term.thy
- ID: $Id$
Author: David von Oheimb
*)
@@ -244,22 +243,23 @@
"stmt" <= (type) "Term.stmt"
"term" <= (type) "(expr+stmt,var,expr list) sum3"
-syntax
-
- this :: expr
- LAcc :: "vname \<Rightarrow> expr" ("!!")
- LAss :: "vname \<Rightarrow> expr \<Rightarrow>stmt" ("_:==_" [90,85] 85)
- Return :: "expr \<Rightarrow> stmt"
- StatRef :: "ref_ty \<Rightarrow> expr"
+abbreviation this :: expr
+ where "this == Acc (LVar This)"
+
+abbreviation LAcc :: "vname \<Rightarrow> expr" ("!!")
+ where "!!v == Acc (LVar (EName (VNam v)))"
-translations
-
- "this" == "Acc (LVar This)"
- "!!v" == "Acc (LVar (EName (VNam v)))"
- "v:==e" == "Expr (Ass (LVar (EName (VNam v))) e)"
- "Return e" == "Expr (Ass (LVar (EName Res)) e);; Jmp Ret"
- --{* \tt Res := e;; Jmp Ret *}
- "StatRef rt" == "Cast (RefT rt) (Lit Null)"
+abbreviation
+ LAss :: "vname \<Rightarrow> expr \<Rightarrow>stmt" ("_:==_" [90,85] 85)
+ where "v:==e == Expr (Ass (LVar (EName (VNam v))) e)"
+
+abbreviation
+ Return :: "expr \<Rightarrow> stmt"
+ where "Return e == Expr (Ass (LVar (EName Res)) e);; Jmp Ret" --{* \tt Res := e;; Jmp Ret *}
+
+abbreviation
+ StatRef :: "ref_ty \<Rightarrow> expr"
+ where "StatRef rt == Cast (RefT rt) (Lit Null)"
constdefs
@@ -275,17 +275,21 @@
expressions, variables and expression lists into general terms.
*}
-syntax
- expr_inj_term:: "expr \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>e" 1000)
- stmt_inj_term:: "stmt \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>s" 1000)
- var_inj_term:: "var \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>v" 1000)
- lst_inj_term:: "expr list \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>l" 1000)
+abbreviation (input)
+ expr_inj_term :: "expr \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>e" 1000)
+ where "\<langle>e\<rangle>\<^sub>e == In1l e"
+
+abbreviation (input)
+ stmt_inj_term :: "stmt \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>s" 1000)
+ where "\<langle>c\<rangle>\<^sub>s == In1r c"
-translations
- "\<langle>e\<rangle>\<^sub>e" \<rightharpoonup> "In1l e"
- "\<langle>c\<rangle>\<^sub>s" \<rightharpoonup> "In1r c"
- "\<langle>v\<rangle>\<^sub>v" \<rightharpoonup> "In2 v"
- "\<langle>es\<rangle>\<^sub>l" \<rightharpoonup> "In3 es"
+abbreviation (input)
+ var_inj_term :: "var \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>v" 1000)
+ where "\<langle>v\<rangle>\<^sub>v == In2 v"
+
+abbreviation (input)
+ lst_inj_term :: "expr list \<Rightarrow> term" ("\<langle>_\<rangle>\<^sub>l" 1000)
+ where "\<langle>es\<rangle>\<^sub>l == In3 es"
text {* It seems to be more elegant to have an overloaded injection like the
following.
@@ -300,7 +304,7 @@
@{text AxSem} don't follow this convention right now, but introduce subtle
syntactic sugar in the relations themselves to make a distinction on
expressions, statements and so on. So unfortunately you will encounter a
-mixture of dealing with these injections. The translations above are used
+mixture of dealing with these injections. The abbreviations above are used
as bridge between the different conventions.
*}
--- a/src/HOL/Bali/Trans.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/Trans.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Trans.thy
- ID: $Id$
Author: David von Oheimb and Norbert Schirmer
Operational transition (small-step) semantics of the
@@ -60,13 +59,13 @@
by (simp)
declare the_var_AVar_def [simp del]
-syntax (xsymbols)
- Ref :: "loc \<Rightarrow> expr"
- SKIP :: "expr"
+abbreviation
+ Ref :: "loc \<Rightarrow> expr"
+ where "Ref a == Lit (Addr a)"
-translations
- "Ref a" == "Lit (Addr a)"
- "SKIP" == "Lit Unit"
+abbreviation
+ SKIP :: "expr"
+ where "SKIP == Lit Unit"
inductive
step :: "[prog,term \<times> state,term \<times> state] \<Rightarrow> bool" ("_\<turnstile>_ \<mapsto>1 _"[61,82,82] 81)
--- a/src/HOL/Bali/Type.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/Type.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Type.thy
- ID: $Id$
Author: David von Oheimb
*)
@@ -36,17 +35,11 @@
"ref_ty" <= (type) "Type.ref_ty"
"ty" <= (type) "Type.ty"
-syntax
- NT :: " \<spacespace> ty"
- Iface :: "qtname \<Rightarrow> ty"
- Class :: "qtname \<Rightarrow> ty"
- Array :: "ty \<Rightarrow> ty" ("_.[]" [90] 90)
-
-translations
- "NT" == "RefT NullT"
- "Iface I" == "RefT (IfaceT I)"
- "Class C" == "RefT (ClassT C)"
- "T.[]" == "RefT (ArrayT T)"
+abbreviation "NT == RefT NullT"
+abbreviation "Iface I == RefT (IfaceT I)"
+abbreviation "Class C == RefT (ClassT C)"
+abbreviation Array :: "ty \<Rightarrow> ty" ("_.[]" [90] 90)
+ where "T.[] == RefT (ArrayT T)"
constdefs
the_Class :: "ty \<Rightarrow> qtname"
--- a/src/HOL/Bali/TypeRel.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/TypeRel.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/TypeRel.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* The relations between Java types *}
@@ -35,37 +34,22 @@
(*subclseq, by translation*) (* subclass + identity *)
implmt1 :: "prog \<Rightarrow> (qtname \<times> qtname) set" --{* direct implementation *}
-syntax
+abbreviation
+ subint1_syntax :: "prog => [qtname, qtname] => bool" ("_|-_<:I1_" [71,71,71] 70)
+ where "G|-I <:I1 J == (I,J) \<in> subint1 G"
- "_subint1" :: "prog => [qtname, qtname] => bool" ("_|-_<:I1_" [71,71,71] 70)
- "_subint" :: "prog => [qtname, qtname] => bool" ("_|-_<=:I _"[71,71,71] 70)
- (* Defined in Decl.thy:
- "_subcls1" :: "prog => [qtname, qtname] => bool" ("_|-_<:C1_" [71,71,71] 70)
- "_subclseq":: "prog => [qtname, qtname] => bool" ("_|-_<=:C _"[71,71,71] 70)
- "_subcls" :: "prog => [qtname, qtname] => bool" ("_|-_<:C _"[71,71,71] 70)
- *)
- "@implmt1" :: "prog => [qtname, qtname] => bool" ("_|-_~>1_" [71,71,71] 70)
-
-syntax (xsymbols)
+abbreviation
+ subint_syntax :: "prog => [qtname, qtname] => bool" ("_|-_<=:I _"[71,71,71] 70)
+ where "G|-I <=:I J == (I,J) \<in>(subint1 G)^*" --{* cf. 9.1.3 *}
- "_subint1" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<prec>I1_" [71,71,71] 70)
- "_subint" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<preceq>I _" [71,71,71] 70)
- (* Defined in Decl.thy:
-\ "_subcls1" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<prec>\<^sub>C\<^sub>1_" [71,71,71] 70)
- "_subclseq":: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<preceq>\<^sub>C _" [71,71,71] 70)
- "_subcls" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<prec>\<^sub>C _" [71,71,71] 70)
- *)
- "_implmt1" :: "prog \<Rightarrow> [qtname, qtname] \<Rightarrow> bool" ("_\<turnstile>_\<leadsto>1_" [71,71,71] 70)
+abbreviation
+ implmt1_syntax :: "prog => [qtname, qtname] => bool" ("_|-_~>1_" [71,71,71] 70)
+ where "G|-C ~>1 I == (C,I) \<in> implmt1 G"
-translations
-
- "G\<turnstile>I \<prec>I1 J" == "(I,J) \<in> subint1 G"
- "G\<turnstile>I \<preceq>I J" == "(I,J) \<in>(subint1 G)^*" --{* cf. 9.1.3 *}
- (* Defined in Decl.thy:
- "G\<turnstile>C \<prec>\<^sub>C\<^sub>1 D" == "(C,D) \<in> subcls1 G"
- "G\<turnstile>C \<preceq>\<^sub>C D" == "(C,D) \<in>(subcls1 G)^*"
- *)
- "G\<turnstile>C \<leadsto>1 I" == "(C,I) \<in> implmt1 G"
+notation (xsymbols)
+ subint1_syntax ("_\<turnstile>_\<prec>I1_" [71,71,71] 70) and
+ subint_syntax ("_\<turnstile>_\<preceq>I _" [71,71,71] 70) and
+ implmt1_syntax ("_\<turnstile>_\<leadsto>1_" [71,71,71] 70)
section "subclass and subinterface relations"
--- a/src/HOL/Bali/TypeSafe.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/TypeSafe.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/TypeSafe.thy
- ID: $Id$
Author: David von Oheimb and Norbert Schirmer
*)
header {* The type soundness proof for Java *}
--- a/src/HOL/Bali/Value.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/Value.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Bali/Value.thy
- ID: $Id$
Author: David von Oheimb
*)
header {* Java values *}
--- a/src/HOL/Bali/WellForm.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/WellForm.thy Thu Feb 11 12:26:50 2010 -0800
@@ -2925,7 +2925,7 @@
then show "?P m"
by (auto simp add: permits_acc_def)
next
- case (Overriding new C declC newm old Sup)
+ case (Overriding new declC newm old Sup C)
assume member_new: "G \<turnstile> new member_in C" and
new: "new = (declC, mdecl newm)" and
override: "G \<turnstile> (declC, newm) overrides old" and
--- a/src/HOL/Bali/WellType.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Bali/WellType.thy Thu Feb 11 12:26:50 2010 -0800
@@ -43,11 +43,9 @@
"env" <= (type) "\<lparr>prg::prog,cls::qtname,lcl::lenv,\<dots>::'a\<rparr>"
-
-syntax
+abbreviation
pkg :: "env \<Rightarrow> pname" --{* select the current package from an environment *}
-translations
- "pkg e" == "pid (cls e)"
+ where "pkg e == pid (cls e)"
section "Static overloading: maximally specific methods "
@@ -426,29 +424,33 @@
E,dt\<Turnstile>e#es\<Colon>\<doteq>T#Ts"
-syntax (* for purely static typing *)
- "_wt" :: "env \<Rightarrow> [term,tys] \<Rightarrow> bool" ("_|-_::_" [51,51,51] 50)
- "_wt_stmt" :: "env \<Rightarrow> stmt \<Rightarrow> bool" ("_|-_:<>" [51,51 ] 50)
- "_ty_expr" :: "env \<Rightarrow> [expr ,ty ] \<Rightarrow> bool" ("_|-_:-_" [51,51,51] 50)
- "_ty_var" :: "env \<Rightarrow> [var ,ty ] \<Rightarrow> bool" ("_|-_:=_" [51,51,51] 50)
- "_ty_exprs":: "env \<Rightarrow> [expr list,
- \<spacespace> ty list] \<Rightarrow> bool" ("_|-_:#_" [51,51,51] 50)
+(* for purely static typing *)
+abbreviation
+ wt_syntax :: "env \<Rightarrow> [term,tys] \<Rightarrow> bool" ("_|-_::_" [51,51,51] 50)
+ where "E|-t::T == E,empty_dt\<Turnstile>t\<Colon> T"
+
+abbreviation
+ wt_stmt_syntax :: "env \<Rightarrow> stmt \<Rightarrow> bool" ("_|-_:<>" [51,51 ] 50)
+ where "E|-s:<> == E|-In1r s :: Inl (PrimT Void)"
+
+abbreviation
+ ty_expr_syntax :: "env \<Rightarrow> [expr, ty] \<Rightarrow> bool" ("_|-_:-_" [51,51,51] 50)
+ where "E|-e:-T == E|-In1l e :: Inl T"
-syntax (xsymbols)
- "_wt" :: "env \<Rightarrow> [term,tys] \<Rightarrow> bool" ("_\<turnstile>_\<Colon>_" [51,51,51] 50)
- "_wt_stmt" :: "env \<Rightarrow> stmt \<Rightarrow> bool" ("_\<turnstile>_\<Colon>\<surd>" [51,51 ] 50)
- "_ty_expr" :: "env \<Rightarrow> [expr ,ty ] \<Rightarrow> bool" ("_\<turnstile>_\<Colon>-_" [51,51,51] 50)
- "_ty_var" :: "env \<Rightarrow> [var ,ty ] \<Rightarrow> bool" ("_\<turnstile>_\<Colon>=_" [51,51,51] 50)
- "_ty_exprs" :: "env \<Rightarrow> [expr list,
- \<spacespace> ty list] \<Rightarrow> bool" ("_\<turnstile>_\<Colon>\<doteq>_" [51,51,51] 50)
+abbreviation
+ ty_var_syntax :: "env \<Rightarrow> [var, ty] \<Rightarrow> bool" ("_|-_:=_" [51,51,51] 50)
+ where "E|-e:=T == E|-In2 e :: Inl T"
-translations
- "E\<turnstile>t\<Colon> T" == "E,empty_dt\<Turnstile>t\<Colon> T"
- "E\<turnstile>s\<Colon>\<surd>" == "E\<turnstile>In1r s\<Colon>CONST Inl (PrimT Void)"
- "E\<turnstile>e\<Colon>-T" == "E\<turnstile>In1l e\<Colon>CONST Inl T"
- "E\<turnstile>e\<Colon>=T" == "E\<turnstile>In2 e\<Colon>CONST Inl T"
- "E\<turnstile>e\<Colon>\<doteq>T" == "E\<turnstile>In3 e\<Colon>CONST Inr T"
+abbreviation
+ ty_exprs_syntax :: "env \<Rightarrow> [expr list, ty list] \<Rightarrow> bool" ("_|-_:#_" [51,51,51] 50)
+ where "E|-e:#T == E|-In3 e :: Inr T"
+notation (xsymbols)
+ wt_syntax ("_\<turnstile>_\<Colon>_" [51,51,51] 50) and
+ wt_stmt_syntax ("_\<turnstile>_\<Colon>\<surd>" [51,51 ] 50) and
+ ty_expr_syntax ("_\<turnstile>_\<Colon>-_" [51,51,51] 50) and
+ ty_var_syntax ("_\<turnstile>_\<Colon>=_" [51,51,51] 50) and
+ ty_exprs_syntax ("_\<turnstile>_\<Colon>\<doteq>_" [51,51,51] 50)
declare not_None_eq [simp del]
declare split_if [split del] split_if_asm [split del]
--- a/src/HOL/Boogie/Boogie.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Boogie/Boogie.thy Thu Feb 11 12:26:50 2010 -0800
@@ -5,7 +5,7 @@
header {* Integration of the Boogie program verifier *}
theory Boogie
-imports SMT
+imports "~~/src/HOL/SMT/SMT"
uses
("Tools/boogie_vcs.ML")
("Tools/boogie_loader.ML")
--- a/src/HOL/Decision_Procs/Approximation.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Decision_Procs/Approximation.thy Thu Feb 11 12:26:50 2010 -0800
@@ -2950,7 +2950,8 @@
(\<Sum> i = 0..<Suc n. inverse (real (\<Prod> j \<in> {k..<k+i}. j)) * ?f i (real c) * (xs!x - real c)^i) +
inverse (real (\<Prod> j \<in> {k..<k+Suc n}. j)) * ?f (Suc n) t * (xs!x - real c)^Suc n" (is "_ = ?T")
unfolding funpow_Suc C_def[symmetric] setsum_move0 setprod_head_Suc
- by (auto simp add: algebra_simps setsum_right_distrib[symmetric])
+ by (auto simp add: algebra_simps)
+ (simp only: mult_left_commute [of _ "inverse (real k)"] setsum_right_distrib [symmetric])
finally have "?T \<in> {real l .. real u}" . }
thus ?thesis using DERIV by blast
qed
--- a/src/HOL/Decision_Procs/Dense_Linear_Order.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Decision_Procs/Dense_Linear_Order.thy Thu Feb 11 12:26:50 2010 -0800
@@ -655,7 +655,7 @@
if h aconvc y then false else if h aconvc x then true else earlier t x y;
fun dest_frac ct = case term_of ct of
- Const (@{const_name Algebras.divide},_) $ a $ b=>
+ Const (@{const_name Rings.divide},_) $ a $ b=>
Rat.rat_of_quotient (snd (HOLogic.dest_number a), snd (HOLogic.dest_number b))
| Const(@{const_name inverse}, _)$a => Rat.rat_of_quotient(1, HOLogic.dest_number a |> snd)
| t => Rat.rat_of_int (snd (HOLogic.dest_number t))
@@ -684,7 +684,7 @@
fun xnormalize_conv ctxt [] ct = reflexive ct
| xnormalize_conv ctxt (vs as (x::_)) ct =
case term_of ct of
- Const(@{const_name Algebras.less},_)$_$Const(@{const_name Algebras.zero},_) =>
+ Const(@{const_name Orderings.less},_)$_$Const(@{const_name Algebras.zero},_) =>
(case whatis x (Thm.dest_arg1 ct) of
("c*x+t",[c,t]) =>
let
@@ -727,7 +727,7 @@
| _ => reflexive ct)
-| Const(@{const_name Algebras.less_eq},_)$_$Const(@{const_name Algebras.zero},_) =>
+| Const(@{const_name Orderings.less_eq},_)$_$Const(@{const_name Algebras.zero},_) =>
(case whatis x (Thm.dest_arg1 ct) of
("c*x+t",[c,t]) =>
let
@@ -816,7 +816,7 @@
val eq_iff_diff_eq_0 = mk_meta_eq @{thm "eq_iff_diff_eq_0"}
in
fun field_isolate_conv phi ctxt vs ct = case term_of ct of
- Const(@{const_name Algebras.less},_)$a$b =>
+ Const(@{const_name Orderings.less},_)$a$b =>
let val (ca,cb) = Thm.dest_binop ct
val T = ctyp_of_term ca
val th = instantiate' [SOME T] [SOME ca, SOME cb] less_iff_diff_less_0
@@ -825,7 +825,7 @@
(Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
val rth = transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
in rth end
-| Const(@{const_name Algebras.less_eq},_)$a$b =>
+| Const(@{const_name Orderings.less_eq},_)$a$b =>
let val (ca,cb) = Thm.dest_binop ct
val T = ctyp_of_term ca
val th = instantiate' [SOME T] [SOME ca, SOME cb] le_iff_diff_le_0
@@ -856,11 +856,11 @@
else Ferrante_Rackoff_Data.Nox
| @{term "Not"}$(Const("op =", _)$y$z) => if term_of x aconv y then Ferrante_Rackoff_Data.NEq
else Ferrante_Rackoff_Data.Nox
- | Const(@{const_name Algebras.less},_)$y$z =>
+ | Const(@{const_name Orderings.less},_)$y$z =>
if term_of x aconv y then Ferrante_Rackoff_Data.Lt
else if term_of x aconv z then Ferrante_Rackoff_Data.Gt
else Ferrante_Rackoff_Data.Nox
- | Const (@{const_name Algebras.less_eq},_)$y$z =>
+ | Const (@{const_name Orderings.less_eq},_)$y$z =>
if term_of x aconv y then Ferrante_Rackoff_Data.Le
else if term_of x aconv z then Ferrante_Rackoff_Data.Ge
else Ferrante_Rackoff_Data.Nox
--- a/src/HOL/Decision_Procs/Parametric_Ferrante_Rackoff.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Decision_Procs/Parametric_Ferrante_Rackoff.thy Thu Feb 11 12:26:50 2010 -0800
@@ -2946,7 +2946,7 @@
fun num rT x = HOLogic.mk_number rT x;
fun rrelT rT = [rT,rT] ---> rT;
fun rrT rT = [rT, rT] ---> bT;
-fun divt rT = Const(@{const_name Algebras.divide},rrelT rT);
+fun divt rT = Const(@{const_name Rings.divide},rrelT rT);
fun timest rT = Const(@{const_name Algebras.times},rrelT rT);
fun plust rT = Const(@{const_name Algebras.plus},rrelT rT);
fun minust rT = Const(@{const_name Algebras.minus},rrelT rT);
@@ -2958,8 +2958,8 @@
val disjt = @{term "op |"};
val impt = @{term "op -->"};
val ifft = @{term "op = :: bool => _"}
-fun llt rT = Const(@{const_name Algebras.less},rrT rT);
-fun lle rT = Const(@{const_name Algebras.less},rrT rT);
+fun llt rT = Const(@{const_name Orderings.less},rrT rT);
+fun lle rT = Const(@{const_name Orderings.less},rrT rT);
fun eqt rT = Const("op =",rrT rT);
fun rz rT = Const(@{const_name Algebras.zero},rT);
@@ -2974,7 +2974,7 @@
| Const(@{const_name Algebras.minus},_)$a$b => @{code poly.Sub} (num_of_term m a, num_of_term m b)
| Const(@{const_name Algebras.times},_)$a$b => @{code poly.Mul} (num_of_term m a, num_of_term m b)
| Const(@{const_name Power.power},_)$a$n => @{code poly.Pw} (num_of_term m a, dest_nat n)
- | Const(@{const_name Algebras.divide},_)$a$b => @{code poly.C} (HOLogic.dest_number a |> snd, HOLogic.dest_number b |> snd)
+ | Const(@{const_name Rings.divide},_)$a$b => @{code poly.C} (HOLogic.dest_number a |> snd, HOLogic.dest_number b |> snd)
| _ => (@{code poly.C} (HOLogic.dest_number t |> snd,1)
handle TERM _ => @{code poly.Bound} (AList.lookup (op aconv) m t |> the));
@@ -3024,9 +3024,9 @@
| Const("op =",ty)$p$q =>
if domain_type ty = bT then @{code Iff} (fm_of_term m m' p, fm_of_term m m' q)
else @{code Eq} (@{code Sub} (tm_of_term m m' p, tm_of_term m m' q))
- | Const(@{const_name Algebras.less},_)$p$q =>
+ | Const(@{const_name Orderings.less},_)$p$q =>
@{code Lt} (@{code Sub} (tm_of_term m m' p, tm_of_term m m' q))
- | Const(@{const_name Algebras.less_eq},_)$p$q =>
+ | Const(@{const_name Orderings.less_eq},_)$p$q =>
@{code Le} (@{code Sub} (tm_of_term m m' p, tm_of_term m m' q))
| Const("Ex",_)$Abs(xn,xT,p) =>
let val (xn', p') = variant_abs (xn,xT,p)
--- a/src/HOL/Fields.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Fields.thy Thu Feb 11 12:26:50 2010 -0800
@@ -14,8 +14,8 @@
begin
class field = comm_ring_1 + inverse +
- assumes field_inverse: "a \<noteq> 0 \<Longrightarrow> inverse a * a = 1"
- assumes divide_inverse: "a / b = a * inverse b"
+ assumes field_inverse: "a \<noteq> 0 \<Longrightarrow> inverse a * a = 1"
+ assumes field_divide_inverse: "a / b = a * inverse b"
begin
subclass division_ring
@@ -24,6 +24,9 @@
assume "a \<noteq> 0"
thus "inverse a * a = 1" by (rule field_inverse)
thus "a * inverse a = 1" by (simp only: mult_commute)
+next
+ fix a b :: 'a
+ show "a / b = a * inverse b" by (rule field_divide_inverse)
qed
subclass idom ..
@@ -1032,6 +1035,31 @@
apply (simp add: order_less_imp_le)
done
+
+lemma field_le_epsilon:
+ fixes x y :: "'a :: {division_by_zero,linordered_field}"
+ assumes e: "\<And>e. 0 < e \<Longrightarrow> x \<le> y + e"
+ shows "x \<le> y"
+proof (rule ccontr)
+ obtain two :: 'a where two: "two = 1 + 1" by simp
+ assume "\<not> x \<le> y"
+ then have yx: "y < x" by simp
+ then have "y + - y < x + - y" by (rule add_strict_right_mono)
+ then have "x - y > 0" by (simp add: diff_minus)
+ then have "(x - y) / two > 0"
+ by (rule divide_pos_pos) (simp add: two)
+ then have "x \<le> y + (x - y) / two" by (rule e)
+ also have "... = (x - y + two * y) / two"
+ by (simp add: add_divide_distrib two)
+ also have "... = (x + y) / two"
+ by (simp add: two algebra_simps)
+ also have "... < x" using yx
+ by (simp add: two pos_divide_less_eq algebra_simps)
+ finally have "x < x" .
+ then show False ..
+qed
+
+
code_modulename SML
Fields Arith
--- a/src/HOL/Groebner_Basis.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Groebner_Basis.thy Thu Feb 11 12:26:50 2010 -0800
@@ -489,7 +489,13 @@
by (simp add: add_divide_distrib)
lemma add_num_frac: "y\<noteq> 0 \<Longrightarrow> z + (x::'a::{field, division_by_zero}) / y = (x + z*y) / y"
by (simp add: add_divide_distrib)
-ML{* let open Conv in fconv_rule (arg_conv (arg1_conv (rewr_conv (mk_meta_eq @{thm mult_commute})))) (@{thm divide_inverse} RS sym)end*}
+
+ML {*
+let open Conv
+in fconv_rule (arg_conv (arg1_conv (rewr_conv (mk_meta_eq @{thm mult_commute})))) (@{thm field_divide_inverse} RS sym)
+end
+*}
+
ML{*
local
val zr = @{cpat "0"}
@@ -527,13 +533,13 @@
val (l,r) = Thm.dest_binop ct
val T = ctyp_of_term l
in (case (term_of l, term_of r) of
- (Const(@{const_name Algebras.divide},_)$_$_, _) =>
+ (Const(@{const_name Rings.divide},_)$_$_, _) =>
let val (x,y) = Thm.dest_binop l val z = r
val _ = map (HOLogic.dest_number o term_of) [x,y,z]
val ynz = prove_nz ss T y
in SOME (implies_elim (instantiate' [SOME T] (map SOME [y,x,z]) add_frac_num) ynz)
end
- | (_, Const (@{const_name Algebras.divide},_)$_$_) =>
+ | (_, Const (@{const_name Rings.divide},_)$_$_) =>
let val (x,y) = Thm.dest_binop r val z = l
val _ = map (HOLogic.dest_number o term_of) [x,y,z]
val ynz = prove_nz ss T y
@@ -543,49 +549,49 @@
end
handle CTERM _ => NONE | TERM _ => NONE | THM _ => NONE
- fun is_number (Const(@{const_name Algebras.divide},_)$a$b) = is_number a andalso is_number b
+ fun is_number (Const(@{const_name Rings.divide},_)$a$b) = is_number a andalso is_number b
| is_number t = can HOLogic.dest_number t
val is_number = is_number o term_of
fun proc3 phi ss ct =
(case term_of ct of
- Const(@{const_name Algebras.less},_)$(Const(@{const_name Algebras.divide},_)$_$_)$_ =>
+ Const(@{const_name Orderings.less},_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
let
val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
val _ = map is_number [a,b,c]
val T = ctyp_of_term c
val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_less_eq"}
in SOME (mk_meta_eq th) end
- | Const(@{const_name Algebras.less_eq},_)$(Const(@{const_name Algebras.divide},_)$_$_)$_ =>
+ | Const(@{const_name Orderings.less_eq},_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
let
val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
val _ = map is_number [a,b,c]
val T = ctyp_of_term c
val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_le_eq"}
in SOME (mk_meta_eq th) end
- | Const("op =",_)$(Const(@{const_name Algebras.divide},_)$_$_)$_ =>
+ | Const("op =",_)$(Const(@{const_name Rings.divide},_)$_$_)$_ =>
let
val ((a,b),c) = Thm.dest_binop ct |>> Thm.dest_binop
val _ = map is_number [a,b,c]
val T = ctyp_of_term c
val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "divide_eq_eq"}
in SOME (mk_meta_eq th) end
- | Const(@{const_name Algebras.less},_)$_$(Const(@{const_name Algebras.divide},_)$_$_) =>
+ | Const(@{const_name Orderings.less},_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
let
val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
val _ = map is_number [a,b,c]
val T = ctyp_of_term c
val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "less_divide_eq"}
in SOME (mk_meta_eq th) end
- | Const(@{const_name Algebras.less_eq},_)$_$(Const(@{const_name Algebras.divide},_)$_$_) =>
+ | Const(@{const_name Orderings.less_eq},_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
let
val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
val _ = map is_number [a,b,c]
val T = ctyp_of_term c
val th = instantiate' [SOME T] (map SOME [a,b,c]) @{thm "le_divide_eq"}
in SOME (mk_meta_eq th) end
- | Const("op =",_)$_$(Const(@{const_name Algebras.divide},_)$_$_) =>
+ | Const("op =",_)$_$(Const(@{const_name Rings.divide},_)$_$_) =>
let
val (a,(b,c)) = Thm.dest_binop ct ||> Thm.dest_binop
val _ = map is_number [a,b,c]
@@ -628,9 +634,9 @@
@{thm "times_divide_eq_left"}, @{thm "divide_divide_eq_right"},
@{thm "diff_def"}, @{thm "minus_divide_left"},
@{thm "Numeral1_eq1_nat"}, @{thm "add_divide_distrib"} RS sym,
- @{thm divide_inverse} RS sym, @{thm inverse_divide},
+ @{thm field_divide_inverse} RS sym, @{thm inverse_divide},
fconv_rule (arg_conv (arg1_conv (rewr_conv (mk_meta_eq @{thm mult_commute}))))
- (@{thm divide_inverse} RS sym)]
+ (@{thm field_divide_inverse} RS sym)]
val comp_conv = (Simplifier.rewrite
(HOL_basic_ss addsimps @{thms "Groebner_Basis.comp_arith"}
@@ -645,15 +651,15 @@
fun numeral_is_const ct =
case term_of ct of
- Const (@{const_name Algebras.divide},_) $ a $ b =>
+ Const (@{const_name Rings.divide},_) $ a $ b =>
can HOLogic.dest_number a andalso can HOLogic.dest_number b
- | Const (@{const_name Algebras.inverse},_)$t => can HOLogic.dest_number t
+ | Const (@{const_name Rings.inverse},_)$t => can HOLogic.dest_number t
| t => can HOLogic.dest_number t
fun dest_const ct = ((case term_of ct of
- Const (@{const_name Algebras.divide},_) $ a $ b=>
+ Const (@{const_name Rings.divide},_) $ a $ b=>
Rat.rat_of_quotient (snd (HOLogic.dest_number a), snd (HOLogic.dest_number b))
- | Const (@{const_name Algebras.inverse},_)$t =>
+ | Const (@{const_name Rings.inverse},_)$t =>
Rat.inv (Rat.rat_of_int (snd (HOLogic.dest_number t)))
| t => Rat.rat_of_int (snd (HOLogic.dest_number t)))
handle TERM _ => error "ring_dest_const")
--- a/src/HOL/Groups.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Groups.thy Thu Feb 11 12:26:50 2010 -0800
@@ -5,7 +5,7 @@
header {* Groups, also combined with orderings *}
theory Groups
-imports Lattices
+imports Orderings
uses "~~/src/Provers/Arith/abel_cancel.ML"
begin
@@ -40,6 +40,7 @@
Of course it also works for fields, but it knows nothing about multiplicative
inverses or division. This is catered for by @{text field_simps}. *}
+
subsection {* Semigroups and Monoids *}
class semigroup_add = plus +
@@ -884,6 +885,32 @@
shows "[|0\<le>a; b<c|] ==> b < a + c"
by (insert add_le_less_mono [of 0 a b c], simp)
+class abs =
+ fixes abs :: "'a \<Rightarrow> 'a"
+begin
+
+notation (xsymbols)
+ abs ("\<bar>_\<bar>")
+
+notation (HTML output)
+ abs ("\<bar>_\<bar>")
+
+end
+
+class sgn =
+ fixes sgn :: "'a \<Rightarrow> 'a"
+
+class abs_if = minus + uminus + ord + zero + abs +
+ assumes abs_if: "\<bar>a\<bar> = (if a < 0 then - a else a)"
+
+class sgn_if = minus + uminus + zero + one + ord + sgn +
+ assumes sgn_if: "sgn x = (if x = 0 then 0 else if 0 < x then 1 else - 1)"
+begin
+
+lemma sgn0 [simp]: "sgn 0 = 0"
+ by (simp add:sgn_if)
+
+end
class ordered_ab_group_add_abs = ordered_ab_group_add + abs +
assumes abs_ge_zero [simp]: "\<bar>a\<bar> \<ge> 0"
--- a/src/HOL/Hoare/HeapSyntax.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Hoare/HeapSyntax.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Hoare/HeapSyntax.thy
- ID: $Id$
Author: Tobias Nipkow
Copyright 2002 TUM
*)
@@ -9,16 +8,16 @@
subsection "Field access and update"
syntax
- "@refupdate" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ref \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"
+ "_refupdate" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ref \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"
("_/'((_ \<rightarrow> _)')" [1000,0] 900)
- "@fassign" :: "'a ref => id => 'v => 's com"
+ "_fassign" :: "'a ref => id => 'v => 's com"
("(2_^._ :=/ _)" [70,1000,65] 61)
- "@faccess" :: "'a ref => ('a ref \<Rightarrow> 'v) => 'v"
+ "_faccess" :: "'a ref => ('a ref \<Rightarrow> 'v) => 'v"
("_^._" [65,1000] 65)
translations
- "f(r \<rightarrow> v)" == "f(addr r := v)"
+ "f(r \<rightarrow> v)" == "f(CONST addr r := v)"
"p^.f := e" => "f := f(p \<rightarrow> e)"
- "p^.f" => "f(addr p)"
+ "p^.f" => "f(CONST addr p)"
declare fun_upd_apply[simp del] fun_upd_same[simp] fun_upd_other[simp]
--- a/src/HOL/Hoare/HeapSyntaxAbort.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Hoare/HeapSyntaxAbort.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Hoare/HeapSyntax.thy
- ID: $Id$
Author: Tobias Nipkow
Copyright 2002 TUM
*)
@@ -17,16 +16,16 @@
reason about storage allocation/deallocation. *}
syntax
- "refupdate" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ref \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"
+ "_refupdate" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ref \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"
("_/'((_ \<rightarrow> _)')" [1000,0] 900)
- "@fassign" :: "'a ref => id => 'v => 's com"
+ "_fassign" :: "'a ref => id => 'v => 's com"
("(2_^._ :=/ _)" [70,1000,65] 61)
- "@faccess" :: "'a ref => ('a ref \<Rightarrow> 'v) => 'v"
+ "_faccess" :: "'a ref => ('a ref \<Rightarrow> 'v) => 'v"
("_^._" [65,1000] 65)
translations
- "refupdate f r v" == "f(addr r := v)"
- "p^.f := e" => "(p \<noteq> Null) \<rightarrow> (f := refupdate f p e)"
- "p^.f" => "f(addr p)"
+ "_refupdate f r v" == "f(CONST addr r := v)"
+ "p^.f := e" => "(p \<noteq> CONST Null) \<rightarrow> (f := _refupdate f p e)"
+ "p^.f" => "f(CONST addr p)"
declare fun_upd_apply[simp del] fun_upd_same[simp] fun_upd_other[simp]
--- a/src/HOL/Hoare/HoareAbort.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Hoare/HoareAbort.thy Thu Feb 11 12:26:50 2010 -0800
@@ -257,7 +257,7 @@
guarded_com :: "bool \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(2_ \<rightarrow>/ _)" 71)
array_update :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a com" ("(2_[_] :=/ _)" [70, 65] 61)
translations
- "P \<rightarrow> c" == "IF P THEN c ELSE Abort FI"
+ "P \<rightarrow> c" == "IF P THEN c ELSE CONST Abort FI"
"a[i] := v" => "(i < CONST length a) \<rightarrow> (a := CONST list_update a i v)"
(* reverse translation not possible because of duplicate "a" *)
--- a/src/HOL/Hoare/Pointers0.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Hoare/Pointers0.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Hoare/Pointers.thy
- ID: $Id$
Author: Tobias Nipkow
Copyright 2002 TUM
@@ -20,12 +19,12 @@
subsection "Field access and update"
syntax
- "@fassign" :: "'a::ref => id => 'v => 's com"
+ "_fassign" :: "'a::ref => id => 'v => 's com"
("(2_^._ :=/ _)" [70,1000,65] 61)
- "@faccess" :: "'a::ref => ('a::ref \<Rightarrow> 'v) => 'v"
+ "_faccess" :: "'a::ref => ('a::ref \<Rightarrow> 'v) => 'v"
("_^._" [65,1000] 65)
translations
- "p^.f := e" => "f := fun_upd f p e"
+ "p^.f := e" => "f := CONST fun_upd f p e"
"p^.f" => "f p"
--- a/src/HOL/Hoare/Separation.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Hoare/Separation.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/Hoare/Separation.thy
- ID: $Id$
Author: Tobias Nipkow
Copyright 2003 TUM
@@ -50,10 +49,10 @@
bound Hs - otherwise they may bind the implicit H. *}
syntax
- "@emp" :: "bool" ("emp")
- "@singl" :: "nat \<Rightarrow> nat \<Rightarrow> bool" ("[_ \<mapsto> _]")
- "@star" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "**" 60)
- "@wand" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "-*" 60)
+ "_emp" :: "bool" ("emp")
+ "_singl" :: "nat \<Rightarrow> nat \<Rightarrow> bool" ("[_ \<mapsto> _]")
+ "_star" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "**" 60)
+ "_wand" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "-*" 60)
(* FIXME does not handle "_idtdummy" *)
ML{*
@@ -79,8 +78,8 @@
*}
parse_translation
- {* [("@emp", emp_tr), ("@singl", singl_tr),
- ("@star", star_tr), ("@wand", wand_tr)] *}
+ {* [("_emp", emp_tr), ("_singl", singl_tr),
+ ("_star", star_tr), ("_wand", wand_tr)] *}
text{* Now it looks much better: *}
@@ -121,13 +120,13 @@
*)
| strip (Abs(_,_,(t as Const("_var",_) $ Var _) $ Bound 0)) = t
| strip (Abs(_,_,P)) = P
- | strip (Const("is_empty",_)) = Syntax.const "@emp"
+ | strip (Const("is_empty",_)) = Syntax.const "_emp"
| strip t = t;
in
-fun is_empty_tr' [_] = Syntax.const "@emp"
-fun singl_tr' [_,p,q] = Syntax.const "@singl" $ p $ q
-fun star_tr' [P,Q,_] = Syntax.const "@star" $ strip P $ strip Q
-fun wand_tr' [P,Q,_] = Syntax.const "@wand" $ strip P $ strip Q
+fun is_empty_tr' [_] = Syntax.const "_emp"
+fun singl_tr' [_,p,q] = Syntax.const "_singl" $ p $ q
+fun star_tr' [P,Q,_] = Syntax.const "_star" $ strip P $ strip Q
+fun wand_tr' [P,Q,_] = Syntax.const "_wand" $ strip P $ strip Q
end
*}
--- a/src/HOL/Hoare/hoare_tac.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Hoare/hoare_tac.ML Thu Feb 11 12:26:50 2010 -0800
@@ -58,7 +58,7 @@
let val T as Type ("fun",[t,_]) = fastype_of trm
in Collect_const t $ trm end;
-fun inclt ty = Const (@{const_name Algebras.less_eq}, [ty,ty] ---> boolT);
+fun inclt ty = Const (@{const_name Orderings.less_eq}, [ty,ty] ---> boolT);
fun Mset ctxt prop =
--- a/src/HOL/Import/Generate-HOL/GenHOL4Base.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Import/Generate-HOL/GenHOL4Base.thy Thu Feb 11 12:26:50 2010 -0800
@@ -166,7 +166,7 @@
import_theory prim_rec;
const_maps
- "<" > Algebras.less :: "[nat,nat]=>bool";
+ "<" > Orderings.less :: "[nat,nat]=>bool";
end_import;
@@ -181,7 +181,7 @@
">" > HOL4Compat.nat_gt
">=" > HOL4Compat.nat_ge
FUNPOW > HOL4Compat.FUNPOW
- "<=" > Algebras.less_eq :: "[nat,nat]=>bool"
+ "<=" > Orderings.less_eq :: "[nat,nat]=>bool"
"+" > Algebras.plus :: "[nat,nat]=>nat"
"*" > Algebras.times :: "[nat,nat]=>nat"
"-" > Algebras.minus :: "[nat,nat]=>nat"
--- a/src/HOL/Import/Generate-HOL/GenHOL4Real.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Import/Generate-HOL/GenHOL4Real.thy Thu Feb 11 12:26:50 2010 -0800
@@ -22,7 +22,7 @@
inv > Algebras.inverse :: "real => real"
real_add > Algebras.plus :: "[real,real] => real"
real_mul > Algebras.times :: "[real,real] => real"
- real_lt > Algebras.less :: "[real,real] => bool";
+ real_lt > Orderings.less :: "[real,real] => bool";
ignore_thms
real_TY_DEF
@@ -50,11 +50,11 @@
const_maps
real_gt > HOL4Compat.real_gt
real_ge > HOL4Compat.real_ge
- real_lte > Algebras.less_eq :: "[real,real] => bool"
+ real_lte > Orderings.less_eq :: "[real,real] => bool"
real_sub > Algebras.minus :: "[real,real] => real"
"/" > Algebras.divide :: "[real,real] => real"
pow > Power.power :: "[real,nat] => real"
- abs > Algebras.abs :: "real => real"
+ abs > Groups.abs :: "real => real"
real_of_num > RealDef.real :: "nat => real";
end_import;
--- a/src/HOL/Import/HOL/arithmetic.imp Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Import/HOL/arithmetic.imp Thu Feb 11 12:26:50 2010 -0800
@@ -23,7 +23,7 @@
"ALT_ZERO" > "HOL4Compat.ALT_ZERO"
">=" > "HOL4Compat.nat_ge"
">" > "HOL4Compat.nat_gt"
- "<=" > "Algebras.ord_class.less_eq" :: "nat => nat => bool"
+ "<=" > "Orderings.less_eq" :: "nat => nat => bool"
"-" > "Algebras.minus_class.minus" :: "nat => nat => nat"
"+" > "Algebras.plus_class.plus" :: "nat => nat => nat"
"*" > "Algebras.times_class.times" :: "nat => nat => nat"
--- a/src/HOL/Import/HOL/prim_rec.imp Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Import/HOL/prim_rec.imp Thu Feb 11 12:26:50 2010 -0800
@@ -18,7 +18,7 @@
"PRIM_REC_FUN" > "HOL4Base.prim_rec.PRIM_REC_FUN"
"PRIM_REC" > "HOL4Base.prim_rec.PRIM_REC"
"PRE" > "HOL4Base.prim_rec.PRE"
- "<" > "Algebras.less" :: "nat => nat => bool"
+ "<" > "Orderings.less" :: "nat => nat => bool"
thm_maps
"wellfounded_primdef" > "HOL4Base.prim_rec.wellfounded_primdef"
--- a/src/HOL/Import/HOL/real.imp Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Import/HOL/real.imp Thu Feb 11 12:26:50 2010 -0800
@@ -12,12 +12,12 @@
"sum" > "HOL4Real.real.sum"
"real_sub" > "Algebras.minus" :: "real => real => real"
"real_of_num" > "RealDef.real" :: "nat => real"
- "real_lte" > "Algebras.less_eq" :: "real => real => bool"
+ "real_lte" > "Orderings.less_eq" :: "real => real => bool"
"real_gt" > "HOL4Compat.real_gt"
"real_ge" > "HOL4Compat.real_ge"
"pow" > "Power.power_class.power" :: "real => nat => real"
- "abs" > "Algebras.abs" :: "real => real"
- "/" > "Algebras.divide" :: "real => real => real"
+ "abs" > "Groups.abs" :: "real => real"
+ "/" > "Ring.divide" :: "real => real => real"
thm_maps
"sup_def" > "HOL4Real.real.sup_def"
@@ -31,7 +31,7 @@
"real_lt" > "Orderings.linorder_not_le"
"real_gt" > "HOL4Compat.real_gt"
"real_ge" > "HOL4Compat.real_ge"
- "real_div" > "Rings.field_class.divide_inverse"
+ "real_div" > "Ring.divide_inverse"
"pow" > "HOL4Compat.pow"
"abs" > "HOL4Compat.abs"
"SUP_LEMMA3" > "HOL4Real.real.SUP_LEMMA3"
--- a/src/HOL/Import/HOL/realax.imp Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Import/HOL/realax.imp Thu Feb 11 12:26:50 2010 -0800
@@ -29,11 +29,11 @@
"treal_0" > "HOL4Real.realax.treal_0"
"real_neg" > "Algebras.uminus_class.uminus" :: "real => real"
"real_mul" > "Algebras.times_class.times" :: "real => real => real"
- "real_lt" > "Algebras.ord_class.less" :: "real => real => bool"
+ "real_lt" > "Orderings.less" :: "real => real => bool"
"real_add" > "Algebras.plus_class.plus" :: "real => real => real"
"real_1" > "Algebras.one_class.one" :: "real"
"real_0" > "Algebras.zero_class.zero" :: "real"
- "inv" > "Algebras.divide_class.inverse" :: "real => real"
+ "inv" > "Ring.inverse" :: "real => real"
"hreal_of_treal" > "HOL4Real.realax.hreal_of_treal"
thm_maps
--- a/src/HOL/IsaMakefile Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/IsaMakefile Thu Feb 11 12:26:50 2010 -0800
@@ -207,6 +207,7 @@
Tools/Nitpick/nitpick_mono.ML \
Tools/Nitpick/nitpick_nut.ML \
Tools/Nitpick/nitpick_peephole.ML \
+ Tools/Nitpick/nitpick_preproc.ML \
Tools/Nitpick/nitpick_rep.ML \
Tools/Nitpick/nitpick_scope.ML \
Tools/Nitpick/nitpick_tests.ML \
@@ -385,18 +386,17 @@
Library/Permutations.thy Library/Bit.thy Library/FrechetDeriv.thy \
Library/Fraction_Field.thy Library/Fundamental_Theorem_Algebra.thy \
Library/Inner_Product.thy Library/Kleene_Algebra.thy \
- Library/Lattice_Algebras.thy \
- Library/Lattice_Syntax.thy Library/Library.thy \
- Library/List_Prefix.thy Library/List_Set.thy Library/State_Monad.thy \
- Library/Nat_Int_Bij.thy Library/Multiset.thy Library/Permutation.thy \
- Library/Quotient.thy Library/Quicksort.thy Library/Nat_Infinity.thy \
- Library/Word.thy Library/README.html Library/Continuity.thy \
+ Library/Lattice_Algebras.thy Library/Lattice_Syntax.thy \
+ Library/Library.thy Library/List_Prefix.thy Library/List_Set.thy \
+ Library/State_Monad.thy Library/Nat_Int_Bij.thy Library/Multiset.thy \
+ Library/Permutation.thy Library/Quotient_Type.thy \
+ Library/Quicksort.thy Library/Nat_Infinity.thy Library/Word.thy \
+ Library/README.html Library/Continuity.thy \
Library/Order_Relation.thy Library/Nested_Environment.thy \
Library/Ramsey.thy Library/Zorn.thy Library/Library/ROOT.ML \
Library/Library/document/root.tex Library/Library/document/root.bib \
Library/Transitive_Closure_Table.thy Library/While_Combinator.thy \
Library/Product_ord.thy Library/Char_nat.thy \
- Library/Structure_Syntax.thy \
Library/Sublist_Order.thy Library/List_lexord.thy \
Library/Coinductive_List.thy Library/AssocList.thy \
Library/Formal_Power_Series.thy Library/Binomial.thy \
@@ -624,12 +624,13 @@
$(LOG)/HOL-Nitpick_Examples.gz: $(OUT)/HOL Nitpick_Examples/ROOT.ML \
Nitpick_Examples/Core_Nits.thy Nitpick_Examples/Datatype_Nits.thy \
- Nitpick_Examples/Induct_Nits.thy Nitpick_Examples/Integer_Nits.thy \
- Nitpick_Examples/Manual_Nits.thy Nitpick_Examples/Mini_Nits.thy \
- Nitpick_Examples/Mono_Nits.thy Nitpick_Examples/Nitpick_Examples.thy \
- Nitpick_Examples/Pattern_Nits.thy Nitpick_Examples/Record_Nits.thy \
- Nitpick_Examples/Refute_Nits.thy Nitpick_Examples/Special_Nits.thy \
- Nitpick_Examples/Tests_Nits.thy Nitpick_Examples/Typedef_Nits.thy
+ Nitpick_Examples/Hotel_Nits.thy Nitpick_Examples/Induct_Nits.thy \
+ Nitpick_Examples/Integer_Nits.thy Nitpick_Examples/Manual_Nits.thy \
+ Nitpick_Examples/Mini_Nits.thy Nitpick_Examples/Mono_Nits.thy \
+ Nitpick_Examples/Nitpick_Examples.thy Nitpick_Examples/Pattern_Nits.thy \
+ Nitpick_Examples/Record_Nits.thy Nitpick_Examples/Refute_Nits.thy \
+ Nitpick_Examples/Special_Nits.thy Nitpick_Examples/Tests_Nits.thy \
+ Nitpick_Examples/Typedef_Nits.thy
@$(ISABELLE_TOOL) usedir $(OUT)/HOL Nitpick_Examples
--- a/src/HOL/Library/Library.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Library/Library.thy Thu Feb 11 12:26:50 2010 -0800
@@ -45,13 +45,12 @@
Preorder
Product_Vector
Quicksort
- Quotient
+ Quotient_Type
Ramsey
Reflection
RBT
SML_Quickcheck
State_Monad
- Structure_Syntax
Sum_Of_Squares
Transitive_Closure_Table
Univ_Poly
--- a/src/HOL/Library/Quotient.thy Thu Feb 11 12:26:07 2010 -0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,196 +0,0 @@
-(* Title: HOL/Library/Quotient.thy
- Author: Markus Wenzel, TU Muenchen
-*)
-
-header {* Quotient types *}
-
-theory Quotient
-imports Main
-begin
-
-text {*
- We introduce the notion of quotient types over equivalence relations
- via type classes.
-*}
-
-subsection {* Equivalence relations and quotient types *}
-
-text {*
- \medskip Type class @{text equiv} models equivalence relations @{text
- "\<sim> :: 'a => 'a => bool"}.
-*}
-
-class eqv =
- fixes eqv :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sim>" 50)
-
-class equiv = eqv +
- assumes equiv_refl [intro]: "x \<sim> x"
- assumes equiv_trans [trans]: "x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> x \<sim> z"
- assumes equiv_sym [sym]: "x \<sim> y \<Longrightarrow> y \<sim> x"
-
-lemma equiv_not_sym [sym]: "\<not> (x \<sim> y) ==> \<not> (y \<sim> (x::'a::equiv))"
-proof -
- assume "\<not> (x \<sim> y)" then show "\<not> (y \<sim> x)"
- by (rule contrapos_nn) (rule equiv_sym)
-qed
-
-lemma not_equiv_trans1 [trans]: "\<not> (x \<sim> y) ==> y \<sim> z ==> \<not> (x \<sim> (z::'a::equiv))"
-proof -
- assume "\<not> (x \<sim> y)" and "y \<sim> z"
- show "\<not> (x \<sim> z)"
- proof
- assume "x \<sim> z"
- also from `y \<sim> z` have "z \<sim> y" ..
- finally have "x \<sim> y" .
- with `\<not> (x \<sim> y)` show False by contradiction
- qed
-qed
-
-lemma not_equiv_trans2 [trans]: "x \<sim> y ==> \<not> (y \<sim> z) ==> \<not> (x \<sim> (z::'a::equiv))"
-proof -
- assume "\<not> (y \<sim> z)" then have "\<not> (z \<sim> y)" ..
- also assume "x \<sim> y" then have "y \<sim> x" ..
- finally have "\<not> (z \<sim> x)" . then show "(\<not> x \<sim> z)" ..
-qed
-
-text {*
- \medskip The quotient type @{text "'a quot"} consists of all
- \emph{equivalence classes} over elements of the base type @{typ 'a}.
-*}
-
-typedef 'a quot = "{{x. a \<sim> x} | a::'a::eqv. True}"
- by blast
-
-lemma quotI [intro]: "{x. a \<sim> x} \<in> quot"
- unfolding quot_def by blast
-
-lemma quotE [elim]: "R \<in> quot ==> (!!a. R = {x. a \<sim> x} ==> C) ==> C"
- unfolding quot_def by blast
-
-text {*
- \medskip Abstracted equivalence classes are the canonical
- representation of elements of a quotient type.
-*}
-
-definition
- "class" :: "'a::equiv => 'a quot" ("\<lfloor>_\<rfloor>") where
- "\<lfloor>a\<rfloor> = Abs_quot {x. a \<sim> x}"
-
-theorem quot_exhaust: "\<exists>a. A = \<lfloor>a\<rfloor>"
-proof (cases A)
- fix R assume R: "A = Abs_quot R"
- assume "R \<in> quot" then have "\<exists>a. R = {x. a \<sim> x}" by blast
- with R have "\<exists>a. A = Abs_quot {x. a \<sim> x}" by blast
- then show ?thesis unfolding class_def .
-qed
-
-lemma quot_cases [cases type: quot]: "(!!a. A = \<lfloor>a\<rfloor> ==> C) ==> C"
- using quot_exhaust by blast
-
-
-subsection {* Equality on quotients *}
-
-text {*
- Equality of canonical quotient elements coincides with the original
- relation.
-*}
-
-theorem quot_equality [iff?]: "(\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>) = (a \<sim> b)"
-proof
- assume eq: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
- show "a \<sim> b"
- proof -
- from eq have "{x. a \<sim> x} = {x. b \<sim> x}"
- by (simp only: class_def Abs_quot_inject quotI)
- moreover have "a \<sim> a" ..
- ultimately have "a \<in> {x. b \<sim> x}" by blast
- then have "b \<sim> a" by blast
- then show ?thesis ..
- qed
-next
- assume ab: "a \<sim> b"
- show "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
- proof -
- have "{x. a \<sim> x} = {x. b \<sim> x}"
- proof (rule Collect_cong)
- fix x show "(a \<sim> x) = (b \<sim> x)"
- proof
- from ab have "b \<sim> a" ..
- also assume "a \<sim> x"
- finally show "b \<sim> x" .
- next
- note ab
- also assume "b \<sim> x"
- finally show "a \<sim> x" .
- qed
- qed
- then show ?thesis by (simp only: class_def)
- qed
-qed
-
-
-subsection {* Picking representing elements *}
-
-definition
- pick :: "'a::equiv quot => 'a" where
- "pick A = (SOME a. A = \<lfloor>a\<rfloor>)"
-
-theorem pick_equiv [intro]: "pick \<lfloor>a\<rfloor> \<sim> a"
-proof (unfold pick_def)
- show "(SOME x. \<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>) \<sim> a"
- proof (rule someI2)
- show "\<lfloor>a\<rfloor> = \<lfloor>a\<rfloor>" ..
- fix x assume "\<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>"
- then have "a \<sim> x" .. then show "x \<sim> a" ..
- qed
-qed
-
-theorem pick_inverse [intro]: "\<lfloor>pick A\<rfloor> = A"
-proof (cases A)
- fix a assume a: "A = \<lfloor>a\<rfloor>"
- then have "pick A \<sim> a" by (simp only: pick_equiv)
- then have "\<lfloor>pick A\<rfloor> = \<lfloor>a\<rfloor>" ..
- with a show ?thesis by simp
-qed
-
-text {*
- \medskip The following rules support canonical function definitions
- on quotient types (with up to two arguments). Note that the
- stripped-down version without additional conditions is sufficient
- most of the time.
-*}
-
-theorem quot_cond_function:
- assumes eq: "!!X Y. P X Y ==> f X Y == g (pick X) (pick Y)"
- and cong: "!!x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> ==> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor>
- ==> P \<lfloor>x\<rfloor> \<lfloor>y\<rfloor> ==> P \<lfloor>x'\<rfloor> \<lfloor>y'\<rfloor> ==> g x y = g x' y'"
- and P: "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>"
- shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
-proof -
- from eq and P have "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g (pick \<lfloor>a\<rfloor>) (pick \<lfloor>b\<rfloor>)" by (simp only:)
- also have "... = g a b"
- proof (rule cong)
- show "\<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> = \<lfloor>a\<rfloor>" ..
- moreover
- show "\<lfloor>pick \<lfloor>b\<rfloor>\<rfloor> = \<lfloor>b\<rfloor>" ..
- moreover
- show "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>" by (rule P)
- ultimately show "P \<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> \<lfloor>pick \<lfloor>b\<rfloor>\<rfloor>" by (simp only:)
- qed
- finally show ?thesis .
-qed
-
-theorem quot_function:
- assumes "!!X Y. f X Y == g (pick X) (pick Y)"
- and "!!x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> ==> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor> ==> g x y = g x' y'"
- shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
- using assms and TrueI
- by (rule quot_cond_function)
-
-theorem quot_function':
- "(!!X Y. f X Y == g (pick X) (pick Y)) ==>
- (!!x x' y y'. x \<sim> x' ==> y \<sim> y' ==> g x y = g x' y') ==>
- f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
- by (rule quot_function) (simp_all only: quot_equality)
-
-end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Quotient_Type.thy Thu Feb 11 12:26:50 2010 -0800
@@ -0,0 +1,196 @@
+(* Title: HOL/Library/Quotient_Type.thy
+ Author: Markus Wenzel, TU Muenchen
+*)
+
+header {* Quotient types *}
+
+theory Quotient_Type
+imports Main
+begin
+
+text {*
+ We introduce the notion of quotient types over equivalence relations
+ via type classes.
+*}
+
+subsection {* Equivalence relations and quotient types *}
+
+text {*
+ \medskip Type class @{text equiv} models equivalence relations @{text
+ "\<sim> :: 'a => 'a => bool"}.
+*}
+
+class eqv =
+ fixes eqv :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sim>" 50)
+
+class equiv = eqv +
+ assumes equiv_refl [intro]: "x \<sim> x"
+ assumes equiv_trans [trans]: "x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> x \<sim> z"
+ assumes equiv_sym [sym]: "x \<sim> y \<Longrightarrow> y \<sim> x"
+
+lemma equiv_not_sym [sym]: "\<not> (x \<sim> y) ==> \<not> (y \<sim> (x::'a::equiv))"
+proof -
+ assume "\<not> (x \<sim> y)" then show "\<not> (y \<sim> x)"
+ by (rule contrapos_nn) (rule equiv_sym)
+qed
+
+lemma not_equiv_trans1 [trans]: "\<not> (x \<sim> y) ==> y \<sim> z ==> \<not> (x \<sim> (z::'a::equiv))"
+proof -
+ assume "\<not> (x \<sim> y)" and "y \<sim> z"
+ show "\<not> (x \<sim> z)"
+ proof
+ assume "x \<sim> z"
+ also from `y \<sim> z` have "z \<sim> y" ..
+ finally have "x \<sim> y" .
+ with `\<not> (x \<sim> y)` show False by contradiction
+ qed
+qed
+
+lemma not_equiv_trans2 [trans]: "x \<sim> y ==> \<not> (y \<sim> z) ==> \<not> (x \<sim> (z::'a::equiv))"
+proof -
+ assume "\<not> (y \<sim> z)" then have "\<not> (z \<sim> y)" ..
+ also assume "x \<sim> y" then have "y \<sim> x" ..
+ finally have "\<not> (z \<sim> x)" . then show "(\<not> x \<sim> z)" ..
+qed
+
+text {*
+ \medskip The quotient type @{text "'a quot"} consists of all
+ \emph{equivalence classes} over elements of the base type @{typ 'a}.
+*}
+
+typedef 'a quot = "{{x. a \<sim> x} | a::'a::eqv. True}"
+ by blast
+
+lemma quotI [intro]: "{x. a \<sim> x} \<in> quot"
+ unfolding quot_def by blast
+
+lemma quotE [elim]: "R \<in> quot ==> (!!a. R = {x. a \<sim> x} ==> C) ==> C"
+ unfolding quot_def by blast
+
+text {*
+ \medskip Abstracted equivalence classes are the canonical
+ representation of elements of a quotient type.
+*}
+
+definition
+ "class" :: "'a::equiv => 'a quot" ("\<lfloor>_\<rfloor>") where
+ "\<lfloor>a\<rfloor> = Abs_quot {x. a \<sim> x}"
+
+theorem quot_exhaust: "\<exists>a. A = \<lfloor>a\<rfloor>"
+proof (cases A)
+ fix R assume R: "A = Abs_quot R"
+ assume "R \<in> quot" then have "\<exists>a. R = {x. a \<sim> x}" by blast
+ with R have "\<exists>a. A = Abs_quot {x. a \<sim> x}" by blast
+ then show ?thesis unfolding class_def .
+qed
+
+lemma quot_cases [cases type: quot]: "(!!a. A = \<lfloor>a\<rfloor> ==> C) ==> C"
+ using quot_exhaust by blast
+
+
+subsection {* Equality on quotients *}
+
+text {*
+ Equality of canonical quotient elements coincides with the original
+ relation.
+*}
+
+theorem quot_equality [iff?]: "(\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>) = (a \<sim> b)"
+proof
+ assume eq: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
+ show "a \<sim> b"
+ proof -
+ from eq have "{x. a \<sim> x} = {x. b \<sim> x}"
+ by (simp only: class_def Abs_quot_inject quotI)
+ moreover have "a \<sim> a" ..
+ ultimately have "a \<in> {x. b \<sim> x}" by blast
+ then have "b \<sim> a" by blast
+ then show ?thesis ..
+ qed
+next
+ assume ab: "a \<sim> b"
+ show "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
+ proof -
+ have "{x. a \<sim> x} = {x. b \<sim> x}"
+ proof (rule Collect_cong)
+ fix x show "(a \<sim> x) = (b \<sim> x)"
+ proof
+ from ab have "b \<sim> a" ..
+ also assume "a \<sim> x"
+ finally show "b \<sim> x" .
+ next
+ note ab
+ also assume "b \<sim> x"
+ finally show "a \<sim> x" .
+ qed
+ qed
+ then show ?thesis by (simp only: class_def)
+ qed
+qed
+
+
+subsection {* Picking representing elements *}
+
+definition
+ pick :: "'a::equiv quot => 'a" where
+ "pick A = (SOME a. A = \<lfloor>a\<rfloor>)"
+
+theorem pick_equiv [intro]: "pick \<lfloor>a\<rfloor> \<sim> a"
+proof (unfold pick_def)
+ show "(SOME x. \<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>) \<sim> a"
+ proof (rule someI2)
+ show "\<lfloor>a\<rfloor> = \<lfloor>a\<rfloor>" ..
+ fix x assume "\<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>"
+ then have "a \<sim> x" .. then show "x \<sim> a" ..
+ qed
+qed
+
+theorem pick_inverse [intro]: "\<lfloor>pick A\<rfloor> = A"
+proof (cases A)
+ fix a assume a: "A = \<lfloor>a\<rfloor>"
+ then have "pick A \<sim> a" by (simp only: pick_equiv)
+ then have "\<lfloor>pick A\<rfloor> = \<lfloor>a\<rfloor>" ..
+ with a show ?thesis by simp
+qed
+
+text {*
+ \medskip The following rules support canonical function definitions
+ on quotient types (with up to two arguments). Note that the
+ stripped-down version without additional conditions is sufficient
+ most of the time.
+*}
+
+theorem quot_cond_function:
+ assumes eq: "!!X Y. P X Y ==> f X Y == g (pick X) (pick Y)"
+ and cong: "!!x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> ==> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor>
+ ==> P \<lfloor>x\<rfloor> \<lfloor>y\<rfloor> ==> P \<lfloor>x'\<rfloor> \<lfloor>y'\<rfloor> ==> g x y = g x' y'"
+ and P: "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>"
+ shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
+proof -
+ from eq and P have "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g (pick \<lfloor>a\<rfloor>) (pick \<lfloor>b\<rfloor>)" by (simp only:)
+ also have "... = g a b"
+ proof (rule cong)
+ show "\<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> = \<lfloor>a\<rfloor>" ..
+ moreover
+ show "\<lfloor>pick \<lfloor>b\<rfloor>\<rfloor> = \<lfloor>b\<rfloor>" ..
+ moreover
+ show "P \<lfloor>a\<rfloor> \<lfloor>b\<rfloor>" by (rule P)
+ ultimately show "P \<lfloor>pick \<lfloor>a\<rfloor>\<rfloor> \<lfloor>pick \<lfloor>b\<rfloor>\<rfloor>" by (simp only:)
+ qed
+ finally show ?thesis .
+qed
+
+theorem quot_function:
+ assumes "!!X Y. f X Y == g (pick X) (pick Y)"
+ and "!!x x' y y'. \<lfloor>x\<rfloor> = \<lfloor>x'\<rfloor> ==> \<lfloor>y\<rfloor> = \<lfloor>y'\<rfloor> ==> g x y = g x' y'"
+ shows "f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
+ using assms and TrueI
+ by (rule quot_cond_function)
+
+theorem quot_function':
+ "(!!X Y. f X Y == g (pick X) (pick Y)) ==>
+ (!!x x' y y'. x \<sim> x' ==> y \<sim> y' ==> g x y = g x' y') ==>
+ f \<lfloor>a\<rfloor> \<lfloor>b\<rfloor> = g a b"
+ by (rule quot_function) (simp_all only: quot_equality)
+
+end
--- a/src/HOL/Library/Structure_Syntax.thy Thu Feb 11 12:26:07 2010 -0800
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,14 +0,0 @@
-(* Author: Florian Haftmann, TU Muenchen *)
-
-header {* Index syntax for structures *}
-
-theory Structure_Syntax
-imports Pure
-begin
-
-syntax
- "_index1" :: index ("\<^sub>1")
-translations
- (index) "\<^sub>1" => (index) "\<^bsub>\<struct>\<^esub>"
-
-end
--- a/src/HOL/Metis_Examples/Message.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Metis_Examples/Message.thy Thu Feb 11 12:26:50 2010 -0800
@@ -252,7 +252,7 @@
declare [[ atp_problem_prefix = "Message__parts_cut" ]]
lemma parts_cut: "[|Y\<in> parts(insert X G); X\<in> parts H|] ==> Y\<in> parts(G \<union> H)"
-by (metis Un_subset_iff insert_subset parts_increasing parts_trans)
+by (metis Un_insert_left Un_insert_right insert_absorb mem_def parts_Un parts_idem sup1CI)
@@ -698,13 +698,12 @@
apply (rule subsetI)
apply (erule analz.induct)
apply (metis UnCI UnE Un_commute analz.Inj)
-apply (metis MPair_synth UnCI UnE Un_commute Un_upper1 analz.Fst analz_increasing analz_mono insert_absorb insert_subset)
-apply (metis MPair_synth UnCI UnE Un_commute Un_upper1 analz.Snd analz_increasing analz_mono insert_absorb insert_subset)
+apply (metis MPair_synth UnCI UnE Un_commute analz.Fst analz.Inj mem_def)
+apply (metis MPair_synth UnCI UnE Un_commute analz.Inj analz.Snd mem_def)
apply (blast intro: analz.Decrypt)
apply blast
done
-
declare [[ atp_problem_prefix = "Message__analz_synth" ]]
lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
proof (neg_clausify)
--- a/src/HOL/Metis_Examples/TransClosure.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Metis_Examples/TransClosure.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/MetisTest/TransClosure.thy
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Testing the metis method
--- a/src/HOL/MicroJava/BV/BVExample.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/BV/BVExample.thy Thu Feb 11 12:26:50 2010 -0800
@@ -296,12 +296,10 @@
done
text {* Some abbreviations for readability *}
-syntax
- Clist :: ty
- Ctest :: ty
-translations
- "Clist" == "Class list_name"
- "Ctest" == "Class test_name"
+abbreviation Clist :: ty
+ where "Clist == Class list_name"
+abbreviation Ctest :: ty
+ where "Ctest == Class test_name"
constdefs
phi_makelist :: method_type ("\<phi>\<^sub>m")
--- a/src/HOL/MicroJava/BV/JType.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/BV/JType.thy Thu Feb 11 12:26:50 2010 -0800
@@ -37,9 +37,7 @@
"is_ty G T == case T of PrimT P \<Rightarrow> True | RefT R \<Rightarrow>
(case R of NullT \<Rightarrow> True | ClassT C \<Rightarrow> (C, Object) \<in> (subcls1 G)^*)"
-
-translations
- "types G" == "Collect (is_type G)"
+abbreviation "types G == Collect (is_type G)"
constdefs
esl :: "'c prog \<Rightarrow> ty esl"
--- a/src/HOL/MicroJava/Comp/CorrCompTp.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/Comp/CorrCompTp.thy Thu Feb 11 12:26:50 2010 -0800
@@ -584,10 +584,9 @@
(* Currently: empty exception_table *)
-syntax
+abbreviation (input)
empty_et :: exception_table
-translations
- "empty_et" => "[]"
+ where "empty_et == []"
@@ -860,12 +859,13 @@
section "Correspondence bytecode - method types"
(* ********************************************************************** *)
-syntax
+abbreviation (input)
ST_of :: "state_type \<Rightarrow> opstack_type"
+ where "ST_of == fst"
+
+abbreviation (input)
LT_of :: "state_type \<Rightarrow> locvars_type"
-translations
- "ST_of" => "fst"
- "LT_of" => "snd"
+ where "LT_of == snd"
lemma states_lower:
"\<lbrakk> OK (Some (ST, LT)) \<in> states cG mxs mxr; length ST \<le> mxs\<rbrakk>
--- a/src/HOL/MicroJava/Comp/LemmasComp.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/Comp/LemmasComp.thy Thu Feb 11 12:26:50 2010 -0800
@@ -262,10 +262,8 @@
done
-syntax
- mtd_mb :: "cname \<times> ty \<times> 'c \<Rightarrow> 'c"
-translations
- "mtd_mb" => "Fun.comp snd snd"
+abbreviation (input)
+ "mtd_mb == snd o snd"
lemma map_of_map_fst: "\<lbrakk> inj f;
\<forall>x\<in>set xs. fst (f x) = fst x; \<forall>x\<in>set xs. fst (g x) = fst x \<rbrakk>
--- a/src/HOL/MicroJava/Comp/TranslCompTp.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/Comp/TranslCompTp.thy Thu Feb 11 12:26:50 2010 -0800
@@ -41,13 +41,13 @@
(**********************************************************************)
-syntax
- mt_of :: "method_type \<times> state_type \<Rightarrow> method_type"
- sttp_of :: "method_type \<times> state_type \<Rightarrow> state_type"
+abbreviation (input)
+ mt_of :: "method_type \<times> state_type \<Rightarrow> method_type"
+ where "mt_of == fst"
-translations
- "mt_of" => "fst"
- "sttp_of" => "snd"
+abbreviation (input)
+ sttp_of :: "method_type \<times> state_type \<Rightarrow> state_type"
+ where "sttp_of == snd"
consts
compTpExpr :: "java_mb \<Rightarrow> java_mb prog \<Rightarrow> expr
@@ -189,4 +189,3 @@
end
-
--- a/src/HOL/MicroJava/DFA/Err.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/DFA/Err.thy Thu Feb 11 12:26:50 2010 -0800
@@ -45,10 +45,9 @@
sl :: "'a esl \<Rightarrow> 'a err sl"
"sl == %(A,r,f). (err A, le r, lift2 f)"
-syntax
- err_semilat :: "'a esl \<Rightarrow> bool"
-translations
-"err_semilat L" == "semilat(Err.sl L)"
+abbreviation
+ err_semilat :: "'a esl \<Rightarrow> bool"
+ where "err_semilat L == semilat(Err.sl L)"
consts
--- a/src/HOL/MicroJava/DFA/Listn.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/DFA/Listn.thy Thu Feb 11 12:26:50 2010 -0800
@@ -17,21 +17,24 @@
le :: "'a ord \<Rightarrow> ('a list)ord"
"le r == list_all2 (%x y. x <=_r y)"
-syntax "@lesublist" :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
+abbreviation
+ lesublist_syntax :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
("(_ /<=[_] _)" [50, 0, 51] 50)
-syntax "@lesssublist" :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
+ where "x <=[r] y == x <=_(le r) y"
+
+abbreviation
+ lesssublist_syntax :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
("(_ /<[_] _)" [50, 0, 51] 50)
-translations
- "x <=[r] y" == "x <=_(Listn.le r) y"
- "x <[r] y" == "x <_(Listn.le r) y"
+ where "x <[r] y == x <_(le r) y"
constdefs
map2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list"
"map2 f == (%xs ys. map (split f) (zip xs ys))"
-syntax "@plussublist" :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b list \<Rightarrow> 'c list"
+abbreviation
+ plussublist_syntax :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b list \<Rightarrow> 'c list"
("(_ /+[_] _)" [65, 0, 66] 65)
-translations "x +[f] y" == "x +_(map2 f) y"
+ where "x +[f] y == x +_(map2 f) y"
consts coalesce :: "'a err list \<Rightarrow> 'a list err"
primrec
--- a/src/HOL/MicroJava/J/Example.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/J/Example.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/J/Example.thy
- ID: $Id$
Author: David von Oheimb
Copyright 1999 Technische Universitaet Muenchen
*)
@@ -55,19 +54,16 @@
declare inj_cnam' [simp] inj_vnam' [simp]
-syntax
- Base :: cname
- Ext :: cname
- vee :: vname
- x :: vname
- e :: vname
-
-translations
- "Base" == "cnam' Base'"
- "Ext" == "cnam' Ext'"
- "vee" == "VName (vnam' vee')"
- "x" == "VName (vnam' x')"
- "e" == "VName (vnam' e')"
+abbreviation Base :: cname
+ where "Base == cnam' Base'"
+abbreviation Ext :: cname
+ where "Ext == cnam' Ext'"
+abbreviation vee :: vname
+ where "vee == VName (vnam' vee')"
+abbreviation x :: vname
+ where "x == VName (vnam' x')"
+abbreviation e :: vname
+ where "e == VName (vnam' e')"
axioms
Base_not_Object: "Base \<noteq> Object"
--- a/src/HOL/MicroJava/J/Exceptions.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/J/Exceptions.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/J/Exceptions.thy
- ID: $Id$
Author: Gerwin Klein, Martin Strecker
Copyright 2002 Technische Universitaet Muenchen
*)
@@ -17,11 +16,9 @@
(XcptRef OutOfMemory \<mapsto> blank G (Xcpt OutOfMemory))"
-consts
+abbreviation
cname_of :: "aheap \<Rightarrow> val \<Rightarrow> cname"
-
-translations
- "cname_of hp v" == "fst (CONST the (hp (the_Addr v)))"
+ where "cname_of hp v == fst (the (hp (the_Addr v)))"
constdefs
--- a/src/HOL/MicroJava/J/State.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/J/State.thy Thu Feb 11 12:26:50 2010 -0800
@@ -27,21 +27,27 @@
state = "aheap \<times> locals" -- "heap, local parameter including This"
xstate = "val option \<times> state" -- "state including exception information"
-syntax
- heap :: "state => aheap"
- locals :: "state => locals"
- Norm :: "state => xstate"
- abrupt :: "xstate \<Rightarrow> val option"
- store :: "xstate \<Rightarrow> state"
- lookup_obj :: "state \<Rightarrow> val \<Rightarrow> obj"
+abbreviation (input)
+ heap :: "state => aheap"
+ where "heap == fst"
+
+abbreviation (input)
+ locals :: "state => locals"
+ where "locals == snd"
+
+abbreviation "Norm s == (None, s)"
-translations
- "heap" => "fst"
- "locals" => "snd"
- "Norm s" == "(None,s)"
- "abrupt" => "fst"
- "store" => "snd"
- "lookup_obj s a'" == "CONST the (heap s (the_Addr a'))"
+abbreviation (input)
+ abrupt :: "xstate \<Rightarrow> val option"
+ where "abrupt == fst"
+
+abbreviation (input)
+ store :: "xstate \<Rightarrow> state"
+ where "store == snd"
+
+abbreviation
+ lookup_obj :: "state \<Rightarrow> val \<Rightarrow> obj"
+ where "lookup_obj s a' == the (heap s (the_Addr a'))"
constdefs
--- a/src/HOL/MicroJava/J/Type.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/J/Type.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/J/Type.thy
- ID: $Id$
Author: David von Oheimb
Copyright 1999 Technische Universitaet Muenchen
*)
@@ -47,12 +46,10 @@
= PrimT prim_ty -- "primitive type"
| RefT ref_ty -- "reference type"
-syntax
- NT :: "ty"
- Class :: "cname => ty"
+abbreviation NT :: ty
+ where "NT == RefT NullT"
-translations
- "NT" == "RefT NullT"
- "Class C" == "RefT (ClassT C)"
+abbreviation Class :: "cname => ty"
+ where "Class C == RefT (ClassT C)"
end
--- a/src/HOL/MicroJava/J/WellType.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/J/WellType.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/J/WellType.thy
- ID: $Id$
Author: David von Oheimb
Copyright 1999 Technische Universitaet Muenchen
*)
@@ -27,13 +26,13 @@
lenv = "vname \<rightharpoonup> ty"
'c env = "'c prog \<times> lenv"
-syntax
- prg :: "'c env => 'c prog"
- localT :: "'c env => (vname \<rightharpoonup> ty)"
+abbreviation (input)
+ prg :: "'c env => 'c prog"
+ where "prg == fst"
-translations
- "prg" => "fst"
- "localT" => "snd"
+abbreviation (input)
+ localT :: "'c env => (vname \<rightharpoonup> ty)"
+ where "localT == snd"
consts
more_spec :: "'c prog => (ty \<times> 'x) \<times> ty list =>
@@ -207,10 +206,7 @@
(let E = (G,map_of lvars(pns[\<mapsto>]pTs)(This\<mapsto>Class C)) in
E\<turnstile>blk\<surd> \<and> (\<exists>T. E\<turnstile>res::T \<and> G\<turnstile>T\<preceq>rT))"
-syntax
- wf_java_prog :: "'c prog => bool"
-translations
- "wf_java_prog" == "wf_prog wf_java_mdecl"
+abbreviation "wf_java_prog == wf_prog wf_java_mdecl"
lemma wf_java_prog_wf_java_mdecl: "\<lbrakk>
wf_java_prog G; (C, D, fds, mths) \<in> set G; jmdcl \<in> set mths \<rbrakk>
--- a/src/HOL/MicroJava/JVM/JVMDefensive.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/JVM/JVMDefensive.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/JVM/JVMDefensive.thy
- ID: $Id$
Author: Gerwin Klein
*)
@@ -13,9 +12,9 @@
datatype 'a type_error = TypeError | Normal 'a
-syntax "fifth" :: "'a \<times> 'b \<times> 'c \<times> 'd \<times> 'e \<times> 'f \<Rightarrow> 'e"
-translations
- "fifth x" == "fst(snd(snd(snd(snd x))))"
+abbreviation
+ fifth :: "'a \<times> 'b \<times> 'c \<times> 'd \<times> 'e \<times> 'f \<Rightarrow> 'e"
+ where "fifth x == fst(snd(snd(snd(snd x))))"
consts isAddr :: "val \<Rightarrow> bool"
--- a/src/HOL/MicroJava/JVM/JVMExceptions.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/MicroJava/JVM/JVMExceptions.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,5 +1,4 @@
(* Title: HOL/MicroJava/JVM/JVMExceptions.thy
- ID: $Id$
Author: Gerwin Klein, Martin Strecker
Copyright 2001 Technische Universitaet Muenchen
*)
@@ -24,10 +23,9 @@
then Some (fst (snd (snd e)))
else match_exception_table G cn pc es)"
-consts
+abbreviation
ex_table_of :: "jvm_method \<Rightarrow> exception_table"
-translations
- "ex_table_of m" == "snd (snd (snd m))"
+ where "ex_table_of m == snd (snd (snd m))"
consts
--- a/src/HOL/Mutabelle/Mutabelle.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Mutabelle/Mutabelle.thy Thu Feb 11 12:26:50 2010 -0800
@@ -16,7 +16,7 @@
(@{const_name dummy_pattern}, "'a::{}"),
(@{const_name Algebras.uminus}, "'a"),
(@{const_name Nat.size}, "'a"),
- (@{const_name Algebras.abs}, "'a")];
+ (@{const_name Groups.abs}, "'a")];
val forbidden_thms =
["finite_intvl_succ_class",
--- a/src/HOL/Mutabelle/mutabelle_extra.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Mutabelle/mutabelle_extra.ML Thu Feb 11 12:26:50 2010 -0800
@@ -197,7 +197,7 @@
(@{const_name "dummy_pattern"}, "'a::{}") (*,
(@{const_name "uminus"}, "'a"),
(@{const_name "Nat.size"}, "'a"),
- (@{const_name "Algebras.abs"}, "'a") *)]
+ (@{const_name "Groups.abs"}, "'a") *)]
val forbidden_thms =
["finite_intvl_succ_class",
--- a/src/HOL/NSA/StarDef.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/NSA/StarDef.thy Thu Feb 11 12:26:50 2010 -0800
@@ -893,6 +893,7 @@
apply (intro_classes)
apply (transfer, erule left_inverse)
apply (transfer, erule right_inverse)
+apply (transfer, fact divide_inverse)
done
instance star :: (field) field
--- a/src/HOL/NanoJava/Example.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/NanoJava/Example.thy Thu Feb 11 12:26:50 2010 -0800
@@ -50,11 +50,14 @@
consts suc :: mname
add :: mname
consts any :: vname
-syntax dummy:: expr ("<>")
- one :: expr
-translations
- "<>" == "LAcc any"
- "one" == "{Nat}new Nat..suc(<>)"
+
+abbreviation
+ dummy :: expr ("<>")
+ where "<> == LAcc any"
+
+abbreviation
+ one :: expr
+ where "one == {Nat}new Nat..suc(<>)"
text {* The following properties could be derived from a more complete
program model, which we leave out for laziness. *}
--- a/src/HOL/NanoJava/TypeRel.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/NanoJava/TypeRel.thy Thu Feb 11 12:26:50 2010 -0800
@@ -11,16 +11,16 @@
consts
subcls1 :: "(cname \<times> cname) set" --{* subclass *}
-syntax (xsymbols)
- subcls1 :: "[cname, cname] => bool" ("_ \<prec>C1 _" [71,71] 70)
- subcls :: "[cname, cname] => bool" ("_ \<preceq>C _" [71,71] 70)
-syntax
- subcls1 :: "[cname, cname] => bool" ("_ <=C1 _" [71,71] 70)
- subcls :: "[cname, cname] => bool" ("_ <=C _" [71,71] 70)
+abbreviation
+ subcls1_syntax :: "[cname, cname] => bool" ("_ <=C1 _" [71,71] 70)
+ where "C <=C1 D == (C,D) \<in> subcls1"
+abbreviation
+ subcls_syntax :: "[cname, cname] => bool" ("_ <=C _" [71,71] 70)
+ where "C <=C D == (C,D) \<in> subcls1^*"
-translations
- "C \<prec>C1 D" == "(C,D) \<in> subcls1"
- "C \<preceq>C D" == "(C,D) \<in> subcls1^*"
+notation (xsymbols)
+ subcls1_syntax ("_ \<prec>C1 _" [71,71] 70) and
+ subcls_syntax ("_ \<preceq>C _" [71,71] 70)
consts
method :: "cname => (mname \<rightharpoonup> methd)"
--- a/src/HOL/Nat.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nat.thy Thu Feb 11 12:26:50 2010 -0800
@@ -176,7 +176,7 @@
end
-hide (open) fact add_0_right
+hide (open) fact add_0 add_0_right diff_0
instantiation nat :: comm_semiring_1_cancel
begin
@@ -1491,6 +1491,8 @@
lemma diff_diff_eq: "[| k \<le> m; k \<le> (n::nat) |] ==> ((m-k) - (n-k)) = (m-n)"
by (simp split add: nat_diff_split)
+hide (open) fact diff_diff_eq
+
lemma eq_diff_iff: "[| k \<le> m; k \<le> (n::nat) |] ==> (m-k = n-k) = (m=n)"
by (auto split add: nat_diff_split)
--- a/src/HOL/Nitpick.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick.thy Thu Feb 11 12:26:50 2010 -0800
@@ -13,6 +13,7 @@
("Tools/Nitpick/kodkod_sat.ML")
("Tools/Nitpick/nitpick_util.ML")
("Tools/Nitpick/nitpick_hol.ML")
+ ("Tools/Nitpick/nitpick_preproc.ML")
("Tools/Nitpick/nitpick_mono.ML")
("Tools/Nitpick/nitpick_scope.ML")
("Tools/Nitpick/nitpick_peephole.ML")
@@ -237,6 +238,7 @@
use "Tools/Nitpick/kodkod_sat.ML"
use "Tools/Nitpick/nitpick_util.ML"
use "Tools/Nitpick/nitpick_hol.ML"
+use "Tools/Nitpick/nitpick_preproc.ML"
use "Tools/Nitpick/nitpick_mono.ML"
use "Tools/Nitpick/nitpick_scope.ML"
use "Tools/Nitpick/nitpick_peephole.ML"
--- a/src/HOL/Nitpick_Examples/Core_Nits.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Core_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Core_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick's functional core.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
subsection {* Curry in a Hurry *}
--- a/src/HOL/Nitpick_Examples/Datatype_Nits.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Datatype_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Datatype_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick applied to datatypes.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
primrec rot where
"rot Nibble0 = Nibble1" | "rot Nibble1 = Nibble2" | "rot Nibble2 = Nibble3" |
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nitpick_Examples/Hotel_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -0,0 +1,57 @@
+(* Title: HOL/Nitpick_Examples/Hotel_Nits.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2010
+
+Nitpick example based on Tobias Nipkow's hotel key card formalization.
+*)
+
+header {* Nitpick Example Based on Tobias Nipkow's Hotel Key Card
+ Formalization *}
+
+theory Hotel_Nits
+imports Main
+begin
+
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 120 s]
+
+typedecl guest
+typedecl key
+typedecl room
+
+types keycard = "key \<times> key"
+
+record state =
+ owns :: "room \<Rightarrow> guest option"
+ currk :: "room \<Rightarrow> key"
+ issued :: "key set"
+ cards :: "guest \<Rightarrow> keycard set"
+ roomk :: "room \<Rightarrow> key"
+ isin :: "room \<Rightarrow> guest set"
+ safe :: "room \<Rightarrow> bool"
+
+inductive_set reach :: "state set" where
+init:
+"inj initk \<Longrightarrow>
+ \<lparr>owns = (\<lambda>r. None), currk = initk, issued = range initk, cards = (\<lambda>g. {}),
+ roomk = initk, isin = (\<lambda>r. {}), safe = (\<lambda>r. True)\<rparr> \<in> reach" |
+check_in:
+"\<lbrakk>s \<in> reach; k \<notin> issued s\<rbrakk> \<Longrightarrow>
+ s\<lparr>currk := (currk s)(r := k), issued := issued s \<union> {k},
+ cards := (cards s)(g := cards s g \<union> {(currk s r, k)}),
+ owns := (owns s)(r := Some g), safe := (safe s)(r := False)\<rparr> \<in> reach" |
+enter_room:
+"\<lbrakk>s \<in> reach; (k,k') \<in> cards s g; roomk s r \<in> {k,k'}\<rbrakk> \<Longrightarrow>
+ s\<lparr>isin := (isin s)(r := isin s r \<union> {g}),
+ roomk := (roomk s)(r := k'),
+ safe := (safe s)(r := owns s r = Some g \<and> isin s r = {} (* \<and> k' = currk s r *)
+ \<or> safe s r)\<rparr> \<in> reach" |
+exit_room:
+"\<lbrakk>s \<in> reach; g \<in> isin s r\<rbrakk> \<Longrightarrow> s\<lparr>isin := (isin s)(r := isin s r - {g})\<rparr> \<in> reach"
+
+theorem safe: "s \<in> reach \<Longrightarrow> safe s r \<Longrightarrow> g \<in> isin s r \<Longrightarrow> owns s r = Some g"
+nitpick [card room = 1, card guest = 2, card "guest option" = 3,
+ card key = 4, card state = 6, expect = genuine]
+nitpick [card room = 1, card guest = 2, expect = genuine]
+oops
+
+end
--- a/src/HOL/Nitpick_Examples/Induct_Nits.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Induct_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Induct_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick applied to (co)inductive definitions.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
inductive p1 :: "nat \<Rightarrow> bool" where
"p1 0" |
--- a/src/HOL/Nitpick_Examples/Integer_Nits.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Integer_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Integer_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick applied to natural numbers and integers.
*)
@@ -11,7 +11,7 @@
imports Nitpick
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s,
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s,
card = 1\<midarrow>6, bits = 1,2,3,4,6,8]
lemma "Suc x = x + 1"
--- a/src/HOL/Nitpick_Examples/Manual_Nits.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Manual_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Manual_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples from the Nitpick manual.
*)
@@ -13,7 +13,7 @@
chapter {* 3. First Steps *}
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1]
subsection {* 3.1. Propositional Logic *}
--- a/src/HOL/Nitpick_Examples/Mini_Nits.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Mini_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Mini_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Minipick, the minimalistic version of Nitpick.
*)
--- a/src/HOL/Nitpick_Examples/Mono_Nits.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Mono_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Mono_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick's monotonicity check.
*)
@@ -16,7 +16,7 @@
val defs = Nitpick_HOL.all_axioms_of @{theory} |> #1
val def_table = Nitpick_HOL.const_def_table @{context} defs
-val ext_ctxt : Nitpick_HOL.extended_context =
+val hol_ctxt : Nitpick_HOL.hol_context =
{thy = @{theory}, ctxt = @{context}, max_bisim_depth = ~1, boxes = [],
stds = [(NONE, true)], wfs = [], user_axioms = NONE, debug = false,
binary_ints = SOME false, destroy_constrs = false, specialize = false,
@@ -29,7 +29,7 @@
special_funs = Unsynchronized.ref [], unrolled_preds = Unsynchronized.ref [],
wf_cache = Unsynchronized.ref [], constr_cache = Unsynchronized.ref []}
(* term -> bool *)
-val is_mono = Nitpick_Mono.formulas_monotonic ext_ctxt @{typ 'a}
+val is_mono = Nitpick_Mono.formulas_monotonic hol_ctxt @{typ 'a}
Nitpick_Mono.Plus [] []
fun is_const t =
let val T = fastype_of t in
--- a/src/HOL/Nitpick_Examples/Nitpick_Examples.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Nitpick_Examples.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,13 +1,13 @@
(* Title: HOL/Nitpick_Examples/Nitpick_Examples.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Nitpick examples.
*)
theory Nitpick_Examples
-imports Core_Nits Datatype_Nits Induct_Nits Integer_Nits Manual_Nits Mini_Nits
- Mono_Nits Pattern_Nits Record_Nits Refute_Nits Special_Nits Tests_Nits
- Typedef_Nits
+imports Core_Nits Datatype_Nits Hotel_Nits Induct_Nits Integer_Nits Manual_Nits
+ Mini_Nits Mono_Nits Pattern_Nits Record_Nits Refute_Nits Special_Nits
+ Tests_Nits Typedef_Nits
begin
end
--- a/src/HOL/Nitpick_Examples/Pattern_Nits.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Pattern_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Pattern_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick's "destroy_constrs" optimization.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s,
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s,
card = 14]
lemma "x = (case u of () \<Rightarrow> y)"
--- a/src/HOL/Nitpick_Examples/Record_Nits.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Record_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Record_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick applied to records.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
record point2d =
xc :: int
--- a/src/HOL/Nitpick_Examples/Refute_Nits.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Refute_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Refute_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Refute examples adapted to Nitpick.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
lemma "P \<and> Q"
apply (rule conjI)
@@ -885,7 +885,7 @@
done
lemma "BinTree_rec l n (Node x y) = n x y (BinTree_rec l n x) (BinTree_rec l n y)"
-nitpick [card = 1\<midarrow>6, expect = none]
+nitpick [card = 1\<midarrow>5, expect = none]
apply simp
done
--- a/src/HOL/Nitpick_Examples/Special_Nits.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Special_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Special_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick's "specialize" optimization.
*)
@@ -11,7 +11,7 @@
imports Main
begin
-nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s,
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s,
card = 4]
fun f1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
--- a/src/HOL/Nitpick_Examples/Tests_Nits.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Tests_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Tests_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Nitpick tests.
*)
--- a/src/HOL/Nitpick_Examples/Typedef_Nits.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nitpick_Examples/Typedef_Nits.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1,6 +1,6 @@
(* Title: HOL/Nitpick_Examples/Typedef_Nits.thy
Author: Jasmin Blanchette, TU Muenchen
- Copyright 2009
+ Copyright 2009, 2010
Examples featuring Nitpick applied to typedefs.
*)
@@ -11,7 +11,8 @@
imports Main Rational
begin
-nitpick_params [card = 1\<midarrow>4, timeout = 30 s]
+nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s,
+ card = 1\<midarrow>4]
typedef three = "{0\<Colon>nat, 1, 2}"
by blast
--- a/src/HOL/Nominal/nominal_primrec.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Nominal/nominal_primrec.ML Thu Feb 11 12:26:50 2010 -0800
@@ -303,8 +303,10 @@
HOLogic.dest_eq |> fst |> strip_comb |> snd |> take_prefix is_Var |> fst;
val (pvars, ctxtvars) = List.partition
(equal HOLogic.boolT o body_type o snd)
- (subtract (op =) (map dest_Var fvars) (fold_rev Term.add_vars (map Logic.strip_assums_concl
- (prems_of (hd rec_rewrites))) []));
+ (subtract (op =)
+ (Term.add_vars (concl_of (hd rec_rewrites)) [])
+ (fold_rev (Term.add_vars o Logic.strip_assums_concl)
+ (prems_of (hd rec_rewrites)) []));
val cfs = defs' |> hd |> snd |> strip_comb |> snd |>
curry (List.take o swap) (length fvars) |> map cert;
val invs' = (case invs of
--- a/src/HOL/Orderings.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Orderings.thy Thu Feb 11 12:26:50 2010 -0800
@@ -11,6 +11,41 @@
"~~/src/Provers/quasi.ML" (* FIXME unused? *)
begin
+subsection {* Syntactic orders *}
+
+class ord =
+ fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
+ and less :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
+begin
+
+notation
+ less_eq ("op <=") and
+ less_eq ("(_/ <= _)" [51, 51] 50) and
+ less ("op <") and
+ less ("(_/ < _)" [51, 51] 50)
+
+notation (xsymbols)
+ less_eq ("op \<le>") and
+ less_eq ("(_/ \<le> _)" [51, 51] 50)
+
+notation (HTML output)
+ less_eq ("op \<le>") and
+ less_eq ("(_/ \<le> _)" [51, 51] 50)
+
+abbreviation (input)
+ greater_eq (infix ">=" 50) where
+ "x >= y \<equiv> y <= x"
+
+notation (input)
+ greater_eq (infix "\<ge>" 50)
+
+abbreviation (input)
+ greater (infix ">" 50) where
+ "x > y \<equiv> y < x"
+
+end
+
+
subsection {* Quasi orders *}
class preorder = ord +
--- a/src/HOL/Rational.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Rational.thy Thu Feb 11 12:26:50 2010 -0800
@@ -1083,14 +1083,6 @@
finally show ?thesis using assms by simp
qed
-lemma (in linordered_idom) sgn_greater [simp]:
- "0 < sgn a \<longleftrightarrow> 0 < a"
- unfolding sgn_if by auto
-
-lemma (in linordered_idom) sgn_less [simp]:
- "sgn a < 0 \<longleftrightarrow> a < 0"
- unfolding sgn_if by auto
-
lemma rat_le_eq_code [code]:
"Fract a b < Fract c d \<longleftrightarrow> (if b = 0
then sgn c * sgn d > 0
--- a/src/HOL/Real.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Real.thy Thu Feb 11 12:26:50 2010 -0800
@@ -2,28 +2,4 @@
imports RComplete RealVector
begin
-lemma field_le_epsilon:
- fixes x y :: "'a:: {number_ring,division_by_zero,linordered_field}"
- assumes e: "(!!e. 0 < e ==> x \<le> y + e)"
- shows "x \<le> y"
-proof (rule ccontr)
- assume xy: "\<not> x \<le> y"
- hence "(x-y)/2 > 0"
- by (metis half_gt_zero le_iff_diff_le_0 linorder_not_le local.xy)
- hence "x \<le> y + (x - y) / 2"
- by (rule e [of "(x-y)/2"])
- also have "... = (x - y + 2*y)/2"
- by auto
- (metis add_less_cancel_left add_numeral_0_right class_semiring.add_c xy e
- diff_add_cancel gt_half_sum less_half_sum linorder_not_le number_of_Pls)
- also have "... = (x + y) / 2"
- by auto
- also have "... < x" using xy
- by auto
- finally have "x<x" .
- thus False
- by auto
-qed
-
-
end
--- a/src/HOL/Rings.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Rings.thy Thu Feb 11 12:26:50 2010 -0800
@@ -410,9 +410,14 @@
end
+class inverse =
+ fixes inverse :: "'a \<Rightarrow> 'a"
+ and divide :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "'/" 70)
+
class division_ring = ring_1 + inverse +
assumes left_inverse [simp]: "a \<noteq> 0 \<Longrightarrow> inverse a * a = 1"
assumes right_inverse [simp]: "a \<noteq> 0 \<Longrightarrow> a * inverse a = 1"
+ assumes divide_inverse: "a / b = a * inverse b"
begin
subclass ring_1_no_zero_divisors
@@ -681,7 +686,7 @@
end
-class linlinordered_semiring_1_strict = linordered_semiring_strict + semiring_1
+class linordered_semiring_1_strict = linordered_semiring_strict + semiring_1
class mult_mono1 = times + zero + ord +
assumes mult_mono1: "a \<le> b \<Longrightarrow> 0 \<le> c \<Longrightarrow> c * a \<le> c * b"
@@ -777,15 +782,6 @@
end
-class abs_if = minus + uminus + ord + zero + abs +
- assumes abs_if: "\<bar>a\<bar> = (if a < 0 then - a else a)"
-
-class sgn_if = minus + uminus + zero + one + ord + sgn +
- assumes sgn_if: "sgn x = (if x = 0 then 0 else if 0 < x then 1 else - 1)"
-
-lemma (in sgn_if) sgn0[simp]: "sgn 0 = 0"
-by(simp add:sgn_if)
-
class linordered_ring = ring + linordered_semiring + linordered_ab_group_add + abs_if
begin
--- a/src/HOL/SET_Protocol/Event_SET.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/SET_Protocol/Event_SET.thy Thu Feb 11 12:26:50 2010 -0800
@@ -11,8 +11,7 @@
begin
text{*The Root Certification Authority*}
-syntax RCA :: agent
-translations "RCA" == "CA 0"
+abbreviation "RCA == CA 0"
text{*Message events*}
--- a/src/HOL/SET_Protocol/Message_SET.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/SET_Protocol/Message_SET.thy Thu Feb 11 12:26:50 2010 -0800
@@ -71,14 +71,14 @@
(*Concrete syntax: messages appear as {|A,B,NA|}, etc...*)
syntax
- "@MTuple" :: "['a, args] => 'a * 'b" ("(2{|_,/ _|})")
+ "_MTuple" :: "['a, args] => 'a * 'b" ("(2{|_,/ _|})")
syntax (xsymbols)
- "@MTuple" :: "['a, args] => 'a * 'b" ("(2\<lbrace>_,/ _\<rbrace>)")
+ "_MTuple" :: "['a, args] => 'a * 'b" ("(2\<lbrace>_,/ _\<rbrace>)")
translations
"{|x, y, z|}" == "{|x, {|y, z|}|}"
- "{|x, y|}" == "MPair x y"
+ "{|x, y|}" == "CONST MPair x y"
constdefs
--- a/src/HOL/SET_Protocol/Public_SET.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/SET_Protocol/Public_SET.thy Thu Feb 11 12:26:50 2010 -0800
@@ -23,19 +23,12 @@
publicKey :: "[bool, agent] => key"
--{*the boolean is TRUE if a signing key*}
-syntax
- pubEK :: "agent => key"
- pubSK :: "agent => key"
- priEK :: "agent => key"
- priSK :: "agent => key"
+abbreviation "pubEK == publicKey False"
+abbreviation "pubSK == publicKey True"
-translations
- "pubEK" == "publicKey False"
- "pubSK" == "publicKey True"
-
- (*BEWARE!! priEK, priSK DON'T WORK with inj, range, image, etc.*)
- "priEK A" == "invKey (pubEK A)"
- "priSK A" == "invKey (pubSK A)"
+(*BEWARE!! priEK, priSK DON'T WORK with inj, range, image, etc.*)
+abbreviation "priEK A == invKey (pubEK A)"
+abbreviation "priSK A == invKey (pubSK A)"
text{*By freeness of agents, no two agents have the same key. Since
@{term "True\<noteq>False"}, no agent has the same signing and encryption keys.*}
@@ -159,18 +152,12 @@
"certC PAN Ka PS T signK ==
signCert signK {|Hash {|Nonce PS, Pan PAN|}, Key Ka, T|}"
- (*cert and certA have no repeated elements, so they could be translations,
- but that's tricky and makes proofs slower*)
+(*cert and certA have no repeated elements, so they could be abbreviations,
+ but that's tricky and makes proofs slower*)
-syntax
- "onlyEnc" :: msg
- "onlySig" :: msg
- "authCode" :: msg
-
-translations
- "onlyEnc" == "Number 0"
- "onlySig" == "Number (Suc 0)"
- "authCode" == "Number (Suc (Suc 0))"
+abbreviation "onlyEnc == Number 0"
+abbreviation "onlySig == Number (Suc 0)"
+abbreviation "authCode == Number (Suc (Suc 0))"
subsection{*Encryption Primitives*}
--- a/src/HOL/SMT/SMT_Base.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/SMT/SMT_Base.thy Thu Feb 11 12:26:50 2010 -0800
@@ -5,7 +5,8 @@
header {* SMT-specific definitions and basic tools *}
theory SMT_Base
-imports Real Word "~~/src/HOL/Decision_Procs/Dense_Linear_Order"
+imports Real "~~/src/HOL/Word/Word"
+ "~~/src/HOL/Decision_Procs/Dense_Linear_Order"
uses
("Tools/smt_normalize.ML")
("Tools/smt_monomorph.ML")
--- a/src/HOL/SMT/Tools/smt_normalize.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/SMT/Tools/smt_normalize.ML Thu Feb 11 12:26:50 2010 -0800
@@ -125,8 +125,15 @@
Conv.rewr_conv @{thm atomize_all}
| _ => Conv.all_conv) ct
+fun unfold_quants_conv ctxt =
+ let
+ val rules = [@{thm Ex1_def}, @{thm Ball_def}, @{thm Bex_def}]
+ val unfold_conv = Conv.try_conv (More_Conv.rewrs_conv rules)
+ in More_Conv.top_conv (K unfold_conv) ctxt end
+
fun normalize_rule ctxt =
Conv.fconv_rule (
+ unfold_quants_conv ctxt then_conv
Thm.beta_conversion true then_conv
Thm.eta_conversion then_conv
norm_binder_conv ctxt) #>
--- a/src/HOL/TLA/Memory/ProcedureInterface.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/TLA/Memory/ProcedureInterface.thy Thu Feb 11 12:26:50 2010 -0800
@@ -55,10 +55,10 @@
"_Return" :: "['a, 'b, lift] => lift" ("(Return _ _ _)" [90,90,90] 90)
translations
- "_slice" == "slice"
+ "_slice" == "CONST slice"
- "_Call" == "ACall"
- "_Return" == "AReturn"
+ "_Call" == "CONST ACall"
+ "_Return" == "CONST AReturn"
defs
slice_def: "(PRED (x!i)) s == x s i"
--- a/src/HOL/TLA/TLA.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/TLA/TLA.thy Thu Feb 11 12:26:50 2010 -0800
@@ -37,12 +37,12 @@
"_AAll" :: "[idts, lift] => lift" ("(3AALL _./ _)" [0,10] 10)
translations
- "_Box" == "Box"
- "_Dmd" == "Dmd"
- "_leadsto" == "leadsto"
- "_stable" == "Stable"
- "_WF" == "WF"
- "_SF" == "SF"
+ "_Box" == "CONST Box"
+ "_Dmd" == "CONST Dmd"
+ "_leadsto" == "CONST leadsto"
+ "_stable" == "CONST Stable"
+ "_WF" == "CONST WF"
+ "_SF" == "CONST SF"
"_EEx v A" == "Eex v. A"
"_AAll v A" == "Aall v. A"
--- a/src/HOL/Tools/Function/lexicographic_order.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Function/lexicographic_order.ML Thu Feb 11 12:26:50 2010 -0800
@@ -80,10 +80,10 @@
let
val goals = cterm_of thy o mk_goal (vars, prems, mfun $ lhs, mfun $ rhs)
in
- case try_proof (goals @{const_name Algebras.less}) solve_tac of
+ case try_proof (goals @{const_name Orderings.less}) solve_tac of
Solved thm => Less thm
| Stuck thm =>
- (case try_proof (goals @{const_name Algebras.less_eq}) solve_tac of
+ (case try_proof (goals @{const_name Orderings.less_eq}) solve_tac of
Solved thm2 => LessEq (thm2, thm)
| Stuck thm2 =>
if prems_of thm2 = [HOLogic.Trueprop $ HOLogic.false_const] then False thm2
--- a/src/HOL/Tools/Function/size.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Function/size.ML Thu Feb 11 12:26:50 2010 -0800
@@ -153,7 +153,7 @@
val ctxt = ProofContext.init thy';
- val simpset1 = HOL_basic_ss addsimps @{thm add_0} :: @{thm Nat.add_0_right} ::
+ val simpset1 = HOL_basic_ss addsimps @{thm Nat.add_0} :: @{thm Nat.add_0_right} ::
size_def_thms @ size_def_thms' @ rec_rewrites @ extra_rewrites;
val xs = map (fn i => "x" ^ string_of_int i) (1 upto length recTs2);
--- a/src/HOL/Tools/Function/termination.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Function/termination.ML Thu Feb 11 12:26:50 2010 -0800
@@ -203,10 +203,10 @@
HOLogic.mk_Trueprop (Const (rel, @{typ "nat => nat => bool"})
$ (m2 $ r) $ (m1 $ l)))))) tac
in
- case try @{const_name Algebras.less} of
+ case try @{const_name Orderings.less} of
Solved thm => Less thm
| Stuck thm =>
- (case try @{const_name Algebras.less_eq} of
+ (case try @{const_name Orderings.less_eq} of
Solved thm2 => LessEq (thm2, thm)
| Stuck thm2 =>
if prems_of thm2 = [HOLogic.Trueprop $ HOLogic.false_const]
--- a/src/HOL/Tools/Groebner_Basis/normalizer.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Groebner_Basis/normalizer.ML Thu Feb 11 12:26:50 2010 -0800
@@ -60,7 +60,7 @@
(Simplifier.rewrite
(HOL_basic_ss
addsimps @{thms arith_simps} @ natarith @ @{thms rel_simps}
- @ [if_False, if_True, @{thm add_0}, @{thm add_Suc},
+ @ [if_False, if_True, @{thm Nat.add_0}, @{thm add_Suc},
@{thm add_number_of_left}, @{thm Suc_eq_plus1}]
@ map (fn th => th RS sym) @{thms numerals}));
@@ -634,7 +634,7 @@
val nat_arith = @{thms "nat_arith"};
val nat_exp_ss = HOL_basic_ss addsimps (@{thms nat_number} @ nat_arith @ @{thms arith_simps} @ @{thms rel_simps})
- addsimps [Let_def, if_False, if_True, @{thm add_0}, @{thm add_Suc}];
+ addsimps [Let_def, if_False, if_True, @{thm Nat.add_0}, @{thm add_Suc}];
fun simple_cterm_ord t u = TermOrd.term_ord (term_of t, term_of u) = LESS;
--- a/src/HOL/Tools/Nitpick/HISTORY Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Nitpick/HISTORY Thu Feb 11 12:26:50 2010 -0800
@@ -4,6 +4,8 @@
* Added "std" option and implemented support for nonstandard models
* Fixed soundness bugs related to "destroy_constrs" optimization and record
getters
+ * Renamed "MiniSatJNI", "zChaffJNI", "BerkMinAlloy", and "SAT4JLight" to
+ "MiniSat_JNI", "zChaff_JNI", "BerkMin_Alloy", and "SAT4J_Light"
Version 2009-1
--- a/src/HOL/Tools/Nitpick/kodkod.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Nitpick/kodkod.ML Thu Feb 11 12:26:50 2010 -0800
@@ -1054,23 +1054,23 @@
let
val code =
bash ("cd " ^ File.shell_quote temp_dir ^ ";\n" ^
- "env CLASSPATH=\"$KODKODI_CLASSPATH:$CLASSPATH\" \
- \JAVA_LIBRARY_PATH=\"$KODKODI_JAVA_LIBRARY_PATH:\
- \$JAVA_LIBRARY_PATH\" \
- \LD_LIBRARY_PATH=\"$KODKODI_JAVA_LIBRARY_PATH:\
- \$LD_LIBRARY_PATH\" \
- \\"$KODKODI\"/bin/kodkodi" ^
- (if ms >= 0 then " -max-msecs " ^ string_of_int ms
- else "") ^
- (if max_solutions > 1 then " -solve-all" else "") ^
- " -max-solutions " ^ string_of_int max_solutions ^
- (if max_threads > 0 then
- " -max-threads " ^ string_of_int max_threads
- else
- "") ^
- " < " ^ File.shell_path in_path ^
- " > " ^ File.shell_path out_path ^
- " 2> " ^ File.shell_path err_path)
+ "env CLASSPATH=\"$KODKODI_CLASSPATH:$CLASSPATH\" \
+ \JAVA_LIBRARY_PATH=\"$KODKODI_JAVA_LIBRARY_PATH:\
+ \$JAVA_LIBRARY_PATH\" \
+ \LD_LIBRARY_PATH=\"$KODKODI_JAVA_LIBRARY_PATH:\
+ \$LD_LIBRARY_PATH\" \
+ \\"$KODKODI\"/bin/kodkodi" ^
+ (if ms >= 0 then " -max-msecs " ^ string_of_int ms
+ else "") ^
+ (if max_solutions > 1 then " -solve-all" else "") ^
+ " -max-solutions " ^ string_of_int max_solutions ^
+ (if max_threads > 0 then
+ " -max-threads " ^ string_of_int max_threads
+ else
+ "") ^
+ " < " ^ File.shell_path in_path ^
+ " > " ^ File.shell_path out_path ^
+ " 2> " ^ File.shell_path err_path)
val (ps, nontriv_js) = read_output_file out_path
|>> map (apfst reindex) ||> map reindex
val js = triv_js @ nontriv_js
--- a/src/HOL/Tools/Nitpick/kodkod_sat.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Nitpick/kodkod_sat.ML Thu Feb 11 12:26:50 2010 -0800
@@ -42,12 +42,12 @@
if berkmin_exec = "" then "BerkMin561"
else berkmin_exec, [], "Satisfiable !!",
"solution =", "UNSATISFIABLE !!")),
- ("BerkMinAlloy", External (ToStdout, "BERKMINALLOY_HOME", "berkmin", [])),
+ ("BerkMin_Alloy", External (ToStdout, "BERKMINALLOY_HOME", "berkmin", [])),
("Jerusat", External (ToStdout, "JERUSAT_HOME", "Jerusat1.3", [])),
- ("MiniSatJNI", Internal (JNI, Incremental, ["MiniSat"])),
- ("zChaffJNI", Internal (JNI, Batch, ["zChaff"])),
+ ("MiniSat_JNI", Internal (JNI, Incremental, ["MiniSat"])),
+ ("zChaff_JNI", Internal (JNI, Batch, ["zChaff"])),
("SAT4J", Internal (Java, Incremental, ["DefaultSAT4J"])),
- ("SAT4JLight", Internal (Java, Incremental, ["LightSAT4J"])),
+ ("SAT4J_Light", Internal (Java, Incremental, ["LightSAT4J"])),
("HaifaSat", ExternalV2 (ToStdout, "HAIFASAT_HOME", "HaifaSat", ["-p", "1"],
"s SATISFIABLE", "v ", "s UNSATISFIABLE"))]
--- a/src/HOL/Tools/Nitpick/nitpick.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Nitpick/nitpick.ML Thu Feb 11 12:26:50 2010 -0800
@@ -69,6 +69,7 @@
open Nitpick_Util
open Nitpick_HOL
+open Nitpick_Preproc
open Nitpick_Mono
open Nitpick_Scope
open Nitpick_Peephole
@@ -273,7 +274,7 @@
val intro_table = inductive_intro_table ctxt def_table
val ground_thm_table = ground_theorem_table thy
val ersatz_table = ersatz_table thy
- val (ext_ctxt as {wf_cache, ...}) =
+ val (hol_ctxt as {wf_cache, ...}) =
{thy = thy, ctxt = ctxt, max_bisim_depth = max_bisim_depth, boxes = boxes,
stds = stds, wfs = wfs, user_axioms = user_axioms, debug = debug,
binary_ints = binary_ints, destroy_constrs = destroy_constrs,
@@ -292,7 +293,7 @@
val _ = null (Term.add_tvars assms_t []) orelse
raise NOT_SUPPORTED "schematic type variables"
val (((def_ts, nondef_ts), (got_all_mono_user_axioms, no_poly_user_axioms)),
- core_t) = preprocess_term ext_ctxt assms_t
+ core_t) = preprocess_term hol_ctxt assms_t
val got_all_user_axioms =
got_all_mono_user_axioms andalso no_poly_user_axioms
@@ -319,9 +320,9 @@
handle TYPE (_, Ts, ts) =>
raise TYPE ("Nitpick.pick_them_nits_in_term", Ts, ts)
- val core_u = nut_from_term ext_ctxt Eq core_t
- val def_us = map (nut_from_term ext_ctxt DefEq) def_ts
- val nondef_us = map (nut_from_term ext_ctxt Eq) nondef_ts
+ val core_u = nut_from_term hol_ctxt Eq core_t
+ val def_us = map (nut_from_term hol_ctxt DefEq) def_ts
+ val nondef_us = map (nut_from_term hol_ctxt Eq) nondef_ts
val (free_names, const_names) =
fold add_free_and_const_names (core_u :: def_us @ nondef_us) ([], [])
val (sel_names, nonsel_names) =
@@ -338,18 +339,18 @@
fun is_type_always_monotonic T =
(is_datatype thy T andalso not (is_quot_type thy T) andalso
(not (is_pure_typedef thy T) orelse is_univ_typedef thy T)) orelse
- is_number_type thy T orelse is_bit_type T orelse T = @{typ \<xi>}
+ is_number_type thy T orelse is_bit_type T
fun is_type_monotonic T =
unique_scope orelse
case triple_lookup (type_match thy) monos T of
SOME (SOME b) => b
| _ => is_type_always_monotonic T orelse
- formulas_monotonic ext_ctxt T Plus def_ts nondef_ts core_t
+ formulas_monotonic hol_ctxt T Plus def_ts nondef_ts core_t
fun is_deep_datatype T =
is_datatype thy T andalso
(is_word_type T orelse
exists (curry (op =) T o domain_type o type_of) sel_names)
- val all_Ts = ground_types_in_terms ext_ctxt (core_t :: def_ts @ nondef_ts)
+ val all_Ts = ground_types_in_terms hol_ctxt (core_t :: def_ts @ nondef_ts)
|> sort TermOrd.typ_ord
val _ = if verbose andalso binary_ints = SOME true andalso
exists (member (op =) [nat_T, int_T]) all_Ts then
@@ -522,7 +523,7 @@
val plain_bounds = map (bound_for_plain_rel ctxt debug) plain_rels
val plain_axioms = map (declarative_axiom_for_plain_rel kk) plain_rels
val sel_bounds = map (bound_for_sel_rel ctxt debug datatypes) sel_rels
- val dtype_axioms = declarative_axioms_for_datatypes ext_ctxt bits ofs kk
+ val dtype_axioms = declarative_axioms_for_datatypes hol_ctxt bits ofs kk
rel_table datatypes
val declarative_axioms = plain_axioms @ dtype_axioms
val univ_card = univ_card nat_card int_card main_j0
@@ -553,7 +554,7 @@
if loc = "Nitpick_Kodkod.check_arity" andalso
not (Typtab.is_empty ofs) then
problem_for_scope liberal
- {ext_ctxt = ext_ctxt, card_assigns = card_assigns,
+ {hol_ctxt = hol_ctxt, card_assigns = card_assigns,
bits = bits, bisim_depth = bisim_depth,
datatypes = datatypes, ofs = Typtab.empty}
else if loc = "Nitpick.pick_them_nits_in_term.\
@@ -891,7 +892,7 @@
end
val (skipped, the_scopes) =
- all_scopes ext_ctxt sym_break cards_assigns maxes_assigns iters_assigns
+ all_scopes hol_ctxt sym_break cards_assigns maxes_assigns iters_assigns
bitss bisim_depths mono_Ts nonmono_Ts deep_dataTs
val _ = if skipped > 0 then
print_m (fn () => "Too many scopes. Skipping " ^
--- a/src/HOL/Tools/Nitpick/nitpick_hol.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML Thu Feb 11 12:26:50 2010 -0800
@@ -13,7 +13,7 @@
type unrolled = styp * styp
type wf_cache = (styp * (bool * bool)) list
- type extended_context = {
+ type hol_context = {
thy: theory,
ctxt: Proof.context,
max_bisim_depth: int,
@@ -46,12 +46,24 @@
wf_cache: wf_cache Unsynchronized.ref,
constr_cache: (typ * styp list) list Unsynchronized.ref}
+ datatype fixpoint_kind = Lfp | Gfp | NoFp
+ datatype boxability =
+ InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2
+
val name_sep : string
val numeral_prefix : string
+ val ubfp_prefix : string
+ val lbfp_prefix : string
val skolem_prefix : string
+ val special_prefix : string
+ val uncurry_prefix : string
val eval_prefix : string
val original_name : string -> string
val s_conj : term * term -> term
+ val s_disj : term * term -> term
+ val strip_any_connective : term -> term list * term
+ val conjuncts_of : term -> term list
+ val disjuncts_of : term -> term list
val unbit_and_unbox_type : typ -> typ
val string_for_type : Proof.context -> typ -> string
val prefix_name : string -> string -> string
@@ -76,6 +88,7 @@
val is_record_type : typ -> bool
val is_number_type : theory -> typ -> bool
val const_for_iterator_type : typ -> styp
+ val strip_n_binders : int -> typ -> typ list * typ
val nth_range_type : int -> typ -> typ
val num_factors_in_type : typ -> int
val num_binder_types : typ -> int
@@ -96,16 +109,20 @@
val is_rep_fun : theory -> styp -> bool
val is_quot_abs_fun : Proof.context -> styp -> bool
val is_quot_rep_fun : Proof.context -> styp -> bool
+ val mate_of_rep_fun : theory -> styp -> styp
+ val is_constr_like : theory -> styp -> bool
+ val is_stale_constr : theory -> styp -> bool
val is_constr : theory -> styp -> bool
- val is_stale_constr : theory -> styp -> bool
val is_sel : string -> bool
val is_sel_like_and_no_discr : string -> bool
+ val box_type : hol_context -> boxability -> typ -> typ
val discr_for_constr : styp -> styp
val num_sels_for_constr_type : typ -> int
val nth_sel_name_for_constr_name : string -> int -> string
val nth_sel_for_constr : styp -> int -> styp
- val boxed_nth_sel_for_constr : extended_context -> styp -> int -> styp
+ val boxed_nth_sel_for_constr : hol_context -> styp -> int -> styp
val sel_no_from_name : string -> int
+ val close_form : term -> term
val eta_expand : typ list -> term -> int -> term
val extensionalize : term -> term
val distinctness_formula : typ -> term list -> term
@@ -113,19 +130,25 @@
val unregister_frac_type : string -> theory -> theory
val register_codatatype : typ -> string -> styp list -> theory -> theory
val unregister_codatatype : typ -> theory -> theory
- val datatype_constrs : extended_context -> typ -> styp list
- val boxed_datatype_constrs : extended_context -> typ -> styp list
- val num_datatype_constrs : extended_context -> typ -> int
+ val datatype_constrs : hol_context -> typ -> styp list
+ val boxed_datatype_constrs : hol_context -> typ -> styp list
+ val num_datatype_constrs : hol_context -> typ -> int
val constr_name_for_sel_like : string -> string
- val boxed_constr_for_sel : extended_context -> styp -> styp
+ val boxed_constr_for_sel : hol_context -> styp -> styp
+ val discriminate_value : hol_context -> styp -> term -> term
+ val select_nth_constr_arg : theory -> styp -> term -> int -> typ -> term
+ val construct_value : theory -> styp -> term list -> term
val card_of_type : (typ * int) list -> typ -> int
val bounded_card_of_type : int -> int -> (typ * int) list -> typ -> int
val bounded_exact_card_of_type :
- extended_context -> int -> int -> (typ * int) list -> typ -> int
- val is_finite_type : extended_context -> typ -> bool
+ hol_context -> int -> int -> (typ * int) list -> typ -> int
+ val is_finite_type : hol_context -> typ -> bool
+ val special_bounds : term list -> (indexname * typ) list
+ val is_funky_typedef : theory -> typ -> bool
val all_axioms_of : theory -> term list * term list * term list
val arity_of_built_in_const : bool -> styp -> int option
val is_built_in_const : bool -> styp -> bool
+ val term_under_def : term -> term
val case_const_names : theory -> (string * int) list
val const_def_table : Proof.context -> term list -> const_table
val const_nondef_table : term list -> const_table
@@ -134,22 +157,33 @@
val inductive_intro_table : Proof.context -> const_table -> const_table
val ground_theorem_table : theory -> term list Inttab.table
val ersatz_table : theory -> (string * string) list
+ val add_simps : const_table Unsynchronized.ref -> string -> term list -> unit
+ val inverse_axioms_for_rep_fun : theory -> styp -> term list
+ val optimized_typedef_axioms : theory -> string * typ list -> term list
+ val optimized_quot_type_axioms : theory -> string * typ list -> term list
val def_of_const : theory -> const_table -> styp -> term option
- val is_inductive_pred : extended_context -> styp -> bool
+ val fixpoint_kind_of_const :
+ theory -> const_table -> string * typ -> fixpoint_kind
+ val is_inductive_pred : hol_context -> styp -> bool
+ val is_equational_fun : hol_context -> styp -> bool
val is_constr_pattern_lhs : theory -> term -> bool
val is_constr_pattern_formula : theory -> term -> bool
+ val unfold_defs_in_term : hol_context -> term -> term
+ val codatatype_bisim_axioms : hol_context -> typ -> term list
+ val is_well_founded_inductive_pred : hol_context -> styp -> bool
+ val unrolled_inductive_pred_const : hol_context -> bool -> styp -> term
+ val equational_fun_axioms : hol_context -> styp -> term list
+ val is_equational_fun_surely_complete : hol_context -> styp -> bool
val merge_type_vars_in_terms : term list -> term list
- val ground_types_in_type : extended_context -> typ -> typ list
- val ground_types_in_terms : extended_context -> term list -> typ list
+ val ground_types_in_type : hol_context -> typ -> typ list
+ val ground_types_in_terms : hol_context -> term list -> typ list
val format_type : int list -> int list -> typ -> typ
val format_term_type :
theory -> const_table -> (term option * int list) list -> term -> typ
val user_friendly_const :
- extended_context -> string * string -> (term option * int list) list
+ hol_context -> string * string -> (term option * int list) list
-> styp -> term * typ
val assign_operator_for_const : styp -> string
- val preprocess_term :
- extended_context -> term -> ((term list * term list) * (bool * bool)) * term
end;
structure Nitpick_HOL : NITPICK_HOL =
@@ -162,7 +196,7 @@
type unrolled = styp * styp
type wf_cache = (styp * (bool * bool)) list
-type extended_context = {
+type hol_context = {
thy: theory,
ctxt: Proof.context,
max_bisim_depth: int,
@@ -195,6 +229,10 @@
wf_cache: wf_cache Unsynchronized.ref,
constr_cache: (typ * styp list) list Unsynchronized.ref}
+datatype fixpoint_kind = Lfp | Gfp | NoFp
+datatype boxability =
+ InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2
+
structure Data = Theory_Data(
type T = {frac_types: (string * (string * string) list) list,
codatatypes: (string * (string * styp list)) list}
@@ -222,20 +260,11 @@
val special_prefix = nitpick_prefix ^ "sp"
val uncurry_prefix = nitpick_prefix ^ "unc"
val eval_prefix = nitpick_prefix ^ "eval"
-val bound_var_prefix = "b"
-val cong_var_prefix = "c"
val iter_var_prefix = "i"
-val val_var_prefix = nitpick_prefix ^ "v"
val arg_var_prefix = "x"
(* int -> string *)
fun sel_prefix_for j = sel_prefix ^ string_of_int j ^ name_sep
-fun special_prefix_for j = special_prefix ^ string_of_int j ^ name_sep
-(* int -> int -> string *)
-fun skolem_prefix_for k j =
- skolem_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
-fun uncurry_prefix_for k j =
- uncurry_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
(* string -> string * string *)
val strip_first_name_sep =
@@ -260,9 +289,6 @@
| s_disj (t1, t2) =
if t1 = @{const True} orelse t2 = @{const True} then @{const True}
else HOLogic.mk_disj (t1, t2)
-(* term -> term -> term *)
-fun mk_exists v t =
- HOLogic.exists_const (fastype_of v) $ lambda v (incr_boundvars 1 t)
(* term -> term -> term list *)
fun strip_connective conn_t (t as (t0 $ t1 $ t2)) =
@@ -276,8 +302,8 @@
([t], @{const Not})
| strip_any_connective t = ([t], @{const Not})
(* term -> term list *)
-val conjuncts = strip_connective @{const "op &"}
-val disjuncts = strip_connective @{const "op |"}
+val conjuncts_of = strip_connective @{const "op &"}
+val disjuncts_of = strip_connective @{const "op |"}
(* When you add constants to these lists, make sure to handle them in
"Nitpick_Nut.nut_from_term", and perhaps in "Nitpick_Mono.consider_term" as
@@ -373,8 +399,6 @@
fun shortest_name s = List.last (space_explode "." s) handle List.Empty => ""
(* string -> term -> term *)
val prefix_abs_vars = Term.map_abs_vars o prefix_name
-(* term -> term *)
-val shorten_abs_vars = Term.map_abs_vars shortest_name
(* string -> string *)
fun short_name s =
case space_explode name_sep s of
@@ -441,7 +465,7 @@
| const_for_iterator_type T =
raise TYPE ("Nitpick_HOL.const_for_iterator_type", [T], [])
-(* int -> typ -> typ * typ *)
+(* int -> typ -> typ list * typ *)
fun strip_n_binders 0 T = ([], T)
| strip_n_binders n (Type ("fun", [T1, T2])) =
strip_n_binders (n - 1) T2 |>> cons T1
@@ -552,7 +576,7 @@
val is_real_datatype = is_some oo Datatype.get_info
(* theory -> typ -> bool *)
fun is_quot_type _ (Type ("IntEx.my_int", _)) = true (* FIXME *)
- | is_quot_type _ (Type ("FSet.fset", _)) = true (* FIXME *)
+ | is_quot_type _ (Type ("FSet.fset", _)) = true
| is_quot_type _ _ = false
fun is_codatatype thy (T as Type (s, _)) =
not (null (AList.lookup (op =) (#codatatypes (Data.get thy)) s
@@ -619,11 +643,11 @@
| NONE => false)
| is_rep_fun _ _ = false
(* Proof.context -> styp -> bool *)
-fun is_quot_abs_fun _ ("IntEx.abs_my_int", _) = true (* FIXME *)
- | is_quot_abs_fun _ ("FSet.abs_fset", _) = true (* FIXME *)
+fun is_quot_abs_fun _ ("IntEx.abs_my_int", _) = true
+ | is_quot_abs_fun _ ("FSet.abs_fset", _) = true
| is_quot_abs_fun _ _ = false
-fun is_quot_rep_fun _ ("IntEx.rep_my_int", _) = true (* FIXME *)
- | is_quot_rep_fun _ ("FSet.rep_fset", _) = true (* FIXME *)
+fun is_quot_rep_fun _ ("IntEx.rep_my_int", _) = true
+ | is_quot_rep_fun _ ("FSet.rep_fset", _) = true
| is_quot_rep_fun _ _ = false
(* theory -> styp -> styp *)
@@ -682,9 +706,6 @@
String.isPrefix sel_prefix
orf (member (op =) [@{const_name fst}, @{const_name snd}])
-datatype boxability =
- InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2
-
(* boxability -> boxability *)
fun in_fun_lhs_for InConstr = InSel
| in_fun_lhs_for _ = InFunLHS
@@ -693,8 +714,8 @@
| in_fun_rhs_for InFunRHS1 = InFunRHS2
| in_fun_rhs_for _ = InFunRHS1
-(* extended_context -> boxability -> typ -> bool *)
-fun is_boxing_worth_it (ext_ctxt : extended_context) boxy T =
+(* hol_context -> boxability -> typ -> bool *)
+fun is_boxing_worth_it (hol_ctxt : hol_context) boxy T =
case T of
Type ("fun", _) =>
(boxy = InPair orelse boxy = InFunLHS) andalso
@@ -702,31 +723,31 @@
| Type ("*", Ts) =>
boxy = InPair orelse boxy = InFunRHS1 orelse boxy = InFunRHS2 orelse
((boxy = InExpr orelse boxy = InFunLHS) andalso
- exists (is_boxing_worth_it ext_ctxt InPair)
- (map (box_type ext_ctxt InPair) Ts))
+ exists (is_boxing_worth_it hol_ctxt InPair)
+ (map (box_type hol_ctxt InPair) Ts))
| _ => false
-(* extended_context -> boxability -> string * typ list -> string *)
-and should_box_type (ext_ctxt as {thy, boxes, ...}) boxy (z as (s, Ts)) =
+(* hol_context -> boxability -> string * typ list -> string *)
+and should_box_type (hol_ctxt as {thy, boxes, ...}) boxy (z as (s, Ts)) =
case triple_lookup (type_match thy) boxes (Type z) of
SOME (SOME box_me) => box_me
- | _ => is_boxing_worth_it ext_ctxt boxy (Type z)
-(* extended_context -> boxability -> typ -> typ *)
-and box_type ext_ctxt boxy T =
+ | _ => is_boxing_worth_it hol_ctxt boxy (Type z)
+(* hol_context -> boxability -> typ -> typ *)
+and box_type hol_ctxt boxy T =
case T of
Type (z as ("fun", [T1, T2])) =>
if boxy <> InConstr andalso boxy <> InSel andalso
- should_box_type ext_ctxt boxy z then
+ should_box_type hol_ctxt boxy z then
Type (@{type_name fun_box},
- [box_type ext_ctxt InFunLHS T1, box_type ext_ctxt InFunRHS1 T2])
+ [box_type hol_ctxt InFunLHS T1, box_type hol_ctxt InFunRHS1 T2])
else
- box_type ext_ctxt (in_fun_lhs_for boxy) T1
- --> box_type ext_ctxt (in_fun_rhs_for boxy) T2
+ box_type hol_ctxt (in_fun_lhs_for boxy) T1
+ --> box_type hol_ctxt (in_fun_rhs_for boxy) T2
| Type (z as ("*", Ts)) =>
if boxy <> InConstr andalso boxy <> InSel
- andalso should_box_type ext_ctxt boxy z then
- Type (@{type_name pair_box}, map (box_type ext_ctxt InSel) Ts)
+ andalso should_box_type hol_ctxt boxy z then
+ Type (@{type_name pair_box}, map (box_type hol_ctxt InSel) Ts)
else
- Type ("*", map (box_type ext_ctxt
+ Type ("*", map (box_type hol_ctxt
(if boxy = InConstr orelse boxy = InSel then boxy
else InPair)) Ts)
| _ => T
@@ -747,9 +768,9 @@
| nth_sel_for_constr (s, T) n =
(nth_sel_name_for_constr_name s n,
body_type T --> nth (maybe_curried_binder_types T) n)
-(* extended_context -> styp -> int -> styp *)
-fun boxed_nth_sel_for_constr ext_ctxt =
- apsnd (box_type ext_ctxt InSel) oo nth_sel_for_constr
+(* hol_context -> styp -> int -> styp *)
+fun boxed_nth_sel_for_constr hol_ctxt =
+ apsnd (box_type hol_ctxt InSel) oo nth_sel_for_constr
(* string -> int *)
fun sel_no_from_name s =
@@ -762,6 +783,22 @@
else
0
+(* term -> term *)
+val close_form =
+ let
+ (* (indexname * typ) list -> (indexname * typ) list -> term -> term *)
+ fun close_up zs zs' =
+ fold (fn (z as ((s, _), T)) => fn t' =>
+ Term.all T $ Abs (s, T, abstract_over (Var z, t')))
+ (take (length zs' - length zs) zs')
+ (* (indexname * typ) list -> term -> term *)
+ fun aux zs (@{const "==>"} $ t1 $ t2) =
+ let val zs' = Term.add_vars t1 zs in
+ close_up zs zs' (Logic.mk_implies (t1, aux zs' t2))
+ end
+ | aux zs t = close_up zs (Term.add_vars t zs) t
+ in aux [] end
+
(* typ list -> term -> int -> term *)
fun eta_expand _ t 0 = t
| eta_expand Ts (Abs (s, T, t')) n =
@@ -791,8 +828,8 @@
fun zero_const T = Const (@{const_name zero_nat_inst.zero_nat}, T)
fun suc_const T = Const (@{const_name Suc}, T --> T)
-(* extended_context -> typ -> styp list *)
-fun uncached_datatype_constrs ({thy, stds, ...} : extended_context)
+(* hol_context -> typ -> styp list *)
+fun uncached_datatype_constrs ({thy, stds, ...} : hol_context)
(T as Type (s, Ts)) =
(case AList.lookup (op =) (#codatatypes (Data.get thy)) s of
SOME (_, xs' as (_ :: _)) => map (apsnd (repair_constr_type thy T)) xs'
@@ -829,49 +866,49 @@
else
[])
| uncached_datatype_constrs _ _ = []
-(* extended_context -> typ -> styp list *)
-fun datatype_constrs (ext_ctxt as {constr_cache, ...}) T =
+(* hol_context -> typ -> styp list *)
+fun datatype_constrs (hol_ctxt as {constr_cache, ...}) T =
case AList.lookup (op =) (!constr_cache) T of
SOME xs => xs
| NONE =>
- let val xs = uncached_datatype_constrs ext_ctxt T in
+ let val xs = uncached_datatype_constrs hol_ctxt T in
(Unsynchronized.change constr_cache (cons (T, xs)); xs)
end
-fun boxed_datatype_constrs ext_ctxt =
- map (apsnd (box_type ext_ctxt InConstr)) o datatype_constrs ext_ctxt
-(* extended_context -> typ -> int *)
+fun boxed_datatype_constrs hol_ctxt =
+ map (apsnd (box_type hol_ctxt InConstr)) o datatype_constrs hol_ctxt
+(* hol_context -> typ -> int *)
val num_datatype_constrs = length oo datatype_constrs
(* string -> string *)
fun constr_name_for_sel_like @{const_name fst} = @{const_name Pair}
| constr_name_for_sel_like @{const_name snd} = @{const_name Pair}
| constr_name_for_sel_like s' = original_name s'
-(* extended_context -> styp -> styp *)
-fun boxed_constr_for_sel ext_ctxt (s', T') =
+(* hol_context -> styp -> styp *)
+fun boxed_constr_for_sel hol_ctxt (s', T') =
let val s = constr_name_for_sel_like s' in
- AList.lookup (op =) (boxed_datatype_constrs ext_ctxt (domain_type T')) s
+ AList.lookup (op =) (boxed_datatype_constrs hol_ctxt (domain_type T')) s
|> the |> pair s
end
-(* extended_context -> styp -> term *)
-fun discr_term_for_constr ext_ctxt (x as (s, T)) =
+(* hol_context -> styp -> term *)
+fun discr_term_for_constr hol_ctxt (x as (s, T)) =
let val dataT = body_type T in
if s = @{const_name Suc} then
Abs (Name.uu, dataT,
@{const Not} $ HOLogic.mk_eq (zero_const dataT, Bound 0))
- else if num_datatype_constrs ext_ctxt dataT >= 2 then
+ else if num_datatype_constrs hol_ctxt dataT >= 2 then
Const (discr_for_constr x)
else
Abs (Name.uu, dataT, @{const True})
end
-(* extended_context -> styp -> term -> term *)
-fun discriminate_value (ext_ctxt as {thy, ...}) (x as (_, T)) t =
+(* hol_context -> styp -> term -> term *)
+fun discriminate_value (hol_ctxt as {thy, ...}) (x as (_, T)) t =
case strip_comb t of
(Const x', args) =>
if x = x' then @{const True}
else if is_constr_like thy x' then @{const False}
- else betapply (discr_term_for_constr ext_ctxt x, t)
- | _ => betapply (discr_term_for_constr ext_ctxt x, t)
+ else betapply (discr_term_for_constr hol_ctxt x, t)
+ | _ => betapply (discr_term_for_constr hol_ctxt x, t)
(* styp -> term -> term *)
fun nth_arg_sel_term_for_constr (x as (s, T)) n =
@@ -920,25 +957,9 @@
| _ => list_comb (Const x, args)
end
-(* extended_context -> typ -> term -> term *)
-fun constr_expand (ext_ctxt as {thy, ...}) T t =
- (case head_of t of
- Const x => if is_constr_like thy x then t else raise SAME ()
- | _ => raise SAME ())
- handle SAME () =>
- let
- val x' as (_, T') =
- if is_pair_type T then
- let val (T1, T2) = HOLogic.dest_prodT T in
- (@{const_name Pair}, T1 --> T2 --> T)
- end
- else
- datatype_constrs ext_ctxt T |> hd
- val arg_Ts = binder_types T'
- in
- list_comb (Const x', map2 (select_nth_constr_arg thy x' t)
- (index_seq 0 (length arg_Ts)) arg_Ts)
- end
+(* The higher this number is, the more nonstandard models can be generated. It's
+ not important enough to be a user option, though. *)
+val xi_card = 8
(* (typ * int) list -> typ -> int *)
fun card_of_type assigns (Type ("fun", [T1, T2])) =
@@ -949,6 +970,7 @@
| card_of_type _ @{typ prop} = 2
| card_of_type _ @{typ bool} = 2
| card_of_type _ @{typ unit} = 1
+ | card_of_type _ @{typ \<xi>} = xi_card
| card_of_type assigns T =
case AList.lookup (op =) assigns T of
SOME k => k
@@ -975,8 +997,8 @@
card_of_type assigns T
handle TYPE ("Nitpick_HOL.card_of_type", _, _) =>
default_card)
-(* extended_context -> int -> (typ * int) list -> typ -> int *)
-fun bounded_exact_card_of_type ext_ctxt max default_card assigns T =
+(* hol_context -> int -> (typ * int) list -> typ -> int *)
+fun bounded_exact_card_of_type hol_ctxt max default_card assigns T =
let
(* typ list -> typ -> int *)
fun aux avoid T =
@@ -1005,14 +1027,15 @@
| @{typ prop} => 2
| @{typ bool} => 2
| @{typ unit} => 1
+ | @{typ \<xi>} => xi_card
| Type _ =>
- (case datatype_constrs ext_ctxt T of
+ (case datatype_constrs hol_ctxt T of
[] => if is_integer_type T orelse is_bit_type T then 0
else raise SAME ()
| constrs =>
let
val constr_cards =
- datatype_constrs ext_ctxt T
+ datatype_constrs hol_ctxt T
|> map (Integer.prod o map (aux (T :: avoid)) o binder_types
o snd)
in
@@ -1024,9 +1047,9 @@
AList.lookup (op =) assigns T |> the_default default_card
in Int.min (max, aux [] T) end
-(* extended_context -> typ -> bool *)
-fun is_finite_type ext_ctxt =
- not_equal 0 o bounded_exact_card_of_type ext_ctxt 1 2 []
+(* hol_context -> typ -> bool *)
+fun is_finite_type hol_ctxt =
+ not_equal 0 o bounded_exact_card_of_type hol_ctxt 1 2 []
(* term -> bool *)
fun is_ground_term (t1 $ t2) = is_ground_term t1 andalso is_ground_term t2
@@ -1052,7 +1075,7 @@
member (op =) [@{type_name unit}, @{type_name "*"}, @{type_name "+"},
@{type_name int}] s orelse
is_frac_type thy (Type (s, []))
-(* theory -> term -> bool *)
+(* theory -> typ -> bool *)
fun is_funky_typedef thy (Type (s, _)) = is_funky_typedef_name thy s
| is_funky_typedef _ _ = false
(* term -> bool *)
@@ -1199,8 +1222,6 @@
|> normalized_rhs_of thy |> Option.map (prefix_abs_vars s)
handle List.Empty => NONE
-datatype fixpoint_kind = Lfp | Gfp | NoFp
-
(* term -> fixpoint_kind *)
fun fixpoint_kind_of_rhs (Abs (_, _, t)) = fixpoint_kind_of_rhs t
| fixpoint_kind_of_rhs (Const (@{const_name lfp}, _) $ Abs _) = Lfp
@@ -1299,35 +1320,6 @@
Unsynchronized.change simp_table
(Symtab.update (s, eqs @ these (Symtab.lookup (!simp_table) s)))
-(* Similar to "Refute.specialize_type" but returns all matches rather than only
- the first (preorder) match. *)
-(* theory -> styp -> term -> term list *)
-fun multi_specialize_type thy slack (x as (s, T)) t =
- let
- (* term -> (typ * term) list -> (typ * term) list *)
- fun aux (Const (s', T')) ys =
- if s = s' then
- ys |> (if AList.defined (op =) ys T' then
- I
- else
- cons (T', Refute.monomorphic_term
- (Sign.typ_match thy (T', T) Vartab.empty) t)
- handle Type.TYPE_MATCH => I
- | Refute.REFUTE _ =>
- if slack then
- I
- else
- raise NOT_SUPPORTED ("too much polymorphism in \
- \axiom involving " ^ quote s))
- else
- ys
- | aux _ ys = ys
- in map snd (fold_aterms aux t []) end
-
-(* theory -> bool -> const_table -> styp -> term list *)
-fun nondef_props_for_const thy slack table (x as (s, _)) =
- these (Symtab.lookup table s) |> maps (multi_specialize_type thy slack x)
-
(* theory -> styp -> term list *)
fun inverse_axioms_for_rep_fun thy (x as (_, T)) =
let val abs_T = domain_type T in
@@ -1336,7 +1328,7 @@
|> pairself (Refute.specialize_type thy x o prop_of o the)
||> single |> op ::
end
-(* theory -> styp list -> term list *)
+(* theory -> string * typ list -> term list *)
fun optimized_typedef_axioms thy (abs_z as (abs_s, abs_Ts)) =
let val abs_T = Type abs_z in
if is_univ_typedef thy abs_T then
@@ -1392,15 +1384,15 @@
list_comb (Bound j, map2 (select_nth_constr_arg thy x (Bound 0))
(index_seq 0 (length arg_Ts)) arg_Ts)
end
-(* extended_context -> typ -> int * styp -> term -> term *)
-fun add_constr_case (ext_ctxt as {thy, ...}) res_T (j, x) res_t =
+(* hol_context -> typ -> int * styp -> term -> term *)
+fun add_constr_case (hol_ctxt as {thy, ...}) res_T (j, x) res_t =
Const (@{const_name If}, bool_T --> res_T --> res_T --> res_T)
- $ discriminate_value ext_ctxt x (Bound 0) $ constr_case_body thy (j, x)
+ $ discriminate_value hol_ctxt x (Bound 0) $ constr_case_body thy (j, x)
$ res_t
-(* extended_context -> typ -> typ -> term *)
-fun optimized_case_def (ext_ctxt as {thy, ...}) dataT res_T =
+(* hol_context -> typ -> typ -> term *)
+fun optimized_case_def (hol_ctxt as {thy, ...}) dataT res_T =
let
- val xs = datatype_constrs ext_ctxt dataT
+ val xs = datatype_constrs hol_ctxt dataT
val xs' = filter_out (fn (s, _) => s = @{const_name NonStd}) xs
val func_Ts = map ((fn T => binder_types T ---> res_T) o snd) xs'
in
@@ -1409,19 +1401,19 @@
val (xs'', x) = split_last xs'
in
constr_case_body thy (1, x)
- |> fold_rev (add_constr_case ext_ctxt res_T)
+ |> fold_rev (add_constr_case hol_ctxt res_T)
(length xs' downto 2 ~~ xs'')
end
else
Const (@{const_name undefined}, dataT --> res_T) $ Bound 0
- |> fold_rev (add_constr_case ext_ctxt res_T)
+ |> fold_rev (add_constr_case hol_ctxt res_T)
(length xs' downto 1 ~~ xs'))
|> fold_rev (curry absdummy) (func_Ts @ [dataT])
end
-(* extended_context -> string -> typ -> typ -> term -> term *)
-fun optimized_record_get (ext_ctxt as {thy, ...}) s rec_T res_T t =
- let val constr_x = hd (datatype_constrs ext_ctxt rec_T) in
+(* hol_context -> string -> typ -> typ -> term -> term *)
+fun optimized_record_get (hol_ctxt as {thy, ...}) s rec_T res_T t =
+ let val constr_x = hd (datatype_constrs hol_ctxt rec_T) in
case no_of_record_field thy s rec_T of
~1 => (case rec_T of
Type (_, Ts as _ :: _) =>
@@ -1430,16 +1422,16 @@
val j = num_record_fields thy rec_T - 1
in
select_nth_constr_arg thy constr_x t j res_T
- |> optimized_record_get ext_ctxt s rec_T' res_T
+ |> optimized_record_get hol_ctxt s rec_T' res_T
end
| _ => raise TYPE ("Nitpick_HOL.optimized_record_get", [rec_T],
[]))
| j => select_nth_constr_arg thy constr_x t j res_T
end
-(* extended_context -> string -> typ -> term -> term -> term *)
-fun optimized_record_update (ext_ctxt as {thy, ...}) s rec_T fun_t rec_t =
+(* hol_context -> string -> typ -> term -> term -> term *)
+fun optimized_record_update (hol_ctxt as {thy, ...}) s rec_T fun_t rec_t =
let
- val constr_x as (_, constr_T) = hd (datatype_constrs ext_ctxt rec_T)
+ val constr_x as (_, constr_T) = hd (datatype_constrs hol_ctxt rec_T)
val Ts = binder_types constr_T
val n = length Ts
val special_j = no_of_record_field thy s rec_T
@@ -1450,7 +1442,7 @@
if j = special_j then
betapply (fun_t, t)
else if j = n - 1 andalso special_j = ~1 then
- optimized_record_update ext_ctxt s
+ optimized_record_update hol_ctxt s
(rec_T |> dest_Type |> snd |> List.last) fun_t t
else
t
@@ -1473,19 +1465,19 @@
fixpoint_kind_of_rhs (the (def_of_const thy table x))
handle Option.Option => NoFp
-(* extended_context -> styp -> bool *)
+(* hol_context -> styp -> bool *)
fun is_real_inductive_pred ({thy, fast_descrs, def_table, intro_table, ...}
- : extended_context) x =
+ : hol_context) x =
not (null (def_props_for_const thy fast_descrs intro_table x)) andalso
fixpoint_kind_of_const thy def_table x <> NoFp
fun is_real_equational_fun ({thy, fast_descrs, simp_table, psimp_table, ...}
- : extended_context) x =
+ : hol_context) x =
exists (fn table => not (null (def_props_for_const thy fast_descrs table x)))
[!simp_table, psimp_table]
-fun is_inductive_pred ext_ctxt =
- is_real_inductive_pred ext_ctxt andf (not o is_real_equational_fun ext_ctxt)
-fun is_equational_fun (ext_ctxt as {thy, def_table, ...}) =
- (is_real_equational_fun ext_ctxt orf is_real_inductive_pred ext_ctxt
+fun is_inductive_pred hol_ctxt =
+ is_real_inductive_pred hol_ctxt andf (not o is_real_equational_fun hol_ctxt)
+fun is_equational_fun (hol_ctxt as {thy, def_table, ...}) =
+ (is_real_equational_fun hol_ctxt orf is_real_inductive_pred hol_ctxt
orf (String.isPrefix ubfp_prefix orf String.isPrefix lbfp_prefix) o fst)
andf (not o has_trivial_definition thy def_table)
@@ -1522,11 +1514,11 @@
SOME t' => is_constr_pattern_lhs thy t'
| NONE => false
+(* Prevents divergence in case of cyclic or infinite definition dependencies. *)
val unfold_max_depth = 255
-val axioms_max_depth = 255
-(* extended_context -> term -> term *)
-fun unfold_defs_in_term (ext_ctxt as {thy, destroy_constrs, fast_descrs,
+(* hol_context -> term -> term *)
+fun unfold_defs_in_term (hol_ctxt as {thy, destroy_constrs, fast_descrs,
case_names, def_table, ground_thm_table,
ersatz_table, ...}) =
let
@@ -1600,7 +1592,7 @@
val (dataT, res_T) = nth_range_type n T
|> pairf domain_type range_type
in
- (optimized_case_def ext_ctxt dataT res_T
+ (optimized_case_def hol_ctxt dataT res_T
|> do_term (depth + 1) Ts, ts)
end
| _ =>
@@ -1628,11 +1620,11 @@
else if is_record_get thy x then
case length ts of
0 => (do_term depth Ts (eta_expand Ts t 1), [])
- | _ => (optimized_record_get ext_ctxt s (domain_type T)
+ | _ => (optimized_record_get hol_ctxt s (domain_type T)
(range_type T) (do_term depth Ts (hd ts)), tl ts)
else if is_record_update thy x then
case length ts of
- 2 => (optimized_record_update ext_ctxt
+ 2 => (optimized_record_update hol_ctxt
(unsuffix Record.updateN s) (nth_range_type 2 T)
(do_term depth Ts (hd ts))
(do_term depth Ts (nth ts 1)), [])
@@ -1645,7 +1637,7 @@
else
(Const x, ts)
end
- else if is_equational_fun ext_ctxt x then
+ else if is_equational_fun hol_ctxt x then
(Const x, ts)
else case def_of_const thy def_table x of
SOME def =>
@@ -1662,10 +1654,10 @@
in s_betapplys (const, map (do_term depth Ts) ts) |> Envir.beta_norm end
in do_term 0 [] end
-(* extended_context -> typ -> term list *)
-fun codatatype_bisim_axioms (ext_ctxt as {thy, ...}) T =
+(* hol_context -> typ -> term list *)
+fun codatatype_bisim_axioms (hol_ctxt as {thy, ...}) T =
let
- val xs = datatype_constrs ext_ctxt T
+ val xs = datatype_constrs hol_ctxt T
val set_T = T --> bool_T
val iter_T = @{typ bisim_iterator}
val bisim_const = Const (@{const_name bisim}, iter_T --> T --> T --> bool_T)
@@ -1688,14 +1680,14 @@
let
val arg_Ts = binder_types T
val core_t =
- discriminate_value ext_ctxt x y_var ::
+ discriminate_value hol_ctxt x y_var ::
map2 (nth_sub_bisim x) (index_seq 0 (length arg_Ts)) arg_Ts
|> foldr1 s_conj
in List.foldr absdummy core_t arg_Ts end
in
[HOLogic.eq_const bool_T $ (bisim_const $ n_var $ x_var $ y_var)
$ (@{term "op |"} $ (HOLogic.eq_const iter_T $ n_var $ zero_const iter_T)
- $ (betapplys (optimized_case_def ext_ctxt T bool_T,
+ $ (betapplys (optimized_case_def hol_ctxt T bool_T,
map case_func xs @ [x_var]))),
HOLogic.eq_const set_T $ (bisim_const $ bisim_max $ x_var)
$ (Const (@{const_name insert}, T --> set_T --> set_T)
@@ -1754,10 +1746,10 @@
val termination_tacs = [Lexicographic_Order.lex_order_tac true,
ScnpReconstruct.sizechange_tac]
-(* extended_context -> const_table -> styp -> bool *)
+(* hol_context -> const_table -> styp -> bool *)
fun uncached_is_well_founded_inductive_pred
({thy, ctxt, debug, fast_descrs, tac_timeout, intro_table, ...}
- : extended_context) (x as (_, T)) =
+ : hol_context) (x as (_, T)) =
case def_props_for_const thy fast_descrs intro_table x of
[] => raise TERM ("Nitpick_HOL.uncached_is_well_founded_inductive",
[Const x])
@@ -1797,11 +1789,11 @@
handle List.Empty => false
| NO_TRIPLE () => false
-(* The type constraint below is a workaround for a Poly/ML bug. *)
+(* The type constraint below is a workaround for a Poly/ML crash. *)
-(* extended_context -> styp -> bool *)
+(* hol_context -> styp -> bool *)
fun is_well_founded_inductive_pred
- (ext_ctxt as {thy, wfs, def_table, wf_cache, ...} : extended_context)
+ (hol_ctxt as {thy, wfs, def_table, wf_cache, ...} : hol_context)
(x as (s, _)) =
case triple_lookup (const_match thy) wfs x of
SOME (SOME b) => b
@@ -1811,7 +1803,7 @@
| NONE =>
let
val gfp = (fixpoint_kind_of_const thy def_table x = Gfp)
- val wf = uncached_is_well_founded_inductive_pred ext_ctxt x
+ val wf = uncached_is_well_founded_inductive_pred hol_ctxt x
in
Unsynchronized.change wf_cache (cons (x, (gfp, wf))); wf
end
@@ -1842,14 +1834,14 @@
| do_disjunct j t =
case num_occs_of_bound_in_term j t of
0 => true
- | 1 => exists (curry (op =) (Bound j) o head_of) (conjuncts t)
+ | 1 => exists (curry (op =) (Bound j) o head_of) (conjuncts_of t)
| _ => false
(* term -> bool *)
fun do_lfp_def (Const (@{const_name lfp}, _) $ t2) =
let val (xs, body) = strip_abs t2 in
case length xs of
1 => false
- | n => forall (do_disjunct (n - 1)) (disjuncts body)
+ | n => forall (do_disjunct (n - 1)) (disjuncts_of body)
end
| do_lfp_def _ = false
in do_lfp_def o strip_abs_body end
@@ -1887,7 +1879,7 @@
end
val (nonrecs, recs) =
List.partition (curry (op =) 0 o num_occs_of_bound_in_term j)
- (disjuncts body)
+ (disjuncts_of body)
val base_body = nonrecs |> List.foldl s_disj @{const False}
val step_body = recs |> map (repair_rec j)
|> List.foldl s_disj @{const False}
@@ -1901,8 +1893,8 @@
raise TERM ("Nitpick_HOL.linear_pred_base_and_step_rhss.aux", [t])
in aux end
-(* extended_context -> styp -> term -> term *)
-fun starred_linear_pred_const (ext_ctxt as {simp_table, ...}) (x as (s, T))
+(* hol_context -> styp -> term -> term *)
+fun starred_linear_pred_const (hol_ctxt as {simp_table, ...}) (x as (s, T))
def =
let
val j = maxidx_of_term def + 1
@@ -1933,11 +1925,11 @@
$ list_comb (Const step_x, outer_bounds)))
$ list_comb (Const base_x, outer_bounds)
|> ap_curry tuple_arg_Ts tuple_T bool_T)
- |> unfold_defs_in_term ext_ctxt
+ |> unfold_defs_in_term hol_ctxt
end
-(* extended_context -> bool -> styp -> term *)
-fun unrolled_inductive_pred_const (ext_ctxt as {thy, star_linear_preds,
+(* hol_context -> bool -> styp -> term *)
+fun unrolled_inductive_pred_const (hol_ctxt as {thy, star_linear_preds,
def_table, simp_table, ...})
gfp (x as (s, T)) =
let
@@ -1946,11 +1938,11 @@
val unrolled_const = Const x' $ zero_const iter_T
val def = the (def_of_const thy def_table x)
in
- if is_equational_fun ext_ctxt x' then
+ if is_equational_fun hol_ctxt x' then
unrolled_const (* already done *)
else if not gfp andalso is_linear_inductive_pred_def def andalso
star_linear_preds then
- starred_linear_pred_const ext_ctxt x def
+ starred_linear_pred_const hol_ctxt x def
else
let
val j = maxidx_of_term def + 1
@@ -1973,8 +1965,8 @@
in unrolled_const end
end
-(* extended_context -> styp -> term *)
-fun raw_inductive_pred_axiom ({thy, def_table, ...} : extended_context) x =
+(* hol_context -> styp -> term *)
+fun raw_inductive_pred_axiom ({thy, def_table, ...} : hol_context) x =
let
val def = the (def_of_const thy def_table x)
val (outer, fp_app) = strip_abs def
@@ -1992,24 +1984,29 @@
HOLogic.mk_eq (list_comb (Const x, bounds), naked_rhs)
|> HOLogic.mk_Trueprop |> curry subst_bounds (rev vars)
end
-fun inductive_pred_axiom ext_ctxt (x as (s, T)) =
+fun inductive_pred_axiom hol_ctxt (x as (s, T)) =
if String.isPrefix ubfp_prefix s orelse String.isPrefix lbfp_prefix s then
let val x' = (after_name_sep s, T) in
- raw_inductive_pred_axiom ext_ctxt x' |> subst_atomic [(Const x', Const x)]
+ raw_inductive_pred_axiom hol_ctxt x' |> subst_atomic [(Const x', Const x)]
end
else
- raw_inductive_pred_axiom ext_ctxt x
+ raw_inductive_pred_axiom hol_ctxt x
-(* extended_context -> styp -> term list *)
-fun raw_equational_fun_axioms (ext_ctxt as {thy, fast_descrs, simp_table,
+(* hol_context -> styp -> term list *)
+fun raw_equational_fun_axioms (hol_ctxt as {thy, fast_descrs, simp_table,
psimp_table, ...}) (x as (s, _)) =
case def_props_for_const thy fast_descrs (!simp_table) x of
[] => (case def_props_for_const thy fast_descrs psimp_table x of
- [] => [inductive_pred_axiom ext_ctxt x]
+ [] => [inductive_pred_axiom hol_ctxt x]
| psimps => psimps)
| simps => simps
-
val equational_fun_axioms = map extensionalize oo raw_equational_fun_axioms
+(* hol_context -> styp -> bool *)
+fun is_equational_fun_surely_complete hol_ctxt x =
+ case raw_equational_fun_axioms hol_ctxt x of
+ [@{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t1 $ _)] =>
+ strip_comb t1 |> snd |> forall is_Var
+ | _ => false
(* term list -> term list *)
fun merge_type_vars_in_terms ts =
@@ -2028,1261 +2025,29 @@
| coalesce T = T
in map (map_types (map_atyps coalesce)) ts end
-(* extended_context -> typ -> typ list -> typ list *)
-fun add_ground_types ext_ctxt T accum =
+(* hol_context -> typ -> typ list -> typ list *)
+fun add_ground_types hol_ctxt T accum =
case T of
- Type ("fun", Ts) => fold (add_ground_types ext_ctxt) Ts accum
- | Type ("*", Ts) => fold (add_ground_types ext_ctxt) Ts accum
- | Type (@{type_name itself}, [T1]) => add_ground_types ext_ctxt T1 accum
+ Type ("fun", Ts) => fold (add_ground_types hol_ctxt) Ts accum
+ | Type ("*", Ts) => fold (add_ground_types hol_ctxt) Ts accum
+ | Type (@{type_name itself}, [T1]) => add_ground_types hol_ctxt T1 accum
| Type (_, Ts) =>
- if member (op =) (@{typ prop} :: @{typ bool} :: @{typ unit} :: accum) T then
+ if member (op =) (@{typ prop} :: @{typ bool} :: @{typ unit} ::
+ @{typ \<xi>} :: accum) T then
accum
else
T :: accum
- |> fold (add_ground_types ext_ctxt)
- (case boxed_datatype_constrs ext_ctxt T of
+ |> fold (add_ground_types hol_ctxt)
+ (case boxed_datatype_constrs hol_ctxt T of
[] => Ts
| xs => map snd xs)
| _ => insert (op =) T accum
-(* extended_context -> typ -> typ list *)
-fun ground_types_in_type ext_ctxt T = add_ground_types ext_ctxt T []
-(* extended_context -> term list -> typ list *)
-fun ground_types_in_terms ext_ctxt ts =
- fold (fold_types (add_ground_types ext_ctxt)) ts []
-(* typ list -> int -> term -> bool *)
-fun has_heavy_bounds_or_vars Ts level t =
- let
- (* typ list -> bool *)
- fun aux [] = false
- | aux [T] = is_fun_type T orelse is_pair_type T
- | aux _ = true
- in aux (map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t)) end
-
-(* typ list -> int -> int -> int -> term -> term *)
-fun fresh_value_var Ts k n j t =
- Var ((val_var_prefix ^ nat_subscript (n - j), k), fastype_of1 (Ts, t))
-
-(* theory -> typ list -> bool -> int -> int -> term -> term list -> term list
- -> term * term list *)
-fun pull_out_constr_comb thy Ts relax k level t args seen =
- let val t_comb = list_comb (t, args) in
- case t of
- Const x =>
- if not relax andalso is_constr thy x andalso
- not (is_fun_type (fastype_of1 (Ts, t_comb))) andalso
- has_heavy_bounds_or_vars Ts level t_comb andalso
- not (loose_bvar (t_comb, level)) then
- let
- val (j, seen) = case find_index (curry (op =) t_comb) seen of
- ~1 => (0, t_comb :: seen)
- | j => (j, seen)
- in (fresh_value_var Ts k (length seen) j t_comb, seen) end
- else
- (t_comb, seen)
- | _ => (t_comb, seen)
- end
-
-(* (term -> term) -> typ list -> int -> term list -> term list *)
-fun equations_for_pulled_out_constrs mk_eq Ts k seen =
- let val n = length seen in
- map2 (fn j => fn t => mk_eq (fresh_value_var Ts k n j t, t))
- (index_seq 0 n) seen
- end
-
-(* theory -> bool -> term -> term *)
-fun pull_out_universal_constrs thy def t =
- let
- val k = maxidx_of_term t + 1
- (* typ list -> bool -> term -> term list -> term list -> term * term list *)
- fun do_term Ts def t args seen =
- case t of
- (t0 as Const (@{const_name "=="}, _)) $ t1 $ t2 =>
- do_eq_or_imp Ts true def t0 t1 t2 seen
- | (t0 as @{const "==>"}) $ t1 $ t2 =>
- if def then (t, []) else do_eq_or_imp Ts false def t0 t1 t2 seen
- | (t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2 =>
- do_eq_or_imp Ts true def t0 t1 t2 seen
- | (t0 as @{const "op -->"}) $ t1 $ t2 =>
- do_eq_or_imp Ts false def t0 t1 t2 seen
- | Abs (s, T, t') =>
- let val (t', seen) = do_term (T :: Ts) def t' [] seen in
- (list_comb (Abs (s, T, t'), args), seen)
- end
- | t1 $ t2 =>
- let val (t2, seen) = do_term Ts def t2 [] seen in
- do_term Ts def t1 (t2 :: args) seen
- end
- | _ => pull_out_constr_comb thy Ts def k 0 t args seen
- (* typ list -> bool -> bool -> term -> term -> term -> term list
- -> term * term list *)
- and do_eq_or_imp Ts eq def t0 t1 t2 seen =
- let
- val (t2, seen) = if eq andalso def then (t2, seen)
- else do_term Ts false t2 [] seen
- val (t1, seen) = do_term Ts false t1 [] seen
- in (t0 $ t1 $ t2, seen) end
- val (concl, seen) = do_term [] def t [] []
- in
- Logic.list_implies (equations_for_pulled_out_constrs Logic.mk_equals [] k
- seen, concl)
- end
-
-(* extended_context -> bool -> term -> term *)
-fun destroy_pulled_out_constrs (ext_ctxt as {thy, ...}) axiom t =
- let
- (* styp -> int *)
- val num_occs_of_var =
- fold_aterms (fn Var z => (fn f => fn z' => f z' |> z = z' ? Integer.add 1)
- | _ => I) t (K 0)
- (* bool -> term -> term *)
- fun aux careful ((t0 as Const (@{const_name "=="}, _)) $ t1 $ t2) =
- aux_eq careful true t0 t1 t2
- | aux careful ((t0 as @{const "==>"}) $ t1 $ t2) =
- t0 $ aux false t1 $ aux careful t2
- | aux careful ((t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2) =
- aux_eq careful true t0 t1 t2
- | aux careful ((t0 as @{const "op -->"}) $ t1 $ t2) =
- t0 $ aux false t1 $ aux careful t2
- | aux careful (Abs (s, T, t')) = Abs (s, T, aux careful t')
- | aux careful (t1 $ t2) = aux careful t1 $ aux careful t2
- | aux _ t = t
- (* bool -> bool -> term -> term -> term -> term *)
- and aux_eq careful pass1 t0 t1 t2 =
- ((if careful then
- raise SAME ()
- else if axiom andalso is_Var t2 andalso
- num_occs_of_var (dest_Var t2) = 1 then
- @{const True}
- else case strip_comb t2 of
- (* The first case is not as general as it could be. *)
- (Const (@{const_name PairBox}, _),
- [Const (@{const_name fst}, _) $ Var z1,
- Const (@{const_name snd}, _) $ Var z2]) =>
- if z1 = z2 andalso num_occs_of_var z1 = 2 then @{const True}
- else raise SAME ()
- | (Const (x as (s, T)), args) =>
- let val arg_Ts = binder_types T in
- if length arg_Ts = length args andalso
- (is_constr thy x orelse s = @{const_name Pair} orelse
- x = (@{const_name Suc}, nat_T --> nat_T)) andalso
- (not careful orelse not (is_Var t1) orelse
- String.isPrefix val_var_prefix (fst (fst (dest_Var t1)))) then
- discriminate_value ext_ctxt x t1 ::
- map3 (sel_eq x t1) (index_seq 0 (length args)) arg_Ts args
- |> foldr1 s_conj
- else
- raise SAME ()
- end
- | _ => raise SAME ())
- |> body_type (type_of t0) = prop_T ? HOLogic.mk_Trueprop)
- handle SAME () => if pass1 then aux_eq careful false t0 t2 t1
- else t0 $ aux false t2 $ aux false t1
- (* styp -> term -> int -> typ -> term -> term *)
- and sel_eq x t n nth_T nth_t =
- HOLogic.eq_const nth_T $ nth_t $ select_nth_constr_arg thy x t n nth_T
- |> aux false
- in aux axiom t end
-
-(* theory -> term -> term *)
-fun simplify_constrs_and_sels thy t =
- let
- (* term -> int -> term *)
- fun is_nth_sel_on t' n (Const (s, _) $ t) =
- (t = t' andalso is_sel_like_and_no_discr s andalso
- sel_no_from_name s = n)
- | is_nth_sel_on _ _ _ = false
- (* term -> term list -> term *)
- fun do_term (Const (@{const_name Rep_Frac}, _)
- $ (Const (@{const_name Abs_Frac}, _) $ t1)) [] = do_term t1 []
- | do_term (Const (@{const_name Abs_Frac}, _)
- $ (Const (@{const_name Rep_Frac}, _) $ t1)) [] = do_term t1 []
- | do_term (t1 $ t2) args = do_term t1 (do_term t2 [] :: args)
- | do_term (t as Const (x as (s, T))) (args as _ :: _) =
- ((if is_constr_like thy x then
- if length args = num_binder_types T then
- case hd args of
- Const (x' as (_, T')) $ t' =>
- if domain_type T' = body_type T andalso
- forall (uncurry (is_nth_sel_on t'))
- (index_seq 0 (length args) ~~ args) then
- t'
- else
- raise SAME ()
- | _ => raise SAME ()
- else
- raise SAME ()
- else if is_sel_like_and_no_discr s then
- case strip_comb (hd args) of
- (Const (x' as (s', T')), ts') =>
- if is_constr_like thy x' andalso
- constr_name_for_sel_like s = s' andalso
- not (exists is_pair_type (binder_types T')) then
- list_comb (nth ts' (sel_no_from_name s), tl args)
- else
- raise SAME ()
- | _ => raise SAME ()
- else
- raise SAME ())
- handle SAME () => betapplys (t, args))
- | do_term (Abs (s, T, t')) args =
- betapplys (Abs (s, T, do_term t' []), args)
- | do_term t args = betapplys (t, args)
- in do_term t [] end
-
-(* term -> term *)
-fun curry_assms (@{const "==>"} $ (@{const Trueprop}
- $ (@{const "op &"} $ t1 $ t2)) $ t3) =
- curry_assms (Logic.list_implies ([t1, t2] |> map HOLogic.mk_Trueprop, t3))
- | curry_assms (@{const "==>"} $ t1 $ t2) =
- @{const "==>"} $ curry_assms t1 $ curry_assms t2
- | curry_assms t = t
-
-(* term -> term *)
-val destroy_universal_equalities =
- let
- (* term list -> (indexname * typ) list -> term -> term *)
- fun aux prems zs t =
- case t of
- @{const "==>"} $ t1 $ t2 => aux_implies prems zs t1 t2
- | _ => Logic.list_implies (rev prems, t)
- (* term list -> (indexname * typ) list -> term -> term -> term *)
- and aux_implies prems zs t1 t2 =
- case t1 of
- Const (@{const_name "=="}, _) $ Var z $ t' => aux_eq prems zs z t' t1 t2
- | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ Var z $ t') =>
- aux_eq prems zs z t' t1 t2
- | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t' $ Var z) =>
- aux_eq prems zs z t' t1 t2
- | _ => aux (t1 :: prems) (Term.add_vars t1 zs) t2
- (* term list -> (indexname * typ) list -> indexname * typ -> term -> term
- -> term -> term *)
- and aux_eq prems zs z t' t1 t2 =
- if not (member (op =) zs z) andalso
- not (exists_subterm (curry (op =) (Var z)) t') then
- aux prems zs (subst_free [(Var z, t')] t2)
- else
- aux (t1 :: prems) (Term.add_vars t1 zs) t2
- in aux [] [] end
-
-(* theory -> term -> term *)
-fun pull_out_existential_constrs thy t =
- let
- val k = maxidx_of_term t + 1
- (* typ list -> int -> term -> term list -> term list -> term * term list *)
- fun aux Ts num_exists t args seen =
- case t of
- (t0 as Const (@{const_name Ex}, _)) $ Abs (s1, T1, t1) =>
- let
- val (t1, seen') = aux (T1 :: Ts) (num_exists + 1) t1 [] []
- val n = length seen'
- (* unit -> term list *)
- fun vars () = map2 (fresh_value_var Ts k n) (index_seq 0 n) seen'
- in
- (equations_for_pulled_out_constrs HOLogic.mk_eq Ts k seen'
- |> List.foldl s_conj t1 |> fold mk_exists (vars ())
- |> curry3 Abs s1 T1 |> curry (op $) t0, seen)
- end
- | t1 $ t2 =>
- let val (t2, seen) = aux Ts num_exists t2 [] seen in
- aux Ts num_exists t1 (t2 :: args) seen
- end
- | Abs (s, T, t') =>
- let
- val (t', seen) = aux (T :: Ts) 0 t' [] (map (incr_boundvars 1) seen)
- in (list_comb (Abs (s, T, t'), args), map (incr_boundvars ~1) seen) end
- | _ =>
- if num_exists > 0 then
- pull_out_constr_comb thy Ts false k num_exists t args seen
- else
- (list_comb (t, args), seen)
- in aux [] 0 t [] [] |> fst end
-
-(* theory -> int -> term list -> term list -> (term * term list) option *)
-fun find_bound_assign _ _ _ [] = NONE
- | find_bound_assign thy j seen (t :: ts) =
- let
- (* bool -> term -> term -> (term * term list) option *)
- fun aux pass1 t1 t2 =
- (if loose_bvar1 (t2, j) then
- if pass1 then aux false t2 t1 else raise SAME ()
- else case t1 of
- Bound j' => if j' = j then SOME (t2, ts @ seen) else raise SAME ()
- | Const (s, Type ("fun", [T1, T2])) $ Bound j' =>
- if j' = j andalso s = sel_prefix_for 0 ^ @{const_name FunBox} then
- SOME (construct_value thy (@{const_name FunBox}, T2 --> T1) [t2],
- ts @ seen)
- else
- raise SAME ()
- | _ => raise SAME ())
- handle SAME () => find_bound_assign thy j (t :: seen) ts
- in
- case t of
- Const (@{const_name "op ="}, _) $ t1 $ t2 => aux true t1 t2
- | _ => find_bound_assign thy j (t :: seen) ts
- end
-
-(* int -> term -> term -> term *)
-fun subst_one_bound j arg t =
- let
- fun aux (Bound i, lev) =
- if i < lev then raise SAME ()
- else if i = lev then incr_boundvars (lev - j) arg
- else Bound (i - 1)
- | aux (Abs (a, T, body), lev) = Abs (a, T, aux (body, lev + 1))
- | aux (f $ t, lev) =
- (aux (f, lev) $ (aux (t, lev) handle SAME () => t)
- handle SAME () => f $ aux (t, lev))
- | aux _ = raise SAME ()
- in aux (t, j) handle SAME () => t end
-
-(* theory -> term -> term *)
-fun destroy_existential_equalities thy =
- let
- (* string list -> typ list -> term list -> term *)
- fun kill [] [] ts = foldr1 s_conj ts
- | kill (s :: ss) (T :: Ts) ts =
- (case find_bound_assign thy (length ss) [] ts of
- SOME (_, []) => @{const True}
- | SOME (arg_t, ts) =>
- kill ss Ts (map (subst_one_bound (length ss)
- (incr_bv (~1, length ss + 1, arg_t))) ts)
- | NONE =>
- Const (@{const_name Ex}, (T --> bool_T) --> bool_T)
- $ Abs (s, T, kill ss Ts ts))
- | kill _ _ _ = raise UnequalLengths
- (* string list -> typ list -> term -> term *)
- fun gather ss Ts ((t0 as Const (@{const_name Ex}, _)) $ Abs (s1, T1, t1)) =
- gather (ss @ [s1]) (Ts @ [T1]) t1
- | gather [] [] (Abs (s, T, t1)) = Abs (s, T, gather [] [] t1)
- | gather [] [] (t1 $ t2) = gather [] [] t1 $ gather [] [] t2
- | gather [] [] t = t
- | gather ss Ts t = kill ss Ts (conjuncts (gather [] [] t))
- in gather [] [] end
-
-(* term -> term *)
-fun distribute_quantifiers t =
- case t of
- (t0 as Const (@{const_name All}, T0)) $ Abs (s, T1, t1) =>
- (case t1 of
- (t10 as @{const "op &"}) $ t11 $ t12 =>
- t10 $ distribute_quantifiers (t0 $ Abs (s, T1, t11))
- $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
- | (t10 as @{const Not}) $ t11 =>
- t10 $ distribute_quantifiers (Const (@{const_name Ex}, T0)
- $ Abs (s, T1, t11))
- | t1 =>
- if not (loose_bvar1 (t1, 0)) then
- distribute_quantifiers (incr_boundvars ~1 t1)
- else
- t0 $ Abs (s, T1, distribute_quantifiers t1))
- | (t0 as Const (@{const_name Ex}, T0)) $ Abs (s, T1, t1) =>
- (case distribute_quantifiers t1 of
- (t10 as @{const "op |"}) $ t11 $ t12 =>
- t10 $ distribute_quantifiers (t0 $ Abs (s, T1, t11))
- $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
- | (t10 as @{const "op -->"}) $ t11 $ t12 =>
- t10 $ distribute_quantifiers (Const (@{const_name All}, T0)
- $ Abs (s, T1, t11))
- $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
- | (t10 as @{const Not}) $ t11 =>
- t10 $ distribute_quantifiers (Const (@{const_name All}, T0)
- $ Abs (s, T1, t11))
- | t1 =>
- if not (loose_bvar1 (t1, 0)) then
- distribute_quantifiers (incr_boundvars ~1 t1)
- else
- t0 $ Abs (s, T1, distribute_quantifiers t1))
- | t1 $ t2 => distribute_quantifiers t1 $ distribute_quantifiers t2
- | Abs (s, T, t') => Abs (s, T, distribute_quantifiers t')
- | _ => t
-
-(* int -> int -> (int -> int) -> term -> term *)
-fun renumber_bounds j n f t =
- case t of
- t1 $ t2 => renumber_bounds j n f t1 $ renumber_bounds j n f t2
- | Abs (s, T, t') => Abs (s, T, renumber_bounds (j + 1) n f t')
- | Bound j' =>
- Bound (if j' >= j andalso j' < j + n then f (j' - j) + j else j')
- | _ => t
-
-val quantifier_cluster_threshold = 7
-
-(* theory -> term -> term *)
-fun push_quantifiers_inward thy =
- let
- (* string -> string list -> typ list -> term -> term *)
- fun aux quant_s ss Ts t =
- (case t of
- (t0 as Const (s0, _)) $ Abs (s1, T1, t1 as _ $ _) =>
- if s0 = quant_s then
- aux s0 (s1 :: ss) (T1 :: Ts) t1
- else if quant_s = "" andalso
- (s0 = @{const_name All} orelse s0 = @{const_name Ex}) then
- aux s0 [s1] [T1] t1
- else
- raise SAME ()
- | _ => raise SAME ())
- handle SAME () =>
- case t of
- t1 $ t2 =>
- if quant_s = "" then
- aux "" [] [] t1 $ aux "" [] [] t2
- else
- let
- val typical_card = 4
- (* ('a -> ''b list) -> 'a list -> ''b list *)
- fun big_union proj ps =
- fold (fold (insert (op =)) o proj) ps []
- val (ts, connective) = strip_any_connective t
- val T_costs =
- map (bounded_card_of_type 65536 typical_card []) Ts
- val t_costs = map size_of_term ts
- val num_Ts = length Ts
- (* int -> int *)
- val flip = curry (op -) (num_Ts - 1)
- val t_boundss = map (map flip o loose_bnos) ts
- (* (int list * int) list -> int list
- -> (int list * int) list *)
- fun merge costly_boundss [] = costly_boundss
- | merge costly_boundss (j :: js) =
- let
- val (yeas, nays) =
- List.partition (fn (bounds, _) =>
- member (op =) bounds j)
- costly_boundss
- val yeas_bounds = big_union fst yeas
- val yeas_cost = Integer.sum (map snd yeas)
- * nth T_costs j
- in merge ((yeas_bounds, yeas_cost) :: nays) js end
- (* (int list * int) list -> int list -> int *)
- val cost = Integer.sum o map snd oo merge
- (* Inspired by Claessen & Sörensson's polynomial binary
- splitting heuristic (p. 5 of their MODEL 2003 paper). *)
- (* (int list * int) list -> int list -> int list *)
- fun heuristically_best_permutation _ [] = []
- | heuristically_best_permutation costly_boundss js =
- let
- val (costly_boundss, (j, js)) =
- js |> map (`(merge costly_boundss o single))
- |> sort (int_ord
- o pairself (Integer.sum o map snd o fst))
- |> split_list |>> hd ||> pairf hd tl
- in
- j :: heuristically_best_permutation costly_boundss js
- end
- val js =
- if length Ts <= quantifier_cluster_threshold then
- all_permutations (index_seq 0 num_Ts)
- |> map (`(cost (t_boundss ~~ t_costs)))
- |> sort (int_ord o pairself fst) |> hd |> snd
- else
- heuristically_best_permutation (t_boundss ~~ t_costs)
- (index_seq 0 num_Ts)
- val back_js = map (fn j => find_index (curry (op =) j) js)
- (index_seq 0 num_Ts)
- val ts = map (renumber_bounds 0 num_Ts (nth back_js o flip))
- ts
- (* (term * int list) list -> term *)
- fun mk_connection [] =
- raise ARG ("Nitpick_HOL.push_quantifiers_inward.aux.\
- \mk_connection", "")
- | mk_connection ts_cum_bounds =
- ts_cum_bounds |> map fst
- |> foldr1 (fn (t1, t2) => connective $ t1 $ t2)
- (* (term * int list) list -> int list -> term *)
- fun build ts_cum_bounds [] = ts_cum_bounds |> mk_connection
- | build ts_cum_bounds (j :: js) =
- let
- val (yeas, nays) =
- List.partition (fn (_, bounds) =>
- member (op =) bounds j)
- ts_cum_bounds
- ||> map (apfst (incr_boundvars ~1))
- in
- if null yeas then
- build nays js
- else
- let val T = nth Ts (flip j) in
- build ((Const (quant_s, (T --> bool_T) --> bool_T)
- $ Abs (nth ss (flip j), T,
- mk_connection yeas),
- big_union snd yeas) :: nays) js
- end
- end
- in build (ts ~~ t_boundss) js end
- | Abs (s, T, t') => Abs (s, T, aux "" [] [] t')
- | _ => t
- in aux "" [] [] end
-
-(* polarity -> string -> bool *)
-fun is_positive_existential polar quant_s =
- (polar = Pos andalso quant_s = @{const_name Ex}) orelse
- (polar = Neg andalso quant_s <> @{const_name Ex})
-
-(* extended_context -> int -> term -> term *)
-fun skolemize_term_and_more (ext_ctxt as {thy, def_table, skolems, ...})
- skolem_depth =
- let
- (* int list -> int list *)
- val incrs = map (Integer.add 1)
- (* string list -> typ list -> int list -> int -> polarity -> term -> term *)
- fun aux ss Ts js depth polar t =
- let
- (* string -> typ -> string -> typ -> term -> term *)
- fun do_quantifier quant_s quant_T abs_s abs_T t =
- if not (loose_bvar1 (t, 0)) then
- aux ss Ts js depth polar (incr_boundvars ~1 t)
- else if depth <= skolem_depth andalso
- is_positive_existential polar quant_s then
- let
- val j = length (!skolems) + 1
- val sko_s = skolem_prefix_for (length js) j ^ abs_s
- val _ = Unsynchronized.change skolems (cons (sko_s, ss))
- val sko_t = list_comb (Const (sko_s, rev Ts ---> abs_T),
- map Bound (rev js))
- val abs_t = Abs (abs_s, abs_T, aux ss Ts (incrs js) depth polar t)
- in
- if null js then betapply (abs_t, sko_t)
- else Const (@{const_name Let}, abs_T --> quant_T) $ sko_t $ abs_t
- end
- else
- Const (quant_s, quant_T)
- $ Abs (abs_s, abs_T,
- if is_higher_order_type abs_T then
- t
- else
- aux (abs_s :: ss) (abs_T :: Ts) (0 :: incrs js)
- (depth + 1) polar t)
- in
- case t of
- Const (s0 as @{const_name all}, T0) $ Abs (s1, T1, t1) =>
- do_quantifier s0 T0 s1 T1 t1
- | @{const "==>"} $ t1 $ t2 =>
- @{const "==>"} $ aux ss Ts js depth (flip_polarity polar) t1
- $ aux ss Ts js depth polar t2
- | @{const Pure.conjunction} $ t1 $ t2 =>
- @{const Pure.conjunction} $ aux ss Ts js depth polar t1
- $ aux ss Ts js depth polar t2
- | @{const Trueprop} $ t1 =>
- @{const Trueprop} $ aux ss Ts js depth polar t1
- | @{const Not} $ t1 =>
- @{const Not} $ aux ss Ts js depth (flip_polarity polar) t1
- | Const (s0 as @{const_name All}, T0) $ Abs (s1, T1, t1) =>
- do_quantifier s0 T0 s1 T1 t1
- | Const (s0 as @{const_name Ex}, T0) $ Abs (s1, T1, t1) =>
- do_quantifier s0 T0 s1 T1 t1
- | @{const "op &"} $ t1 $ t2 =>
- @{const "op &"} $ aux ss Ts js depth polar t1
- $ aux ss Ts js depth polar t2
- | @{const "op |"} $ t1 $ t2 =>
- @{const "op |"} $ aux ss Ts js depth polar t1
- $ aux ss Ts js depth polar t2
- | @{const "op -->"} $ t1 $ t2 =>
- @{const "op -->"} $ aux ss Ts js depth (flip_polarity polar) t1
- $ aux ss Ts js depth polar t2
- | (t0 as Const (@{const_name Let}, T0)) $ t1 $ t2 =>
- t0 $ t1 $ aux ss Ts js depth polar t2
- | Const (x as (s, T)) =>
- if is_inductive_pred ext_ctxt x andalso
- not (is_well_founded_inductive_pred ext_ctxt x) then
- let
- val gfp = (fixpoint_kind_of_const thy def_table x = Gfp)
- val (pref, connective, set_oper) =
- if gfp then
- (lbfp_prefix,
- @{const "op |"},
- @{const_name semilattice_sup_fun_inst.sup_fun})
- else
- (ubfp_prefix,
- @{const "op &"},
- @{const_name semilattice_inf_fun_inst.inf_fun})
- (* unit -> term *)
- fun pos () = unrolled_inductive_pred_const ext_ctxt gfp x
- |> aux ss Ts js depth polar
- fun neg () = Const (pref ^ s, T)
- in
- (case polar |> gfp ? flip_polarity of
- Pos => pos ()
- | Neg => neg ()
- | Neut =>
- if is_fun_type T then
- let
- val ((trunk_arg_Ts, rump_arg_T), body_T) =
- T |> strip_type |>> split_last
- val set_T = rump_arg_T --> body_T
- (* (unit -> term) -> term *)
- fun app f =
- list_comb (f (),
- map Bound (length trunk_arg_Ts - 1 downto 0))
- in
- List.foldr absdummy
- (Const (set_oper, set_T --> set_T --> set_T)
- $ app pos $ app neg) trunk_arg_Ts
- end
- else
- connective $ pos () $ neg ())
- end
- else
- Const x
- | t1 $ t2 =>
- betapply (aux ss Ts [] (skolem_depth + 1) polar t1,
- aux ss Ts [] depth Neut t2)
- | Abs (s, T, t1) => Abs (s, T, aux ss Ts (incrs js) depth polar t1)
- | _ => t
- end
- in aux [] [] [] 0 Pos end
-
-(* extended_context -> styp -> (int * term option) list *)
-fun static_args_in_term ({ersatz_table, ...} : extended_context) x t =
- let
- (* term -> term list -> term list -> term list list *)
- fun fun_calls (Abs (_, _, t)) _ = fun_calls t []
- | fun_calls (t1 $ t2) args = fun_calls t2 [] #> fun_calls t1 (t2 :: args)
- | fun_calls t args =
- (case t of
- Const (x' as (s', T')) =>
- x = x' orelse (case AList.lookup (op =) ersatz_table s' of
- SOME s'' => x = (s'', T')
- | NONE => false)
- | _ => false) ? cons args
- (* term list list -> term list list -> term list -> term list list *)
- fun call_sets [] [] vs = [vs]
- | call_sets [] uss vs = vs :: call_sets uss [] []
- | call_sets ([] :: _) _ _ = []
- | call_sets ((t :: ts) :: tss) uss vs =
- OrdList.insert TermOrd.term_ord t vs |> call_sets tss (ts :: uss)
- val sets = call_sets (fun_calls t [] []) [] []
- val indexed_sets = sets ~~ (index_seq 0 (length sets))
- in
- fold_rev (fn (set, j) =>
- case set of
- [Var _] => AList.lookup (op =) indexed_sets set = SOME j
- ? cons (j, NONE)
- | [t as Const _] => cons (j, SOME t)
- | [t as Free _] => cons (j, SOME t)
- | _ => I) indexed_sets []
- end
-(* extended_context -> styp -> term list -> (int * term option) list *)
-fun static_args_in_terms ext_ctxt x =
- map (static_args_in_term ext_ctxt x)
- #> fold1 (OrdList.inter (prod_ord int_ord (option_ord TermOrd.term_ord)))
-
-(* term -> term list *)
-fun params_in_equation (@{const "==>"} $ _ $ t2) = params_in_equation t2
- | params_in_equation (@{const Trueprop} $ t1) = params_in_equation t1
- | params_in_equation (Const (@{const_name "op ="}, _) $ t1 $ _) =
- snd (strip_comb t1)
- | params_in_equation _ = []
-
-(* styp -> styp -> int list -> term list -> term list -> term -> term *)
-fun specialize_fun_axiom x x' fixed_js fixed_args extra_args t =
- let
- val k = fold Integer.max (map maxidx_of_term (fixed_args @ extra_args)) 0
- + 1
- val t = map_aterms (fn Var ((s, i), T) => Var ((s, k + i), T) | t' => t') t
- val fixed_params = filter_indices fixed_js (params_in_equation t)
- (* term list -> term -> term *)
- fun aux args (Abs (s, T, t)) = list_comb (Abs (s, T, aux [] t), args)
- | aux args (t1 $ t2) = aux (aux [] t2 :: args) t1
- | aux args t =
- if t = Const x then
- list_comb (Const x', extra_args @ filter_out_indices fixed_js args)
- else
- let val j = find_index (curry (op =) t) fixed_params in
- list_comb (if j >= 0 then nth fixed_args j else t, args)
- end
- in aux [] t end
-
-(* typ list -> term -> bool *)
-fun is_eligible_arg Ts t =
- let val bad_Ts = map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t) in
- null bad_Ts orelse
- (is_higher_order_type (fastype_of1 (Ts, t)) andalso
- forall (not o is_higher_order_type) bad_Ts)
- end
-
-(* (int * term option) list -> (int * term) list -> int list *)
-fun overlapping_indices [] _ = []
- | overlapping_indices _ [] = []
- | overlapping_indices (ps1 as (j1, t1) :: ps1') (ps2 as (j2, t2) :: ps2') =
- if j1 < j2 then overlapping_indices ps1' ps2
- else if j1 > j2 then overlapping_indices ps1 ps2'
- else overlapping_indices ps1' ps2' |> the_default t2 t1 = t2 ? cons j1
-
-val special_depth = 20
-
-(* extended_context -> int -> term -> term *)
-fun specialize_consts_in_term (ext_ctxt as {thy, specialize, simp_table,
- special_funs, ...}) depth t =
- if not specialize orelse depth > special_depth then
- t
- else
- let
- val blacklist = if depth = 0 then []
- else case term_under_def t of Const x => [x] | _ => []
- (* term list -> typ list -> term -> term *)
- fun aux args Ts (Const (x as (s, T))) =
- ((if not (member (op =) blacklist x) andalso not (null args) andalso
- not (String.isPrefix special_prefix s) andalso
- is_equational_fun ext_ctxt x then
- let
- val eligible_args = filter (is_eligible_arg Ts o snd)
- (index_seq 0 (length args) ~~ args)
- val _ = not (null eligible_args) orelse raise SAME ()
- val old_axs = equational_fun_axioms ext_ctxt x
- |> map (destroy_existential_equalities thy)
- val static_params = static_args_in_terms ext_ctxt x old_axs
- val fixed_js = overlapping_indices static_params eligible_args
- val _ = not (null fixed_js) orelse raise SAME ()
- val fixed_args = filter_indices fixed_js args
- val vars = fold Term.add_vars fixed_args []
- |> sort (TermOrd.fast_indexname_ord o pairself fst)
- val bound_js = fold (fn t => fn js => add_loose_bnos (t, 0, js))
- fixed_args []
- |> sort int_ord
- val live_args = filter_out_indices fixed_js args
- val extra_args = map Var vars @ map Bound bound_js @ live_args
- val extra_Ts = map snd vars @ filter_indices bound_js Ts
- val k = maxidx_of_term t + 1
- (* int -> term *)
- fun var_for_bound_no j =
- Var ((bound_var_prefix ^
- nat_subscript (find_index (curry (op =) j) bound_js
- + 1), k),
- nth Ts j)
- val fixed_args_in_axiom =
- map (curry subst_bounds
- (map var_for_bound_no (index_seq 0 (length Ts))))
- fixed_args
- in
- case AList.lookup (op =) (!special_funs)
- (x, fixed_js, fixed_args_in_axiom) of
- SOME x' => list_comb (Const x', extra_args)
- | NONE =>
- let
- val extra_args_in_axiom =
- map Var vars @ map var_for_bound_no bound_js
- val x' as (s', _) =
- (special_prefix_for (length (!special_funs) + 1) ^ s,
- extra_Ts @ filter_out_indices fixed_js (binder_types T)
- ---> body_type T)
- val new_axs =
- map (specialize_fun_axiom x x' fixed_js
- fixed_args_in_axiom extra_args_in_axiom) old_axs
- val _ =
- Unsynchronized.change special_funs
- (cons ((x, fixed_js, fixed_args_in_axiom), x'))
- val _ = add_simps simp_table s' new_axs
- in list_comb (Const x', extra_args) end
- end
- else
- raise SAME ())
- handle SAME () => list_comb (Const x, args))
- | aux args Ts (Abs (s, T, t)) =
- list_comb (Abs (s, T, aux [] (T :: Ts) t), args)
- | aux args Ts (t1 $ t2) = aux (aux [] Ts t2 :: args) Ts t1
- | aux args _ t = list_comb (t, args)
- in aux [] [] t end
-
-(* theory -> term -> int Termtab.tab -> int Termtab.tab *)
-fun add_to_uncurry_table thy t =
- let
- (* term -> term list -> int Termtab.tab -> int Termtab.tab *)
- fun aux (t1 $ t2) args table =
- let val table = aux t2 [] table in aux t1 (t2 :: args) table end
- | aux (Abs (_, _, t')) _ table = aux t' [] table
- | aux (t as Const (x as (s, _))) args table =
- if is_built_in_const true x orelse is_constr_like thy x orelse
- is_sel s orelse s = @{const_name Sigma} then
- table
- else
- Termtab.map_default (t, 65536) (curry Int.min (length args)) table
- | aux _ _ table = table
- in aux t [] end
-
-(* int Termtab.tab term -> term *)
-fun uncurry_term table t =
- let
- (* term -> term list -> term *)
- fun aux (t1 $ t2) args = aux t1 (aux t2 [] :: args)
- | aux (Abs (s, T, t')) args = betapplys (Abs (s, T, aux t' []), args)
- | aux (t as Const (s, T)) args =
- (case Termtab.lookup table t of
- SOME n =>
- if n >= 2 then
- let
- val (arg_Ts, rest_T) = strip_n_binders n T
- val j =
- if hd arg_Ts = @{typ bisim_iterator} orelse
- is_fp_iterator_type (hd arg_Ts) then
- 1
- else case find_index (not_equal bool_T) arg_Ts of
- ~1 => n
- | j => j
- val ((before_args, tuple_args), after_args) =
- args |> chop n |>> chop j
- val ((before_arg_Ts, tuple_arg_Ts), rest_T) =
- T |> strip_n_binders n |>> chop j
- val tuple_T = HOLogic.mk_tupleT tuple_arg_Ts
- in
- if n - j < 2 then
- betapplys (t, args)
- else
- betapplys (Const (uncurry_prefix_for (n - j) j ^ s,
- before_arg_Ts ---> tuple_T --> rest_T),
- before_args @ [mk_flat_tuple tuple_T tuple_args] @
- after_args)
- end
- else
- betapplys (t, args)
- | NONE => betapplys (t, args))
- | aux t args = betapplys (t, args)
- in aux t [] end
-
-(* (term -> term) -> int -> term -> term *)
-fun coerce_bound_no f j t =
- case t of
- t1 $ t2 => coerce_bound_no f j t1 $ coerce_bound_no f j t2
- | Abs (s, T, t') => Abs (s, T, coerce_bound_no f (j + 1) t')
- | Bound j' => if j' = j then f t else t
- | _ => t
-
-(* extended_context -> bool -> term -> term *)
-fun box_fun_and_pair_in_term (ext_ctxt as {thy, fast_descrs, ...}) def orig_t =
- let
- (* typ -> typ *)
- fun box_relational_operator_type (Type ("fun", Ts)) =
- Type ("fun", map box_relational_operator_type Ts)
- | box_relational_operator_type (Type ("*", Ts)) =
- Type ("*", map (box_type ext_ctxt InPair) Ts)
- | box_relational_operator_type T = T
- (* typ -> typ -> term -> term *)
- fun coerce_bound_0_in_term new_T old_T =
- old_T <> new_T ? coerce_bound_no (coerce_term [new_T] old_T new_T) 0
- (* typ list -> typ -> term -> term *)
- and coerce_term Ts new_T old_T t =
- if old_T = new_T then
- t
- else
- case (new_T, old_T) of
- (Type (new_s, new_Ts as [new_T1, new_T2]),
- Type ("fun", [old_T1, old_T2])) =>
- (case eta_expand Ts t 1 of
- Abs (s, _, t') =>
- Abs (s, new_T1,
- t' |> coerce_bound_0_in_term new_T1 old_T1
- |> coerce_term (new_T1 :: Ts) new_T2 old_T2)
- |> Envir.eta_contract
- |> new_s <> "fun"
- ? construct_value thy (@{const_name FunBox},
- Type ("fun", new_Ts) --> new_T) o single
- | t' => raise TERM ("Nitpick_HOL.box_fun_and_pair_in_term.\
- \coerce_term", [t']))
- | (Type (new_s, new_Ts as [new_T1, new_T2]),
- Type (old_s, old_Ts as [old_T1, old_T2])) =>
- if old_s = @{type_name fun_box} orelse
- old_s = @{type_name pair_box} orelse old_s = "*" then
- case constr_expand ext_ctxt old_T t of
- Const (@{const_name FunBox}, _) $ t1 =>
- if new_s = "fun" then
- coerce_term Ts new_T (Type ("fun", old_Ts)) t1
- else
- construct_value thy
- (@{const_name FunBox}, Type ("fun", new_Ts) --> new_T)
- [coerce_term Ts (Type ("fun", new_Ts))
- (Type ("fun", old_Ts)) t1]
- | Const _ $ t1 $ t2 =>
- construct_value thy
- (if new_s = "*" then @{const_name Pair}
- else @{const_name PairBox}, new_Ts ---> new_T)
- [coerce_term Ts new_T1 old_T1 t1,
- coerce_term Ts new_T2 old_T2 t2]
- | t' => raise TERM ("Nitpick_HOL.box_fun_and_pair_in_term.\
- \coerce_term", [t'])
- else
- raise TYPE ("coerce_term", [new_T, old_T], [t])
- | _ => raise TYPE ("coerce_term", [new_T, old_T], [t])
- (* indexname * typ -> typ * term -> typ option list -> typ option list *)
- fun add_boxed_types_for_var (z as (_, T)) (T', t') =
- case t' of
- Var z' => z' = z ? insert (op =) T'
- | Const (@{const_name Pair}, _) $ t1 $ t2 =>
- (case T' of
- Type (_, [T1, T2]) =>
- fold (add_boxed_types_for_var z) [(T1, t1), (T2, t2)]
- | _ => raise TYPE ("Nitpick_HOL.box_fun_and_pair_in_term.\
- \add_boxed_types_for_var", [T'], []))
- | _ => exists_subterm (curry (op =) (Var z)) t' ? insert (op =) T
- (* typ list -> typ list -> term -> indexname * typ -> typ *)
- fun box_var_in_def new_Ts old_Ts t (z as (_, T)) =
- case t of
- @{const Trueprop} $ t1 => box_var_in_def new_Ts old_Ts t1 z
- | Const (s0, _) $ t1 $ _ =>
- if s0 = @{const_name "=="} orelse s0 = @{const_name "op ="} then
- let
- val (t', args) = strip_comb t1
- val T' = fastype_of1 (new_Ts, do_term new_Ts old_Ts Neut t')
- in
- case fold (add_boxed_types_for_var z)
- (fst (strip_n_binders (length args) T') ~~ args) [] of
- [T''] => T''
- | _ => T
- end
- else
- T
- | _ => T
- (* typ list -> typ list -> polarity -> string -> typ -> string -> typ
- -> term -> term *)
- and do_quantifier new_Ts old_Ts polar quant_s quant_T abs_s abs_T t =
- let
- val abs_T' =
- if polar = Neut orelse is_positive_existential polar quant_s then
- box_type ext_ctxt InFunLHS abs_T
- else
- abs_T
- val body_T = body_type quant_T
- in
- Const (quant_s, (abs_T' --> body_T) --> body_T)
- $ Abs (abs_s, abs_T',
- t |> do_term (abs_T' :: new_Ts) (abs_T :: old_Ts) polar)
- end
- (* typ list -> typ list -> string -> typ -> term -> term -> term *)
- and do_equals new_Ts old_Ts s0 T0 t1 t2 =
- let
- val (t1, t2) = pairself (do_term new_Ts old_Ts Neut) (t1, t2)
- val (T1, T2) = pairself (curry fastype_of1 new_Ts) (t1, t2)
- val T = [T1, T2] |> sort TermOrd.typ_ord |> List.last
- in
- list_comb (Const (s0, T --> T --> body_type T0),
- map2 (coerce_term new_Ts T) [T1, T2] [t1, t2])
- end
- (* string -> typ -> term *)
- and do_description_operator s T =
- let val T1 = box_type ext_ctxt InFunLHS (range_type T) in
- Const (s, (T1 --> bool_T) --> T1)
- end
- (* typ list -> typ list -> polarity -> term -> term *)
- and do_term new_Ts old_Ts polar t =
- case t of
- Const (s0 as @{const_name all}, T0) $ Abs (s1, T1, t1) =>
- do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
- | Const (s0 as @{const_name "=="}, T0) $ t1 $ t2 =>
- do_equals new_Ts old_Ts s0 T0 t1 t2
- | @{const "==>"} $ t1 $ t2 =>
- @{const "==>"} $ do_term new_Ts old_Ts (flip_polarity polar) t1
- $ do_term new_Ts old_Ts polar t2
- | @{const Pure.conjunction} $ t1 $ t2 =>
- @{const Pure.conjunction} $ do_term new_Ts old_Ts polar t1
- $ do_term new_Ts old_Ts polar t2
- | @{const Trueprop} $ t1 =>
- @{const Trueprop} $ do_term new_Ts old_Ts polar t1
- | @{const Not} $ t1 =>
- @{const Not} $ do_term new_Ts old_Ts (flip_polarity polar) t1
- | Const (s0 as @{const_name All}, T0) $ Abs (s1, T1, t1) =>
- do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
- | Const (s0 as @{const_name Ex}, T0) $ Abs (s1, T1, t1) =>
- do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
- | Const (s0 as @{const_name "op ="}, T0) $ t1 $ t2 =>
- do_equals new_Ts old_Ts s0 T0 t1 t2
- | @{const "op &"} $ t1 $ t2 =>
- @{const "op &"} $ do_term new_Ts old_Ts polar t1
- $ do_term new_Ts old_Ts polar t2
- | @{const "op |"} $ t1 $ t2 =>
- @{const "op |"} $ do_term new_Ts old_Ts polar t1
- $ do_term new_Ts old_Ts polar t2
- | @{const "op -->"} $ t1 $ t2 =>
- @{const "op -->"} $ do_term new_Ts old_Ts (flip_polarity polar) t1
- $ do_term new_Ts old_Ts polar t2
- | Const (s as @{const_name The}, T) => do_description_operator s T
- | Const (s as @{const_name Eps}, T) => do_description_operator s T
- | Const (@{const_name quot_normal}, Type ("fun", [_, T2])) =>
- let val T' = box_type ext_ctxt InSel T2 in
- Const (@{const_name quot_normal}, T' --> T')
- end
- | Const (s as @{const_name Tha}, T) => do_description_operator s T
- | Const (x as (s, T)) =>
- Const (s, if s = @{const_name converse} orelse
- s = @{const_name trancl} then
- box_relational_operator_type T
- else if is_built_in_const fast_descrs x orelse
- s = @{const_name Sigma} then
- T
- else if is_constr_like thy x then
- box_type ext_ctxt InConstr T
- else if is_sel s
- orelse is_rep_fun thy x then
- box_type ext_ctxt InSel T
- else
- box_type ext_ctxt InExpr T)
- | t1 $ Abs (s, T, t2') =>
- let
- val t1 = do_term new_Ts old_Ts Neut t1
- val T1 = fastype_of1 (new_Ts, t1)
- val (s1, Ts1) = dest_Type T1
- val T' = hd (snd (dest_Type (hd Ts1)))
- val t2 = Abs (s, T', do_term (T' :: new_Ts) (T :: old_Ts) Neut t2')
- val T2 = fastype_of1 (new_Ts, t2)
- val t2 = coerce_term new_Ts (hd Ts1) T2 t2
- in
- betapply (if s1 = "fun" then
- t1
- else
- select_nth_constr_arg thy
- (@{const_name FunBox}, Type ("fun", Ts1) --> T1) t1 0
- (Type ("fun", Ts1)), t2)
- end
- | t1 $ t2 =>
- let
- val t1 = do_term new_Ts old_Ts Neut t1
- val T1 = fastype_of1 (new_Ts, t1)
- val (s1, Ts1) = dest_Type T1
- val t2 = do_term new_Ts old_Ts Neut t2
- val T2 = fastype_of1 (new_Ts, t2)
- val t2 = coerce_term new_Ts (hd Ts1) T2 t2
- in
- betapply (if s1 = "fun" then
- t1
- else
- select_nth_constr_arg thy
- (@{const_name FunBox}, Type ("fun", Ts1) --> T1) t1 0
- (Type ("fun", Ts1)), t2)
- end
- | Free (s, T) => Free (s, box_type ext_ctxt InExpr T)
- | Var (z as (x, T)) =>
- Var (x, if def then box_var_in_def new_Ts old_Ts orig_t z
- else box_type ext_ctxt InExpr T)
- | Bound _ => t
- | Abs (s, T, t') =>
- Abs (s, T, do_term (T :: new_Ts) (T :: old_Ts) Neut t')
- in do_term [] [] Pos orig_t end
-
-(* int -> term -> term *)
-fun eval_axiom_for_term j t =
- Logic.mk_equals (Const (eval_prefix ^ string_of_int j, fastype_of t), t)
-
-(* extended_context -> styp -> bool *)
-fun is_equational_fun_surely_complete ext_ctxt x =
- case raw_equational_fun_axioms ext_ctxt x of
- [@{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t1 $ _)] =>
- strip_comb t1 |> snd |> forall is_Var
- | _ => false
-
-type special = int list * term list * styp
-
-(* styp -> special -> special -> term *)
-fun special_congruence_axiom (s, T) (js1, ts1, x1) (js2, ts2, x2) =
- let
- val (bounds1, bounds2) = pairself (map Var o special_bounds) (ts1, ts2)
- val Ts = binder_types T
- val max_j = fold (fold Integer.max) [js1, js2] ~1
- val (eqs, (args1, args2)) =
- fold (fn j => case pairself (fn ps => AList.lookup (op =) ps j)
- (js1 ~~ ts1, js2 ~~ ts2) of
- (SOME t1, SOME t2) => apfst (cons (t1, t2))
- | (SOME t1, NONE) => apsnd (apsnd (cons t1))
- | (NONE, SOME t2) => apsnd (apfst (cons t2))
- | (NONE, NONE) =>
- let val v = Var ((cong_var_prefix ^ nat_subscript j, 0),
- nth Ts j) in
- apsnd (pairself (cons v))
- end) (max_j downto 0) ([], ([], []))
- in
- Logic.list_implies (eqs |> filter_out (op =) |> distinct (op =)
- |> map Logic.mk_equals,
- Logic.mk_equals (list_comb (Const x1, bounds1 @ args1),
- list_comb (Const x2, bounds2 @ args2)))
- |> Refute.close_form (* TODO: needed? *)
- end
-
-(* extended_context -> styp list -> term list *)
-fun special_congruence_axioms (ext_ctxt as {special_funs, ...}) xs =
- let
- val groups =
- !special_funs
- |> map (fn ((x, js, ts), x') => (x, (js, ts, x')))
- |> AList.group (op =)
- |> filter_out (is_equational_fun_surely_complete ext_ctxt o fst)
- |> map (fn (x, zs) => (x, zs |> member (op =) xs x ? cons ([], [], x)))
- (* special -> int *)
- fun generality (js, _, _) = ~(length js)
- (* special -> special -> bool *)
- fun is_more_specific (j1, t1, x1) (j2, t2, x2) =
- x1 <> x2 andalso OrdList.subset (prod_ord int_ord TermOrd.term_ord)
- (j2 ~~ t2, j1 ~~ t1)
- (* styp -> special list -> special list -> special list -> term list
- -> term list *)
- fun do_pass_1 _ [] [_] [_] = I
- | do_pass_1 x skipped _ [] = do_pass_2 x skipped
- | do_pass_1 x skipped all (z :: zs) =
- case filter (is_more_specific z) all
- |> sort (int_ord o pairself generality) of
- [] => do_pass_1 x (z :: skipped) all zs
- | (z' :: _) => cons (special_congruence_axiom x z z')
- #> do_pass_1 x skipped all zs
- (* styp -> special list -> term list -> term list *)
- and do_pass_2 _ [] = I
- | do_pass_2 x (z :: zs) =
- fold (cons o special_congruence_axiom x z) zs #> do_pass_2 x zs
- in fold (fn (x, zs) => do_pass_1 x [] zs zs) groups [] end
-
-(* term -> bool *)
-val is_trivial_equation = the_default false o try (op aconv o Logic.dest_equals)
-
-(* 'a Symtab.table -> 'a list *)
-fun all_table_entries table = Symtab.fold (append o snd) table []
-(* const_table -> string -> const_table *)
-fun extra_table table s = Symtab.make [(s, all_table_entries table)]
-
-(* extended_context -> term -> (term list * term list) * (bool * bool) *)
-fun axioms_for_term
- (ext_ctxt as {thy, max_bisim_depth, user_axioms, fast_descrs, evals,
- def_table, nondef_table, user_nondefs, ...}) t =
- let
- type accumulator = styp list * (term list * term list)
- (* (term list * term list -> term list)
- -> ((term list -> term list) -> term list * term list
- -> term list * term list)
- -> int -> term -> accumulator -> accumulator *)
- fun add_axiom get app depth t (accum as (xs, axs)) =
- let
- val t = t |> unfold_defs_in_term ext_ctxt
- |> skolemize_term_and_more ext_ctxt ~1
- in
- if is_trivial_equation t then
- accum
- else
- let val t' = t |> specialize_consts_in_term ext_ctxt depth in
- if exists (member (op aconv) (get axs)) [t, t'] then accum
- else add_axioms_for_term (depth + 1) t' (xs, app (cons t') axs)
- end
- end
- (* int -> term -> accumulator -> accumulator *)
- and add_def_axiom depth = add_axiom fst apfst depth
- and add_nondef_axiom depth = add_axiom snd apsnd depth
- and add_maybe_def_axiom depth t =
- (if head_of t <> @{const "==>"} then add_def_axiom
- else add_nondef_axiom) depth t
- and add_eq_axiom depth t =
- (if is_constr_pattern_formula thy t then add_def_axiom
- else add_nondef_axiom) depth t
- (* int -> term -> accumulator -> accumulator *)
- and add_axioms_for_term depth t (accum as (xs, axs)) =
- case t of
- t1 $ t2 => accum |> fold (add_axioms_for_term depth) [t1, t2]
- | Const (x as (s, T)) =>
- (if member (op =) xs x orelse is_built_in_const fast_descrs x then
- accum
- else
- let val accum as (xs, _) = (x :: xs, axs) in
- if depth > axioms_max_depth then
- raise TOO_LARGE ("Nitpick_HOL.axioms_for_term.\
- \add_axioms_for_term",
- "too many nested axioms (" ^
- string_of_int depth ^ ")")
- else if Refute.is_const_of_class thy x then
- let
- val class = Logic.class_of_const s
- val of_class = Logic.mk_of_class (TVar (("'a", 0), [class]),
- class)
- val ax1 = try (Refute.specialize_type thy x) of_class
- val ax2 = Option.map (Refute.specialize_type thy x o snd)
- (Refute.get_classdef thy class)
- in
- fold (add_maybe_def_axiom depth) (map_filter I [ax1, ax2])
- accum
- end
- else if is_constr thy x then
- accum
- else if is_equational_fun ext_ctxt x then
- fold (add_eq_axiom depth) (equational_fun_axioms ext_ctxt x)
- accum
- else if is_abs_fun thy x then
- if is_quot_type thy (range_type T) then
- raise NOT_SUPPORTED "\"Abs_\" function of quotient type"
- else
- accum |> fold (add_nondef_axiom depth)
- (nondef_props_for_const thy false nondef_table x)
- |> is_funky_typedef thy (range_type T)
- ? fold (add_maybe_def_axiom depth)
- (nondef_props_for_const thy true
- (extra_table def_table s) x)
- else if is_rep_fun thy x then
- if is_quot_type thy (domain_type T) then
- raise NOT_SUPPORTED "\"Rep_\" function of quotient type"
- else
- accum |> fold (add_nondef_axiom depth)
- (nondef_props_for_const thy false nondef_table x)
- |> is_funky_typedef thy (range_type T)
- ? fold (add_maybe_def_axiom depth)
- (nondef_props_for_const thy true
- (extra_table def_table s) x)
- |> add_axioms_for_term depth
- (Const (mate_of_rep_fun thy x))
- |> fold (add_def_axiom depth)
- (inverse_axioms_for_rep_fun thy x)
- else
- accum |> user_axioms <> SOME false
- ? fold (add_nondef_axiom depth)
- (nondef_props_for_const thy false nondef_table x)
- end)
- |> add_axioms_for_type depth T
- | Free (_, T) => add_axioms_for_type depth T accum
- | Var (_, T) => add_axioms_for_type depth T accum
- | Bound _ => accum
- | Abs (_, T, t) => accum |> add_axioms_for_term depth t
- |> add_axioms_for_type depth T
- (* int -> typ -> accumulator -> accumulator *)
- and add_axioms_for_type depth T =
- case T of
- Type ("fun", Ts) => fold (add_axioms_for_type depth) Ts
- | Type ("*", Ts) => fold (add_axioms_for_type depth) Ts
- | @{typ prop} => I
- | @{typ bool} => I
- | @{typ unit} => I
- | TFree (_, S) => add_axioms_for_sort depth T S
- | TVar (_, S) => add_axioms_for_sort depth T S
- | Type (z as (s, Ts)) =>
- fold (add_axioms_for_type depth) Ts
- #> (if is_pure_typedef thy T then
- fold (add_maybe_def_axiom depth) (optimized_typedef_axioms thy z)
- else if is_quot_type thy T then
- fold (add_def_axiom depth) (optimized_quot_type_axioms thy z)
- else if max_bisim_depth >= 0 andalso is_codatatype thy T then
- fold (add_maybe_def_axiom depth)
- (codatatype_bisim_axioms ext_ctxt T)
- else
- I)
- (* int -> typ -> sort -> accumulator -> accumulator *)
- and add_axioms_for_sort depth T S =
- let
- val supers = Sign.complete_sort thy S
- val class_axioms =
- maps (fn class => map prop_of (AxClass.get_info thy class |> #axioms
- handle ERROR _ => [])) supers
- val monomorphic_class_axioms =
- map (fn t => case Term.add_tvars t [] of
- [] => t
- | [(x, S)] =>
- Refute.monomorphic_term (Vartab.make [(x, (S, T))]) t
- | _ => raise TERM ("Nitpick_HOL.axioms_for_term.\
- \add_axioms_for_sort", [t]))
- class_axioms
- in fold (add_nondef_axiom depth) monomorphic_class_axioms end
- val (mono_user_nondefs, poly_user_nondefs) =
- List.partition (null o Term.hidden_polymorphism) user_nondefs
- val eval_axioms = map2 eval_axiom_for_term (index_seq 0 (length evals))
- evals
- val (xs, (defs, nondefs)) =
- ([], ([], [])) |> add_axioms_for_term 1 t
- |> fold_rev (add_def_axiom 1) eval_axioms
- |> user_axioms = SOME true
- ? fold (add_nondef_axiom 1) mono_user_nondefs
- val defs = defs @ special_congruence_axioms ext_ctxt xs
- in
- ((defs, nondefs), (user_axioms = SOME true orelse null mono_user_nondefs,
- null poly_user_nondefs))
- end
+(* hol_context -> typ -> typ list *)
+fun ground_types_in_type hol_ctxt T = add_ground_types hol_ctxt T []
+(* hol_context -> term list -> typ list *)
+fun ground_types_in_terms hol_ctxt ts =
+ fold (fold_types (add_ground_types hol_ctxt)) ts []
(* theory -> const_table -> styp -> int list *)
fun const_format thy def_table (x as (s, T)) =
@@ -3356,10 +2121,10 @@
|> map (rev o filter_out (member (op =) js))
|> filter_out null |> map length |> rev
-(* extended_context -> string * string -> (term option * int list) list
+(* hol_context -> string * string -> (term option * int list) list
-> styp -> term * typ *)
fun user_friendly_const ({thy, evals, def_table, skolems, special_funs, ...}
- : extended_context) (base_name, step_name) formats =
+ : hol_context) (base_name, step_name) formats =
let
val default_format = the (AList.lookup (op =) formats NONE)
(* styp -> term * typ *)
@@ -3460,7 +2225,7 @@
(t, format_term_type thy def_table formats t)
end)
|>> map_types unbit_and_unbox_type
- |>> shorten_names_in_term |>> shorten_abs_vars
+ |>> shorten_names_in_term |>> Term.map_abs_vars shortest_name
in do_const end
(* styp -> string *)
@@ -3474,84 +2239,4 @@
else
"="
-val binary_int_threshold = 4
-
-(* term -> bool *)
-fun may_use_binary_ints (t1 $ t2) =
- may_use_binary_ints t1 andalso may_use_binary_ints t2
- | may_use_binary_ints (t as Const (s, _)) =
- t <> @{const Suc} andalso
- not (member (op =) [@{const_name Abs_Frac}, @{const_name Rep_Frac},
- @{const_name nat_gcd}, @{const_name nat_lcm},
- @{const_name Frac}, @{const_name norm_frac}] s)
- | may_use_binary_ints (Abs (_, _, t')) = may_use_binary_ints t'
- | may_use_binary_ints _ = true
-fun should_use_binary_ints (t1 $ t2) =
- should_use_binary_ints t1 orelse should_use_binary_ints t2
- | should_use_binary_ints (Const (s, _)) =
- member (op =) [@{const_name times_nat_inst.times_nat},
- @{const_name div_nat_inst.div_nat},
- @{const_name times_int_inst.times_int},
- @{const_name div_int_inst.div_int}] s orelse
- (String.isPrefix numeral_prefix s andalso
- let val n = the (Int.fromString (unprefix numeral_prefix s)) in
- n <= ~ binary_int_threshold orelse n >= binary_int_threshold
- end)
- | should_use_binary_ints (Abs (_, _, t')) = should_use_binary_ints t'
- | should_use_binary_ints _ = false
-
-(* typ -> typ *)
-fun binarize_nat_and_int_in_type @{typ nat} = @{typ "unsigned_bit word"}
- | binarize_nat_and_int_in_type @{typ int} = @{typ "signed_bit word"}
- | binarize_nat_and_int_in_type (Type (s, Ts)) =
- Type (s, map binarize_nat_and_int_in_type Ts)
- | binarize_nat_and_int_in_type T = T
-(* term -> term *)
-val binarize_nat_and_int_in_term = map_types binarize_nat_and_int_in_type
-
-(* extended_context -> term
- -> ((term list * term list) * (bool * bool)) * term *)
-fun preprocess_term (ext_ctxt as {thy, binary_ints, destroy_constrs, boxes,
- skolemize, uncurry, ...}) t =
- let
- val skolem_depth = if skolemize then 4 else ~1
- val (((def_ts, nondef_ts), (got_all_mono_user_axioms, no_poly_user_axioms)),
- core_t) = t |> unfold_defs_in_term ext_ctxt
- |> Refute.close_form
- |> skolemize_term_and_more ext_ctxt skolem_depth
- |> specialize_consts_in_term ext_ctxt 0
- |> `(axioms_for_term ext_ctxt)
- val binarize =
- case binary_ints of
- SOME false => false
- | _ =>
- forall may_use_binary_ints (core_t :: def_ts @ nondef_ts) andalso
- (binary_ints = SOME true orelse
- exists should_use_binary_ints (core_t :: def_ts @ nondef_ts))
- val box = exists (not_equal (SOME false) o snd) boxes
- val table =
- Termtab.empty |> uncurry
- ? fold (add_to_uncurry_table thy) (core_t :: def_ts @ nondef_ts)
- (* bool -> bool -> term -> term *)
- fun do_rest def core =
- binarize ? binarize_nat_and_int_in_term
- #> uncurry ? uncurry_term table
- #> box ? box_fun_and_pair_in_term ext_ctxt def
- #> destroy_constrs ? (pull_out_universal_constrs thy def
- #> pull_out_existential_constrs thy
- #> destroy_pulled_out_constrs ext_ctxt def)
- #> curry_assms
- #> destroy_universal_equalities
- #> destroy_existential_equalities thy
- #> simplify_constrs_and_sels thy
- #> distribute_quantifiers
- #> push_quantifiers_inward thy
- #> not core ? Refute.close_form
- #> shorten_abs_vars
- in
- (((map (do_rest true false) def_ts, map (do_rest false false) nondef_ts),
- (got_all_mono_user_axioms, no_poly_user_axioms)),
- do_rest false true core_t)
- end
-
end;
--- a/src/HOL/Tools/Nitpick/nitpick_kodkod.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Nitpick/nitpick_kodkod.ML Thu Feb 11 12:26:50 2010 -0800
@@ -7,7 +7,7 @@
signature NITPICK_KODKOD =
sig
- type extended_context = Nitpick_HOL.extended_context
+ type hol_context = Nitpick_HOL.hol_context
type dtype_spec = Nitpick_Scope.dtype_spec
type kodkod_constrs = Nitpick_Peephole.kodkod_constrs
type nut = Nitpick_Nut.nut
@@ -33,7 +33,7 @@
val merge_bounds : Kodkod.bound list -> Kodkod.bound list
val declarative_axiom_for_plain_rel : kodkod_constrs -> nut -> Kodkod.formula
val declarative_axioms_for_datatypes :
- extended_context -> int -> int Typtab.table -> kodkod_constrs
+ hol_context -> int -> int Typtab.table -> kodkod_constrs
-> nut NameTable.table -> dtype_spec list -> Kodkod.formula list
val kodkod_formula_from_nut :
int -> int Typtab.table -> bool -> kodkod_constrs -> nut -> Kodkod.formula
@@ -316,7 +316,15 @@
if R2 = Formula Neut then
[ts] |> not exclusive ? cons (KK.TupleSet [])
else
- [KK.TupleSet [], KK.TupleProduct (ts, upper_bound_for_rep R2)]
+ [KK.TupleSet [],
+ if (* ### exclusive andalso*) T1 = T2 andalso epsilon > delta then
+ index_seq delta (epsilon - delta)
+ |> map (fn j =>
+ KK.TupleProduct (KK.TupleSet [Kodkod.Tuple [j + j0]],
+ KK.TupleAtomSeq (j, j0)))
+ |> foldl1 KK.TupleUnion
+ else
+ KK.TupleProduct (ts, upper_bound_for_rep R2)]
end)
end
| bound_for_sel_rel _ _ _ u =
@@ -732,12 +740,12 @@
(* nut NameTable.table -> styp -> KK.rel_expr *)
fun discr_rel_expr rel_table = #1 o const_triple rel_table o discr_for_constr
-(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
+(* hol_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
-> styp -> int -> nfa_transition list *)
-fun nfa_transitions_for_sel ext_ctxt ({kk_project, ...} : kodkod_constrs)
+fun nfa_transitions_for_sel hol_ctxt ({kk_project, ...} : kodkod_constrs)
rel_table (dtypes : dtype_spec list) constr_x n =
let
- val x as (_, T) = boxed_nth_sel_for_constr ext_ctxt constr_x n
+ val x as (_, T) = boxed_nth_sel_for_constr hol_ctxt constr_x n
val (r, R, arity) = const_triple rel_table x
val type_schema = type_schema_of_rep T R
in
@@ -746,17 +754,17 @@
else SOME (kk_project r (map KK.Num [0, j]), T))
(index_seq 1 (arity - 1) ~~ tl type_schema)
end
-(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
+(* hol_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
-> styp -> nfa_transition list *)
-fun nfa_transitions_for_constr ext_ctxt kk rel_table dtypes (x as (_, T)) =
- maps (nfa_transitions_for_sel ext_ctxt kk rel_table dtypes x)
+fun nfa_transitions_for_constr hol_ctxt kk rel_table dtypes (x as (_, T)) =
+ maps (nfa_transitions_for_sel hol_ctxt kk rel_table dtypes x)
(index_seq 0 (num_sels_for_constr_type T))
-(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
+(* hol_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
-> dtype_spec -> nfa_entry option *)
fun nfa_entry_for_datatype _ _ _ _ ({co = true, ...} : dtype_spec) = NONE
| nfa_entry_for_datatype _ _ _ _ {deep = false, ...} = NONE
- | nfa_entry_for_datatype ext_ctxt kk rel_table dtypes {typ, constrs, ...} =
- SOME (typ, maps (nfa_transitions_for_constr ext_ctxt kk rel_table dtypes
+ | nfa_entry_for_datatype hol_ctxt kk rel_table dtypes {typ, constrs, ...} =
+ SOME (typ, maps (nfa_transitions_for_constr hol_ctxt kk rel_table dtypes
o #const) constrs)
val empty_rel = KK.Product (KK.None, KK.None)
@@ -812,23 +820,23 @@
fun acyclicity_axiom_for_datatype dtypes kk nfa start =
#kk_no kk (#kk_intersect kk
(loop_path_rel_expr kk nfa (map fst nfa) start) KK.Iden)
-(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
+(* hol_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
-> KK.formula list *)
-fun acyclicity_axioms_for_datatypes ext_ctxt kk rel_table dtypes =
- map_filter (nfa_entry_for_datatype ext_ctxt kk rel_table dtypes) dtypes
+fun acyclicity_axioms_for_datatypes hol_ctxt kk rel_table dtypes =
+ map_filter (nfa_entry_for_datatype hol_ctxt kk rel_table dtypes) dtypes
|> strongly_connected_sub_nfas
|> maps (fn nfa => map (acyclicity_axiom_for_datatype dtypes kk nfa o fst)
nfa)
-(* extended_context -> int -> kodkod_constrs -> nut NameTable.table
- -> KK.rel_expr -> constr_spec -> int -> KK.formula *)
-fun sel_axiom_for_sel ext_ctxt j0
+(* hol_context -> int -> kodkod_constrs -> nut NameTable.table -> KK.rel_expr
+ -> constr_spec -> int -> KK.formula *)
+fun sel_axiom_for_sel hol_ctxt j0
(kk as {kk_all, kk_implies, kk_formula_if, kk_subset, kk_rel_eq, kk_no,
kk_join, ...}) rel_table dom_r
({const, delta, epsilon, exclusive, explicit_max, ...} : constr_spec)
n =
let
- val x as (_, T) = boxed_nth_sel_for_constr ext_ctxt const n
+ val x as (_, T) = boxed_nth_sel_for_constr hol_ctxt const n
val (r, R, arity) = const_triple rel_table x
val R2 = dest_Func R |> snd
val z = (epsilon - delta, delta + j0)
@@ -842,9 +850,9 @@
(kk_n_ary_function kk R2 r') (kk_no r'))
end
end
-(* extended_context -> int -> int -> kodkod_constrs -> nut NameTable.table
+(* hol_context -> int -> int -> kodkod_constrs -> nut NameTable.table
-> constr_spec -> KK.formula list *)
-fun sel_axioms_for_constr ext_ctxt bits j0 kk rel_table
+fun sel_axioms_for_constr hol_ctxt bits j0 kk rel_table
(constr as {const, delta, epsilon, explicit_max, ...}) =
let
val honors_explicit_max =
@@ -866,19 +874,19 @@
" too small for \"max\"")
in
max_axiom ::
- map (sel_axiom_for_sel ext_ctxt j0 kk rel_table ran_r constr)
+ map (sel_axiom_for_sel hol_ctxt j0 kk rel_table ran_r constr)
(index_seq 0 (num_sels_for_constr_type (snd const)))
end
end
-(* extended_context -> int -> int -> kodkod_constrs -> nut NameTable.table
+(* hol_context -> int -> int -> kodkod_constrs -> nut NameTable.table
-> dtype_spec -> KK.formula list *)
-fun sel_axioms_for_datatype ext_ctxt bits j0 kk rel_table
+fun sel_axioms_for_datatype hol_ctxt bits j0 kk rel_table
({constrs, ...} : dtype_spec) =
- maps (sel_axioms_for_constr ext_ctxt bits j0 kk rel_table) constrs
+ maps (sel_axioms_for_constr hol_ctxt bits j0 kk rel_table) constrs
-(* extended_context -> kodkod_constrs -> nut NameTable.table -> constr_spec
+(* hol_context -> kodkod_constrs -> nut NameTable.table -> constr_spec
-> KK.formula list *)
-fun uniqueness_axiom_for_constr ext_ctxt
+fun uniqueness_axiom_for_constr hol_ctxt
({kk_all, kk_implies, kk_and, kk_rel_eq, kk_lone, kk_join, ...}
: kodkod_constrs) rel_table ({const, ...} : constr_spec) =
let
@@ -887,7 +895,7 @@
kk_rel_eq (kk_join (KK.Var (1, 0)) r) (kk_join (KK.Var (1, 1)) r)
val num_sels = num_sels_for_constr_type (snd const)
val triples = map (const_triple rel_table
- o boxed_nth_sel_for_constr ext_ctxt const)
+ o boxed_nth_sel_for_constr hol_ctxt const)
(~1 upto num_sels - 1)
val j0 = case triples |> hd |> #2 of
Func (Atom (_, j0), _) => j0
@@ -903,11 +911,11 @@
(fold1 kk_and (map (conjunct_for_sel o #1) (tl triples)))
(kk_rel_eq (KK.Var (1, 0)) (KK.Var (1, 1))))
end
-(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec
+(* hol_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec
-> KK.formula list *)
-fun uniqueness_axioms_for_datatype ext_ctxt kk rel_table
+fun uniqueness_axioms_for_datatype hol_ctxt kk rel_table
({constrs, ...} : dtype_spec) =
- map (uniqueness_axiom_for_constr ext_ctxt kk rel_table) constrs
+ map (uniqueness_axiom_for_constr hol_ctxt kk rel_table) constrs
(* constr_spec -> int *)
fun effective_constr_max ({delta, epsilon, ...} : constr_spec) = epsilon - delta
@@ -924,31 +932,31 @@
kk_disjoint_sets kk rs]
end
-(* extended_context -> int -> int Typtab.table -> kodkod_constrs
+(* hol_context -> int -> int Typtab.table -> kodkod_constrs
-> nut NameTable.table -> dtype_spec -> KK.formula list *)
fun other_axioms_for_datatype _ _ _ _ _ {deep = false, ...} = []
- | other_axioms_for_datatype ext_ctxt bits ofs kk rel_table
+ | other_axioms_for_datatype hol_ctxt bits ofs kk rel_table
(dtype as {typ, ...}) =
let val j0 = offset_of_type ofs typ in
- sel_axioms_for_datatype ext_ctxt bits j0 kk rel_table dtype @
- uniqueness_axioms_for_datatype ext_ctxt kk rel_table dtype @
+ sel_axioms_for_datatype hol_ctxt bits j0 kk rel_table dtype @
+ uniqueness_axioms_for_datatype hol_ctxt kk rel_table dtype @
partition_axioms_for_datatype j0 kk rel_table dtype
end
-(* extended_context -> int -> int Typtab.table -> kodkod_constrs
+(* hol_context -> int -> int Typtab.table -> kodkod_constrs
-> nut NameTable.table -> dtype_spec list -> KK.formula list *)
-fun declarative_axioms_for_datatypes ext_ctxt bits ofs kk rel_table dtypes =
- acyclicity_axioms_for_datatypes ext_ctxt kk rel_table dtypes @
- maps (other_axioms_for_datatype ext_ctxt bits ofs kk rel_table) dtypes
+fun declarative_axioms_for_datatypes hol_ctxt bits ofs kk rel_table dtypes =
+ acyclicity_axioms_for_datatypes hol_ctxt kk rel_table dtypes @
+ maps (other_axioms_for_datatype hol_ctxt bits ofs kk rel_table) dtypes
(* int -> int Typtab.table -> bool -> kodkod_constrs -> nut -> KK.formula *)
fun kodkod_formula_from_nut bits ofs liberal
(kk as {kk_all, kk_exist, kk_formula_let, kk_formula_if, kk_or, kk_not,
- kk_iff, kk_implies, kk_and, kk_subset, kk_rel_eq, kk_no, kk_one,
- kk_some, kk_rel_let, kk_rel_if, kk_union, kk_difference,
- kk_intersect, kk_product, kk_join, kk_closure, kk_comprehension,
- kk_project, kk_project_seq, kk_not3, kk_nat_less, kk_int_less,
- ...}) u =
+ kk_iff, kk_implies, kk_and, kk_subset, kk_rel_eq, kk_no,
+ kk_lone, kk_one, kk_some, kk_rel_let, kk_rel_if, kk_union,
+ kk_difference, kk_intersect, kk_product, kk_join, kk_closure,
+ kk_comprehension, kk_project, kk_project_seq, kk_not3,
+ kk_nat_less, kk_int_less, ...}) u =
let
val main_j0 = offset_of_type ofs bool_T
val bool_j0 = main_j0
@@ -1108,7 +1116,7 @@
else
if is_lone_rep min_R then
if arity_of_rep min_R = 1 then
- kk_subset (kk_product r1 r2) KK.Iden
+ kk_lone (kk_union r1 r2)
else if not both_opt then
(r1, r2) |> is_opt_rep (rep_of u2) ? swap
|-> kk_subset
--- a/src/HOL/Tools/Nitpick/nitpick_model.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Nitpick/nitpick_model.ML Thu Feb 11 12:26:50 2010 -0800
@@ -56,29 +56,39 @@
val opt_flag = nitpick_prefix ^ "opt"
val non_opt_flag = nitpick_prefix ^ "non_opt"
-(* string -> int -> string *)
-fun atom_suffix s j =
- nat_subscript (j + 1)
+type atom_pool = ((string * int) * int list) list
+
+(* atom_pool Unsynchronized.ref -> string -> int -> int -> string *)
+fun nth_atom_suffix pool s j k =
+ (case AList.lookup (op =) (!pool) (s, k) of
+ SOME js =>
+ (case find_index (curry (op =) j) js of
+ ~1 => (Unsynchronized.change pool (cons ((s, k), j :: js));
+ length js + 1)
+ | n => length js - n)
+ | NONE => (Unsynchronized.change pool (cons ((s, k), [j])); 1))
+ |> nat_subscript
|> (s <> "" andalso Symbol.is_ascii_digit (List.last (explode s)))
? prefix "\<^isub>,"
-(* string -> typ -> int -> string *)
-fun atom_name prefix (T as Type (s, _)) j =
+(* atom_pool Unsynchronized.ref -> string -> typ -> int -> int -> string *)
+fun nth_atom_name pool prefix (T as Type (s, _)) j k =
let val s' = shortest_name s in
prefix ^ (if String.isPrefix "\\" s' then s' else substring (s', 0, 1)) ^
- atom_suffix s j
+ nth_atom_suffix pool s j k
end
- | atom_name prefix (T as TFree (s, _)) j =
- prefix ^ perhaps (try (unprefix "'")) s ^ atom_suffix s j
- | atom_name _ T _ = raise TYPE ("Nitpick_Model.atom_name", [T], [])
-(* bool -> typ -> int -> term *)
-fun atom for_auto T j =
+ | nth_atom_name pool prefix (T as TFree (s, _)) j k =
+ prefix ^ perhaps (try (unprefix "'")) s ^ nth_atom_suffix pool s j k
+ | nth_atom_name _ _ T _ _ =
+ raise TYPE ("Nitpick_Model.nth_atom_name", [T], [])
+(* atom_pool Unsynchronized.ref -> bool -> typ -> int -> int -> term *)
+fun nth_atom pool for_auto T j k =
if for_auto then
- Free (atom_name (hd (space_explode "." nitpick_prefix)) T j, T)
+ Free (nth_atom_name pool (hd (space_explode "." nitpick_prefix)) T j k, T)
else
- Const (atom_name "" T j, T)
+ Const (nth_atom_name pool "" T j k, T)
(* term -> real *)
-fun extract_real_number (Const (@{const_name Algebras.divide}, _) $ t1 $ t2) =
+fun extract_real_number (Const (@{const_name Rings.divide}, _) $ t1 $ t2) =
real (snd (HOLogic.dest_number t1)) / real (snd (HOLogic.dest_number t2))
| extract_real_number t = real (snd (HOLogic.dest_number t))
(* term * term -> order *)
@@ -251,9 +261,10 @@
-> nut list -> nut NameTable.table -> KK.raw_bound list -> typ -> typ -> rep
-> int list list -> term *)
fun reconstruct_term (maybe_name, base_name, step_name, abs_name)
- ({ext_ctxt as {thy, ctxt, ...}, card_assigns, bits, datatypes, ofs, ...}
+ ({hol_ctxt as {thy, ctxt, ...}, card_assigns, bits, datatypes, ofs, ...}
: scope) sel_names rel_table bounds =
let
+ val pool = Unsynchronized.ref []
val for_auto = (maybe_name = "")
(* int list list -> int *)
fun value_of_bits jss =
@@ -348,7 +359,7 @@
(unbit_and_unbox_type T1)
(unbit_and_unbox_type T2)
(* (typ * int) list -> typ -> typ -> int -> term *)
- fun term_for_atom seen (T as Type ("fun", [T1, T2])) T' j =
+ fun term_for_atom seen (T as Type ("fun", [T1, T2])) T' j k =
let
val k1 = card_of_type card_assigns T1
val k2 = card_of_type card_assigns T2
@@ -360,37 +371,39 @@
signed_string_of_int j ^ " for " ^
string_for_rep (Vect (k1, Atom (k2, 0))))
end
- | term_for_atom seen (Type ("*", [T1, T2])) _ j =
- let val k1 = card_of_type card_assigns T1 in
+ | term_for_atom seen (Type ("*", [T1, T2])) _ j k =
+ let
+ val k1 = card_of_type card_assigns T1
+ val k2 = k div k1
+ in
list_comb (HOLogic.pair_const T1 T2,
- map2 (fn T => term_for_atom seen T T) [T1, T2]
- [j div k1, j mod k1])
+ map3 (fn T => term_for_atom seen T T) [T1, T2]
+ [j div k2, j mod k2] [k1, k2]) (* ### k2 or k1? FIXME *)
end
- | term_for_atom seen @{typ prop} _ j =
- HOLogic.mk_Trueprop (term_for_atom seen bool_T bool_T j)
- | term_for_atom _ @{typ bool} _ j =
+ | term_for_atom seen @{typ prop} _ j k =
+ HOLogic.mk_Trueprop (term_for_atom seen bool_T bool_T j k)
+ | term_for_atom _ @{typ bool} _ j _ =
if j = 0 then @{const False} else @{const True}
- | term_for_atom _ @{typ unit} _ _ = @{const Unity}
- | term_for_atom seen T _ j =
+ | term_for_atom _ @{typ unit} _ _ _ = @{const Unity}
+ | term_for_atom seen T _ j k =
if T = nat_T then
HOLogic.mk_number nat_T j
else if T = int_T then
- HOLogic.mk_number int_T
- (int_for_atom (card_of_type card_assigns int_T, 0) j)
+ HOLogic.mk_number int_T (int_for_atom (k, 0) j)
else if is_fp_iterator_type T then
- HOLogic.mk_number nat_T (card_of_type card_assigns T - j - 1)
+ HOLogic.mk_number nat_T (k - j - 1)
else if T = @{typ bisim_iterator} then
HOLogic.mk_number nat_T j
else case datatype_spec datatypes T of
- NONE => atom for_auto T j
- | SOME {deep = false, ...} => atom for_auto T j
+ NONE => nth_atom pool for_auto T j k
+ | SOME {deep = false, ...} => nth_atom pool for_auto T j k
| SOME {co, constrs, ...} =>
let
(* styp -> int list *)
fun tuples_for_const (s, T) =
tuple_list_for_name rel_table bounds (ConstName (s, T, Any))
(* unit -> indexname * typ *)
- fun var () = ((atom_name "" T j, 0), T)
+ fun var () = ((nth_atom_name pool "" T j k, 0), T)
val discr_jsss = map (tuples_for_const o discr_for_constr o #const)
constrs
val real_j = j + offset_of_type ofs T
@@ -400,7 +413,7 @@
else NONE)
(discr_jsss ~~ constrs) |> the
val arg_Ts = curried_binder_types constr_T
- val sel_xs = map (boxed_nth_sel_for_constr ext_ctxt constr_x)
+ val sel_xs = map (boxed_nth_sel_for_constr hol_ctxt constr_x)
(index_seq 0 (length arg_Ts))
val sel_Rs =
map (fn x => get_first
@@ -446,7 +459,7 @@
0 => mk_num 0
| n1 => case HOLogic.dest_number t2 |> snd of
1 => mk_num n1
- | n2 => Const (@{const_name Algebras.divide},
+ | n2 => Const (@{const_name Rings.divide},
num_T --> num_T --> num_T)
$ mk_num n1 $ mk_num n2)
| _ => raise TERM ("Nitpick_Model.reconstruct_term.\
@@ -479,13 +492,14 @@
(* (typ * int) list -> int -> rep -> typ -> typ -> typ -> int list
-> term *)
and term_for_vect seen k R T1 T2 T' js =
- make_fun true T1 T2 T' (map (term_for_atom seen T1 T1) (index_seq 0 k))
+ make_fun true T1 T2 T'
+ (map (fn j => term_for_atom seen T1 T1 j k) (index_seq 0 k))
(map (term_for_rep seen T2 T2 R o single)
(batch_list (arity_of_rep R) js))
(* (typ * int) list -> typ -> typ -> rep -> int list list -> term *)
- and term_for_rep seen T T' Unit [[]] = term_for_atom seen T T' 0
+ and term_for_rep seen T T' Unit [[]] = term_for_atom seen T T' 0 1
| term_for_rep seen T T' (R as Atom (k, j0)) [[j]] =
- if j >= j0 andalso j < j0 + k then term_for_atom seen T T' (j - j0)
+ if j >= j0 andalso j < j0 + k then term_for_atom seen T T' (j - j0) k
else raise REP ("Nitpick_Model.reconstruct_term.term_for_rep", [R])
| term_for_rep seen (Type ("*", [T1, T2])) _ (Struct [R1, R2]) [js] =
let
@@ -586,7 +600,7 @@
-> nut list -> nut list -> nut NameTable.table -> KK.raw_bound list
-> Pretty.T * bool *)
fun reconstruct_hol_model {show_skolems, show_datatypes, show_consts}
- ({ext_ctxt as {thy, ctxt, max_bisim_depth, boxes, stds, wfs,
+ ({hol_ctxt as {thy, ctxt, max_bisim_depth, boxes, stds, wfs,
user_axioms, debug, binary_ints, destroy_constrs,
specialize, skolemize, star_linear_preds, uncurry,
fast_descrs, tac_timeout, evals, case_names, def_table,
@@ -598,7 +612,7 @@
let
val (wacky_names as (_, base_name, step_name, _), ctxt) =
add_wacky_syntax ctxt
- val ext_ctxt =
+ val hol_ctxt =
{thy = thy, ctxt = ctxt, max_bisim_depth = max_bisim_depth, boxes = boxes,
stds = stds, wfs = wfs, user_axioms = user_axioms, debug = debug,
binary_ints = binary_ints, destroy_constrs = destroy_constrs,
@@ -612,7 +626,7 @@
ersatz_table = ersatz_table, skolems = skolems,
special_funs = special_funs, unrolled_preds = unrolled_preds,
wf_cache = wf_cache, constr_cache = constr_cache}
- val scope = {ext_ctxt = ext_ctxt, card_assigns = card_assigns,
+ val scope = {hol_ctxt = hol_ctxt, card_assigns = card_assigns,
bits = bits, bisim_depth = bisim_depth, datatypes = datatypes,
ofs = ofs}
(* typ -> typ -> rep -> int list list -> term *)
@@ -644,7 +658,7 @@
end
| ConstName (s, T, _) =>
(assign_operator_for_const (s, T),
- user_friendly_const ext_ctxt (base_name, step_name) formats (s, T),
+ user_friendly_const hol_ctxt (base_name, step_name) formats (s, T),
T)
| _ => raise NUT ("Nitpick_Model.reconstruct_hol_model.\
\pretty_for_assign", [name])
@@ -724,15 +738,16 @@
(* scope -> Time.time option -> nut list -> nut list -> nut NameTable.table
-> KK.raw_bound list -> term -> bool option *)
-fun prove_hol_model (scope as {ext_ctxt as {thy, ctxt, debug, ...},
+fun prove_hol_model (scope as {hol_ctxt as {thy, ctxt, debug, ...},
card_assigns, ...})
auto_timeout free_names sel_names rel_table bounds prop =
let
+ val pool = Unsynchronized.ref []
(* typ * int -> term *)
fun free_type_assm (T, k) =
let
(* int -> term *)
- val atom = atom true T
+ fun atom j = nth_atom pool true T j k
fun equation_for_atom j = HOLogic.eq_const T $ Bound 0 $ atom j
val eqs = map equation_for_atom (index_seq 0 k)
val compreh_assm =
--- a/src/HOL/Tools/Nitpick/nitpick_mono.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Nitpick/nitpick_mono.ML Thu Feb 11 12:26:50 2010 -0800
@@ -8,10 +8,10 @@
signature NITPICK_MONO =
sig
datatype sign = Plus | Minus
- type extended_context = Nitpick_HOL.extended_context
+ type hol_context = Nitpick_HOL.hol_context
val formulas_monotonic :
- extended_context -> typ -> sign -> term list -> term list -> term -> bool
+ hol_context -> typ -> sign -> term list -> term list -> term -> bool
end;
structure Nitpick_Mono : NITPICK_MONO =
@@ -35,7 +35,7 @@
CRec of string * typ list
type cdata =
- {ext_ctxt: extended_context,
+ {hol_ctxt: hol_context,
alpha_T: typ,
max_fresh: int Unsynchronized.ref,
datatype_cache: ((string * typ list) * ctype) list Unsynchronized.ref,
@@ -114,9 +114,9 @@
| flatten_ctype (CType (_, Cs)) = maps flatten_ctype Cs
| flatten_ctype C = [C]
-(* extended_context -> typ -> cdata *)
-fun initial_cdata ext_ctxt alpha_T =
- ({ext_ctxt = ext_ctxt, alpha_T = alpha_T, max_fresh = Unsynchronized.ref 0,
+(* hol_context -> typ -> cdata *)
+fun initial_cdata hol_ctxt alpha_T =
+ ({hol_ctxt = hol_ctxt, alpha_T = alpha_T, max_fresh = Unsynchronized.ref 0,
datatype_cache = Unsynchronized.ref [],
constr_cache = Unsynchronized.ref []} : cdata)
@@ -188,7 +188,7 @@
in List.app repair_one (!constr_cache) end
(* cdata -> typ -> ctype *)
-fun fresh_ctype_for_type ({ext_ctxt as {thy, ...}, alpha_T, max_fresh,
+fun fresh_ctype_for_type ({hol_ctxt as {thy, ...}, alpha_T, max_fresh,
datatype_cache, constr_cache, ...} : cdata) =
let
(* typ -> typ -> ctype *)
@@ -217,7 +217,7 @@
| NONE =>
let
val _ = Unsynchronized.change datatype_cache (cons (z, CRec z))
- val xs = datatype_constrs ext_ctxt T
+ val xs = datatype_constrs hol_ctxt T
val (all_Cs, constr_Cs) =
fold_rev (fn (_, T') => fn (all_Cs, constr_Cs) =>
let
@@ -264,7 +264,7 @@
end
(* cdata -> styp -> ctype *)
-fun ctype_for_constr (cdata as {ext_ctxt as {thy, ...}, alpha_T, constr_cache,
+fun ctype_for_constr (cdata as {hol_ctxt as {thy, ...}, alpha_T, constr_cache,
...}) (x as (_, T)) =
if could_exist_alpha_sub_ctype thy alpha_T T then
case AList.lookup (op =) (!constr_cache) x of
@@ -278,8 +278,8 @@
AList.lookup (op =) (!constr_cache) x |> the)
else
fresh_ctype_for_type cdata T
-fun ctype_for_sel (cdata as {ext_ctxt, ...}) (x as (s, _)) =
- x |> boxed_constr_for_sel ext_ctxt |> ctype_for_constr cdata
+fun ctype_for_sel (cdata as {hol_ctxt, ...}) (x as (s, _)) =
+ x |> boxed_constr_for_sel hol_ctxt |> ctype_for_constr cdata
|> sel_ctype_from_constr_ctype s
(* literal list -> ctype -> ctype *)
@@ -549,7 +549,7 @@
handle List.Empty => initial_gamma
(* cdata -> term -> accumulator -> ctype * accumulator *)
-fun consider_term (cdata as {ext_ctxt as {ctxt, thy, def_table, ...}, alpha_T,
+fun consider_term (cdata as {hol_ctxt as {ctxt, thy, def_table, ...}, alpha_T,
max_fresh, ...}) =
let
(* typ -> ctype *)
@@ -806,7 +806,7 @@
in do_term end
(* cdata -> sign -> term -> accumulator -> accumulator *)
-fun consider_general_formula (cdata as {ext_ctxt as {ctxt, ...}, ...}) =
+fun consider_general_formula (cdata as {hol_ctxt as {ctxt, ...}, ...}) =
let
(* typ -> ctype *)
val ctype_for = fresh_ctype_for_type cdata
@@ -895,7 +895,7 @@
not (is_harmless_axiom t) ? consider_general_formula cdata sn t
(* cdata -> term -> accumulator -> accumulator *)
-fun consider_definitional_axiom (cdata as {ext_ctxt as {thy, ...}, ...}) t =
+fun consider_definitional_axiom (cdata as {hol_ctxt as {thy, ...}, ...}) t =
if not (is_constr_pattern_formula thy t) then
consider_nondefinitional_axiom cdata Plus t
else if is_harmless_axiom t then
@@ -945,13 +945,13 @@
map (fn (x, C) => string_for_ctype_of_term ctxt lits (Const x) C) consts
|> cat_lines |> print_g
-(* extended_context -> typ -> sign -> term list -> term list -> term -> bool *)
-fun formulas_monotonic (ext_ctxt as {ctxt, ...}) alpha_T sn def_ts nondef_ts
+(* hol_context -> typ -> sign -> term list -> term list -> term -> bool *)
+fun formulas_monotonic (hol_ctxt as {ctxt, ...}) alpha_T sn def_ts nondef_ts
core_t =
let
val _ = print_g ("****** " ^ string_for_ctype CAlpha ^ " is " ^
Syntax.string_of_typ ctxt alpha_T)
- val cdata as {max_fresh, ...} = initial_cdata ext_ctxt alpha_T
+ val cdata as {max_fresh, ...} = initial_cdata hol_ctxt alpha_T
val (gamma, cset) =
(initial_gamma, slack)
|> fold (consider_definitional_axiom cdata) def_ts
--- a/src/HOL/Tools/Nitpick/nitpick_nut.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Nitpick/nitpick_nut.ML Thu Feb 11 12:26:50 2010 -0800
@@ -8,7 +8,7 @@
signature NITPICK_NUT =
sig
type special_fun = Nitpick_HOL.special_fun
- type extended_context = Nitpick_HOL.extended_context
+ type hol_context = Nitpick_HOL.hol_context
type scope = Nitpick_Scope.scope
type name_pool = Nitpick_Peephole.name_pool
type rep = Nitpick_Rep.rep
@@ -106,7 +106,7 @@
val name_ord : (nut * nut) -> order
val the_name : 'a NameTable.table -> nut -> 'a
val the_rel : nut NameTable.table -> nut -> Kodkod.n_ary_index
- val nut_from_term : extended_context -> op2 -> term -> nut
+ val nut_from_term : hol_context -> op2 -> term -> nut
val choose_reps_for_free_vars :
scope -> nut list -> rep NameTable.table -> nut list * rep NameTable.table
val choose_reps_for_consts :
@@ -466,8 +466,8 @@
fun factorize (z as (Type ("*", _), _)) = maps factorize [mk_fst z, mk_snd z]
| factorize z = [z]
-(* extended_context -> op2 -> term -> nut *)
-fun nut_from_term (ext_ctxt as {thy, fast_descrs, special_funs, ...}) eq =
+(* hol_context -> op2 -> term -> nut *)
+fun nut_from_term (hol_ctxt as {thy, fast_descrs, special_funs, ...}) eq =
let
(* string list -> typ list -> term -> nut *)
fun aux eq ss Ts t =
@@ -597,7 +597,7 @@
Op2 (Image, nth_range_type 2 T, Any, sub t1, sub t2)
| (Const (@{const_name Suc}, T), []) => Cst (Suc, T, Any)
| (Const (@{const_name finite}, T), [t1]) =>
- (if is_finite_type ext_ctxt (domain_type T) then
+ (if is_finite_type hol_ctxt (domain_type T) then
Cst (True, bool_T, Any)
else case t1 of
Const (@{const_name top}, _) => Cst (False, bool_T, Any)
@@ -712,7 +712,7 @@
in (v :: vs, NameTable.update (v, R) table) end
(* scope -> bool -> nut -> nut list * rep NameTable.table
-> nut list * rep NameTable.table *)
-fun choose_rep_for_const (scope as {ext_ctxt as {thy, ctxt, ...}, datatypes,
+fun choose_rep_for_const (scope as {hol_ctxt as {thy, ctxt, ...}, datatypes,
ofs, ...}) all_exact v (vs, table) =
let
val x as (s, T) = (nickname_of v, type_of v)
@@ -747,10 +747,10 @@
(* scope -> styp -> int -> nut list * rep NameTable.table
-> nut list * rep NameTable.table *)
-fun choose_rep_for_nth_sel_for_constr (scope as {ext_ctxt, ...}) (x as (_, T)) n
+fun choose_rep_for_nth_sel_for_constr (scope as {hol_ctxt, ...}) (x as (_, T)) n
(vs, table) =
let
- val (s', T') = boxed_nth_sel_for_constr ext_ctxt x n
+ val (s', T') = boxed_nth_sel_for_constr hol_ctxt x n
val R' = if n = ~1 orelse is_word_type (body_type T) orelse
(is_fun_type (range_type T') andalso
is_boolean_type (body_type T')) then
@@ -890,7 +890,7 @@
| untuple f u = if rep_of u = Unit then [] else [f u]
(* scope -> bool -> rep NameTable.table -> bool -> nut -> nut *)
-fun choose_reps_in_nut (scope as {ext_ctxt as {thy, ctxt, ...}, card_assigns,
+fun choose_reps_in_nut (scope as {hol_ctxt as {thy, ctxt, ...}, card_assigns,
bits, datatypes, ofs, ...})
liberal table def =
let
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/Nitpick/nitpick_preproc.ML Thu Feb 11 12:26:50 2010 -0800
@@ -0,0 +1,1431 @@
+(* Title: HOL/Tools/Nitpick/nitpick_preproc.ML
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2008, 2009, 2010
+
+Nitpick's HOL preprocessor.
+*)
+
+signature NITPICK_PREPROC =
+sig
+ type hol_context = Nitpick_HOL.hol_context
+ val preprocess_term :
+ hol_context -> term -> ((term list * term list) * (bool * bool)) * term
+end
+
+structure Nitpick_Preproc : NITPICK_PREPROC =
+struct
+
+open Nitpick_Util
+open Nitpick_HOL
+
+(* polarity -> string -> bool *)
+fun is_positive_existential polar quant_s =
+ (polar = Pos andalso quant_s = @{const_name Ex}) orelse
+ (polar = Neg andalso quant_s <> @{const_name Ex})
+
+(** Binary coding of integers **)
+
+(* If a formula contains a numeral whose absolute value is more than this
+ threshold, the unary coding is likely not to work well and we prefer the
+ binary coding. *)
+val binary_int_threshold = 3
+
+(* term -> bool *)
+fun may_use_binary_ints (t1 $ t2) =
+ may_use_binary_ints t1 andalso may_use_binary_ints t2
+ | may_use_binary_ints (t as Const (s, _)) =
+ t <> @{const Suc} andalso
+ not (member (op =) [@{const_name Abs_Frac}, @{const_name Rep_Frac},
+ @{const_name nat_gcd}, @{const_name nat_lcm},
+ @{const_name Frac}, @{const_name norm_frac}] s)
+ | may_use_binary_ints (Abs (_, _, t')) = may_use_binary_ints t'
+ | may_use_binary_ints _ = true
+fun should_use_binary_ints (t1 $ t2) =
+ should_use_binary_ints t1 orelse should_use_binary_ints t2
+ | should_use_binary_ints (Const (s, _)) =
+ member (op =) [@{const_name times_nat_inst.times_nat},
+ @{const_name div_nat_inst.div_nat},
+ @{const_name times_int_inst.times_int},
+ @{const_name div_int_inst.div_int}] s orelse
+ (String.isPrefix numeral_prefix s andalso
+ let val n = the (Int.fromString (unprefix numeral_prefix s)) in
+ n < ~ binary_int_threshold orelse n > binary_int_threshold
+ end)
+ | should_use_binary_ints (Abs (_, _, t')) = should_use_binary_ints t'
+ | should_use_binary_ints _ = false
+
+(* typ -> typ *)
+fun binarize_nat_and_int_in_type @{typ nat} = @{typ "unsigned_bit word"}
+ | binarize_nat_and_int_in_type @{typ int} = @{typ "signed_bit word"}
+ | binarize_nat_and_int_in_type (Type (s, Ts)) =
+ Type (s, map binarize_nat_and_int_in_type Ts)
+ | binarize_nat_and_int_in_type T = T
+(* term -> term *)
+val binarize_nat_and_int_in_term = map_types binarize_nat_and_int_in_type
+
+(** Uncurrying **)
+
+(* theory -> term -> int Termtab.tab -> int Termtab.tab *)
+fun add_to_uncurry_table thy t =
+ let
+ (* term -> term list -> int Termtab.tab -> int Termtab.tab *)
+ fun aux (t1 $ t2) args table =
+ let val table = aux t2 [] table in aux t1 (t2 :: args) table end
+ | aux (Abs (_, _, t')) _ table = aux t' [] table
+ | aux (t as Const (x as (s, _))) args table =
+ if is_built_in_const true x orelse is_constr_like thy x orelse
+ is_sel s orelse s = @{const_name Sigma} then
+ table
+ else
+ Termtab.map_default (t, 65536) (curry Int.min (length args)) table
+ | aux _ _ table = table
+ in aux t [] end
+
+(* int -> int -> string *)
+fun uncurry_prefix_for k j =
+ uncurry_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
+
+(* int Termtab.tab term -> term *)
+fun uncurry_term table t =
+ let
+ (* term -> term list -> term *)
+ fun aux (t1 $ t2) args = aux t1 (aux t2 [] :: args)
+ | aux (Abs (s, T, t')) args = betapplys (Abs (s, T, aux t' []), args)
+ | aux (t as Const (s, T)) args =
+ (case Termtab.lookup table t of
+ SOME n =>
+ if n >= 2 then
+ let
+ val (arg_Ts, rest_T) = strip_n_binders n T
+ val j =
+ if hd arg_Ts = @{typ bisim_iterator} orelse
+ is_fp_iterator_type (hd arg_Ts) then
+ 1
+ else case find_index (not_equal bool_T) arg_Ts of
+ ~1 => n
+ | j => j
+ val ((before_args, tuple_args), after_args) =
+ args |> chop n |>> chop j
+ val ((before_arg_Ts, tuple_arg_Ts), rest_T) =
+ T |> strip_n_binders n |>> chop j
+ val tuple_T = HOLogic.mk_tupleT tuple_arg_Ts
+ in
+ if n - j < 2 then
+ betapplys (t, args)
+ else
+ betapplys (Const (uncurry_prefix_for (n - j) j ^ s,
+ before_arg_Ts ---> tuple_T --> rest_T),
+ before_args @ [mk_flat_tuple tuple_T tuple_args] @
+ after_args)
+ end
+ else
+ betapplys (t, args)
+ | NONE => betapplys (t, args))
+ | aux t args = betapplys (t, args)
+ in aux t [] end
+
+(** Boxing **)
+
+(* hol_context -> typ -> term -> term *)
+fun constr_expand (hol_ctxt as {thy, ...}) T t =
+ (case head_of t of
+ Const x => if is_constr_like thy x then t else raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () =>
+ let
+ val x' as (_, T') =
+ if is_pair_type T then
+ let val (T1, T2) = HOLogic.dest_prodT T in
+ (@{const_name Pair}, T1 --> T2 --> T)
+ end
+ else
+ datatype_constrs hol_ctxt T |> hd
+ val arg_Ts = binder_types T'
+ in
+ list_comb (Const x', map2 (select_nth_constr_arg thy x' t)
+ (index_seq 0 (length arg_Ts)) arg_Ts)
+ end
+
+(* hol_context -> bool -> term -> term *)
+fun box_fun_and_pair_in_term (hol_ctxt as {thy, fast_descrs, ...}) def orig_t =
+ let
+ (* typ -> typ *)
+ fun box_relational_operator_type (Type ("fun", Ts)) =
+ Type ("fun", map box_relational_operator_type Ts)
+ | box_relational_operator_type (Type ("*", Ts)) =
+ Type ("*", map (box_type hol_ctxt InPair) Ts)
+ | box_relational_operator_type T = T
+ (* (term -> term) -> int -> term -> term *)
+ fun coerce_bound_no f j t =
+ case t of
+ t1 $ t2 => coerce_bound_no f j t1 $ coerce_bound_no f j t2
+ | Abs (s, T, t') => Abs (s, T, coerce_bound_no f (j + 1) t')
+ | Bound j' => if j' = j then f t else t
+ | _ => t
+ (* typ -> typ -> term -> term *)
+ fun coerce_bound_0_in_term new_T old_T =
+ old_T <> new_T ? coerce_bound_no (coerce_term [new_T] old_T new_T) 0
+ (* typ list -> typ -> term -> term *)
+ and coerce_term Ts new_T old_T t =
+ if old_T = new_T then
+ t
+ else
+ case (new_T, old_T) of
+ (Type (new_s, new_Ts as [new_T1, new_T2]),
+ Type ("fun", [old_T1, old_T2])) =>
+ (case eta_expand Ts t 1 of
+ Abs (s, _, t') =>
+ Abs (s, new_T1,
+ t' |> coerce_bound_0_in_term new_T1 old_T1
+ |> coerce_term (new_T1 :: Ts) new_T2 old_T2)
+ |> Envir.eta_contract
+ |> new_s <> "fun"
+ ? construct_value thy (@{const_name FunBox},
+ Type ("fun", new_Ts) --> new_T) o single
+ | t' => raise TERM ("Nitpick_Preproc.box_fun_and_pair_in_term.\
+ \coerce_term", [t']))
+ | (Type (new_s, new_Ts as [new_T1, new_T2]),
+ Type (old_s, old_Ts as [old_T1, old_T2])) =>
+ if old_s = @{type_name fun_box} orelse
+ old_s = @{type_name pair_box} orelse old_s = "*" then
+ case constr_expand hol_ctxt old_T t of
+ Const (@{const_name FunBox}, _) $ t1 =>
+ if new_s = "fun" then
+ coerce_term Ts new_T (Type ("fun", old_Ts)) t1
+ else
+ construct_value thy
+ (@{const_name FunBox}, Type ("fun", new_Ts) --> new_T)
+ [coerce_term Ts (Type ("fun", new_Ts))
+ (Type ("fun", old_Ts)) t1]
+ | Const _ $ t1 $ t2 =>
+ construct_value thy
+ (if new_s = "*" then @{const_name Pair}
+ else @{const_name PairBox}, new_Ts ---> new_T)
+ [coerce_term Ts new_T1 old_T1 t1,
+ coerce_term Ts new_T2 old_T2 t2]
+ | t' => raise TERM ("Nitpick_Preproc.box_fun_and_pair_in_term.\
+ \coerce_term", [t'])
+ else
+ raise TYPE ("coerce_term", [new_T, old_T], [t])
+ | _ => raise TYPE ("coerce_term", [new_T, old_T], [t])
+ (* indexname * typ -> typ * term -> typ option list -> typ option list *)
+ fun add_boxed_types_for_var (z as (_, T)) (T', t') =
+ case t' of
+ Var z' => z' = z ? insert (op =) T'
+ | Const (@{const_name Pair}, _) $ t1 $ t2 =>
+ (case T' of
+ Type (_, [T1, T2]) =>
+ fold (add_boxed_types_for_var z) [(T1, t1), (T2, t2)]
+ | _ => raise TYPE ("Nitpick_Preproc.box_fun_and_pair_in_term.\
+ \add_boxed_types_for_var", [T'], []))
+ | _ => exists_subterm (curry (op =) (Var z)) t' ? insert (op =) T
+ (* typ list -> typ list -> term -> indexname * typ -> typ *)
+ fun box_var_in_def new_Ts old_Ts t (z as (_, T)) =
+ case t of
+ @{const Trueprop} $ t1 => box_var_in_def new_Ts old_Ts t1 z
+ | Const (s0, _) $ t1 $ _ =>
+ if s0 = @{const_name "=="} orelse s0 = @{const_name "op ="} then
+ let
+ val (t', args) = strip_comb t1
+ val T' = fastype_of1 (new_Ts, do_term new_Ts old_Ts Neut t')
+ in
+ case fold (add_boxed_types_for_var z)
+ (fst (strip_n_binders (length args) T') ~~ args) [] of
+ [T''] => T''
+ | _ => T
+ end
+ else
+ T
+ | _ => T
+ (* typ list -> typ list -> polarity -> string -> typ -> string -> typ
+ -> term -> term *)
+ and do_quantifier new_Ts old_Ts polar quant_s quant_T abs_s abs_T t =
+ let
+ val abs_T' =
+ if polar = Neut orelse is_positive_existential polar quant_s then
+ box_type hol_ctxt InFunLHS abs_T
+ else
+ abs_T
+ val body_T = body_type quant_T
+ in
+ Const (quant_s, (abs_T' --> body_T) --> body_T)
+ $ Abs (abs_s, abs_T',
+ t |> do_term (abs_T' :: new_Ts) (abs_T :: old_Ts) polar)
+ end
+ (* typ list -> typ list -> string -> typ -> term -> term -> term *)
+ and do_equals new_Ts old_Ts s0 T0 t1 t2 =
+ let
+ val (t1, t2) = pairself (do_term new_Ts old_Ts Neut) (t1, t2)
+ val (T1, T2) = pairself (curry fastype_of1 new_Ts) (t1, t2)
+ val T = [T1, T2] |> sort TermOrd.typ_ord |> List.last
+ in
+ list_comb (Const (s0, T --> T --> body_type T0),
+ map2 (coerce_term new_Ts T) [T1, T2] [t1, t2])
+ end
+ (* string -> typ -> term *)
+ and do_description_operator s T =
+ let val T1 = box_type hol_ctxt InFunLHS (range_type T) in
+ Const (s, (T1 --> bool_T) --> T1)
+ end
+ (* typ list -> typ list -> polarity -> term -> term *)
+ and do_term new_Ts old_Ts polar t =
+ case t of
+ Const (s0 as @{const_name all}, T0) $ Abs (s1, T1, t1) =>
+ do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
+ | Const (s0 as @{const_name "=="}, T0) $ t1 $ t2 =>
+ do_equals new_Ts old_Ts s0 T0 t1 t2
+ | @{const "==>"} $ t1 $ t2 =>
+ @{const "==>"} $ do_term new_Ts old_Ts (flip_polarity polar) t1
+ $ do_term new_Ts old_Ts polar t2
+ | @{const Pure.conjunction} $ t1 $ t2 =>
+ @{const Pure.conjunction} $ do_term new_Ts old_Ts polar t1
+ $ do_term new_Ts old_Ts polar t2
+ | @{const Trueprop} $ t1 =>
+ @{const Trueprop} $ do_term new_Ts old_Ts polar t1
+ | @{const Not} $ t1 =>
+ @{const Not} $ do_term new_Ts old_Ts (flip_polarity polar) t1
+ | Const (s0 as @{const_name All}, T0) $ Abs (s1, T1, t1) =>
+ do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
+ | Const (s0 as @{const_name Ex}, T0) $ Abs (s1, T1, t1) =>
+ do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
+ | Const (s0 as @{const_name "op ="}, T0) $ t1 $ t2 =>
+ do_equals new_Ts old_Ts s0 T0 t1 t2
+ | @{const "op &"} $ t1 $ t2 =>
+ @{const "op &"} $ do_term new_Ts old_Ts polar t1
+ $ do_term new_Ts old_Ts polar t2
+ | @{const "op |"} $ t1 $ t2 =>
+ @{const "op |"} $ do_term new_Ts old_Ts polar t1
+ $ do_term new_Ts old_Ts polar t2
+ | @{const "op -->"} $ t1 $ t2 =>
+ @{const "op -->"} $ do_term new_Ts old_Ts (flip_polarity polar) t1
+ $ do_term new_Ts old_Ts polar t2
+ | Const (s as @{const_name The}, T) => do_description_operator s T
+ | Const (s as @{const_name Eps}, T) => do_description_operator s T
+ | Const (@{const_name quot_normal}, Type ("fun", [_, T2])) =>
+ let val T' = box_type hol_ctxt InSel T2 in
+ Const (@{const_name quot_normal}, T' --> T')
+ end
+ | Const (s as @{const_name Tha}, T) => do_description_operator s T
+ | Const (x as (s, T)) =>
+ Const (s, if s = @{const_name converse} orelse
+ s = @{const_name trancl} then
+ box_relational_operator_type T
+ else if is_built_in_const fast_descrs x orelse
+ s = @{const_name Sigma} then
+ T
+ else if is_constr_like thy x then
+ box_type hol_ctxt InConstr T
+ else if is_sel s
+ orelse is_rep_fun thy x then
+ box_type hol_ctxt InSel T
+ else
+ box_type hol_ctxt InExpr T)
+ | t1 $ Abs (s, T, t2') =>
+ let
+ val t1 = do_term new_Ts old_Ts Neut t1
+ val T1 = fastype_of1 (new_Ts, t1)
+ val (s1, Ts1) = dest_Type T1
+ val T' = hd (snd (dest_Type (hd Ts1)))
+ val t2 = Abs (s, T', do_term (T' :: new_Ts) (T :: old_Ts) Neut t2')
+ val T2 = fastype_of1 (new_Ts, t2)
+ val t2 = coerce_term new_Ts (hd Ts1) T2 t2
+ in
+ betapply (if s1 = "fun" then
+ t1
+ else
+ select_nth_constr_arg thy
+ (@{const_name FunBox}, Type ("fun", Ts1) --> T1) t1 0
+ (Type ("fun", Ts1)), t2)
+ end
+ | t1 $ t2 =>
+ let
+ val t1 = do_term new_Ts old_Ts Neut t1
+ val T1 = fastype_of1 (new_Ts, t1)
+ val (s1, Ts1) = dest_Type T1
+ val t2 = do_term new_Ts old_Ts Neut t2
+ val T2 = fastype_of1 (new_Ts, t2)
+ val t2 = coerce_term new_Ts (hd Ts1) T2 t2
+ in
+ betapply (if s1 = "fun" then
+ t1
+ else
+ select_nth_constr_arg thy
+ (@{const_name FunBox}, Type ("fun", Ts1) --> T1) t1 0
+ (Type ("fun", Ts1)), t2)
+ end
+ | Free (s, T) => Free (s, box_type hol_ctxt InExpr T)
+ | Var (z as (x, T)) =>
+ Var (x, if def then box_var_in_def new_Ts old_Ts orig_t z
+ else box_type hol_ctxt InExpr T)
+ | Bound _ => t
+ | Abs (s, T, t') =>
+ Abs (s, T, do_term (T :: new_Ts) (T :: old_Ts) Neut t')
+ in do_term [] [] Pos orig_t end
+
+(** Destruction of constructors **)
+
+val val_var_prefix = nitpick_prefix ^ "v"
+
+(* typ list -> int -> int -> int -> term -> term *)
+fun fresh_value_var Ts k n j t =
+ Var ((val_var_prefix ^ nat_subscript (n - j), k), fastype_of1 (Ts, t))
+
+(* typ list -> int -> term -> bool *)
+fun has_heavy_bounds_or_vars Ts level t =
+ let
+ (* typ list -> bool *)
+ fun aux [] = false
+ | aux [T] = is_fun_type T orelse is_pair_type T
+ | aux _ = true
+ in aux (map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t)) end
+
+(* theory -> typ list -> bool -> int -> int -> term -> term list -> term list
+ -> term * term list *)
+fun pull_out_constr_comb thy Ts relax k level t args seen =
+ let val t_comb = list_comb (t, args) in
+ case t of
+ Const x =>
+ if not relax andalso is_constr thy x andalso
+ not (is_fun_type (fastype_of1 (Ts, t_comb))) andalso
+ has_heavy_bounds_or_vars Ts level t_comb andalso
+ not (loose_bvar (t_comb, level)) then
+ let
+ val (j, seen) = case find_index (curry (op =) t_comb) seen of
+ ~1 => (0, t_comb :: seen)
+ | j => (j, seen)
+ in (fresh_value_var Ts k (length seen) j t_comb, seen) end
+ else
+ (t_comb, seen)
+ | _ => (t_comb, seen)
+ end
+
+(* (term -> term) -> typ list -> int -> term list -> term list *)
+fun equations_for_pulled_out_constrs mk_eq Ts k seen =
+ let val n = length seen in
+ map2 (fn j => fn t => mk_eq (fresh_value_var Ts k n j t, t))
+ (index_seq 0 n) seen
+ end
+
+(* theory -> bool -> term -> term *)
+fun pull_out_universal_constrs thy def t =
+ let
+ val k = maxidx_of_term t + 1
+ (* typ list -> bool -> term -> term list -> term list -> term * term list *)
+ fun do_term Ts def t args seen =
+ case t of
+ (t0 as Const (@{const_name "=="}, _)) $ t1 $ t2 =>
+ do_eq_or_imp Ts true def t0 t1 t2 seen
+ | (t0 as @{const "==>"}) $ t1 $ t2 =>
+ if def then (t, []) else do_eq_or_imp Ts false def t0 t1 t2 seen
+ | (t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2 =>
+ do_eq_or_imp Ts true def t0 t1 t2 seen
+ | (t0 as @{const "op -->"}) $ t1 $ t2 =>
+ do_eq_or_imp Ts false def t0 t1 t2 seen
+ | Abs (s, T, t') =>
+ let val (t', seen) = do_term (T :: Ts) def t' [] seen in
+ (list_comb (Abs (s, T, t'), args), seen)
+ end
+ | t1 $ t2 =>
+ let val (t2, seen) = do_term Ts def t2 [] seen in
+ do_term Ts def t1 (t2 :: args) seen
+ end
+ | _ => pull_out_constr_comb thy Ts def k 0 t args seen
+ (* typ list -> bool -> bool -> term -> term -> term -> term list
+ -> term * term list *)
+ and do_eq_or_imp Ts eq def t0 t1 t2 seen =
+ let
+ val (t2, seen) = if eq andalso def then (t2, seen)
+ else do_term Ts false t2 [] seen
+ val (t1, seen) = do_term Ts false t1 [] seen
+ in (t0 $ t1 $ t2, seen) end
+ val (concl, seen) = do_term [] def t [] []
+ in
+ Logic.list_implies (equations_for_pulled_out_constrs Logic.mk_equals [] k
+ seen, concl)
+ end
+
+(* term -> term -> term *)
+fun mk_exists v t =
+ HOLogic.exists_const (fastype_of v) $ lambda v (incr_boundvars 1 t)
+
+(* theory -> term -> term *)
+fun pull_out_existential_constrs thy t =
+ let
+ val k = maxidx_of_term t + 1
+ (* typ list -> int -> term -> term list -> term list -> term * term list *)
+ fun aux Ts num_exists t args seen =
+ case t of
+ (t0 as Const (@{const_name Ex}, _)) $ Abs (s1, T1, t1) =>
+ let
+ val (t1, seen') = aux (T1 :: Ts) (num_exists + 1) t1 [] []
+ val n = length seen'
+ (* unit -> term list *)
+ fun vars () = map2 (fresh_value_var Ts k n) (index_seq 0 n) seen'
+ in
+ (equations_for_pulled_out_constrs HOLogic.mk_eq Ts k seen'
+ |> List.foldl s_conj t1 |> fold mk_exists (vars ())
+ |> curry3 Abs s1 T1 |> curry (op $) t0, seen)
+ end
+ | t1 $ t2 =>
+ let val (t2, seen) = aux Ts num_exists t2 [] seen in
+ aux Ts num_exists t1 (t2 :: args) seen
+ end
+ | Abs (s, T, t') =>
+ let
+ val (t', seen) = aux (T :: Ts) 0 t' [] (map (incr_boundvars 1) seen)
+ in (list_comb (Abs (s, T, t'), args), map (incr_boundvars ~1) seen) end
+ | _ =>
+ if num_exists > 0 then
+ pull_out_constr_comb thy Ts false k num_exists t args seen
+ else
+ (list_comb (t, args), seen)
+ in aux [] 0 t [] [] |> fst end
+
+(* hol_context -> bool -> term -> term *)
+fun destroy_pulled_out_constrs (hol_ctxt as {thy, ...}) axiom t =
+ let
+ (* styp -> int *)
+ val num_occs_of_var =
+ fold_aterms (fn Var z => (fn f => fn z' => f z' |> z = z' ? Integer.add 1)
+ | _ => I) t (K 0)
+ (* bool -> term -> term *)
+ fun aux careful ((t0 as Const (@{const_name "=="}, _)) $ t1 $ t2) =
+ aux_eq careful true t0 t1 t2
+ | aux careful ((t0 as @{const "==>"}) $ t1 $ t2) =
+ t0 $ aux false t1 $ aux careful t2
+ | aux careful ((t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2) =
+ aux_eq careful true t0 t1 t2
+ | aux careful ((t0 as @{const "op -->"}) $ t1 $ t2) =
+ t0 $ aux false t1 $ aux careful t2
+ | aux careful (Abs (s, T, t')) = Abs (s, T, aux careful t')
+ | aux careful (t1 $ t2) = aux careful t1 $ aux careful t2
+ | aux _ t = t
+ (* bool -> bool -> term -> term -> term -> term *)
+ and aux_eq careful pass1 t0 t1 t2 =
+ ((if careful then
+ raise SAME ()
+ else if axiom andalso is_Var t2 andalso
+ num_occs_of_var (dest_Var t2) = 1 then
+ @{const True}
+ else case strip_comb t2 of
+ (* The first case is not as general as it could be. *)
+ (Const (@{const_name PairBox}, _),
+ [Const (@{const_name fst}, _) $ Var z1,
+ Const (@{const_name snd}, _) $ Var z2]) =>
+ if z1 = z2 andalso num_occs_of_var z1 = 2 then @{const True}
+ else raise SAME ()
+ | (Const (x as (s, T)), args) =>
+ let val arg_Ts = binder_types T in
+ if length arg_Ts = length args andalso
+ (is_constr thy x orelse s = @{const_name Pair} orelse
+ x = (@{const_name Suc}, nat_T --> nat_T)) andalso
+ (not careful orelse not (is_Var t1) orelse
+ String.isPrefix val_var_prefix (fst (fst (dest_Var t1)))) then
+ discriminate_value hol_ctxt x t1 ::
+ map3 (sel_eq x t1) (index_seq 0 (length args)) arg_Ts args
+ |> foldr1 s_conj
+ else
+ raise SAME ()
+ end
+ | _ => raise SAME ())
+ |> body_type (type_of t0) = prop_T ? HOLogic.mk_Trueprop)
+ handle SAME () => if pass1 then aux_eq careful false t0 t2 t1
+ else t0 $ aux false t2 $ aux false t1
+ (* styp -> term -> int -> typ -> term -> term *)
+ and sel_eq x t n nth_T nth_t =
+ HOLogic.eq_const nth_T $ nth_t $ select_nth_constr_arg thy x t n nth_T
+ |> aux false
+ in aux axiom t end
+
+(** Destruction of universal and existential equalities **)
+
+(* term -> term *)
+fun curry_assms (@{const "==>"} $ (@{const Trueprop}
+ $ (@{const "op &"} $ t1 $ t2)) $ t3) =
+ curry_assms (Logic.list_implies ([t1, t2] |> map HOLogic.mk_Trueprop, t3))
+ | curry_assms (@{const "==>"} $ t1 $ t2) =
+ @{const "==>"} $ curry_assms t1 $ curry_assms t2
+ | curry_assms t = t
+
+(* term -> term *)
+val destroy_universal_equalities =
+ let
+ (* term list -> (indexname * typ) list -> term -> term *)
+ fun aux prems zs t =
+ case t of
+ @{const "==>"} $ t1 $ t2 => aux_implies prems zs t1 t2
+ | _ => Logic.list_implies (rev prems, t)
+ (* term list -> (indexname * typ) list -> term -> term -> term *)
+ and aux_implies prems zs t1 t2 =
+ case t1 of
+ Const (@{const_name "=="}, _) $ Var z $ t' => aux_eq prems zs z t' t1 t2
+ | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ Var z $ t') =>
+ aux_eq prems zs z t' t1 t2
+ | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t' $ Var z) =>
+ aux_eq prems zs z t' t1 t2
+ | _ => aux (t1 :: prems) (Term.add_vars t1 zs) t2
+ (* term list -> (indexname * typ) list -> indexname * typ -> term -> term
+ -> term -> term *)
+ and aux_eq prems zs z t' t1 t2 =
+ if not (member (op =) zs z) andalso
+ not (exists_subterm (curry (op =) (Var z)) t') then
+ aux prems zs (subst_free [(Var z, t')] t2)
+ else
+ aux (t1 :: prems) (Term.add_vars t1 zs) t2
+ in aux [] [] end
+
+(* theory -> int -> term list -> term list -> (term * term list) option *)
+fun find_bound_assign _ _ _ [] = NONE
+ | find_bound_assign thy j seen (t :: ts) =
+ let
+ (* bool -> term -> term -> (term * term list) option *)
+ fun aux pass1 t1 t2 =
+ (if loose_bvar1 (t2, j) then
+ if pass1 then aux false t2 t1 else raise SAME ()
+ else case t1 of
+ Bound j' => if j' = j then SOME (t2, ts @ seen) else raise SAME ()
+ | Const (s, Type ("fun", [T1, T2])) $ Bound j' =>
+ if j' = j andalso
+ s = nth_sel_name_for_constr_name @{const_name FunBox} 0 then
+ SOME (construct_value thy (@{const_name FunBox}, T2 --> T1) [t2],
+ ts @ seen)
+ else
+ raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () => find_bound_assign thy j (t :: seen) ts
+ in
+ case t of
+ Const (@{const_name "op ="}, _) $ t1 $ t2 => aux true t1 t2
+ | _ => find_bound_assign thy j (t :: seen) ts
+ end
+
+(* int -> term -> term -> term *)
+fun subst_one_bound j arg t =
+ let
+ fun aux (Bound i, lev) =
+ if i < lev then raise SAME ()
+ else if i = lev then incr_boundvars (lev - j) arg
+ else Bound (i - 1)
+ | aux (Abs (a, T, body), lev) = Abs (a, T, aux (body, lev + 1))
+ | aux (f $ t, lev) =
+ (aux (f, lev) $ (aux (t, lev) handle SAME () => t)
+ handle SAME () => f $ aux (t, lev))
+ | aux _ = raise SAME ()
+ in aux (t, j) handle SAME () => t end
+
+(* theory -> term -> term *)
+fun destroy_existential_equalities thy =
+ let
+ (* string list -> typ list -> term list -> term *)
+ fun kill [] [] ts = foldr1 s_conj ts
+ | kill (s :: ss) (T :: Ts) ts =
+ (case find_bound_assign thy (length ss) [] ts of
+ SOME (_, []) => @{const True}
+ | SOME (arg_t, ts) =>
+ kill ss Ts (map (subst_one_bound (length ss)
+ (incr_bv (~1, length ss + 1, arg_t))) ts)
+ | NONE =>
+ Const (@{const_name Ex}, (T --> bool_T) --> bool_T)
+ $ Abs (s, T, kill ss Ts ts))
+ | kill _ _ _ = raise UnequalLengths
+ (* string list -> typ list -> term -> term *)
+ fun gather ss Ts ((t0 as Const (@{const_name Ex}, _)) $ Abs (s1, T1, t1)) =
+ gather (ss @ [s1]) (Ts @ [T1]) t1
+ | gather [] [] (Abs (s, T, t1)) = Abs (s, T, gather [] [] t1)
+ | gather [] [] (t1 $ t2) = gather [] [] t1 $ gather [] [] t2
+ | gather [] [] t = t
+ | gather ss Ts t = kill ss Ts (conjuncts_of (gather [] [] t))
+ in gather [] [] end
+
+(** Skolemization **)
+
+(* int -> int -> string *)
+fun skolem_prefix_for k j =
+ skolem_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
+
+(* hol_context -> int -> term -> term *)
+fun skolemize_term_and_more (hol_ctxt as {thy, def_table, skolems, ...})
+ skolem_depth =
+ let
+ (* int list -> int list *)
+ val incrs = map (Integer.add 1)
+ (* string list -> typ list -> int list -> int -> polarity -> term -> term *)
+ fun aux ss Ts js depth polar t =
+ let
+ (* string -> typ -> string -> typ -> term -> term *)
+ fun do_quantifier quant_s quant_T abs_s abs_T t =
+ if not (loose_bvar1 (t, 0)) then
+ aux ss Ts js depth polar (incr_boundvars ~1 t)
+ else if depth <= skolem_depth andalso
+ is_positive_existential polar quant_s then
+ let
+ val j = length (!skolems) + 1
+ val sko_s = skolem_prefix_for (length js) j ^ abs_s
+ val _ = Unsynchronized.change skolems (cons (sko_s, ss))
+ val sko_t = list_comb (Const (sko_s, rev Ts ---> abs_T),
+ map Bound (rev js))
+ val abs_t = Abs (abs_s, abs_T, aux ss Ts (incrs js) depth polar t)
+ in
+ if null js then betapply (abs_t, sko_t)
+ else Const (@{const_name Let}, abs_T --> quant_T) $ sko_t $ abs_t
+ end
+ else
+ Const (quant_s, quant_T)
+ $ Abs (abs_s, abs_T,
+ if is_higher_order_type abs_T then
+ t
+ else
+ aux (abs_s :: ss) (abs_T :: Ts) (0 :: incrs js)
+ (depth + 1) polar t)
+ in
+ case t of
+ Const (s0 as @{const_name all}, T0) $ Abs (s1, T1, t1) =>
+ do_quantifier s0 T0 s1 T1 t1
+ | @{const "==>"} $ t1 $ t2 =>
+ @{const "==>"} $ aux ss Ts js depth (flip_polarity polar) t1
+ $ aux ss Ts js depth polar t2
+ | @{const Pure.conjunction} $ t1 $ t2 =>
+ @{const Pure.conjunction} $ aux ss Ts js depth polar t1
+ $ aux ss Ts js depth polar t2
+ | @{const Trueprop} $ t1 =>
+ @{const Trueprop} $ aux ss Ts js depth polar t1
+ | @{const Not} $ t1 =>
+ @{const Not} $ aux ss Ts js depth (flip_polarity polar) t1
+ | Const (s0 as @{const_name All}, T0) $ Abs (s1, T1, t1) =>
+ do_quantifier s0 T0 s1 T1 t1
+ | Const (s0 as @{const_name Ex}, T0) $ Abs (s1, T1, t1) =>
+ do_quantifier s0 T0 s1 T1 t1
+ | @{const "op &"} $ t1 $ t2 =>
+ @{const "op &"} $ aux ss Ts js depth polar t1
+ $ aux ss Ts js depth polar t2
+ | @{const "op |"} $ t1 $ t2 =>
+ @{const "op |"} $ aux ss Ts js depth polar t1
+ $ aux ss Ts js depth polar t2
+ | @{const "op -->"} $ t1 $ t2 =>
+ @{const "op -->"} $ aux ss Ts js depth (flip_polarity polar) t1
+ $ aux ss Ts js depth polar t2
+ | (t0 as Const (@{const_name Let}, T0)) $ t1 $ t2 =>
+ t0 $ t1 $ aux ss Ts js depth polar t2
+ | Const (x as (s, T)) =>
+ if is_inductive_pred hol_ctxt x andalso
+ not (is_well_founded_inductive_pred hol_ctxt x) then
+ let
+ val gfp = (fixpoint_kind_of_const thy def_table x = Gfp)
+ val (pref, connective, set_oper) =
+ if gfp then
+ (lbfp_prefix,
+ @{const "op |"},
+ @{const_name semilattice_sup_fun_inst.sup_fun})
+ else
+ (ubfp_prefix,
+ @{const "op &"},
+ @{const_name semilattice_inf_fun_inst.inf_fun})
+ (* unit -> term *)
+ fun pos () = unrolled_inductive_pred_const hol_ctxt gfp x
+ |> aux ss Ts js depth polar
+ fun neg () = Const (pref ^ s, T)
+ in
+ (case polar |> gfp ? flip_polarity of
+ Pos => pos ()
+ | Neg => neg ()
+ | Neut =>
+ if is_fun_type T then
+ let
+ val ((trunk_arg_Ts, rump_arg_T), body_T) =
+ T |> strip_type |>> split_last
+ val set_T = rump_arg_T --> body_T
+ (* (unit -> term) -> term *)
+ fun app f =
+ list_comb (f (),
+ map Bound (length trunk_arg_Ts - 1 downto 0))
+ in
+ List.foldr absdummy
+ (Const (set_oper, set_T --> set_T --> set_T)
+ $ app pos $ app neg) trunk_arg_Ts
+ end
+ else
+ connective $ pos () $ neg ())
+ end
+ else
+ Const x
+ | t1 $ t2 =>
+ betapply (aux ss Ts [] (skolem_depth + 1) polar t1,
+ aux ss Ts [] depth Neut t2)
+ | Abs (s, T, t1) => Abs (s, T, aux ss Ts (incrs js) depth polar t1)
+ | _ => t
+ end
+ in aux [] [] [] 0 Pos end
+
+(** Function specialization **)
+
+(* term -> term list *)
+fun params_in_equation (@{const "==>"} $ _ $ t2) = params_in_equation t2
+ | params_in_equation (@{const Trueprop} $ t1) = params_in_equation t1
+ | params_in_equation (Const (@{const_name "op ="}, _) $ t1 $ _) =
+ snd (strip_comb t1)
+ | params_in_equation _ = []
+
+(* styp -> styp -> int list -> term list -> term list -> term -> term *)
+fun specialize_fun_axiom x x' fixed_js fixed_args extra_args t =
+ let
+ val k = fold Integer.max (map maxidx_of_term (fixed_args @ extra_args)) 0
+ + 1
+ val t = map_aterms (fn Var ((s, i), T) => Var ((s, k + i), T) | t' => t') t
+ val fixed_params = filter_indices fixed_js (params_in_equation t)
+ (* term list -> term -> term *)
+ fun aux args (Abs (s, T, t)) = list_comb (Abs (s, T, aux [] t), args)
+ | aux args (t1 $ t2) = aux (aux [] t2 :: args) t1
+ | aux args t =
+ if t = Const x then
+ list_comb (Const x', extra_args @ filter_out_indices fixed_js args)
+ else
+ let val j = find_index (curry (op =) t) fixed_params in
+ list_comb (if j >= 0 then nth fixed_args j else t, args)
+ end
+ in aux [] t end
+
+(* hol_context -> styp -> (int * term option) list *)
+fun static_args_in_term ({ersatz_table, ...} : hol_context) x t =
+ let
+ (* term -> term list -> term list -> term list list *)
+ fun fun_calls (Abs (_, _, t)) _ = fun_calls t []
+ | fun_calls (t1 $ t2) args = fun_calls t2 [] #> fun_calls t1 (t2 :: args)
+ | fun_calls t args =
+ (case t of
+ Const (x' as (s', T')) =>
+ x = x' orelse (case AList.lookup (op =) ersatz_table s' of
+ SOME s'' => x = (s'', T')
+ | NONE => false)
+ | _ => false) ? cons args
+ (* term list list -> term list list -> term list -> term list list *)
+ fun call_sets [] [] vs = [vs]
+ | call_sets [] uss vs = vs :: call_sets uss [] []
+ | call_sets ([] :: _) _ _ = []
+ | call_sets ((t :: ts) :: tss) uss vs =
+ OrdList.insert TermOrd.term_ord t vs |> call_sets tss (ts :: uss)
+ val sets = call_sets (fun_calls t [] []) [] []
+ val indexed_sets = sets ~~ (index_seq 0 (length sets))
+ in
+ fold_rev (fn (set, j) =>
+ case set of
+ [Var _] => AList.lookup (op =) indexed_sets set = SOME j
+ ? cons (j, NONE)
+ | [t as Const _] => cons (j, SOME t)
+ | [t as Free _] => cons (j, SOME t)
+ | _ => I) indexed_sets []
+ end
+(* hol_context -> styp -> term list -> (int * term option) list *)
+fun static_args_in_terms hol_ctxt x =
+ map (static_args_in_term hol_ctxt x)
+ #> fold1 (OrdList.inter (prod_ord int_ord (option_ord TermOrd.term_ord)))
+
+(* (int * term option) list -> (int * term) list -> int list *)
+fun overlapping_indices [] _ = []
+ | overlapping_indices _ [] = []
+ | overlapping_indices (ps1 as (j1, t1) :: ps1') (ps2 as (j2, t2) :: ps2') =
+ if j1 < j2 then overlapping_indices ps1' ps2
+ else if j1 > j2 then overlapping_indices ps1 ps2'
+ else overlapping_indices ps1' ps2' |> the_default t2 t1 = t2 ? cons j1
+
+(* typ list -> term -> bool *)
+fun is_eligible_arg Ts t =
+ let val bad_Ts = map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t) in
+ null bad_Ts orelse
+ (is_higher_order_type (fastype_of1 (Ts, t)) andalso
+ forall (not o is_higher_order_type) bad_Ts)
+ end
+
+(* int -> string *)
+fun special_prefix_for j = special_prefix ^ string_of_int j ^ name_sep
+
+(* If a constant's definition is picked up deeper than this threshold, we
+ prevent excessive specialization by not specializing it. *)
+val special_max_depth = 20
+
+val bound_var_prefix = "b"
+
+(* hol_context -> int -> term -> term *)
+fun specialize_consts_in_term (hol_ctxt as {thy, specialize, simp_table,
+ special_funs, ...}) depth t =
+ if not specialize orelse depth > special_max_depth then
+ t
+ else
+ let
+ val blacklist = if depth = 0 then []
+ else case term_under_def t of Const x => [x] | _ => []
+ (* term list -> typ list -> term -> term *)
+ fun aux args Ts (Const (x as (s, T))) =
+ ((if not (member (op =) blacklist x) andalso not (null args) andalso
+ not (String.isPrefix special_prefix s) andalso
+ is_equational_fun hol_ctxt x then
+ let
+ val eligible_args = filter (is_eligible_arg Ts o snd)
+ (index_seq 0 (length args) ~~ args)
+ val _ = not (null eligible_args) orelse raise SAME ()
+ val old_axs = equational_fun_axioms hol_ctxt x
+ |> map (destroy_existential_equalities thy)
+ val static_params = static_args_in_terms hol_ctxt x old_axs
+ val fixed_js = overlapping_indices static_params eligible_args
+ val _ = not (null fixed_js) orelse raise SAME ()
+ val fixed_args = filter_indices fixed_js args
+ val vars = fold Term.add_vars fixed_args []
+ |> sort (TermOrd.fast_indexname_ord o pairself fst)
+ val bound_js = fold (fn t => fn js => add_loose_bnos (t, 0, js))
+ fixed_args []
+ |> sort int_ord
+ val live_args = filter_out_indices fixed_js args
+ val extra_args = map Var vars @ map Bound bound_js @ live_args
+ val extra_Ts = map snd vars @ filter_indices bound_js Ts
+ val k = maxidx_of_term t + 1
+ (* int -> term *)
+ fun var_for_bound_no j =
+ Var ((bound_var_prefix ^
+ nat_subscript (find_index (curry (op =) j) bound_js
+ + 1), k),
+ nth Ts j)
+ val fixed_args_in_axiom =
+ map (curry subst_bounds
+ (map var_for_bound_no (index_seq 0 (length Ts))))
+ fixed_args
+ in
+ case AList.lookup (op =) (!special_funs)
+ (x, fixed_js, fixed_args_in_axiom) of
+ SOME x' => list_comb (Const x', extra_args)
+ | NONE =>
+ let
+ val extra_args_in_axiom =
+ map Var vars @ map var_for_bound_no bound_js
+ val x' as (s', _) =
+ (special_prefix_for (length (!special_funs) + 1) ^ s,
+ extra_Ts @ filter_out_indices fixed_js (binder_types T)
+ ---> body_type T)
+ val new_axs =
+ map (specialize_fun_axiom x x' fixed_js
+ fixed_args_in_axiom extra_args_in_axiom) old_axs
+ val _ =
+ Unsynchronized.change special_funs
+ (cons ((x, fixed_js, fixed_args_in_axiom), x'))
+ val _ = add_simps simp_table s' new_axs
+ in list_comb (Const x', extra_args) end
+ end
+ else
+ raise SAME ())
+ handle SAME () => list_comb (Const x, args))
+ | aux args Ts (Abs (s, T, t)) =
+ list_comb (Abs (s, T, aux [] (T :: Ts) t), args)
+ | aux args Ts (t1 $ t2) = aux (aux [] Ts t2 :: args) Ts t1
+ | aux args _ t = list_comb (t, args)
+ in aux [] [] t end
+
+type special_triple = int list * term list * styp
+
+val cong_var_prefix = "c"
+
+(* styp -> special_triple -> special_triple -> term *)
+fun special_congruence_axiom (s, T) (js1, ts1, x1) (js2, ts2, x2) =
+ let
+ val (bounds1, bounds2) = pairself (map Var o special_bounds) (ts1, ts2)
+ val Ts = binder_types T
+ val max_j = fold (fold Integer.max) [js1, js2] ~1
+ val (eqs, (args1, args2)) =
+ fold (fn j => case pairself (fn ps => AList.lookup (op =) ps j)
+ (js1 ~~ ts1, js2 ~~ ts2) of
+ (SOME t1, SOME t2) => apfst (cons (t1, t2))
+ | (SOME t1, NONE) => apsnd (apsnd (cons t1))
+ | (NONE, SOME t2) => apsnd (apfst (cons t2))
+ | (NONE, NONE) =>
+ let val v = Var ((cong_var_prefix ^ nat_subscript j, 0),
+ nth Ts j) in
+ apsnd (pairself (cons v))
+ end) (max_j downto 0) ([], ([], []))
+ in
+ Logic.list_implies (eqs |> filter_out (op =) |> distinct (op =)
+ |> map Logic.mk_equals,
+ Logic.mk_equals (list_comb (Const x1, bounds1 @ args1),
+ list_comb (Const x2, bounds2 @ args2)))
+ |> close_form (* TODO: needed? *)
+ end
+
+(* hol_context -> styp list -> term list *)
+fun special_congruence_axioms (hol_ctxt as {special_funs, ...}) xs =
+ let
+ val groups =
+ !special_funs
+ |> map (fn ((x, js, ts), x') => (x, (js, ts, x')))
+ |> AList.group (op =)
+ |> filter_out (is_equational_fun_surely_complete hol_ctxt o fst)
+ |> map (fn (x, zs) => (x, zs |> member (op =) xs x ? cons ([], [], x)))
+ (* special_triple -> int *)
+ fun generality (js, _, _) = ~(length js)
+ (* special_triple -> special_triple -> bool *)
+ fun is_more_specific (j1, t1, x1) (j2, t2, x2) =
+ x1 <> x2 andalso OrdList.subset (prod_ord int_ord TermOrd.term_ord)
+ (j2 ~~ t2, j1 ~~ t1)
+ (* styp -> special_triple list -> special_triple list -> special_triple list
+ -> term list -> term list *)
+ fun do_pass_1 _ [] [_] [_] = I
+ | do_pass_1 x skipped _ [] = do_pass_2 x skipped
+ | do_pass_1 x skipped all (z :: zs) =
+ case filter (is_more_specific z) all
+ |> sort (int_ord o pairself generality) of
+ [] => do_pass_1 x (z :: skipped) all zs
+ | (z' :: _) => cons (special_congruence_axiom x z z')
+ #> do_pass_1 x skipped all zs
+ (* styp -> special_triple list -> term list -> term list *)
+ and do_pass_2 _ [] = I
+ | do_pass_2 x (z :: zs) =
+ fold (cons o special_congruence_axiom x z) zs #> do_pass_2 x zs
+ in fold (fn (x, zs) => do_pass_1 x [] zs zs) groups [] end
+
+(** Axiom selection **)
+
+(* Similar to "Refute.specialize_type" but returns all matches rather than only
+ the first (preorder) match. *)
+(* theory -> styp -> term -> term list *)
+fun multi_specialize_type thy slack (x as (s, T)) t =
+ let
+ (* term -> (typ * term) list -> (typ * term) list *)
+ fun aux (Const (s', T')) ys =
+ if s = s' then
+ ys |> (if AList.defined (op =) ys T' then
+ I
+ else
+ cons (T', Refute.monomorphic_term
+ (Sign.typ_match thy (T', T) Vartab.empty) t)
+ handle Type.TYPE_MATCH => I
+ | Refute.REFUTE _ =>
+ if slack then
+ I
+ else
+ raise NOT_SUPPORTED ("too much polymorphism in \
+ \axiom involving " ^ quote s))
+ else
+ ys
+ | aux _ ys = ys
+ in map snd (fold_aterms aux t []) end
+
+(* theory -> bool -> const_table -> styp -> term list *)
+fun nondef_props_for_const thy slack table (x as (s, _)) =
+ these (Symtab.lookup table s) |> maps (multi_specialize_type thy slack x)
+
+(* 'a Symtab.table -> 'a list *)
+fun all_table_entries table = Symtab.fold (append o snd) table []
+(* const_table -> string -> const_table *)
+fun extra_table table s = Symtab.make [(s, all_table_entries table)]
+
+(* int -> term -> term *)
+fun eval_axiom_for_term j t =
+ Logic.mk_equals (Const (eval_prefix ^ string_of_int j, fastype_of t), t)
+
+(* term -> bool *)
+val is_trivial_equation = the_default false o try (op aconv o Logic.dest_equals)
+
+(* Prevents divergence in case of cyclic or infinite axiom dependencies. *)
+val axioms_max_depth = 255
+
+(* hol_context -> term -> (term list * term list) * (bool * bool) *)
+fun axioms_for_term
+ (hol_ctxt as {thy, max_bisim_depth, user_axioms, fast_descrs, evals,
+ def_table, nondef_table, user_nondefs, ...}) t =
+ let
+ type accumulator = styp list * (term list * term list)
+ (* (term list * term list -> term list)
+ -> ((term list -> term list) -> term list * term list
+ -> term list * term list)
+ -> int -> term -> accumulator -> accumulator *)
+ fun add_axiom get app depth t (accum as (xs, axs)) =
+ let
+ val t = t |> unfold_defs_in_term hol_ctxt
+ |> skolemize_term_and_more hol_ctxt ~1
+ in
+ if is_trivial_equation t then
+ accum
+ else
+ let val t' = t |> specialize_consts_in_term hol_ctxt depth in
+ if exists (member (op aconv) (get axs)) [t, t'] then accum
+ else add_axioms_for_term (depth + 1) t' (xs, app (cons t') axs)
+ end
+ end
+ (* int -> term -> accumulator -> accumulator *)
+ and add_def_axiom depth = add_axiom fst apfst depth
+ and add_nondef_axiom depth = add_axiom snd apsnd depth
+ and add_maybe_def_axiom depth t =
+ (if head_of t <> @{const "==>"} then add_def_axiom
+ else add_nondef_axiom) depth t
+ and add_eq_axiom depth t =
+ (if is_constr_pattern_formula thy t then add_def_axiom
+ else add_nondef_axiom) depth t
+ (* int -> term -> accumulator -> accumulator *)
+ and add_axioms_for_term depth t (accum as (xs, axs)) =
+ case t of
+ t1 $ t2 => accum |> fold (add_axioms_for_term depth) [t1, t2]
+ | Const (x as (s, T)) =>
+ (if member (op =) xs x orelse is_built_in_const fast_descrs x then
+ accum
+ else
+ let val accum as (xs, _) = (x :: xs, axs) in
+ if depth > axioms_max_depth then
+ raise TOO_LARGE ("Nitpick_Preproc.axioms_for_term.\
+ \add_axioms_for_term",
+ "too many nested axioms (" ^
+ string_of_int depth ^ ")")
+ else if Refute.is_const_of_class thy x then
+ let
+ val class = Logic.class_of_const s
+ val of_class = Logic.mk_of_class (TVar (("'a", 0), [class]),
+ class)
+ val ax1 = try (Refute.specialize_type thy x) of_class
+ val ax2 = Option.map (Refute.specialize_type thy x o snd)
+ (Refute.get_classdef thy class)
+ in
+ fold (add_maybe_def_axiom depth) (map_filter I [ax1, ax2])
+ accum
+ end
+ else if is_constr thy x then
+ accum
+ else if is_equational_fun hol_ctxt x then
+ fold (add_eq_axiom depth) (equational_fun_axioms hol_ctxt x)
+ accum
+ else if is_abs_fun thy x then
+ if is_quot_type thy (range_type T) then
+ raise NOT_SUPPORTED "\"Abs_\" function of quotient type"
+ else
+ accum |> fold (add_nondef_axiom depth)
+ (nondef_props_for_const thy false nondef_table x)
+ |> is_funky_typedef thy (range_type T)
+ ? fold (add_maybe_def_axiom depth)
+ (nondef_props_for_const thy true
+ (extra_table def_table s) x)
+ else if is_rep_fun thy x then
+ if is_quot_type thy (domain_type T) then
+ raise NOT_SUPPORTED "\"Rep_\" function of quotient type"
+ else
+ accum |> fold (add_nondef_axiom depth)
+ (nondef_props_for_const thy false nondef_table x)
+ |> is_funky_typedef thy (range_type T)
+ ? fold (add_maybe_def_axiom depth)
+ (nondef_props_for_const thy true
+ (extra_table def_table s) x)
+ |> add_axioms_for_term depth
+ (Const (mate_of_rep_fun thy x))
+ |> fold (add_def_axiom depth)
+ (inverse_axioms_for_rep_fun thy x)
+ else
+ accum |> user_axioms <> SOME false
+ ? fold (add_nondef_axiom depth)
+ (nondef_props_for_const thy false nondef_table x)
+ end)
+ |> add_axioms_for_type depth T
+ | Free (_, T) => add_axioms_for_type depth T accum
+ | Var (_, T) => add_axioms_for_type depth T accum
+ | Bound _ => accum
+ | Abs (_, T, t) => accum |> add_axioms_for_term depth t
+ |> add_axioms_for_type depth T
+ (* int -> typ -> accumulator -> accumulator *)
+ and add_axioms_for_type depth T =
+ case T of
+ Type ("fun", Ts) => fold (add_axioms_for_type depth) Ts
+ | Type ("*", Ts) => fold (add_axioms_for_type depth) Ts
+ | @{typ prop} => I
+ | @{typ bool} => I
+ | @{typ unit} => I
+ | TFree (_, S) => add_axioms_for_sort depth T S
+ | TVar (_, S) => add_axioms_for_sort depth T S
+ | Type (z as (s, Ts)) =>
+ fold (add_axioms_for_type depth) Ts
+ #> (if is_pure_typedef thy T then
+ fold (add_maybe_def_axiom depth) (optimized_typedef_axioms thy z)
+ else if is_quot_type thy T then
+ fold (add_def_axiom depth) (optimized_quot_type_axioms thy z)
+ else if max_bisim_depth >= 0 andalso is_codatatype thy T then
+ fold (add_maybe_def_axiom depth)
+ (codatatype_bisim_axioms hol_ctxt T)
+ else
+ I)
+ (* int -> typ -> sort -> accumulator -> accumulator *)
+ and add_axioms_for_sort depth T S =
+ let
+ val supers = Sign.complete_sort thy S
+ val class_axioms =
+ maps (fn class => map prop_of (AxClass.get_info thy class |> #axioms
+ handle ERROR _ => [])) supers
+ val monomorphic_class_axioms =
+ map (fn t => case Term.add_tvars t [] of
+ [] => t
+ | [(x, S)] =>
+ Refute.monomorphic_term (Vartab.make [(x, (S, T))]) t
+ | _ => raise TERM ("Nitpick_Preproc.axioms_for_term.\
+ \add_axioms_for_sort", [t]))
+ class_axioms
+ in fold (add_nondef_axiom depth) monomorphic_class_axioms end
+ val (mono_user_nondefs, poly_user_nondefs) =
+ List.partition (null o Term.hidden_polymorphism) user_nondefs
+ val eval_axioms = map2 eval_axiom_for_term (index_seq 0 (length evals))
+ evals
+ val (xs, (defs, nondefs)) =
+ ([], ([], [])) |> add_axioms_for_term 1 t
+ |> fold_rev (add_def_axiom 1) eval_axioms
+ |> user_axioms = SOME true
+ ? fold (add_nondef_axiom 1) mono_user_nondefs
+ val defs = defs @ special_congruence_axioms hol_ctxt xs
+ in
+ ((defs, nondefs), (user_axioms = SOME true orelse null mono_user_nondefs,
+ null poly_user_nondefs))
+ end
+
+(** Simplification of constructor/selector terms **)
+
+(* theory -> term -> term *)
+fun simplify_constrs_and_sels thy t =
+ let
+ (* term -> int -> term *)
+ fun is_nth_sel_on t' n (Const (s, _) $ t) =
+ (t = t' andalso is_sel_like_and_no_discr s andalso
+ sel_no_from_name s = n)
+ | is_nth_sel_on _ _ _ = false
+ (* term -> term list -> term *)
+ fun do_term (Const (@{const_name Rep_Frac}, _)
+ $ (Const (@{const_name Abs_Frac}, _) $ t1)) [] = do_term t1 []
+ | do_term (Const (@{const_name Abs_Frac}, _)
+ $ (Const (@{const_name Rep_Frac}, _) $ t1)) [] = do_term t1 []
+ | do_term (t1 $ t2) args = do_term t1 (do_term t2 [] :: args)
+ | do_term (t as Const (x as (s, T))) (args as _ :: _) =
+ ((if is_constr_like thy x then
+ if length args = num_binder_types T then
+ case hd args of
+ Const (x' as (_, T')) $ t' =>
+ if domain_type T' = body_type T andalso
+ forall (uncurry (is_nth_sel_on t'))
+ (index_seq 0 (length args) ~~ args) then
+ t'
+ else
+ raise SAME ()
+ | _ => raise SAME ()
+ else
+ raise SAME ()
+ else if is_sel_like_and_no_discr s then
+ case strip_comb (hd args) of
+ (Const (x' as (s', T')), ts') =>
+ if is_constr_like thy x' andalso
+ constr_name_for_sel_like s = s' andalso
+ not (exists is_pair_type (binder_types T')) then
+ list_comb (nth ts' (sel_no_from_name s), tl args)
+ else
+ raise SAME ()
+ | _ => raise SAME ()
+ else
+ raise SAME ())
+ handle SAME () => betapplys (t, args))
+ | do_term (Abs (s, T, t')) args =
+ betapplys (Abs (s, T, do_term t' []), args)
+ | do_term t args = betapplys (t, args)
+ in do_term t [] end
+
+(** Quantifier massaging: Distributing quantifiers **)
+
+(* term -> term *)
+fun distribute_quantifiers t =
+ case t of
+ (t0 as Const (@{const_name All}, T0)) $ Abs (s, T1, t1) =>
+ (case t1 of
+ (t10 as @{const "op &"}) $ t11 $ t12 =>
+ t10 $ distribute_quantifiers (t0 $ Abs (s, T1, t11))
+ $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
+ | (t10 as @{const Not}) $ t11 =>
+ t10 $ distribute_quantifiers (Const (@{const_name Ex}, T0)
+ $ Abs (s, T1, t11))
+ | t1 =>
+ if not (loose_bvar1 (t1, 0)) then
+ distribute_quantifiers (incr_boundvars ~1 t1)
+ else
+ t0 $ Abs (s, T1, distribute_quantifiers t1))
+ | (t0 as Const (@{const_name Ex}, T0)) $ Abs (s, T1, t1) =>
+ (case distribute_quantifiers t1 of
+ (t10 as @{const "op |"}) $ t11 $ t12 =>
+ t10 $ distribute_quantifiers (t0 $ Abs (s, T1, t11))
+ $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
+ | (t10 as @{const "op -->"}) $ t11 $ t12 =>
+ t10 $ distribute_quantifiers (Const (@{const_name All}, T0)
+ $ Abs (s, T1, t11))
+ $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
+ | (t10 as @{const Not}) $ t11 =>
+ t10 $ distribute_quantifiers (Const (@{const_name All}, T0)
+ $ Abs (s, T1, t11))
+ | t1 =>
+ if not (loose_bvar1 (t1, 0)) then
+ distribute_quantifiers (incr_boundvars ~1 t1)
+ else
+ t0 $ Abs (s, T1, distribute_quantifiers t1))
+ | t1 $ t2 => distribute_quantifiers t1 $ distribute_quantifiers t2
+ | Abs (s, T, t') => Abs (s, T, distribute_quantifiers t')
+ | _ => t
+
+(** Quantifier massaging: Pushing quantifiers inward **)
+
+(* int -> int -> (int -> int) -> term -> term *)
+fun renumber_bounds j n f t =
+ case t of
+ t1 $ t2 => renumber_bounds j n f t1 $ renumber_bounds j n f t2
+ | Abs (s, T, t') => Abs (s, T, renumber_bounds (j + 1) n f t')
+ | Bound j' =>
+ Bound (if j' >= j andalso j' < j + n then f (j' - j) + j else j')
+ | _ => t
+
+(* Maximum number of quantifiers in a cluster for which the exponential
+ algorithm is used. Larger clusters use a heuristic inspired by Claessen &
+ Sörensson's polynomial binary splitting procedure (p. 5 of their MODEL 2003
+ paper). *)
+val quantifier_cluster_threshold = 7
+
+(* theory -> term -> term *)
+fun push_quantifiers_inward thy =
+ let
+ (* string -> string list -> typ list -> term -> term *)
+ fun aux quant_s ss Ts t =
+ (case t of
+ (t0 as Const (s0, _)) $ Abs (s1, T1, t1 as _ $ _) =>
+ if s0 = quant_s then
+ aux s0 (s1 :: ss) (T1 :: Ts) t1
+ else if quant_s = "" andalso
+ (s0 = @{const_name All} orelse s0 = @{const_name Ex}) then
+ aux s0 [s1] [T1] t1
+ else
+ raise SAME ()
+ | _ => raise SAME ())
+ handle SAME () =>
+ case t of
+ t1 $ t2 =>
+ if quant_s = "" then
+ aux "" [] [] t1 $ aux "" [] [] t2
+ else
+ let
+ val typical_card = 4
+ (* ('a -> ''b list) -> 'a list -> ''b list *)
+ fun big_union proj ps =
+ fold (fold (insert (op =)) o proj) ps []
+ val (ts, connective) = strip_any_connective t
+ val T_costs =
+ map (bounded_card_of_type 65536 typical_card []) Ts
+ val t_costs = map size_of_term ts
+ val num_Ts = length Ts
+ (* int -> int *)
+ val flip = curry (op -) (num_Ts - 1)
+ val t_boundss = map (map flip o loose_bnos) ts
+ (* (int list * int) list -> int list
+ -> (int list * int) list *)
+ fun merge costly_boundss [] = costly_boundss
+ | merge costly_boundss (j :: js) =
+ let
+ val (yeas, nays) =
+ List.partition (fn (bounds, _) =>
+ member (op =) bounds j)
+ costly_boundss
+ val yeas_bounds = big_union fst yeas
+ val yeas_cost = Integer.sum (map snd yeas)
+ * nth T_costs j
+ in merge ((yeas_bounds, yeas_cost) :: nays) js end
+ (* (int list * int) list -> int list -> int *)
+ val cost = Integer.sum o map snd oo merge
+ (* (int list * int) list -> int list -> int list *)
+ fun heuristically_best_permutation _ [] = []
+ | heuristically_best_permutation costly_boundss js =
+ let
+ val (costly_boundss, (j, js)) =
+ js |> map (`(merge costly_boundss o single))
+ |> sort (int_ord
+ o pairself (Integer.sum o map snd o fst))
+ |> split_list |>> hd ||> pairf hd tl
+ in
+ j :: heuristically_best_permutation costly_boundss js
+ end
+ val js =
+ if length Ts <= quantifier_cluster_threshold then
+ all_permutations (index_seq 0 num_Ts)
+ |> map (`(cost (t_boundss ~~ t_costs)))
+ |> sort (int_ord o pairself fst) |> hd |> snd
+ else
+ heuristically_best_permutation (t_boundss ~~ t_costs)
+ (index_seq 0 num_Ts)
+ val back_js = map (fn j => find_index (curry (op =) j) js)
+ (index_seq 0 num_Ts)
+ val ts = map (renumber_bounds 0 num_Ts (nth back_js o flip))
+ ts
+ (* (term * int list) list -> term *)
+ fun mk_connection [] =
+ raise ARG ("Nitpick_Preproc.push_quantifiers_inward.aux.\
+ \mk_connection", "")
+ | mk_connection ts_cum_bounds =
+ ts_cum_bounds |> map fst
+ |> foldr1 (fn (t1, t2) => connective $ t1 $ t2)
+ (* (term * int list) list -> int list -> term *)
+ fun build ts_cum_bounds [] = ts_cum_bounds |> mk_connection
+ | build ts_cum_bounds (j :: js) =
+ let
+ val (yeas, nays) =
+ List.partition (fn (_, bounds) =>
+ member (op =) bounds j)
+ ts_cum_bounds
+ ||> map (apfst (incr_boundvars ~1))
+ in
+ if null yeas then
+ build nays js
+ else
+ let val T = nth Ts (flip j) in
+ build ((Const (quant_s, (T --> bool_T) --> bool_T)
+ $ Abs (nth ss (flip j), T,
+ mk_connection yeas),
+ big_union snd yeas) :: nays) js
+ end
+ end
+ in build (ts ~~ t_boundss) js end
+ | Abs (s, T, t') => Abs (s, T, aux "" [] [] t')
+ | _ => t
+ in aux "" [] [] end
+
+(** Preprocessor entry point **)
+
+(* hol_context -> term -> ((term list * term list) * (bool * bool)) * term *)
+fun preprocess_term (hol_ctxt as {thy, binary_ints, destroy_constrs, boxes,
+ skolemize, uncurry, ...}) t =
+ let
+ val skolem_depth = if skolemize then 4 else ~1
+ val (((def_ts, nondef_ts), (got_all_mono_user_axioms, no_poly_user_axioms)),
+ core_t) = t |> unfold_defs_in_term hol_ctxt
+ |> close_form
+ |> skolemize_term_and_more hol_ctxt skolem_depth
+ |> specialize_consts_in_term hol_ctxt 0
+ |> `(axioms_for_term hol_ctxt)
+ val binarize =
+ case binary_ints of
+ SOME false => false
+ | _ =>
+ forall may_use_binary_ints (core_t :: def_ts @ nondef_ts) andalso
+ (binary_ints = SOME true orelse
+ exists should_use_binary_ints (core_t :: def_ts @ nondef_ts))
+ val box = exists (not_equal (SOME false) o snd) boxes
+ val table =
+ Termtab.empty |> uncurry
+ ? fold (add_to_uncurry_table thy) (core_t :: def_ts @ nondef_ts)
+ (* bool -> bool -> term -> term *)
+ fun do_rest def core =
+ binarize ? binarize_nat_and_int_in_term
+ #> uncurry ? uncurry_term table
+ #> box ? box_fun_and_pair_in_term hol_ctxt def
+ #> destroy_constrs ? (pull_out_universal_constrs thy def
+ #> pull_out_existential_constrs thy
+ #> destroy_pulled_out_constrs hol_ctxt def)
+ #> curry_assms
+ #> destroy_universal_equalities
+ #> destroy_existential_equalities thy
+ #> simplify_constrs_and_sels thy
+ #> distribute_quantifiers
+ #> push_quantifiers_inward thy
+ #> close_form
+ #> Term.map_abs_vars shortest_name
+ in
+ (((map (do_rest true false) def_ts, map (do_rest false false) nondef_ts),
+ (got_all_mono_user_axioms, no_poly_user_axioms)),
+ do_rest false true core_t)
+ end
+
+end;
--- a/src/HOL/Tools/Nitpick/nitpick_scope.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Nitpick/nitpick_scope.ML Thu Feb 11 12:26:50 2010 -0800
@@ -8,7 +8,7 @@
signature NITPICK_SCOPE =
sig
type styp = Nitpick_Util.styp
- type extended_context = Nitpick_HOL.extended_context
+ type hol_context = Nitpick_HOL.hol_context
type constr_spec = {
const: styp,
@@ -28,7 +28,7 @@
constrs: constr_spec list}
type scope = {
- ext_ctxt: extended_context,
+ hol_ctxt: hol_context,
card_assigns: (typ * int) list,
bits: int,
bisim_depth: int,
@@ -47,7 +47,7 @@
val scopes_equivalent : scope -> scope -> bool
val scope_less_eq : scope -> scope -> bool
val all_scopes :
- extended_context -> int -> (typ option * int list) list
+ hol_context -> int -> (typ option * int list) list
-> (styp option * int list) list -> (styp option * int list) list
-> int list -> int list -> typ list -> typ list -> typ list
-> int * scope list
@@ -77,7 +77,7 @@
constrs: constr_spec list}
type scope = {
- ext_ctxt: extended_context,
+ hol_ctxt: hol_context,
card_assigns: (typ * int) list,
bits: int,
bisim_depth: int,
@@ -131,10 +131,10 @@
(* (string -> string) -> scope
-> string list * string list * string list * string list * string list *)
-fun quintuple_for_scope quote ({ext_ctxt as {thy, ctxt, ...}, card_assigns,
+fun quintuple_for_scope quote ({hol_ctxt as {thy, ctxt, ...}, card_assigns,
bits, bisim_depth, datatypes, ...} : scope) =
let
- val boring_Ts = [@{typ unsigned_bit}, @{typ signed_bit}, @{typ \<xi>},
+ val boring_Ts = [@{typ unsigned_bit}, @{typ signed_bit},
@{typ bisim_iterator}]
val (iter_assigns, card_assigns) =
card_assigns |> filter_out (member (op =) boring_Ts o fst)
@@ -240,10 +240,9 @@
val max_bits = 31 (* Kodkod limit *)
-(* extended_context -> (typ option * int list) list
- -> (styp option * int list) list -> (styp option * int list) list -> int list
- -> int list -> typ -> block *)
-fun block_for_type (ext_ctxt as {thy, ...}) cards_assigns maxes_assigns
+(* hol_context -> (typ option * int list) list -> (styp option * int list) list
+ -> (styp option * int list) list -> int list -> int list -> typ -> block *)
+fun block_for_type (hol_ctxt as {thy, ...}) cards_assigns maxes_assigns
iters_assigns bitss bisim_depths T =
if T = @{typ unsigned_bit} then
[(Card T, map (Integer.min max_bits o Integer.max 1) bitss)]
@@ -261,18 +260,18 @@
(const_for_iterator_type T)))]
else
(Card T, lookup_type_ints_assign thy cards_assigns T) ::
- (case datatype_constrs ext_ctxt T of
+ (case datatype_constrs hol_ctxt T of
[_] => []
| constrs => map_filter (row_for_constr thy maxes_assigns) constrs)
-(* extended_context -> (typ option * int list) list
- -> (styp option * int list) list -> (styp option * int list) list -> int list
- -> int list -> typ list -> typ list -> block list *)
-fun blocks_for_types ext_ctxt cards_assigns maxes_assigns iters_assigns bitss
+(* hol_context -> (typ option * int list) list -> (styp option * int list) list
+ -> (styp option * int list) list -> int list -> int list -> typ list
+ -> typ list -> block list *)
+fun blocks_for_types hol_ctxt cards_assigns maxes_assigns iters_assigns bitss
bisim_depths mono_Ts nonmono_Ts =
let
(* typ -> block *)
- val block_for = block_for_type ext_ctxt cards_assigns maxes_assigns
+ val block_for = block_for_type hol_ctxt cards_assigns maxes_assigns
iters_assigns bitss bisim_depths
val mono_block = maps block_for mono_Ts
val nonmono_blocks = map block_for nonmono_Ts
@@ -313,10 +312,10 @@
type scope_desc = (typ * int) list * (styp * int) list
-(* extended_context -> scope_desc -> typ * int -> bool *)
-fun is_surely_inconsistent_card_assign ext_ctxt (card_assigns, max_assigns)
+(* hol_context -> scope_desc -> typ * int -> bool *)
+fun is_surely_inconsistent_card_assign hol_ctxt (card_assigns, max_assigns)
(T, k) =
- case datatype_constrs ext_ctxt T of
+ case datatype_constrs hol_ctxt T of
[] => false
| xs =>
let
@@ -329,20 +328,20 @@
| effective_max card max = Int.min (card, max)
val max = map2 effective_max dom_cards maxes |> Integer.sum
in max < k end
-(* extended_context -> (typ * int) list -> (typ * int) list
- -> (styp * int) list -> bool *)
-fun is_surely_inconsistent_scope_description ext_ctxt seen rest max_assigns =
- exists (is_surely_inconsistent_card_assign ext_ctxt
+(* hol_context -> (typ * int) list -> (typ * int) list -> (styp * int) list
+ -> bool *)
+fun is_surely_inconsistent_scope_description hol_ctxt seen rest max_assigns =
+ exists (is_surely_inconsistent_card_assign hol_ctxt
(seen @ rest, max_assigns)) seen
-(* extended_context -> scope_desc -> (typ * int) list option *)
-fun repair_card_assigns ext_ctxt (card_assigns, max_assigns) =
+(* hol_context -> scope_desc -> (typ * int) list option *)
+fun repair_card_assigns hol_ctxt (card_assigns, max_assigns) =
let
(* (typ * int) list -> (typ * int) list -> (typ * int) list option *)
fun aux seen [] = SOME seen
| aux seen ((T, 0) :: _) = NONE
| aux seen ((T, k) :: rest) =
- (if is_surely_inconsistent_scope_description ext_ctxt ((T, k) :: seen)
+ (if is_surely_inconsistent_scope_description hol_ctxt ((T, k) :: seen)
rest max_assigns then
raise SAME ()
else
@@ -374,12 +373,12 @@
(* block -> scope_desc *)
fun scope_descriptor_from_block block =
fold_rev add_row_to_scope_descriptor block ([], [])
-(* extended_context -> block list -> int list -> scope_desc option *)
-fun scope_descriptor_from_combination (ext_ctxt as {thy, ...}) blocks columns =
+(* hol_context -> block list -> int list -> scope_desc option *)
+fun scope_descriptor_from_combination (hol_ctxt as {thy, ...}) blocks columns =
let
val (card_assigns, max_assigns) =
maps project_block (columns ~~ blocks) |> scope_descriptor_from_block
- val card_assigns = repair_card_assigns ext_ctxt (card_assigns, max_assigns)
+ val card_assigns = repair_card_assigns hol_ctxt (card_assigns, max_assigns)
|> the
in
SOME (map (repair_iterator_assign thy card_assigns) card_assigns,
@@ -427,15 +426,21 @@
{delta = delta, epsilon = delta, exclusive = true, total = false}
end
else if not co andalso num_self_recs > 0 then
- if not self_rec andalso num_non_self_recs = 1 andalso
- domain_card 2 card_assigns T = 1 then
- {delta = 0, epsilon = 1,
- exclusive = (s = @{const_name Nil} andalso length constrs = 2),
- total = true}
- else if s = @{const_name Cons} andalso length constrs = 2 then
- {delta = 1, epsilon = card, exclusive = true, total = false}
- else
- {delta = 0, epsilon = card, exclusive = false, total = false}
+ (if num_self_recs = 1 andalso num_non_self_recs = 1 then
+ if self_rec then
+ case constrs of
+ [{delta = 0, epsilon = 1, exclusive = true, ...}] =>
+ {delta = 1, epsilon = card, exclusive = true, total = false}
+ | _ => raise SAME ()
+ else
+ if domain_card 2 card_assigns T = 1 then
+ {delta = 0, epsilon = 1, exclusive = true, total = true}
+ else
+ raise SAME ()
+ else
+ raise SAME ())
+ handle SAME () =>
+ {delta = 0, epsilon = card, exclusive = false, total = false}
else if card = sum_dom_cards (card + 1) then
let val delta = next_delta () in
{delta = delta, epsilon = delta + domain_card card card_assigns T,
@@ -449,31 +454,32 @@
explicit_max = max, total = total} :: constrs
end
-(* extended_context -> (typ * int) list -> typ -> bool *)
-fun has_exact_card ext_ctxt card_assigns T =
+(* hol_context -> (typ * int) list -> typ -> bool *)
+fun has_exact_card hol_ctxt card_assigns T =
let val card = card_of_type card_assigns T in
- card = bounded_exact_card_of_type ext_ctxt (card + 1) 0 card_assigns T
+ card = bounded_exact_card_of_type hol_ctxt (card + 1) 0 card_assigns T
end
-(* extended_context -> typ list -> scope_desc -> typ * int -> dtype_spec *)
-fun datatype_spec_from_scope_descriptor (ext_ctxt as {thy, ...}) deep_dataTs
+(* hol_context -> typ list -> scope_desc -> typ * int -> dtype_spec *)
+fun datatype_spec_from_scope_descriptor (hol_ctxt as {thy, ...}) deep_dataTs
(desc as (card_assigns, _)) (T, card) =
let
val deep = member (op =) deep_dataTs T
val co = is_codatatype thy T
- val xs = boxed_datatype_constrs ext_ctxt T
+ val xs = boxed_datatype_constrs hol_ctxt T
val self_recs = map (is_self_recursive_constr_type o snd) xs
val (num_self_recs, num_non_self_recs) =
List.partition I self_recs |> pairself length
- val complete = has_exact_card ext_ctxt card_assigns T
+ val complete = has_exact_card hol_ctxt card_assigns T
val concrete = xs |> maps (binder_types o snd) |> maps binder_types
- |> forall (has_exact_card ext_ctxt card_assigns)
+ |> forall (has_exact_card hol_ctxt card_assigns)
(* int -> int *)
fun sum_dom_cards max =
map (domain_card max card_assigns o snd) xs |> Integer.sum
val constrs =
fold_rev (add_constr_spec desc co card sum_dom_cards num_self_recs
- num_non_self_recs) (self_recs ~~ xs) []
+ num_non_self_recs)
+ (sort (bool_ord o swap o pairself fst) (self_recs ~~ xs)) []
in
{typ = T, card = card, co = co, complete = complete, concrete = concrete,
deep = deep, constrs = constrs}
@@ -487,12 +493,12 @@
min_bits_for_nat_value (fold Integer.max
(map snd card_assigns @ map snd max_assigns) 0)
-(* extended_context -> int -> typ list -> scope_desc -> scope *)
-fun scope_from_descriptor (ext_ctxt as {thy, ...}) sym_break deep_dataTs
+(* hol_context -> int -> typ list -> scope_desc -> scope *)
+fun scope_from_descriptor (hol_ctxt as {thy, ...}) sym_break deep_dataTs
(desc as (card_assigns, _)) =
let
val datatypes =
- map (datatype_spec_from_scope_descriptor ext_ctxt deep_dataTs desc)
+ map (datatype_spec_from_scope_descriptor hol_ctxt deep_dataTs desc)
(filter (is_datatype thy o fst) card_assigns)
val bits = card_of_type card_assigns @{typ signed_bit} - 1
handle TYPE ("Nitpick_HOL.card_of_type", _, _) =>
@@ -500,7 +506,7 @@
handle TYPE ("Nitpick_HOL.card_of_type", _, _) => 0
val bisim_depth = card_of_type card_assigns @{typ bisim_iterator} - 1
in
- {ext_ctxt = ext_ctxt, card_assigns = card_assigns, datatypes = datatypes,
+ {hol_ctxt = hol_ctxt, card_assigns = card_assigns, datatypes = datatypes,
bits = bits, bisim_depth = bisim_depth,
ofs = if sym_break <= 0 then Typtab.empty
else offset_table_for_card_assigns thy card_assigns datatypes}
@@ -521,26 +527,26 @@
val max_scopes = 4096
val distinct_threshold = 512
-(* extended_context -> int -> (typ option * int list) list
+(* hol_context -> int -> (typ option * int list) list
-> (styp option * int list) list -> (styp option * int list) list -> int list
-> typ list -> typ list -> typ list -> int * scope list *)
-fun all_scopes (ext_ctxt as {thy, ...}) sym_break cards_assigns maxes_assigns
+fun all_scopes (hol_ctxt as {thy, ...}) sym_break cards_assigns maxes_assigns
iters_assigns bitss bisim_depths mono_Ts nonmono_Ts deep_dataTs =
let
val cards_assigns = repair_cards_assigns_wrt_boxing thy mono_Ts
cards_assigns
- val blocks = blocks_for_types ext_ctxt cards_assigns maxes_assigns
+ val blocks = blocks_for_types hol_ctxt cards_assigns maxes_assigns
iters_assigns bitss bisim_depths mono_Ts
nonmono_Ts
val ranks = map rank_of_block blocks
val all = all_combinations_ordered_smartly (map (rpair 0) ranks)
val head = take max_scopes all
- val descs = map_filter (scope_descriptor_from_combination ext_ctxt blocks)
+ val descs = map_filter (scope_descriptor_from_combination hol_ctxt blocks)
head
in
(length all - length head,
descs |> length descs <= distinct_threshold ? distinct (op =)
- |> map (scope_from_descriptor ext_ctxt sym_break deep_dataTs))
+ |> map (scope_from_descriptor hol_ctxt sym_break deep_dataTs))
end
end;
--- a/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML Thu Feb 11 12:26:50 2010 -0800
@@ -223,7 +223,7 @@
@{const_name False},
@{const_name Suc}, @{const_name Nat.zero_nat_inst.zero_nat},
@{const_name Nat.one_nat_inst.one_nat},
- @{const_name Algebras.ord_class.less}, @{const_name Algebras.ord_class.less_eq},
+ @{const_name Orderings.less}, @{const_name Orderings.less_eq},
@{const_name Algebras.zero},
@{const_name Algebras.one}, @{const_name Algebras.plus},
@{const_name Nat.ord_nat_inst.less_eq_nat},
--- a/src/HOL/Tools/Qelim/cooper.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/Qelim/cooper.ML Thu Feb 11 12:26:50 2010 -0800
@@ -73,10 +73,10 @@
| Const ("op =",ty)$y$_ => if term_of x aconv y then Eq (Thm.dest_arg ct) else Nox
| Const (@{const_name Not},_) $ (Const ("op =",_)$y$_) =>
if term_of x aconv y then NEq (funpow 2 Thm.dest_arg ct) else Nox
-| Const (@{const_name Algebras.less}, _) $ y$ z =>
+| Const (@{const_name Orderings.less}, _) $ y$ z =>
if term_of x aconv y then Lt (Thm.dest_arg ct)
else if term_of x aconv z then Gt (Thm.dest_arg1 ct) else Nox
-| Const (@{const_name Algebras.less_eq}, _) $ y $ z =>
+| Const (@{const_name Orderings.less_eq}, _) $ y $ z =>
if term_of x aconv y then Le (Thm.dest_arg ct)
else if term_of x aconv z then Ge (Thm.dest_arg1 ct) else Nox
| Const (@{const_name Rings.dvd},_)$_$(Const(@{const_name Algebras.plus},_)$y$_) =>
@@ -217,10 +217,10 @@
end
| _ => addC $ (mulC $ one $ tm) $ zero;
-fun lin (vs as x::_) (Const (@{const_name Not}, _) $ (Const (@{const_name Algebras.less}, T) $ s $ t)) =
- lin vs (Const (@{const_name Algebras.less_eq}, T) $ t $ s)
- | lin (vs as x::_) (Const (@{const_name Not},_) $ (Const(@{const_name Algebras.less_eq}, T) $ s $ t)) =
- lin vs (Const (@{const_name Algebras.less}, T) $ t $ s)
+fun lin (vs as x::_) (Const (@{const_name Not}, _) $ (Const (@{const_name Orderings.less}, T) $ s $ t)) =
+ lin vs (Const (@{const_name Orderings.less_eq}, T) $ t $ s)
+ | lin (vs as x::_) (Const (@{const_name Not},_) $ (Const(@{const_name Orderings.less_eq}, T) $ s $ t)) =
+ lin vs (Const (@{const_name Orderings.less}, T) $ t $ s)
| lin vs (Const (@{const_name Not},T)$t) = Const (@{const_name Not},T)$ (lin vs t)
| lin (vs as x::_) (Const(@{const_name Rings.dvd},_)$d$t) =
HOLogic.mk_binrel @{const_name Rings.dvd} (numeral1 abs d, lint vs t)
@@ -295,11 +295,11 @@
case (term_of t) of
Const(s,_)$(Const(@{const_name Algebras.times},_)$c$y)$ _ =>
if x aconv y andalso member (op =)
- ["op =", @{const_name Algebras.less}, @{const_name Algebras.less_eq}] s
+ ["op =", @{const_name Orderings.less}, @{const_name Orderings.less_eq}] s
then (ins (dest_numeral c) acc,dacc) else (acc,dacc)
| Const(s,_)$_$(Const(@{const_name Algebras.times},_)$c$y) =>
if x aconv y andalso member (op =)
- [@{const_name Algebras.less}, @{const_name Algebras.less_eq}] s
+ [@{const_name Orderings.less}, @{const_name Orderings.less_eq}] s
then (ins (dest_numeral c) acc, dacc) else (acc,dacc)
| Const(@{const_name Rings.dvd},_)$_$(Const(@{const_name Algebras.plus},_)$(Const(@{const_name Algebras.times},_)$c$y)$_) =>
if x aconv y then (acc,ins (dest_numeral c) dacc) else (acc,dacc)
@@ -337,11 +337,11 @@
| Const (@{const_name Not},_)$_ => arg_conv unit_conv t
| Const(s,_)$(Const(@{const_name Algebras.times},_)$c$y)$ _ =>
if x=y andalso member (op =)
- ["op =", @{const_name Algebras.less}, @{const_name Algebras.less_eq}] s
+ ["op =", @{const_name Orderings.less}, @{const_name Orderings.less_eq}] s
then cv (l div dest_numeral c) t else Thm.reflexive t
| Const(s,_)$_$(Const(@{const_name Algebras.times},_)$c$y) =>
if x=y andalso member (op =)
- [@{const_name Algebras.less}, @{const_name Algebras.less_eq}] s
+ [@{const_name Orderings.less}, @{const_name Orderings.less_eq}] s
then cv (l div dest_numeral c) t else Thm.reflexive t
| Const(@{const_name Rings.dvd},_)$d$(r as (Const(@{const_name Algebras.plus},_)$(Const(@{const_name Algebras.times},_)$c$y)$_)) =>
if x=y then
@@ -560,8 +560,8 @@
fun qf_of_term ps vs t = case t
of Const("True",_) => T
| Const("False",_) => F
- | Const(@{const_name Algebras.less},_)$t1$t2 => Lt (Sub (i_of_term vs t1,i_of_term vs t2))
- | Const(@{const_name Algebras.less_eq},_)$t1$t2 => Le (Sub(i_of_term vs t1,i_of_term vs t2))
+ | Const(@{const_name Orderings.less},_)$t1$t2 => Lt (Sub (i_of_term vs t1,i_of_term vs t2))
+ | Const(@{const_name Orderings.less_eq},_)$t1$t2 => Le (Sub(i_of_term vs t1,i_of_term vs t2))
| Const(@{const_name Rings.dvd},_)$t1$t2 =>
(Dvd(HOLogic.dest_number t1 |> snd, i_of_term vs t2) handle _ => cooper "Reification: unsupported dvd") (* FIXME avoid handle _ *)
| @{term "op = :: int => _"}$t1$t2 => Eq (Sub (i_of_term vs t1,i_of_term vs t2))
--- a/src/HOL/Tools/inductive.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/inductive.ML Thu Feb 11 12:26:50 2010 -0800
@@ -184,7 +184,7 @@
case concl_of thm of
Const ("==", _) $ _ $ _ => eq2mono (thm RS meta_eq_to_obj_eq)
| _ $ (Const ("op =", _) $ _ $ _) => eq2mono thm
- | _ $ (Const (@{const_name Algebras.less_eq}, _) $ _ $ _) =>
+ | _ $ (Const (@{const_name Orderings.less_eq}, _) $ _ $ _) =>
dest_less_concl (Seq.hd (REPEAT (FIRSTGOAL
(resolve_tac [@{thm le_funI}, @{thm le_boolI'}])) thm))
| _ => thm
@@ -561,7 +561,7 @@
(list_comb (P, make_args' argTs xs (binder_types (fastype_of P))))) preds));
val ind_concl = HOLogic.mk_Trueprop
- (HOLogic.mk_binrel @{const_name Algebras.less_eq} (rec_const, ind_pred));
+ (HOLogic.mk_binrel @{const_name Orderings.less_eq} (rec_const, ind_pred));
val raw_fp_induct = (mono RS (fp_def RS @{thm def_lfp_induct}));
--- a/src/HOL/Tools/int_arith.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/int_arith.ML Thu Feb 11 12:26:50 2010 -0800
@@ -55,7 +55,7 @@
@{const_name Algebras.times}, @{const_name Algebras.uminus},
@{const_name Algebras.minus}, @{const_name Algebras.plus},
@{const_name Algebras.zero},
- @{const_name Algebras.less}, @{const_name Algebras.less_eq}] s
+ @{const_name Orderings.less}, @{const_name Orderings.less_eq}] s
| check (a $ b) = check a andalso check b
| check _ = false;
--- a/src/HOL/Tools/lin_arith.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/lin_arith.ML Thu Feb 11 12:26:50 2010 -0800
@@ -150,7 +150,7 @@
(SOME t', m'') => (SOME (mC $ s' $ t'), m'')
| (NONE, m'') => (SOME s', m''))
| (NONE, m') => demult (t, m')))
- | demult ((mC as Const (@{const_name Algebras.divide}, _)) $ s $ t, m) =
+ | demult ((mC as Const (@{const_name Rings.divide}, _)) $ s $ t, m) =
(* FIXME: Shouldn't we simplify nested quotients, e.g. '(s/t)/u' could
become 's/(t*u)', and '(s*t)/u' could become 's*(t/u)' ? Note that
if we choose to do so here, the simpset used by arith must be able to
@@ -212,7 +212,7 @@
(case demult inj_consts (all, m) of
(NONE, m') => (p, Rat.add i m')
| (SOME u, m') => add_atom u m' pi)
- | poly (all as Const (@{const_name Algebras.divide}, _) $ _ $ _, m, pi as (p, i)) =
+ | poly (all as Const (@{const_name Rings.divide}, _) $ _ $ _, m, pi as (p, i)) =
(case demult inj_consts (all, m) of
(NONE, m') => (p, Rat.add i m')
| (SOME u, m') => add_atom u m' pi)
@@ -229,8 +229,8 @@
val (q, j) = poly (rhs, Rat.one, ([], Rat.zero))
in
case rel of
- @{const_name Algebras.less} => SOME (p, i, "<", q, j)
- | @{const_name Algebras.less_eq} => SOME (p, i, "<=", q, j)
+ @{const_name Orderings.less} => SOME (p, i, "<", q, j)
+ | @{const_name Orderings.less_eq} => SOME (p, i, "<=", q, j)
| "op =" => SOME (p, i, "=", q, j)
| _ => NONE
end handle Rat.DIVZERO => NONE;
@@ -292,7 +292,7 @@
case head_of lhs of
Const (a, _) => member (op =) [@{const_name Orderings.max},
@{const_name Orderings.min},
- @{const_name Algebras.abs},
+ @{const_name Groups.abs},
@{const_name Algebras.minus},
"Int.nat" (*DYNAMIC BINDING!*),
"Divides.div_class.mod" (*DYNAMIC BINDING!*),
@@ -372,7 +372,7 @@
val rev_terms = rev terms
val terms1 = map (subst_term [(split_term, t1)]) rev_terms
val terms2 = map (subst_term [(split_term, t2)]) rev_terms
- val t1_leq_t2 = Const (@{const_name Algebras.less_eq},
+ val t1_leq_t2 = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ t1 $ t2
val not_t1_leq_t2 = HOLogic.Not $ t1_leq_t2
val not_false = HOLogic.mk_Trueprop (HOLogic.Not $ HOLogic.false_const)
@@ -387,7 +387,7 @@
val rev_terms = rev terms
val terms1 = map (subst_term [(split_term, t1)]) rev_terms
val terms2 = map (subst_term [(split_term, t2)]) rev_terms
- val t1_leq_t2 = Const (@{const_name Algebras.less_eq},
+ val t1_leq_t2 = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ t1 $ t2
val not_t1_leq_t2 = HOLogic.Not $ t1_leq_t2
val not_false = HOLogic.mk_Trueprop (HOLogic.Not $ HOLogic.false_const)
@@ -397,16 +397,16 @@
SOME [(Ts, subgoal1), (Ts, subgoal2)]
end
(* ?P (abs ?a) = ((0 <= ?a --> ?P ?a) & (?a < 0 --> ?P (- ?a))) *)
- | (Const (@{const_name Algebras.abs}, _), [t1]) =>
+ | (Const (@{const_name Groups.abs}, _), [t1]) =>
let
val rev_terms = rev terms
val terms1 = map (subst_term [(split_term, t1)]) rev_terms
val terms2 = map (subst_term [(split_term, Const (@{const_name Algebras.uminus},
split_type --> split_type) $ t1)]) rev_terms
val zero = Const (@{const_name Algebras.zero}, split_type)
- val zero_leq_t1 = Const (@{const_name Algebras.less_eq},
+ val zero_leq_t1 = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ zero $ t1
- val t1_lt_zero = Const (@{const_name Algebras.less},
+ val t1_lt_zero = Const (@{const_name Orderings.less},
split_type --> split_type --> HOLogic.boolT) $ t1 $ zero
val not_false = HOLogic.mk_Trueprop (HOLogic.Not $ HOLogic.false_const)
val subgoal1 = (HOLogic.mk_Trueprop zero_leq_t1) :: terms1 @ [not_false]
@@ -427,7 +427,7 @@
(map (incr_boundvars 1) rev_terms)
val t1' = incr_boundvars 1 t1
val t2' = incr_boundvars 1 t2
- val t1_lt_t2 = Const (@{const_name Algebras.less},
+ val t1_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type --> HOLogic.boolT) $ t1 $ t2
val t1_eq_t2_plus_d = Const ("op =", split_type --> split_type --> HOLogic.boolT) $ t1' $
(Const (@{const_name Algebras.plus},
@@ -451,7 +451,7 @@
val t1' = incr_boundvars 1 t1
val t1_eq_nat_n = Const ("op =", HOLogic.intT --> HOLogic.intT --> HOLogic.boolT) $ t1' $
(Const (@{const_name of_nat}, HOLogic.natT --> HOLogic.intT) $ n)
- val t1_lt_zero = Const (@{const_name Algebras.less},
+ val t1_lt_zero = Const (@{const_name Orderings.less},
HOLogic.intT --> HOLogic.intT --> HOLogic.boolT) $ t1 $ zero_int
val not_false = HOLogic.mk_Trueprop (HOLogic.Not $ HOLogic.false_const)
val subgoal1 = (HOLogic.mk_Trueprop t1_eq_nat_n) :: terms1 @ [not_false]
@@ -477,7 +477,7 @@
split_type --> split_type --> HOLogic.boolT) $ t2 $ zero
val t2_neq_zero = HOLogic.mk_not (Const ("op =",
split_type --> split_type --> HOLogic.boolT) $ t2' $ zero)
- val j_lt_t2 = Const (@{const_name Algebras.less},
+ val j_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type--> HOLogic.boolT) $ j $ t2'
val t1_eq_t2_times_i_plus_j = Const ("op =", split_type --> split_type --> HOLogic.boolT) $ t1' $
(Const (@{const_name Algebras.plus}, split_type --> split_type --> split_type) $
@@ -509,7 +509,7 @@
split_type --> split_type --> HOLogic.boolT) $ t2 $ zero
val t2_neq_zero = HOLogic.mk_not (Const ("op =",
split_type --> split_type --> HOLogic.boolT) $ t2' $ zero)
- val j_lt_t2 = Const (@{const_name Algebras.less},
+ val j_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type--> HOLogic.boolT) $ j $ t2'
val t1_eq_t2_times_i_plus_j = Const ("op =", split_type --> split_type --> HOLogic.boolT) $ t1' $
(Const (@{const_name Algebras.plus}, split_type --> split_type --> split_type) $
@@ -545,17 +545,17 @@
val t2' = incr_boundvars 2 t2
val t2_eq_zero = Const ("op =",
split_type --> split_type --> HOLogic.boolT) $ t2 $ zero
- val zero_lt_t2 = Const (@{const_name Algebras.less},
+ val zero_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type --> HOLogic.boolT) $ zero $ t2'
- val t2_lt_zero = Const (@{const_name Algebras.less},
+ val t2_lt_zero = Const (@{const_name Orderings.less},
split_type --> split_type --> HOLogic.boolT) $ t2' $ zero
- val zero_leq_j = Const (@{const_name Algebras.less_eq},
+ val zero_leq_j = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ zero $ j
- val j_leq_zero = Const (@{const_name Algebras.less_eq},
+ val j_leq_zero = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ j $ zero
- val j_lt_t2 = Const (@{const_name Algebras.less},
+ val j_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type--> HOLogic.boolT) $ j $ t2'
- val t2_lt_j = Const (@{const_name Algebras.less},
+ val t2_lt_j = Const (@{const_name Orderings.less},
split_type --> split_type--> HOLogic.boolT) $ t2' $ j
val t1_eq_t2_times_i_plus_j = Const ("op =", split_type --> split_type --> HOLogic.boolT) $ t1' $
(Const (@{const_name Algebras.plus}, split_type --> split_type --> split_type) $
@@ -599,17 +599,17 @@
val t2' = incr_boundvars 2 t2
val t2_eq_zero = Const ("op =",
split_type --> split_type --> HOLogic.boolT) $ t2 $ zero
- val zero_lt_t2 = Const (@{const_name Algebras.less},
+ val zero_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type --> HOLogic.boolT) $ zero $ t2'
- val t2_lt_zero = Const (@{const_name Algebras.less},
+ val t2_lt_zero = Const (@{const_name Orderings.less},
split_type --> split_type --> HOLogic.boolT) $ t2' $ zero
- val zero_leq_j = Const (@{const_name Algebras.less_eq},
+ val zero_leq_j = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ zero $ j
- val j_leq_zero = Const (@{const_name Algebras.less_eq},
+ val j_leq_zero = Const (@{const_name Orderings.less_eq},
split_type --> split_type --> HOLogic.boolT) $ j $ zero
- val j_lt_t2 = Const (@{const_name Algebras.less},
+ val j_lt_t2 = Const (@{const_name Orderings.less},
split_type --> split_type--> HOLogic.boolT) $ j $ t2'
- val t2_lt_j = Const (@{const_name Algebras.less},
+ val t2_lt_j = Const (@{const_name Orderings.less},
split_type --> split_type--> HOLogic.boolT) $ t2' $ j
val t1_eq_t2_times_i_plus_j = Const ("op =", split_type --> split_type --> HOLogic.boolT) $ t1' $
(Const (@{const_name Algebras.plus}, split_type --> split_type --> split_type) $
--- a/src/HOL/Tools/nat_arith.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/nat_arith.ML Thu Feb 11 12:26:50 2010 -0800
@@ -51,7 +51,7 @@
val dest_sum = dest_sum;
val prove_conv = Arith_Data.prove_conv2;
val norm_tac1 = Arith_Data.simp_all_tac [@{thm add_Suc}, @{thm add_Suc_right},
- @{thm add_0}, @{thm Nat.add_0_right}];
+ @{thm Nat.add_0}, @{thm Nat.add_0_right}];
val norm_tac2 = Arith_Data.simp_all_tac @{thms add_ac};
fun norm_tac ss = norm_tac1 ss THEN norm_tac2 ss;
fun gen_uncancel_tac rule = let val rule' = rule RS @{thm subst_equals}
@@ -69,16 +69,16 @@
structure LessCancelSums = CancelSumsFun
(struct
open CommonCancelSums;
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less};
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} HOLogic.natT;
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less};
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} HOLogic.natT;
val uncancel_tac = gen_uncancel_tac @{thm "nat_add_left_cancel_less"};
end);
structure LeCancelSums = CancelSumsFun
(struct
open CommonCancelSums;
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq};
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} HOLogic.natT;
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq};
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} HOLogic.natT;
val uncancel_tac = gen_uncancel_tac @{thm "nat_add_left_cancel_le"};
end);
--- a/src/HOL/Tools/nat_numeral_simprocs.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/nat_numeral_simprocs.ML Thu Feb 11 12:26:50 2010 -0800
@@ -124,7 +124,7 @@
(*Simplify 1*n and n*1 to n*)
-val add_0s = map rename_numerals [@{thm add_0}, @{thm Nat.add_0_right}];
+val add_0s = map rename_numerals [@{thm Nat.add_0}, @{thm Nat.add_0_right}];
val mult_1s = map rename_numerals [@{thm nat_mult_1}, @{thm nat_mult_1_right}];
(*Final simplification: cancel + and *; replace Numeral0 by 0 and Numeral1 by 1*)
@@ -136,7 +136,7 @@
val simplify_meta_eq =
Arith_Data.simplify_meta_eq
- ([@{thm nat_numeral_0_eq_0}, @{thm numeral_1_eq_Suc_0}, @{thm add_0}, @{thm Nat.add_0_right},
+ ([@{thm nat_numeral_0_eq_0}, @{thm numeral_1_eq_Suc_0}, @{thm Nat.add_0}, @{thm Nat.add_0_right},
@{thm mult_0}, @{thm mult_0_right}, @{thm mult_1}, @{thm mult_1_right}] @ contra_rules);
@@ -176,8 +176,8 @@
structure LessCancelNumerals = CancelNumeralsFun
(open CancelNumeralsCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} HOLogic.natT
val bal_add1 = @{thm nat_less_add_iff1} RS trans
val bal_add2 = @{thm nat_less_add_iff2} RS trans
);
@@ -185,8 +185,8 @@
structure LeCancelNumerals = CancelNumeralsFun
(open CancelNumeralsCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} HOLogic.natT
val bal_add1 = @{thm nat_le_add_iff1} RS trans
val bal_add2 = @{thm nat_le_add_iff2} RS trans
);
@@ -308,8 +308,8 @@
structure LessCancelNumeralFactor = CancelNumeralFactorFun
(open CancelNumeralFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} HOLogic.natT
val cancel = @{thm nat_mult_less_cancel1} RS trans
val neg_exchanges = true
)
@@ -317,8 +317,8 @@
structure LeCancelNumeralFactor = CancelNumeralFactorFun
(open CancelNumeralFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} HOLogic.natT
val cancel = @{thm nat_mult_le_cancel1} RS trans
val neg_exchanges = true
)
@@ -387,16 +387,16 @@
structure LessCancelFactor = ExtractCommonTermFun
(open CancelFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} HOLogic.natT
fun simp_conv _ _ = SOME @{thm nat_mult_less_cancel_disj}
);
structure LeCancelFactor = ExtractCommonTermFun
(open CancelFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} HOLogic.natT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} HOLogic.natT
fun simp_conv _ _ = SOME @{thm nat_mult_le_cancel_disj}
);
--- a/src/HOL/Tools/numeral_simprocs.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/numeral_simprocs.ML Thu Feb 11 12:26:50 2010 -0800
@@ -96,7 +96,7 @@
Fractions are reduced later by the cancel_numeral_factor simproc.*)
fun add_frac ((p1, q1), (p2, q2)) = (p1 * q2 + p2 * q1, q1 * q2);
-val mk_divide = HOLogic.mk_binop @{const_name Algebras.divide};
+val mk_divide = HOLogic.mk_binop @{const_name Rings.divide};
(*Build term (p / q) * t*)
fun mk_fcoeff ((p, q), t) =
@@ -105,7 +105,7 @@
(*Express t as a product of a fraction with other sorted terms*)
fun dest_fcoeff sign (Const (@{const_name Algebras.uminus}, _) $ t) = dest_fcoeff (~sign) t
- | dest_fcoeff sign (Const (@{const_name Algebras.divide}, _) $ t $ u) =
+ | dest_fcoeff sign (Const (@{const_name Rings.divide}, _) $ t $ u) =
let val (p, t') = dest_coeff sign t
val (q, u') = dest_coeff 1 u
in (mk_frac (p, q), mk_divide (t', u')) end
@@ -229,8 +229,8 @@
structure LessCancelNumerals = CancelNumeralsFun
(open CancelNumeralsCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} Term.dummyT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} Term.dummyT
val bal_add1 = @{thm less_add_iff1} RS trans
val bal_add2 = @{thm less_add_iff2} RS trans
);
@@ -238,8 +238,8 @@
structure LeCancelNumerals = CancelNumeralsFun
(open CancelNumeralsCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} Term.dummyT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} Term.dummyT
val bal_add1 = @{thm le_add_iff1} RS trans
val bal_add2 = @{thm le_add_iff2} RS trans
);
@@ -373,7 +373,7 @@
[@{thm eq_number_of_eq}, @{thm less_number_of}, @{thm le_number_of}] @ simps
fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
val simplify_meta_eq = Arith_Data.simplify_meta_eq
- [@{thm add_0}, @{thm Nat.add_0_right}, @{thm mult_zero_left},
+ [@{thm Nat.add_0}, @{thm Nat.add_0_right}, @{thm mult_zero_left},
@{thm mult_zero_right}, @{thm mult_Bit1}, @{thm mult_1_right}];
end
@@ -391,8 +391,8 @@
structure DivideCancelNumeralFactor = CancelNumeralFactorFun
(open CancelNumeralFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binop @{const_name Algebras.divide}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.divide} Term.dummyT
+ val mk_bal = HOLogic.mk_binop @{const_name Rings.divide}
+ val dest_bal = HOLogic.dest_bin @{const_name Rings.divide} Term.dummyT
val cancel = @{thm mult_divide_mult_cancel_left} RS trans
val neg_exchanges = false
)
@@ -409,8 +409,8 @@
structure LessCancelNumeralFactor = CancelNumeralFactorFun
(open CancelNumeralFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} Term.dummyT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} Term.dummyT
val cancel = @{thm mult_less_cancel_left} RS trans
val neg_exchanges = true
)
@@ -418,8 +418,8 @@
structure LeCancelNumeralFactor = CancelNumeralFactorFun
(open CancelNumeralFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} Term.dummyT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} Term.dummyT
val cancel = @{thm mult_le_cancel_left} RS trans
val neg_exchanges = true
)
@@ -485,7 +485,7 @@
fun sign_conv pos_th neg_th ss t =
let val T = fastype_of t;
val zero = Const(@{const_name Algebras.zero}, T);
- val less = Const(@{const_name Algebras.less}, [T,T] ---> HOLogic.boolT);
+ val less = Const(@{const_name Orderings.less}, [T,T] ---> HOLogic.boolT);
val pos = less $ zero $ t and neg = less $ t $ zero
fun prove p =
Option.map Eq_True_elim (Lin_Arith.simproc ss p)
@@ -524,8 +524,8 @@
structure LeCancelFactor = ExtractCommonTermFun
(open CancelFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less_eq}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less_eq} Term.dummyT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} Term.dummyT
val simp_conv = sign_conv
@{thm mult_le_cancel_left_pos} @{thm mult_le_cancel_left_neg}
);
@@ -534,8 +534,8 @@
structure LessCancelFactor = ExtractCommonTermFun
(open CancelFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binrel @{const_name Algebras.less}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.less} Term.dummyT
+ val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
+ val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} Term.dummyT
val simp_conv = sign_conv
@{thm mult_less_cancel_left_pos} @{thm mult_less_cancel_left_neg}
);
@@ -570,8 +570,8 @@
structure DivideCancelFactor = ExtractCommonTermFun
(open CancelFactorCommon
val prove_conv = Arith_Data.prove_conv
- val mk_bal = HOLogic.mk_binop @{const_name Algebras.divide}
- val dest_bal = HOLogic.dest_bin @{const_name Algebras.divide} Term.dummyT
+ val mk_bal = HOLogic.mk_binop @{const_name Rings.divide}
+ val dest_bal = HOLogic.dest_bin @{const_name Rings.divide} Term.dummyT
fun simp_conv _ _ = SOME @{thm mult_divide_mult_cancel_left_if}
);
--- a/src/HOL/Tools/refute.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/refute.ML Thu Feb 11 12:26:50 2010 -0800
@@ -708,7 +708,7 @@
(* other optimizations *)
| Const (@{const_name Finite_Set.card}, _) => t
| Const (@{const_name Finite_Set.finite}, _) => t
- | Const (@{const_name Algebras.less}, Type ("fun", [Type ("nat", []),
+ | Const (@{const_name Orderings.less}, Type ("fun", [Type ("nat", []),
Type ("fun", [Type ("nat", []), Type ("bool", [])])])) => t
| Const (@{const_name Algebras.plus}, Type ("fun", [Type ("nat", []),
Type ("fun", [Type ("nat", []), Type ("nat", [])])])) => t
@@ -883,7 +883,7 @@
| Const (@{const_name Finite_Set.card}, T) => collect_type_axioms T axs
| Const (@{const_name Finite_Set.finite}, T) =>
collect_type_axioms T axs
- | Const (@{const_name Algebras.less}, T as Type ("fun", [Type ("nat", []),
+ | Const (@{const_name Orderings.less}, T as Type ("fun", [Type ("nat", []),
Type ("fun", [Type ("nat", []), Type ("bool", [])])])) =>
collect_type_axioms T axs
| Const (@{const_name Algebras.plus}, T as Type ("fun", [Type ("nat", []),
@@ -2771,7 +2771,7 @@
fun Nat_less_interpreter thy model args t =
case t of
- Const (@{const_name Algebras.less}, Type ("fun", [Type ("nat", []),
+ Const (@{const_name Orderings.less}, Type ("fun", [Type ("nat", []),
Type ("fun", [Type ("nat", []), Type ("bool", [])])])) =>
let
val size_of_nat = size_of_type thy model (Type ("nat", []))
--- a/src/HOL/Tools/res_clause.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Tools/res_clause.ML Thu Feb 11 12:26:50 2010 -0800
@@ -99,7 +99,7 @@
(*Provide readable names for the more common symbolic functions*)
val const_trans_table =
Symtab.make [(@{const_name "op ="}, "equal"),
- (@{const_name Algebras.less_eq}, "lessequals"),
+ (@{const_name Orderings.less_eq}, "lessequals"),
(@{const_name "op &"}, "and"),
(@{const_name "op |"}, "or"),
(@{const_name "op -->"}, "implies"),
--- a/src/HOL/UNITY/Union.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/UNITY/Union.thy Thu Feb 11 12:26:50 2010 -0800
@@ -42,7 +42,7 @@
translations
"JN x: A. B" == "CONST JOIN A (%x. B)"
"JN x y. B" == "JN x. JN y. B"
- "JN x. B" == "JOIN CONST UNIV (%x. B)"
+ "JN x. B" == "CONST JOIN (CONST UNIV) (%x. B)"
syntax (xsymbols)
SKIP :: "'a program" ("\<bottom>")
--- a/src/HOL/Word/WordDefinition.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/Word/WordDefinition.thy Thu Feb 11 12:26:50 2010 -0800
@@ -94,7 +94,7 @@
syntax
of_int :: "int => 'a"
translations
- "case x of of_int y => b" == "CONST word_int_case (%y. b) x"
+ "case x of CONST of_int y => b" == "CONST word_int_case (%y. b) x"
subsection "Arithmetic operations"
--- a/src/HOL/ex/SVC_Oracle.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/ex/SVC_Oracle.thy Thu Feb 11 12:26:50 2010 -0800
@@ -65,7 +65,7 @@
(*abstraction of a real/rational expression*)
fun rat ((c as Const(@{const_name Algebras.plus}, _)) $ x $ y) = c $ (rat x) $ (rat y)
| rat ((c as Const(@{const_name Algebras.minus}, _)) $ x $ y) = c $ (rat x) $ (rat y)
- | rat ((c as Const(@{const_name Algebras.divide}, _)) $ x $ y) = c $ (rat x) $ (rat y)
+ | rat ((c as Const(@{const_name Rings.divide}, _)) $ x $ y) = c $ (rat x) $ (rat y)
| rat ((c as Const(@{const_name Algebras.times}, _)) $ x $ y) = c $ (rat x) $ (rat y)
| rat ((c as Const(@{const_name Algebras.uminus}, _)) $ x) = c $ (rat x)
| rat t = lit t
@@ -95,8 +95,8 @@
| fm ((c as Const("True", _))) = c
| fm ((c as Const("False", _))) = c
| fm (t as Const("op =", Type ("fun", [T,_])) $ _ $ _) = rel (T, t)
- | fm (t as Const(@{const_name Algebras.less}, Type ("fun", [T,_])) $ _ $ _) = rel (T, t)
- | fm (t as Const(@{const_name Algebras.less_eq}, Type ("fun", [T,_])) $ _ $ _) = rel (T, t)
+ | fm (t as Const(@{const_name Orderings.less}, Type ("fun", [T,_])) $ _ $ _) = rel (T, t)
+ | fm (t as Const(@{const_name Orderings.less_eq}, Type ("fun", [T,_])) $ _ $ _) = rel (T, t)
| fm t = replace t
(*entry point, and abstraction of a meta-formula*)
fun mt ((c as Const("Trueprop", _)) $ p) = c $ (fm p)
--- a/src/HOL/ex/svc_funcs.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/HOL/ex/svc_funcs.ML Thu Feb 11 12:26:50 2010 -0800
@@ -107,8 +107,8 @@
b1 orelse b2)
end
else (*might be numeric equality*) (t, is_intnat T)
- | Const(@{const_name Algebras.less}, Type ("fun", [T,_])) => (t, is_intnat T)
- | Const(@{const_name Algebras.less_eq}, Type ("fun", [T,_])) => (t, is_intnat T)
+ | Const(@{const_name Orderings.less}, Type ("fun", [T,_])) => (t, is_intnat T)
+ | Const(@{const_name Orderings.less_eq}, Type ("fun", [T,_])) => (t, is_intnat T)
| _ => (t, false)
end
in #1 o tag end;
@@ -173,7 +173,7 @@
| tm (Const(@{const_name Algebras.times}, T) $ x $ y) =
if is_numeric_op T then Interp("*", [tm x, tm y])
else fail t
- | tm (Const(@{const_name Algebras.inverse}, T) $ x) =
+ | tm (Const(@{const_name Rings.inverse}, T) $ x) =
if domain_type T = HOLogic.realT then
Rat(1, litExp x)
else fail t
@@ -211,13 +211,13 @@
else fail t
end
(*inequalities: possible types are nat, int, real*)
- | fm pos (t as Const(@{const_name Algebras.less}, Type ("fun", [T,_])) $ x $ y) =
+ | fm pos (t as Const(@{const_name Orderings.less}, Type ("fun", [T,_])) $ x $ y) =
if not pos orelse T = HOLogic.realT then
Buildin("<", [tm x, tm y])
else if is_intnat T then
Buildin("<=", [suc (tm x), tm y])
else fail t
- | fm pos (t as Const(@{const_name Algebras.less_eq}, Type ("fun", [T,_])) $ x $ y) =
+ | fm pos (t as Const(@{const_name Orderings.less_eq}, Type ("fun", [T,_])) $ x $ y) =
if pos orelse T = HOLogic.realT then
Buildin("<=", [tm x, tm y])
else if is_intnat T then
--- a/src/Tools/quickcheck.ML Thu Feb 11 12:26:07 2010 -0800
+++ b/src/Tools/quickcheck.ML Thu Feb 11 12:26:50 2010 -0800
@@ -153,9 +153,9 @@
|> ObjectLogic.atomize_term thy;
in test_term ctxt quiet generator_name size iterations gi' end;
-fun pretty_counterex ctxt NONE = Pretty.str "No counterexamples found."
+fun pretty_counterex ctxt NONE = Pretty.str "Quickcheck found no counterexample."
| pretty_counterex ctxt (SOME cex) =
- Pretty.chunks (Pretty.str "Counterexample found:\n" ::
+ Pretty.chunks (Pretty.str "Quickcheck found a counterexample:\n" ::
map (fn (s, t) =>
Pretty.block [Pretty.str (s ^ " ="), Pretty.brk 1, Syntax.pretty_term ctxt t]) cex);
--- a/src/ZF/IMP/Com.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/ZF/IMP/Com.thy Thu Feb 11 12:26:50 2010 -0800
@@ -22,8 +22,10 @@
consts evala :: i
-syntax "_evala" :: "[i, i] => o" (infixl "-a->" 50)
-translations "p -a-> n" == "<p,n> \<in> evala"
+
+abbreviation
+ evala_syntax :: "[i, i] => o" (infixl "-a->" 50)
+ where "p -a-> n == <p,n> \<in> evala"
inductive
domains "evala" \<subseteq> "(aexp \<times> (loc -> nat)) \<times> nat"
@@ -50,8 +52,10 @@
consts evalb :: i
-syntax "_evalb" :: "[i,i] => o" (infixl "-b->" 50)
-translations "p -b-> b" == "<p,b> \<in> evalb"
+
+abbreviation
+ evalb_syntax :: "[i,i] => o" (infixl "-b->" 50)
+ where "p -b-> b == <p,b> \<in> evalb"
inductive
domains "evalb" \<subseteq> "(bexp \<times> (loc -> nat)) \<times> bool"
@@ -82,8 +86,10 @@
consts evalc :: i
-syntax "_evalc" :: "[i, i] => o" (infixl "-c->" 50)
-translations "p -c-> s" == "<p,s> \<in> evalc"
+
+abbreviation
+ evalc_syntax :: "[i, i] => o" (infixl "-c->" 50)
+ where "p -c-> s == <p,s> \<in> evalc"
inductive
domains "evalc" \<subseteq> "(com \<times> (loc -> nat)) \<times> (loc -> nat)"
--- a/src/ZF/Induct/Comb.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/ZF/Induct/Comb.thy Thu Feb 11 12:26:50 2010 -0800
@@ -30,12 +30,14 @@
consts
contract :: i
-syntax
- "_contract" :: "[i,i] => o" (infixl "-1->" 50)
- "_contract_multi" :: "[i,i] => o" (infixl "--->" 50)
-translations
- "p -1-> q" == "<p,q> \<in> contract"
- "p ---> q" == "<p,q> \<in> contract^*"
+
+abbreviation
+ contract_syntax :: "[i,i] => o" (infixl "-1->" 50)
+ where "p -1-> q == <p,q> \<in> contract"
+
+abbreviation
+ contract_multi :: "[i,i] => o" (infixl "--->" 50)
+ where "p ---> q == <p,q> \<in> contract^*"
syntax (xsymbols)
"comb.app" :: "[i, i] => i" (infixl "\<bullet>" 90)
@@ -56,12 +58,14 @@
consts
parcontract :: i
-syntax
- "_parcontract" :: "[i,i] => o" (infixl "=1=>" 50)
- "_parcontract_multi" :: "[i,i] => o" (infixl "===>" 50)
-translations
- "p =1=> q" == "<p,q> \<in> parcontract"
- "p ===> q" == "<p,q> \<in> parcontract^+"
+
+abbreviation
+ parcontract_syntax :: "[i,i] => o" (infixl "=1=>" 50)
+ where "p =1=> q == <p,q> \<in> parcontract"
+
+abbreviation
+ parcontract_multi :: "[i,i] => o" (infixl "===>" 50)
+ where "p ===> q == <p,q> \<in> parcontract^+"
inductive
domains "parcontract" \<subseteq> "comb \<times> comb"
--- a/src/ZF/Induct/PropLog.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/ZF/Induct/PropLog.thy Thu Feb 11 12:26:50 2010 -0800
@@ -34,8 +34,10 @@
subsection {* The proof system *}
consts thms :: "i => i"
-syntax "_thms" :: "[i,i] => o" (infixl "|-" 50)
-translations "H |- p" == "p \<in> thms(H)"
+
+abbreviation
+ thms_syntax :: "[i,i] => o" (infixl "|-" 50)
+ where "H |- p == p \<in> thms(H)"
inductive
domains "thms(H)" \<subseteq> "propn"
--- a/src/ZF/List_ZF.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/ZF/List_ZF.thy Thu Feb 11 12:26:50 2010 -0800
@@ -19,9 +19,9 @@
"@List" :: "is => i" ("[(_)]")
translations
- "[x, xs]" == "Cons(x, [xs])"
- "[x]" == "Cons(x, [])"
- "[]" == "Nil"
+ "[x, xs]" == "CONST Cons(x, [xs])"
+ "[x]" == "CONST Cons(x, [])"
+ "[]" == "CONST Nil"
consts
--- a/src/ZF/ZF.thy Thu Feb 11 12:26:07 2010 -0800
+++ b/src/ZF/ZF.thy Thu Feb 11 12:26:50 2010 -0800
@@ -127,23 +127,23 @@
"@patterns" :: "[pttrn, patterns] => patterns" ("_,/_")
translations
- "{x, xs}" == "cons(x, {xs})"
- "{x}" == "cons(x, 0)"
- "{x:A. P}" == "Collect(A, %x. P)"
- "{y. x:A, Q}" == "Replace(A, %x y. Q)"
- "{b. x:A}" == "RepFun(A, %x. b)"
- "INT x:A. B" == "Inter({B. x:A})"
- "UN x:A. B" == "Union({B. x:A})"
- "PROD x:A. B" == "Pi(A, %x. B)"
- "SUM x:A. B" == "Sigma(A, %x. B)"
- "lam x:A. f" == "Lambda(A, %x. f)"
- "ALL x:A. P" == "Ball(A, %x. P)"
- "EX x:A. P" == "Bex(A, %x. P)"
+ "{x, xs}" == "CONST cons(x, {xs})"
+ "{x}" == "CONST cons(x, 0)"
+ "{x:A. P}" == "CONST Collect(A, %x. P)"
+ "{y. x:A, Q}" == "CONST Replace(A, %x y. Q)"
+ "{b. x:A}" == "CONST RepFun(A, %x. b)"
+ "INT x:A. B" == "CONST Inter({B. x:A})"
+ "UN x:A. B" == "CONST Union({B. x:A})"
+ "PROD x:A. B" == "CONST Pi(A, %x. B)"
+ "SUM x:A. B" == "CONST Sigma(A, %x. B)"
+ "lam x:A. f" == "CONST Lambda(A, %x. f)"
+ "ALL x:A. P" == "CONST Ball(A, %x. P)"
+ "EX x:A. P" == "CONST Bex(A, %x. P)"
"<x, y, z>" == "<x, <y, z>>"
- "<x, y>" == "Pair(x, y)"
- "%<x,y,zs>.b" == "split(%x <y,zs>.b)"
- "%<x,y>.b" == "split(%x y. b)"
+ "<x, y>" == "CONST Pair(x, y)"
+ "%<x,y,zs>.b" == "CONST split(%x <y,zs>.b)"
+ "%<x,y>.b" == "CONST split(%x y. b)"
notation (xsymbols)