merged (manual for "nitpick_hol.ML" and "kodkod.ML")
authorblanchet
Tue Feb 09 17:06:05 2010 +0100 (2010-02-09)
changeset 35079592edca1dfb3
parent 35062 fc1594f6adbc
parent 35078 6fd1052fe463
child 35080 342888d802d8
merged (manual for "nitpick_hol.ML" and "kodkod.ML")
src/HOL/IsaMakefile
src/HOL/Nitpick.thy
src/HOL/Tools/Nitpick/kodkod.ML
src/HOL/Tools/Nitpick/nitpick_hol.ML
src/HOL/Tools/Nitpick/nitpick_mono.ML
src/HOL/Tools/Nitpick/nitpick_nut.ML
src/HOL/Tools/Nitpick/nitpick_preproc.ML
     1.1 --- a/doc-src/Nitpick/nitpick.tex	Tue Feb 09 13:54:27 2010 +0100
     1.2 +++ b/doc-src/Nitpick/nitpick.tex	Tue Feb 09 17:06:05 2010 +0100
     1.3 @@ -154,7 +154,7 @@
     1.4  the line
     1.5  
     1.6  \prew
     1.7 -\textbf{nitpick\_params} [\textit{sat\_solver}~= \textit{MiniSatJNI}, \,\textit{max\_threads}~= 1]
     1.8 +\textbf{nitpick\_params} [\textit{sat\_solver}~= \textit{MiniSat\_JNI}, \,\textit{max\_threads}~= 1]
     1.9  \postw
    1.10  
    1.11  after the \textbf{begin} keyword. The JNI version of MiniSat is bundled with
    1.12 @@ -311,9 +311,9 @@
    1.13  \slshape Constant: \nopagebreak \\
    1.14  \hbox{}\qquad $\mathit{The} = \undef{}
    1.15      (\!\begin{aligned}[t]%
    1.16 -    & \{\} := a_3,\> \{a_3\} := a_3,\> \{a_2\} := a_2, \\[-2pt] %% TYPESETTING
    1.17 -    & \{a_2, a_3\} := a_1,\> \{a_1\} := a_1,\> \{a_1, a_3\} := a_3, \\[-2pt]
    1.18 -    & \{a_1, a_2\} := a_3,\> \{a_1, a_2, a_3\} := a_3)\end{aligned}$
    1.19 +    & \{a_1, a_2, a_3\} := a_3,\> \{a_1, a_2\} := a_3,\> \{a_1, a_3\} := a_3, \\[-2pt] %% TYPESETTING
    1.20 +    & \{a_1\} := a_1,\> \{a_2, a_3\} := a_1,\> \{a_2\} := a_2, \\[-2pt]
    1.21 +    & \{a_3\} := a_3,\> \{\} := a_3)\end{aligned}$
    1.22  \postw
    1.23  
    1.24  Notice that $\textit{The}~(\lambda y.\;P~y) = \textit{The}~\{a_2, a_3\} = a_1$,
    1.25 @@ -550,7 +550,7 @@
    1.26  \slshape Nitpick found a counterexample for \textit{card} $'a$~= 3: \\[2\smallskipamount]
    1.27  \hbox{}\qquad Free variables: \nopagebreak \\
    1.28  \hbox{}\qquad\qquad $\textit{xs} = []$ \\
    1.29 -\hbox{}\qquad\qquad $\textit{y} = a_3$
    1.30 +\hbox{}\qquad\qquad $\textit{y} = a_1$
    1.31  \postw
    1.32  
    1.33  To see why the counterexample is genuine, we enable \textit{show\_consts}
    1.34 @@ -558,21 +558,21 @@
    1.35  
    1.36  \prew
    1.37  {\slshape Datatype:} \\
    1.38 -\hbox{}\qquad $'a$~\textit{list}~= $\{[],\, [a_3, a_3],\, [a_3],\, \unr\}$ \\
    1.39 +\hbox{}\qquad $'a$~\textit{list}~= $\{[],\, [a_1],\, [a_1, a_1],\, \unr\}$ \\
    1.40  {\slshape Constants:} \\
    1.41 -\hbox{}\qquad $\lambda x_1.\; x_1 \mathbin{@} [y, y] = \undef([] := [a_3, a_3])$ \\
    1.42 -\hbox{}\qquad $\textit{hd} = \undef([] := a_2,\> [a_3, a_3] := a_3,\> [a_3] := a_3)$
    1.43 +\hbox{}\qquad $\lambda x_1.\; x_1 \mathbin{@} [y, y] = \undef([] := [a_1, a_1])$ \\
    1.44 +\hbox{}\qquad $\textit{hd} = \undef([] := a_2,\> [a_1] := a_1,\> [a_1, a_1] := a_1)$
    1.45  \postw
    1.46  
    1.47  Since $\mathit{hd}~[]$ is undefined in the logic, it may be given any value,
    1.48  including $a_2$.
    1.49  
    1.50  The second constant, $\lambda x_1.\; x_1 \mathbin{@} [y, y]$, is simply the
    1.51 -append operator whose second argument is fixed to be $[y, y]$. Appending $[a_3,
    1.52 -a_3]$ to $[a_3]$ would normally give $[a_3, a_3, a_3]$, but this value is not
    1.53 +append operator whose second argument is fixed to be $[y, y]$. Appending $[a_1,
    1.54 +a_1]$ to $[a_1]$ would normally give $[a_1, a_1, a_1]$, but this value is not
    1.55  representable in the subset of $'a$~\textit{list} considered by Nitpick, which
    1.56  is shown under the ``Datatype'' heading; hence the result is $\unk$. Similarly,
    1.57 -appending $[a_3, a_3]$ to itself gives $\unk$.
    1.58 +appending $[a_1, a_1]$ to itself gives $\unk$.
    1.59  
    1.60  Given \textit{card}~$'a = 3$ and \textit{card}~$'a~\textit{list} = 3$, Nitpick
    1.61  considers the following subsets:
    1.62 @@ -600,8 +600,8 @@
    1.63  
    1.64  All subterm-closed subsets of $'a~\textit{list}$ consisting of three values
    1.65  are listed and only those. As an example of a non-subterm-closed subset,
    1.66 -consider $\mathcal{S} = \{[],\, [a_1],\,\allowbreak [a_1, a_3]\}$, and observe
    1.67 -that $[a_1, a_3]$ (i.e., $a_1 \mathbin{\#} [a_3]$) has $[a_3] \notin
    1.68 +consider $\mathcal{S} = \{[],\, [a_1],\,\allowbreak [a_1, a_2]\}$, and observe
    1.69 +that $[a_1, a_2]$ (i.e., $a_1 \mathbin{\#} [a_2]$) has $[a_2] \notin
    1.70  \mathcal{S}$ as a subterm.
    1.71  
    1.72  Here's another m\"ochtegern-lemma that Nitpick can refute without a blink:
    1.73 @@ -613,11 +613,11 @@
    1.74  \textbf{nitpick} [\textit{show\_datatypes}] \\[2\smallskipamount]
    1.75  \slshape Nitpick found a counterexample for \textit{card} $'a$~= 3: \\[2\smallskipamount]
    1.76  \hbox{}\qquad Free variables: \nopagebreak \\
    1.77 -\hbox{}\qquad\qquad $\textit{xs} = [a_2]$ \\
    1.78 -\hbox{}\qquad\qquad $\textit{ys} = [a_3]$ \\
    1.79 +\hbox{}\qquad\qquad $\textit{xs} = [a_1]$ \\
    1.80 +\hbox{}\qquad\qquad $\textit{ys} = [a_2]$ \\
    1.81  \hbox{}\qquad Datatypes: \\
    1.82  \hbox{}\qquad\qquad $\textit{nat} = \{0,\, 1,\, 2,\, \unr\}$ \\
    1.83 -\hbox{}\qquad\qquad $'a$~\textit{list} = $\{[],\, [a_3],\, [a_2],\, \unr\}$
    1.84 +\hbox{}\qquad\qquad $'a$~\textit{list} = $\{[],\, [a_1],\, [a_2],\, \unr\}$
    1.85  \postw
    1.86  
    1.87  Because datatypes are approximated using a three-valued logic, there is usually
    1.88 @@ -642,11 +642,11 @@
    1.89  \textbf{nitpick} [\textit{show\_datatypes}] \\[2\smallskipamount]
    1.90  \slshape Nitpick found a counterexample: \\[2\smallskipamount]
    1.91  \hbox{}\qquad Free variables: \nopagebreak \\
    1.92 -\hbox{}\qquad\qquad $P = \{\Abs{1},\, \Abs{0}\}$ \\
    1.93 +\hbox{}\qquad\qquad $P = \{\Abs{0},\, \Abs{1}\}$ \\
    1.94  \hbox{}\qquad\qquad $x = \Abs{2}$ \\
    1.95  \hbox{}\qquad Datatypes: \\
    1.96  \hbox{}\qquad\qquad $\textit{nat} = \{0,\, 1,\, 2,\, \unr\}$ \\
    1.97 -\hbox{}\qquad\qquad $\textit{three} = \{\Abs{2},\, \Abs{1},\, \Abs{0},\, \unr\}$
    1.98 +\hbox{}\qquad\qquad $\textit{three} = \{\Abs{0},\, \Abs{1},\, \Abs{2},\, \unr\}$
    1.99  \postw
   1.100  
   1.101  %% MARK
   1.102 @@ -664,12 +664,13 @@
   1.103  \textbf{nitpick} [\textit{show\_datatypes}] \\[2\smallskipamount]
   1.104  \slshape Nitpick found a counterexample: \\[2\smallskipamount]
   1.105  \hbox{}\qquad Free variables: \nopagebreak \\
   1.106 -\hbox{}\qquad\qquad $p = \lparr\textit{Xcoord} = 0,\> \textit{Ycoord} = 0\rparr$ \\
   1.107 -\hbox{}\qquad\qquad $q = \lparr\textit{Xcoord} = 1,\> \textit{Ycoord} = 1\rparr$ \\
   1.108 +\hbox{}\qquad\qquad $p = \lparr\textit{Xcoord} = 1,\> \textit{Ycoord} = 1\rparr$ \\
   1.109 +\hbox{}\qquad\qquad $q = \lparr\textit{Xcoord} = 0,\> \textit{Ycoord} = 0\rparr$ \\
   1.110  \hbox{}\qquad Datatypes: \\
   1.111  \hbox{}\qquad\qquad $\textit{int} = \{0,\, 1,\, \unr\}$ \\
   1.112 -\hbox{}\qquad\qquad $\textit{point} = \{\lparr\textit{Xcoord} = 1,\>
   1.113 -\textit{Ycoord} = 1\rparr,\> \lparr\textit{Xcoord} = 0,\> \textit{Ycoord} = 0\rparr,\, \unr\}$\kern-1pt %% QUIET
   1.114 +\hbox{}\qquad\qquad $\textit{point} = \{\!\begin{aligned}[t]
   1.115 +& \lparr\textit{Xcoord} = 0,\> \textit{Ycoord} = 0\rparr, \\[-2pt] %% TYPESETTING
   1.116 +& \lparr\textit{Xcoord} = 1,\> \textit{Ycoord} = 1\rparr,\, \unr\}\end{aligned}$
   1.117  \postw
   1.118  
   1.119  Finally, Nitpick provides rudimentary support for rationals and reals using a
   1.120 @@ -956,16 +957,16 @@
   1.121  depth}~= 1:
   1.122  \\[2\smallskipamount]
   1.123  \hbox{}\qquad Free variables: \nopagebreak \\
   1.124 -\hbox{}\qquad\qquad $\textit{a} = a_2$ \\
   1.125 -\hbox{}\qquad\qquad $\textit{b} = a_1$ \\
   1.126 -\hbox{}\qquad\qquad $\textit{xs} = \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega$ \\
   1.127 -\hbox{}\qquad\qquad $\textit{ys} = \textit{LCons}~a_1~(\textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega)$ \\[2\smallskipamount]
   1.128 +\hbox{}\qquad\qquad $\textit{a} = a_1$ \\
   1.129 +\hbox{}\qquad\qquad $\textit{b} = a_2$ \\
   1.130 +\hbox{}\qquad\qquad $\textit{xs} = \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\omega$ \\
   1.131 +\hbox{}\qquad\qquad $\textit{ys} = \textit{LCons}~a_2~(\textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\omega)$ \\[2\smallskipamount]
   1.132  Total time: 726 ms.
   1.133  \postw
   1.134  
   1.135 -The lazy list $\textit{xs}$ is simply $[a_2, a_2, a_2, \ldots]$, whereas
   1.136 -$\textit{ys}$ is $[a_1, a_2, a_2, a_2, \ldots]$, i.e., a lasso-shaped list with
   1.137 -$[a_1]$ as its stem and $[a_2]$ as its cycle. In general, the list segment
   1.138 +The lazy list $\textit{xs}$ is simply $[a_1, a_1, a_1, \ldots]$, whereas
   1.139 +$\textit{ys}$ is $[a_2, a_1, a_1, a_1, \ldots]$, i.e., a lasso-shaped list with
   1.140 +$[a_2]$ as its stem and $[a_1]$ as its cycle. In general, the list segment
   1.141  within the scope of the {THE} binder corresponds to the lasso's cycle, whereas
   1.142  the segment leading to the binder is the stem.
   1.143  
   1.144 @@ -1000,15 +1001,15 @@
   1.145  \textbf{nitpick} [\textit{bisim\_depth} = $-1$, \textit{show\_datatypes}] \\[2\smallskipamount]
   1.146  \slshape Nitpick found a likely genuine counterexample for $\textit{card}~'a$ = 2: \\[2\smallskipamount]
   1.147  \hbox{}\qquad Free variables: \nopagebreak \\
   1.148 -\hbox{}\qquad\qquad $a = a_2$ \\
   1.149 +\hbox{}\qquad\qquad $a = a_1$ \\
   1.150  \hbox{}\qquad\qquad $\textit{xs} = \textsl{THE}~\omega.\; \omega =
   1.151 -\textit{LCons}~a_2~\omega$ \\
   1.152 -\hbox{}\qquad\qquad $\textit{ys} = \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega$ \\
   1.153 +\textit{LCons}~a_1~\omega$ \\
   1.154 +\hbox{}\qquad\qquad $\textit{ys} = \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\omega$ \\
   1.155  \hbox{}\qquad Codatatype:\strut \nopagebreak \\
   1.156  \hbox{}\qquad\qquad $'a~\textit{llist} =
   1.157  \{\!\begin{aligned}[t]
   1.158 -  & \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega, \\[-2pt]
   1.159 -  & \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_2~\omega,\> \unr\}\end{aligned}$
   1.160 +  & \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\omega, \\[-2pt]
   1.161 +  & \textsl{THE}~\omega.\; \omega = \textit{LCons}~a_1~\omega,\> \unr\}\end{aligned}$
   1.162  \\[2\smallskipamount]
   1.163  Try again with ``\textit{bisim\_depth}'' set to a nonnegative value to confirm
   1.164  that the counterexample is genuine. \\[2\smallskipamount]
   1.165 @@ -1198,8 +1199,8 @@
   1.166  \textit{card} ``\kern1pt$'b$ \textit{list}''~= 5:
   1.167  \\[2\smallskipamount]
   1.168  \hbox{}\qquad Free variables: \nopagebreak \\
   1.169 -\hbox{}\qquad\qquad $\textit{xs} = [a_4, a_5]$ \\
   1.170 -\hbox{}\qquad\qquad $\textit{ys} = [b_3, b_3]$ \\[2\smallskipamount]
   1.171 +\hbox{}\qquad\qquad $\textit{xs} = [a_1, a_2]$ \\
   1.172 +\hbox{}\qquad\qquad $\textit{ys} = [b_1, b_1]$ \\[2\smallskipamount]
   1.173  Total time: 1636 ms.
   1.174  \postw
   1.175  
   1.176 @@ -1377,21 +1378,21 @@
   1.177  \prew
   1.178  \slshape Nitpick found a nonstandard counterexample for \textit{card} $'a$ = 4: \\[2\smallskipamount]
   1.179  \hbox{}\qquad Free variables: \nopagebreak \\
   1.180 -\hbox{}\qquad\qquad $a = a_4$ \\
   1.181 -\hbox{}\qquad\qquad $b = a_3$ \\
   1.182 -\hbox{}\qquad\qquad $t = \xi_3$ \\
   1.183 -\hbox{}\qquad\qquad $u = \xi_4$ \\
   1.184 +\hbox{}\qquad\qquad $a = a_1$ \\
   1.185 +\hbox{}\qquad\qquad $b = a_2$ \\
   1.186 +\hbox{}\qquad\qquad $t = \xi_1$ \\
   1.187 +\hbox{}\qquad\qquad $u = \xi_2$ \\
   1.188  \hbox{}\qquad {\slshape Constants:} \nopagebreak \\
   1.189  \hbox{}\qquad\qquad $\textit{labels} = \undef
   1.190      (\!\begin{aligned}[t]%
   1.191 -    & \xi_3 := \{a_4\},\> \xi_4 := \{a_1, a_3\}, \\[-2pt] %% TYPESETTING
   1.192 -    & \textit{Branch}~\xi_3~\xi_3 := \{a_4\}, \\[-2pt]
   1.193 -    & \textit{Branch}~\xi_3~\xi_4 := \{a_1, a_3, a_4\})\end{aligned}$ \\
   1.194 +    & \xi_1 := \{a_1, a_4, a_3^\Q\},\> \xi_2 := \{a_2, a_3^\Q\}, \\[-2pt] %% TYPESETTING
   1.195 +    & \textit{Branch}~\xi_1~\xi_2 := \{a_1, a_2, a_4, a_3^\Q\}, \\[-2pt]
   1.196 +    & \textit{Branch}~\xi_2~\xi_2 := \{a_2, a_3^\Q\})\end{aligned}$ \\
   1.197  \hbox{}\qquad\qquad $\lambda x_1.\> \textit{swap}~x_1~a~b = \undef
   1.198      (\!\begin{aligned}[t]%
   1.199 -    & \xi_3 := \xi_3,\> \xi_4 := \xi_3, \\[-2pt]
   1.200 -    & \textit{Branch}~\xi_3~\xi_3 := \textit{Branch}~\xi_3~\xi_3, \\[-2pt]
   1.201 -    & \textit{Branch}~\xi_4~\xi_3 := \textit{Branch}~\xi_3~\xi_3)\end{aligned}$ \\[2\smallskipamount]
   1.202 +    & \xi_1 := \xi_2,\> \xi_2 := \xi_2, \\[-2pt]
   1.203 +    & \textit{Branch}~\xi_1~\xi_2 := \textit{Branch}~\xi_2~\xi_2, \\[-2pt]
   1.204 +    & \textit{Branch}~\xi_2~\xi_2 := \textit{Branch}~\xi_2~\xi_2)\end{aligned}$ \\[2\smallskipamount]
   1.205  The existence of a nonstandard model suggests that the induction hypothesis is not general enough or perhaps
   1.206  even wrong. See the ``Inductive Properties'' section of the Nitpick manual for details (``\textit{isabelle doc nitpick}'').
   1.207  \postw
   1.208 @@ -1406,7 +1407,7 @@
   1.209  allowing unreachable states in the preceding example (by removing the ``$n \in
   1.210  \textit{reach\/}$'' assumption). In both cases, we effectively enlarge the
   1.211  set of objects over which the induction is performed while doing the step
   1.212 -so as to test the induction hypothesis's strength.}
   1.213 +in order to test the induction hypothesis's strength.}
   1.214  The new trees are so nonstandard that we know nothing about them, except what
   1.215  the induction hypothesis states and what can be proved about all trees without
   1.216  relying on induction or case distinction. The key observation is,
   1.217 @@ -1417,8 +1418,8 @@
   1.218  objects, and Nitpick won't find any nonstandard counterexample.}
   1.219  \end{quote}
   1.220  %
   1.221 -But here, Nitpick did find some nonstandard trees $t = \xi_3$
   1.222 -and $u = \xi_4$ such that $a \in \textit{labels}~t$, $b \notin
   1.223 +But here, Nitpick did find some nonstandard trees $t = \xi_1$
   1.224 +and $u = \xi_2$ such that $a \in \textit{labels}~t$, $b \notin
   1.225  \textit{labels}~t$, $a \notin \textit{labels}~u$, and $b \in \textit{labels}~u$.
   1.226  Because neither tree contains both $a$ and $b$, the induction hypothesis tells
   1.227  us nothing about the labels of $\textit{swap}~t~a~b$ and $\textit{swap}~u~a~b$,
   1.228 @@ -1441,7 +1442,7 @@
   1.229  \postw
   1.230  
   1.231  This time, Nitpick won't find any nonstandard counterexample, and we can perform
   1.232 -the induction step using \textbf{auto}.
   1.233 +the induction step using \textit{auto}.
   1.234  
   1.235  \section{Case Studies}
   1.236  \label{case-studies}
   1.237 @@ -1694,7 +1695,7 @@
   1.238  ``$\textit{dataset}~(\textit{skew}~t) = \textit{dataset}~t$'' \\
   1.239  ``$\textit{dataset}~(\textit{split}~t) = \textit{dataset}~t$'' \\
   1.240  \textbf{nitpick} \\[2\smallskipamount]
   1.241 -{\slshape Nitpick ran out of time after checking 7 of 8 scopes.}
   1.242 +{\slshape Nitpick found no counterexample.}
   1.243  \postw
   1.244  
   1.245  Furthermore, applying \textit{skew} or \textit{split} to a well-formed tree
   1.246 @@ -1726,8 +1727,8 @@
   1.247  \textbf{nitpick} \\[2\smallskipamount]
   1.248  \slshape Nitpick found a counterexample for \textit{card} $'a$ = 4: \\[2\smallskipamount]
   1.249  \hbox{}\qquad Free variables: \nopagebreak \\
   1.250 -\hbox{}\qquad\qquad $t = N~a_3~1~\Lambda~\Lambda$ \\
   1.251 -\hbox{}\qquad\qquad $x = a_4$
   1.252 +\hbox{}\qquad\qquad $t = N~a_1~1~\Lambda~\Lambda$ \\
   1.253 +\hbox{}\qquad\qquad $x = a_2$
   1.254  \postw
   1.255  
   1.256  It's hard to see why this is a counterexample. To improve readability, we will
   1.257 @@ -1756,7 +1757,7 @@
   1.258  \prew
   1.259  \textbf{theorem}~\textit{wf\_insort}:\kern.4em ``$\textit{wf}~t\,\Longrightarrow\, \textit{wf}~(\textit{insort}~t~x)$'' \\
   1.260  \textbf{nitpick} \\[2\smallskipamount]
   1.261 -{\slshape Nitpick ran out of time after checking 6 of 8 scopes.}
   1.262 +{\slshape Nitpick ran out of time after checking 7 of 8 scopes.}
   1.263  \postw
   1.264  
   1.265  Insertion should transform the set of elements represented by the tree in the
   1.266 @@ -1766,14 +1767,14 @@
   1.267  \textbf{theorem} \textit{dataset\_insort}:\kern.4em
   1.268  ``$\textit{dataset}~(\textit{insort}~t~x) = \{x\} \cup \textit{dataset}~t$'' \\
   1.269  \textbf{nitpick} \\[2\smallskipamount]
   1.270 -{\slshape Nitpick ran out of time after checking 5 of 8 scopes.}
   1.271 +{\slshape Nitpick ran out of time after checking 6 of 8 scopes.}
   1.272  \postw
   1.273  
   1.274 -We could continue like this and sketch a complete theory of AA trees without
   1.275 -performing a single proof. Once the definitions and main theorems are in place
   1.276 -and have been thoroughly tested using Nitpick, we could start working on the
   1.277 -proofs. Developing theories this way usually saves time, because faulty theorems
   1.278 -and definitions are discovered much earlier in the process.
   1.279 +We could continue like this and sketch a complete theory of AA trees. Once the
   1.280 +definitions and main theorems are in place and have been thoroughly tested using
   1.281 +Nitpick, we could start working on the proofs. Developing theories this way
   1.282 +usually saves time, because faulty theorems and definitions are discovered much
   1.283 +earlier in the process.
   1.284  
   1.285  \section{Option Reference}
   1.286  \label{option-reference}
   1.287 @@ -2138,7 +2139,7 @@
   1.288  is implicitly set to 0 for automatic runs. If you set this option to a value
   1.289  greater than 1, you will need an incremental SAT solver: For efficiency, it is
   1.290  recommended to install the JNI version of MiniSat and set \textit{sat\_solver} =
   1.291 -\textit{MiniSatJNI}. Also be aware that many of the counterexamples may look
   1.292 +\textit{MiniSat\_JNI}. Also be aware that many of the counterexamples may look
   1.293  identical, unless the \textit{show\_all} (\S\ref{output-format}) option is
   1.294  enabled.
   1.295  
   1.296 @@ -2150,7 +2151,7 @@
   1.297  Specifies the maximum number of genuine counterexamples to display. If you set
   1.298  this option to a value greater than 1, you will need an incremental SAT solver:
   1.299  For efficiency, it is recommended to install the JNI version of MiniSat and set
   1.300 -\textit{sat\_solver} = \textit{MiniSatJNI}. Also be aware that many of the
   1.301 +\textit{sat\_solver} = \textit{MiniSat\_JNI}. Also be aware that many of the
   1.302  counterexamples may look identical, unless the \textit{show\_all}
   1.303  (\S\ref{output-format}) option is enabled.
   1.304  
   1.305 @@ -2243,7 +2244,7 @@
   1.306  to be faster than their Java counterparts, but they can be more difficult to
   1.307  install. Also, if you set the \textit{max\_potential} (\S\ref{output-format}) or
   1.308  \textit{max\_genuine} (\S\ref{output-format}) option to a value greater than 1,
   1.309 -you will need an incremental SAT solver, such as \textit{MiniSatJNI}
   1.310 +you will need an incremental SAT solver, such as \textit{MiniSat\_JNI}
   1.311  (recommended) or \textit{SAT4J}.
   1.312  
   1.313  The supported solvers are listed below:
   1.314 @@ -2257,7 +2258,7 @@
   1.315  \url{http://minisat.se/MiniSat.html}. Nitpick has been tested with versions 1.14
   1.316  and 2.0 beta (2007-07-21).
   1.317  
   1.318 -\item[$\bullet$] \textbf{\textit{MiniSatJNI}}: The JNI (Java Native Interface)
   1.319 +\item[$\bullet$] \textbf{\textit{MiniSat\_JNI}}: The JNI (Java Native Interface)
   1.320  version of MiniSat is bundled in \texttt{nativesolver.\allowbreak tgz}, which
   1.321  you will find on Kodkod's web site \cite{kodkod-2009}. Unlike the standard
   1.322  version of MiniSat, the JNI version can be used incrementally.
   1.323 @@ -2279,7 +2280,7 @@
   1.324  \url{http://www.princeton.edu/~chaff/zchaff.html}. Nitpick has been tested with
   1.325  versions 2004-05-13, 2004-11-15, and 2007-03-12.
   1.326  
   1.327 -\item[$\bullet$] \textbf{\textit{zChaffJNI}}: The JNI version of zChaff is
   1.328 +\item[$\bullet$] \textbf{\textit{zChaff\_JNI}}: The JNI version of zChaff is
   1.329  bundled in \texttt{native\-solver.\allowbreak tgz}, which you will find on
   1.330  Kodkod's web site \cite{kodkod-2009}.
   1.331  
   1.332 @@ -2295,7 +2296,7 @@
   1.333  executable. The BerkMin executables are available at
   1.334  \url{http://eigold.tripod.com/BerkMin.html}.
   1.335  
   1.336 -\item[$\bullet$] \textbf{\textit{BerkMinAlloy}}: Variant of BerkMin that is
   1.337 +\item[$\bullet$] \textbf{\textit{BerkMin\_Alloy}}: Variant of BerkMin that is
   1.338  included with Alloy 4 and calls itself ``sat56'' in its banner text. To use this
   1.339  version of BerkMin, set the environment variable
   1.340  \texttt{BERKMINALLOY\_HOME} to the directory that contains the \texttt{berkmin}
   1.341 @@ -2313,7 +2314,7 @@
   1.342  install the official SAT4J packages, because their API is incompatible with
   1.343  Kodkod.
   1.344  
   1.345 -\item[$\bullet$] \textbf{\textit{SAT4JLight}}: Variant of SAT4J that is
   1.346 +\item[$\bullet$] \textbf{\textit{SAT4J\_Light}}: Variant of SAT4J that is
   1.347  optimized for small problems. It can also be used incrementally.
   1.348  
   1.349  \item[$\bullet$] \textbf{\textit{HaifaSat}}: HaifaSat 1.0 beta is an
   1.350 @@ -2324,7 +2325,7 @@
   1.351  
   1.352  \item[$\bullet$] \textbf{\textit{smart}}: If \textit{sat\_solver} is set to
   1.353  \textit{smart}, Nitpick selects the first solver among MiniSat,
   1.354 -PicoSAT, zChaff, RSat, BerkMin, BerkMinAlloy, Jerusat, MiniSatJNI, and zChaffJNI
   1.355 +PicoSAT, zChaff, RSat, BerkMin, BerkMin\_Alloy, Jerusat, MiniSat\_JNI, and zChaff\_JNI
   1.356  that is recognized by Isabelle. If none is found, it falls back on SAT4J, which
   1.357  should always be available. If \textit{verbose} (\S\ref{output-format}) is
   1.358  enabled, Nitpick displays which SAT solver was chosen.
     2.1 --- a/doc-src/manual.bib	Tue Feb 09 13:54:27 2010 +0100
     2.2 +++ b/doc-src/manual.bib	Tue Feb 09 17:06:05 2010 +0100
     2.3 @@ -3,7 +3,7 @@
     2.4  %publishers
     2.5  @string{AP="Academic Press"}
     2.6  @string{CUP="Cambridge University Press"}
     2.7 -@string{IEEE="{\sc ieee} Computer Society Press"}
     2.8 +@string{IEEE="IEEE Computer Society Press"}
     2.9  @string{LNCS="Lecture Notes in Computer Science"}
    2.10  @string{MIT="MIT Press"}
    2.11  @string{NH="North-Holland"}
     3.1 --- a/src/HOL/IsaMakefile	Tue Feb 09 13:54:27 2010 +0100
     3.2 +++ b/src/HOL/IsaMakefile	Tue Feb 09 17:06:05 2010 +0100
     3.3 @@ -207,6 +207,7 @@
     3.4    Tools/Nitpick/nitpick_mono.ML \
     3.5    Tools/Nitpick/nitpick_nut.ML \
     3.6    Tools/Nitpick/nitpick_peephole.ML \
     3.7 +  Tools/Nitpick/nitpick_preproc.ML \
     3.8    Tools/Nitpick/nitpick_rep.ML \
     3.9    Tools/Nitpick/nitpick_scope.ML \
    3.10    Tools/Nitpick/nitpick_tests.ML \
    3.11 @@ -624,12 +625,13 @@
    3.12  
    3.13  $(LOG)/HOL-Nitpick_Examples.gz: $(OUT)/HOL Nitpick_Examples/ROOT.ML \
    3.14    Nitpick_Examples/Core_Nits.thy Nitpick_Examples/Datatype_Nits.thy \
    3.15 -  Nitpick_Examples/Induct_Nits.thy Nitpick_Examples/Integer_Nits.thy \
    3.16 -  Nitpick_Examples/Manual_Nits.thy Nitpick_Examples/Mini_Nits.thy \
    3.17 -  Nitpick_Examples/Mono_Nits.thy Nitpick_Examples/Nitpick_Examples.thy \
    3.18 -  Nitpick_Examples/Pattern_Nits.thy Nitpick_Examples/Record_Nits.thy \
    3.19 -  Nitpick_Examples/Refute_Nits.thy Nitpick_Examples/Special_Nits.thy \
    3.20 -  Nitpick_Examples/Tests_Nits.thy Nitpick_Examples/Typedef_Nits.thy
    3.21 +  Nitpick_Examples/Hotel_Nits.thy Nitpick_Examples/Induct_Nits.thy \
    3.22 +  Nitpick_Examples/Integer_Nits.thy Nitpick_Examples/Manual_Nits.thy \
    3.23 +  Nitpick_Examples/Mini_Nits.thy Nitpick_Examples/Mono_Nits.thy \
    3.24 +  Nitpick_Examples/Nitpick_Examples.thy Nitpick_Examples/Pattern_Nits.thy \
    3.25 +  Nitpick_Examples/Record_Nits.thy Nitpick_Examples/Refute_Nits.thy \
    3.26 +  Nitpick_Examples/Special_Nits.thy Nitpick_Examples/Tests_Nits.thy \
    3.27 +  Nitpick_Examples/Typedef_Nits.thy
    3.28  	@$(ISABELLE_TOOL) usedir $(OUT)/HOL Nitpick_Examples
    3.29  
    3.30  
     4.1 --- a/src/HOL/Nitpick.thy	Tue Feb 09 13:54:27 2010 +0100
     4.2 +++ b/src/HOL/Nitpick.thy	Tue Feb 09 17:06:05 2010 +0100
     4.3 @@ -13,6 +13,7 @@
     4.4       ("Tools/Nitpick/kodkod_sat.ML")
     4.5       ("Tools/Nitpick/nitpick_util.ML")
     4.6       ("Tools/Nitpick/nitpick_hol.ML")
     4.7 +     ("Tools/Nitpick/nitpick_preproc.ML")
     4.8       ("Tools/Nitpick/nitpick_mono.ML")
     4.9       ("Tools/Nitpick/nitpick_scope.ML")
    4.10       ("Tools/Nitpick/nitpick_peephole.ML")
    4.11 @@ -237,6 +238,7 @@
    4.12  use "Tools/Nitpick/kodkod_sat.ML"
    4.13  use "Tools/Nitpick/nitpick_util.ML"
    4.14  use "Tools/Nitpick/nitpick_hol.ML"
    4.15 +use "Tools/Nitpick/nitpick_preproc.ML"
    4.16  use "Tools/Nitpick/nitpick_mono.ML"
    4.17  use "Tools/Nitpick/nitpick_scope.ML"
    4.18  use "Tools/Nitpick/nitpick_peephole.ML"
     5.1 --- a/src/HOL/Nitpick_Examples/Core_Nits.thy	Tue Feb 09 13:54:27 2010 +0100
     5.2 +++ b/src/HOL/Nitpick_Examples/Core_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
     5.3 @@ -1,6 +1,6 @@
     5.4  (*  Title:      HOL/Nitpick_Examples/Core_Nits.thy
     5.5      Author:     Jasmin Blanchette, TU Muenchen
     5.6 -    Copyright   2009
     5.7 +    Copyright   2009, 2010
     5.8  
     5.9  Examples featuring Nitpick's functional core.
    5.10  *)
    5.11 @@ -11,7 +11,7 @@
    5.12  imports Main
    5.13  begin
    5.14  
    5.15 -nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
    5.16 +nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
    5.17  
    5.18  subsection {* Curry in a Hurry *}
    5.19  
     6.1 --- a/src/HOL/Nitpick_Examples/Datatype_Nits.thy	Tue Feb 09 13:54:27 2010 +0100
     6.2 +++ b/src/HOL/Nitpick_Examples/Datatype_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
     6.3 @@ -1,6 +1,6 @@
     6.4  (*  Title:      HOL/Nitpick_Examples/Datatype_Nits.thy
     6.5      Author:     Jasmin Blanchette, TU Muenchen
     6.6 -    Copyright   2009
     6.7 +    Copyright   2009, 2010
     6.8  
     6.9  Examples featuring Nitpick applied to datatypes.
    6.10  *)
    6.11 @@ -11,7 +11,7 @@
    6.12  imports Main
    6.13  begin
    6.14  
    6.15 -nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
    6.16 +nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
    6.17  
    6.18  primrec rot where
    6.19  "rot Nibble0 = Nibble1" | "rot Nibble1 = Nibble2" | "rot Nibble2 = Nibble3" |
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/Nitpick_Examples/Hotel_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
     7.3 @@ -0,0 +1,57 @@
     7.4 +(*  Title:      HOL/Nitpick_Examples/Hotel_Nits.thy
     7.5 +    Author:     Jasmin Blanchette, TU Muenchen
     7.6 +    Copyright   2010
     7.7 +
     7.8 +Nitpick example based on Tobias Nipkow's hotel key card formalization.
     7.9 +*)
    7.10 +
    7.11 +header {* Nitpick Example Based on Tobias Nipkow's Hotel Key Card
    7.12 +          Formalization *}
    7.13 +
    7.14 +theory Hotel_Nits
    7.15 +imports Main
    7.16 +begin
    7.17 +
    7.18 +nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 120 s]
    7.19 +
    7.20 +typedecl guest
    7.21 +typedecl key
    7.22 +typedecl room
    7.23 +
    7.24 +types keycard = "key \<times> key"
    7.25 +
    7.26 +record state =
    7.27 +  owns :: "room \<Rightarrow> guest option"
    7.28 +  currk :: "room \<Rightarrow> key"
    7.29 +  issued :: "key set"
    7.30 +  cards :: "guest \<Rightarrow> keycard set"
    7.31 +  roomk :: "room \<Rightarrow> key"
    7.32 +  isin :: "room \<Rightarrow> guest set"
    7.33 +  safe :: "room \<Rightarrow> bool"
    7.34 +
    7.35 +inductive_set reach :: "state set" where
    7.36 +init:
    7.37 +"inj initk \<Longrightarrow>
    7.38 + \<lparr>owns = (\<lambda>r. None), currk = initk, issued = range initk, cards = (\<lambda>g. {}),
    7.39 +  roomk = initk, isin = (\<lambda>r. {}), safe = (\<lambda>r. True)\<rparr> \<in> reach" |
    7.40 +check_in:
    7.41 +"\<lbrakk>s \<in> reach; k \<notin> issued s\<rbrakk> \<Longrightarrow>
    7.42 + s\<lparr>currk := (currk s)(r := k), issued := issued s \<union> {k},
    7.43 +   cards := (cards s)(g := cards s g \<union> {(currk s r, k)}),
    7.44 +   owns :=  (owns s)(r := Some g), safe := (safe s)(r := False)\<rparr> \<in> reach" |
    7.45 +enter_room:
    7.46 +"\<lbrakk>s \<in> reach; (k,k') \<in> cards s g; roomk s r \<in> {k,k'}\<rbrakk> \<Longrightarrow>
    7.47 + s\<lparr>isin := (isin s)(r := isin s r \<union> {g}),
    7.48 +   roomk := (roomk s)(r := k'),
    7.49 +   safe := (safe s)(r := owns s r = Some g \<and> isin s r = {} (* \<and> k' = currk s r *)
    7.50 +                         \<or> safe s r)\<rparr> \<in> reach" |
    7.51 +exit_room:
    7.52 +"\<lbrakk>s \<in> reach; g \<in> isin s r\<rbrakk> \<Longrightarrow> s\<lparr>isin := (isin s)(r := isin s r - {g})\<rparr> \<in> reach"
    7.53 +
    7.54 +theorem safe: "s \<in> reach \<Longrightarrow> safe s r \<Longrightarrow> g \<in> isin s r \<Longrightarrow> owns s r = Some g"
    7.55 +nitpick [card room = 1, card guest = 2, card "guest option" = 3,
    7.56 +         card key = 4, card state = 6, expect = genuine]
    7.57 +nitpick [card room = 1, card guest = 2, expect = genuine]
    7.58 +oops
    7.59 +
    7.60 +end
     8.1 --- a/src/HOL/Nitpick_Examples/Induct_Nits.thy	Tue Feb 09 13:54:27 2010 +0100
     8.2 +++ b/src/HOL/Nitpick_Examples/Induct_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
     8.3 @@ -1,6 +1,6 @@
     8.4  (*  Title:      HOL/Nitpick_Examples/Induct_Nits.thy
     8.5      Author:     Jasmin Blanchette, TU Muenchen
     8.6 -    Copyright   2009
     8.7 +    Copyright   2009, 2010
     8.8  
     8.9  Examples featuring Nitpick applied to (co)inductive definitions.
    8.10  *)
    8.11 @@ -11,7 +11,7 @@
    8.12  imports Main
    8.13  begin
    8.14  
    8.15 -nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
    8.16 +nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
    8.17  
    8.18  inductive p1 :: "nat \<Rightarrow> bool" where
    8.19  "p1 0" |
     9.1 --- a/src/HOL/Nitpick_Examples/Integer_Nits.thy	Tue Feb 09 13:54:27 2010 +0100
     9.2 +++ b/src/HOL/Nitpick_Examples/Integer_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
     9.3 @@ -1,6 +1,6 @@
     9.4  (*  Title:      HOL/Nitpick_Examples/Integer_Nits.thy
     9.5      Author:     Jasmin Blanchette, TU Muenchen
     9.6 -    Copyright   2009
     9.7 +    Copyright   2009, 2010
     9.8  
     9.9  Examples featuring Nitpick applied to natural numbers and integers.
    9.10  *)
    9.11 @@ -11,7 +11,7 @@
    9.12  imports Nitpick
    9.13  begin
    9.14  
    9.15 -nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s,
    9.16 +nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s,
    9.17                  card = 1\<midarrow>6, bits = 1,2,3,4,6,8]
    9.18  
    9.19  lemma "Suc x = x + 1"
    10.1 --- a/src/HOL/Nitpick_Examples/Manual_Nits.thy	Tue Feb 09 13:54:27 2010 +0100
    10.2 +++ b/src/HOL/Nitpick_Examples/Manual_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
    10.3 @@ -1,6 +1,6 @@
    10.4  (*  Title:      HOL/Nitpick_Examples/Manual_Nits.thy
    10.5      Author:     Jasmin Blanchette, TU Muenchen
    10.6 -    Copyright   2009
    10.7 +    Copyright   2009, 2010
    10.8  
    10.9  Examples from the Nitpick manual.
   10.10  *)
   10.11 @@ -13,7 +13,7 @@
   10.12  
   10.13  chapter {* 3. First Steps *}
   10.14  
   10.15 -nitpick_params [sat_solver = MiniSatJNI, max_threads = 1]
   10.16 +nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1]
   10.17  
   10.18  subsection {* 3.1. Propositional Logic *}
   10.19  
    11.1 --- a/src/HOL/Nitpick_Examples/Mini_Nits.thy	Tue Feb 09 13:54:27 2010 +0100
    11.2 +++ b/src/HOL/Nitpick_Examples/Mini_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
    11.3 @@ -1,6 +1,6 @@
    11.4  (*  Title:      HOL/Nitpick_Examples/Mini_Nits.thy
    11.5      Author:     Jasmin Blanchette, TU Muenchen
    11.6 -    Copyright   2009
    11.7 +    Copyright   2009, 2010
    11.8  
    11.9  Examples featuring Minipick, the minimalistic version of Nitpick.
   11.10  *)
    12.1 --- a/src/HOL/Nitpick_Examples/Mono_Nits.thy	Tue Feb 09 13:54:27 2010 +0100
    12.2 +++ b/src/HOL/Nitpick_Examples/Mono_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
    12.3 @@ -1,6 +1,6 @@
    12.4  (*  Title:      HOL/Nitpick_Examples/Mono_Nits.thy
    12.5      Author:     Jasmin Blanchette, TU Muenchen
    12.6 -    Copyright   2009
    12.7 +    Copyright   2009, 2010
    12.8  
    12.9  Examples featuring Nitpick's monotonicity check.
   12.10  *)
   12.11 @@ -16,7 +16,7 @@
   12.12  
   12.13  val defs = Nitpick_HOL.all_axioms_of @{theory} |> #1
   12.14  val def_table = Nitpick_HOL.const_def_table @{context} defs
   12.15 -val ext_ctxt : Nitpick_HOL.extended_context =
   12.16 +val hol_ctxt : Nitpick_HOL.hol_context =
   12.17    {thy = @{theory}, ctxt = @{context}, max_bisim_depth = ~1, boxes = [],
   12.18     stds = [(NONE, true)], wfs = [], user_axioms = NONE, debug = false,
   12.19     binary_ints = SOME false, destroy_constrs = false, specialize = false,
   12.20 @@ -29,7 +29,7 @@
   12.21     special_funs = Unsynchronized.ref [], unrolled_preds = Unsynchronized.ref [],
   12.22     wf_cache = Unsynchronized.ref [], constr_cache = Unsynchronized.ref []}
   12.23  (* term -> bool *)
   12.24 -val is_mono = Nitpick_Mono.formulas_monotonic ext_ctxt @{typ 'a}
   12.25 +val is_mono = Nitpick_Mono.formulas_monotonic hol_ctxt @{typ 'a}
   12.26                                                Nitpick_Mono.Plus [] []
   12.27  fun is_const t =
   12.28    let val T = fastype_of t in
    13.1 --- a/src/HOL/Nitpick_Examples/Nitpick_Examples.thy	Tue Feb 09 13:54:27 2010 +0100
    13.2 +++ b/src/HOL/Nitpick_Examples/Nitpick_Examples.thy	Tue Feb 09 17:06:05 2010 +0100
    13.3 @@ -1,13 +1,13 @@
    13.4  (*  Title:      HOL/Nitpick_Examples/Nitpick_Examples.thy
    13.5      Author:     Jasmin Blanchette, TU Muenchen
    13.6 -    Copyright   2009
    13.7 +    Copyright   2009, 2010
    13.8  
    13.9  Nitpick examples.
   13.10  *)
   13.11  
   13.12  theory Nitpick_Examples
   13.13 -imports Core_Nits Datatype_Nits Induct_Nits Integer_Nits Manual_Nits Mini_Nits
   13.14 -        Mono_Nits Pattern_Nits Record_Nits Refute_Nits Special_Nits Tests_Nits
   13.15 -        Typedef_Nits
   13.16 +imports Core_Nits Datatype_Nits Hotel_Nits Induct_Nits Integer_Nits Manual_Nits
   13.17 +        Mini_Nits Mono_Nits Pattern_Nits Record_Nits Refute_Nits Special_Nits
   13.18 +        Tests_Nits Typedef_Nits
   13.19  begin
   13.20  end
    14.1 --- a/src/HOL/Nitpick_Examples/Pattern_Nits.thy	Tue Feb 09 13:54:27 2010 +0100
    14.2 +++ b/src/HOL/Nitpick_Examples/Pattern_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
    14.3 @@ -1,6 +1,6 @@
    14.4  (*  Title:      HOL/Nitpick_Examples/Pattern_Nits.thy
    14.5      Author:     Jasmin Blanchette, TU Muenchen
    14.6 -    Copyright   2009
    14.7 +    Copyright   2009, 2010
    14.8  
    14.9  Examples featuring Nitpick's "destroy_constrs" optimization.
   14.10  *)
   14.11 @@ -11,7 +11,7 @@
   14.12  imports Main
   14.13  begin
   14.14  
   14.15 -nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s,
   14.16 +nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s,
   14.17                  card = 14]
   14.18  
   14.19  lemma "x = (case u of () \<Rightarrow> y)"
    15.1 --- a/src/HOL/Nitpick_Examples/Record_Nits.thy	Tue Feb 09 13:54:27 2010 +0100
    15.2 +++ b/src/HOL/Nitpick_Examples/Record_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
    15.3 @@ -1,6 +1,6 @@
    15.4  (*  Title:      HOL/Nitpick_Examples/Record_Nits.thy
    15.5      Author:     Jasmin Blanchette, TU Muenchen
    15.6 -    Copyright   2009
    15.7 +    Copyright   2009, 2010
    15.8  
    15.9  Examples featuring Nitpick applied to records.
   15.10  *)
   15.11 @@ -11,7 +11,7 @@
   15.12  imports Main
   15.13  begin
   15.14  
   15.15 -nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
   15.16 +nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
   15.17  
   15.18  record point2d =
   15.19    xc :: int
    16.1 --- a/src/HOL/Nitpick_Examples/Refute_Nits.thy	Tue Feb 09 13:54:27 2010 +0100
    16.2 +++ b/src/HOL/Nitpick_Examples/Refute_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
    16.3 @@ -1,6 +1,6 @@
    16.4  (*  Title:      HOL/Nitpick_Examples/Refute_Nits.thy
    16.5      Author:     Jasmin Blanchette, TU Muenchen
    16.6 -    Copyright   2009
    16.7 +    Copyright   2009, 2010
    16.8  
    16.9  Refute examples adapted to Nitpick.
   16.10  *)
   16.11 @@ -11,7 +11,7 @@
   16.12  imports Main
   16.13  begin
   16.14  
   16.15 -nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s]
   16.16 +nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s]
   16.17  
   16.18  lemma "P \<and> Q"
   16.19  apply (rule conjI)
    17.1 --- a/src/HOL/Nitpick_Examples/Special_Nits.thy	Tue Feb 09 13:54:27 2010 +0100
    17.2 +++ b/src/HOL/Nitpick_Examples/Special_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
    17.3 @@ -1,6 +1,6 @@
    17.4  (*  Title:      HOL/Nitpick_Examples/Special_Nits.thy
    17.5      Author:     Jasmin Blanchette, TU Muenchen
    17.6 -    Copyright   2009
    17.7 +    Copyright   2009, 2010
    17.8  
    17.9  Examples featuring Nitpick's "specialize" optimization.
   17.10  *)
   17.11 @@ -11,7 +11,7 @@
   17.12  imports Main
   17.13  begin
   17.14  
   17.15 -nitpick_params [sat_solver = MiniSatJNI, max_threads = 1, timeout = 60 s,
   17.16 +nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s,
   17.17                  card = 4]
   17.18  
   17.19  fun f1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
    18.1 --- a/src/HOL/Nitpick_Examples/Tests_Nits.thy	Tue Feb 09 13:54:27 2010 +0100
    18.2 +++ b/src/HOL/Nitpick_Examples/Tests_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
    18.3 @@ -1,6 +1,6 @@
    18.4  (*  Title:      HOL/Nitpick_Examples/Tests_Nits.thy
    18.5      Author:     Jasmin Blanchette, TU Muenchen
    18.6 -    Copyright   2009
    18.7 +    Copyright   2009, 2010
    18.8  
    18.9  Nitpick tests.
   18.10  *)
    19.1 --- a/src/HOL/Nitpick_Examples/Typedef_Nits.thy	Tue Feb 09 13:54:27 2010 +0100
    19.2 +++ b/src/HOL/Nitpick_Examples/Typedef_Nits.thy	Tue Feb 09 17:06:05 2010 +0100
    19.3 @@ -1,6 +1,6 @@
    19.4  (*  Title:      HOL/Nitpick_Examples/Typedef_Nits.thy
    19.5      Author:     Jasmin Blanchette, TU Muenchen
    19.6 -    Copyright   2009
    19.7 +    Copyright   2009, 2010
    19.8  
    19.9  Examples featuring Nitpick applied to typedefs.
   19.10  *)
   19.11 @@ -11,7 +11,8 @@
   19.12  imports Main Rational
   19.13  begin
   19.14  
   19.15 -nitpick_params [card = 1\<midarrow>4, timeout = 30 s]
   19.16 +nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 60 s,
   19.17 +                card = 1\<midarrow>4]
   19.18  
   19.19  typedef three = "{0\<Colon>nat, 1, 2}"
   19.20  by blast
    20.1 --- a/src/HOL/Tools/Nitpick/HISTORY	Tue Feb 09 13:54:27 2010 +0100
    20.2 +++ b/src/HOL/Tools/Nitpick/HISTORY	Tue Feb 09 17:06:05 2010 +0100
    20.3 @@ -4,6 +4,8 @@
    20.4    * Added "std" option and implemented support for nonstandard models
    20.5    * Fixed soundness bugs related to "destroy_constrs" optimization and record
    20.6      getters
    20.7 +  * Renamed "MiniSatJNI", "zChaffJNI", "BerkMinAlloy", and "SAT4JLight" to
    20.8 + 	"MiniSat_JNI", "zChaff_JNI", "BerkMin_Alloy", and "SAT4J_Light"
    20.9  
   20.10  Version 2009-1
   20.11  
    21.1 --- a/src/HOL/Tools/Nitpick/kodkod.ML	Tue Feb 09 13:54:27 2010 +0100
    21.2 +++ b/src/HOL/Tools/Nitpick/kodkod.ML	Tue Feb 09 17:06:05 2010 +0100
    21.3 @@ -1054,23 +1054,23 @@
    21.4              let
    21.5                val code =
    21.6                  bash ("cd " ^ File.shell_quote temp_dir ^ ";\n" ^
    21.7 -                        "env CLASSPATH=\"$KODKODI_CLASSPATH:$CLASSPATH\" \
    21.8 -                        \JAVA_LIBRARY_PATH=\"$KODKODI_JAVA_LIBRARY_PATH:\
    21.9 -                        \$JAVA_LIBRARY_PATH\" \
   21.10 -                        \LD_LIBRARY_PATH=\"$KODKODI_JAVA_LIBRARY_PATH:\
   21.11 -                        \$LD_LIBRARY_PATH\" \
   21.12 -                        \\"$KODKODI\"/bin/kodkodi" ^
   21.13 -                        (if ms >= 0 then " -max-msecs " ^ string_of_int ms
   21.14 -                         else "") ^
   21.15 -                        (if max_solutions > 1 then " -solve-all" else "") ^
   21.16 -                        " -max-solutions " ^ string_of_int max_solutions ^
   21.17 -                        (if max_threads > 0 then
   21.18 -                           " -max-threads " ^ string_of_int max_threads
   21.19 -                         else
   21.20 -                           "") ^
   21.21 -                        " < " ^ File.shell_path in_path ^
   21.22 -                        " > " ^ File.shell_path out_path ^
   21.23 -                        " 2> " ^ File.shell_path err_path)
   21.24 +                      "env CLASSPATH=\"$KODKODI_CLASSPATH:$CLASSPATH\" \
   21.25 +                      \JAVA_LIBRARY_PATH=\"$KODKODI_JAVA_LIBRARY_PATH:\
   21.26 +                      \$JAVA_LIBRARY_PATH\" \
   21.27 +                      \LD_LIBRARY_PATH=\"$KODKODI_JAVA_LIBRARY_PATH:\
   21.28 +                      \$LD_LIBRARY_PATH\" \
   21.29 +                      \\"$KODKODI\"/bin/kodkodi" ^
   21.30 +                      (if ms >= 0 then " -max-msecs " ^ string_of_int ms
   21.31 +                       else "") ^
   21.32 +                      (if max_solutions > 1 then " -solve-all" else "") ^
   21.33 +                      " -max-solutions " ^ string_of_int max_solutions ^
   21.34 +                      (if max_threads > 0 then
   21.35 +                         " -max-threads " ^ string_of_int max_threads
   21.36 +                       else
   21.37 +                         "") ^
   21.38 +                      " < " ^ File.shell_path in_path ^
   21.39 +                      " > " ^ File.shell_path out_path ^
   21.40 +                      " 2> " ^ File.shell_path err_path)
   21.41                val (ps, nontriv_js) = read_output_file out_path
   21.42                                       |>> map (apfst reindex) ||> map reindex
   21.43                val js = triv_js @ nontriv_js
    22.1 --- a/src/HOL/Tools/Nitpick/kodkod_sat.ML	Tue Feb 09 13:54:27 2010 +0100
    22.2 +++ b/src/HOL/Tools/Nitpick/kodkod_sat.ML	Tue Feb 09 17:06:05 2010 +0100
    22.3 @@ -42,12 +42,12 @@
    22.4                             if berkmin_exec = "" then "BerkMin561"
    22.5                             else berkmin_exec, [], "Satisfiable          !!",
    22.6                             "solution =", "UNSATISFIABLE          !!")),
    22.7 -   ("BerkMinAlloy", External (ToStdout, "BERKMINALLOY_HOME", "berkmin", [])),
    22.8 +   ("BerkMin_Alloy", External (ToStdout, "BERKMINALLOY_HOME", "berkmin", [])),
    22.9     ("Jerusat", External (ToStdout, "JERUSAT_HOME", "Jerusat1.3", [])),
   22.10 -   ("MiniSatJNI", Internal (JNI, Incremental, ["MiniSat"])),
   22.11 -   ("zChaffJNI", Internal (JNI, Batch, ["zChaff"])),
   22.12 +   ("MiniSat_JNI", Internal (JNI, Incremental, ["MiniSat"])),
   22.13 +   ("zChaff_JNI", Internal (JNI, Batch, ["zChaff"])),
   22.14     ("SAT4J", Internal (Java, Incremental, ["DefaultSAT4J"])),
   22.15 -   ("SAT4JLight", Internal (Java, Incremental, ["LightSAT4J"])),
   22.16 +   ("SAT4J_Light", Internal (Java, Incremental, ["LightSAT4J"])),
   22.17     ("HaifaSat", ExternalV2 (ToStdout, "HAIFASAT_HOME", "HaifaSat", ["-p", "1"],
   22.18                              "s SATISFIABLE", "v ", "s UNSATISFIABLE"))]
   22.19  
    23.1 --- a/src/HOL/Tools/Nitpick/nitpick.ML	Tue Feb 09 13:54:27 2010 +0100
    23.2 +++ b/src/HOL/Tools/Nitpick/nitpick.ML	Tue Feb 09 17:06:05 2010 +0100
    23.3 @@ -69,6 +69,7 @@
    23.4  
    23.5  open Nitpick_Util
    23.6  open Nitpick_HOL
    23.7 +open Nitpick_Preproc
    23.8  open Nitpick_Mono
    23.9  open Nitpick_Scope
   23.10  open Nitpick_Peephole
   23.11 @@ -273,7 +274,7 @@
   23.12      val intro_table = inductive_intro_table ctxt def_table
   23.13      val ground_thm_table = ground_theorem_table thy
   23.14      val ersatz_table = ersatz_table thy
   23.15 -    val (ext_ctxt as {wf_cache, ...}) =
   23.16 +    val (hol_ctxt as {wf_cache, ...}) =
   23.17        {thy = thy, ctxt = ctxt, max_bisim_depth = max_bisim_depth, boxes = boxes,
   23.18         stds = stds, wfs = wfs, user_axioms = user_axioms, debug = debug,
   23.19         binary_ints = binary_ints, destroy_constrs = destroy_constrs,
   23.20 @@ -292,7 +293,7 @@
   23.21      val _ = null (Term.add_tvars assms_t []) orelse
   23.22              raise NOT_SUPPORTED "schematic type variables"
   23.23      val (((def_ts, nondef_ts), (got_all_mono_user_axioms, no_poly_user_axioms)),
   23.24 -         core_t) = preprocess_term ext_ctxt assms_t
   23.25 +         core_t) = preprocess_term hol_ctxt assms_t
   23.26      val got_all_user_axioms =
   23.27        got_all_mono_user_axioms andalso no_poly_user_axioms
   23.28  
   23.29 @@ -319,9 +320,9 @@
   23.30              handle TYPE (_, Ts, ts) =>
   23.31                     raise TYPE ("Nitpick.pick_them_nits_in_term", Ts, ts)
   23.32  
   23.33 -    val core_u = nut_from_term ext_ctxt Eq core_t
   23.34 -    val def_us = map (nut_from_term ext_ctxt DefEq) def_ts
   23.35 -    val nondef_us = map (nut_from_term ext_ctxt Eq) nondef_ts
   23.36 +    val core_u = nut_from_term hol_ctxt Eq core_t
   23.37 +    val def_us = map (nut_from_term hol_ctxt DefEq) def_ts
   23.38 +    val nondef_us = map (nut_from_term hol_ctxt Eq) nondef_ts
   23.39      val (free_names, const_names) =
   23.40        fold add_free_and_const_names (core_u :: def_us @ nondef_us) ([], [])
   23.41      val (sel_names, nonsel_names) =
   23.42 @@ -338,18 +339,18 @@
   23.43      fun is_type_always_monotonic T =
   23.44        (is_datatype thy T andalso not (is_quot_type thy T) andalso
   23.45         (not (is_pure_typedef thy T) orelse is_univ_typedef thy T)) orelse
   23.46 -      is_number_type thy T orelse is_bit_type T orelse T = @{typ \<xi>}
   23.47 +      is_number_type thy T orelse is_bit_type T
   23.48      fun is_type_monotonic T =
   23.49        unique_scope orelse
   23.50        case triple_lookup (type_match thy) monos T of
   23.51          SOME (SOME b) => b
   23.52        | _ => is_type_always_monotonic T orelse
   23.53 -             formulas_monotonic ext_ctxt T Plus def_ts nondef_ts core_t
   23.54 +             formulas_monotonic hol_ctxt T Plus def_ts nondef_ts core_t
   23.55      fun is_deep_datatype T =
   23.56        is_datatype thy T andalso
   23.57        (is_word_type T orelse
   23.58         exists (curry (op =) T o domain_type o type_of) sel_names)
   23.59 -    val all_Ts = ground_types_in_terms ext_ctxt (core_t :: def_ts @ nondef_ts)
   23.60 +    val all_Ts = ground_types_in_terms hol_ctxt (core_t :: def_ts @ nondef_ts)
   23.61                   |> sort TermOrd.typ_ord
   23.62      val _ = if verbose andalso binary_ints = SOME true andalso
   23.63                 exists (member (op =) [nat_T, int_T]) all_Ts then
   23.64 @@ -522,7 +523,7 @@
   23.65          val plain_bounds = map (bound_for_plain_rel ctxt debug) plain_rels
   23.66          val plain_axioms = map (declarative_axiom_for_plain_rel kk) plain_rels
   23.67          val sel_bounds = map (bound_for_sel_rel ctxt debug datatypes) sel_rels
   23.68 -        val dtype_axioms = declarative_axioms_for_datatypes ext_ctxt bits ofs kk
   23.69 +        val dtype_axioms = declarative_axioms_for_datatypes hol_ctxt bits ofs kk
   23.70                                                              rel_table datatypes
   23.71          val declarative_axioms = plain_axioms @ dtype_axioms
   23.72          val univ_card = univ_card nat_card int_card main_j0
   23.73 @@ -553,7 +554,7 @@
   23.74               if loc = "Nitpick_Kodkod.check_arity" andalso
   23.75                  not (Typtab.is_empty ofs) then
   23.76                 problem_for_scope liberal
   23.77 -                   {ext_ctxt = ext_ctxt, card_assigns = card_assigns,
   23.78 +                   {hol_ctxt = hol_ctxt, card_assigns = card_assigns,
   23.79                      bits = bits, bisim_depth = bisim_depth,
   23.80                      datatypes = datatypes, ofs = Typtab.empty}
   23.81               else if loc = "Nitpick.pick_them_nits_in_term.\
   23.82 @@ -891,7 +892,7 @@
   23.83          end
   23.84  
   23.85      val (skipped, the_scopes) =
   23.86 -      all_scopes ext_ctxt sym_break cards_assigns maxes_assigns iters_assigns
   23.87 +      all_scopes hol_ctxt sym_break cards_assigns maxes_assigns iters_assigns
   23.88                   bitss bisim_depths mono_Ts nonmono_Ts deep_dataTs
   23.89      val _ = if skipped > 0 then
   23.90                print_m (fn () => "Too many scopes. Skipping " ^
    24.1 --- a/src/HOL/Tools/Nitpick/nitpick_hol.ML	Tue Feb 09 13:54:27 2010 +0100
    24.2 +++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML	Tue Feb 09 17:06:05 2010 +0100
    24.3 @@ -13,7 +13,7 @@
    24.4    type unrolled = styp * styp
    24.5    type wf_cache = (styp * (bool * bool)) list
    24.6  
    24.7 -  type extended_context = {
    24.8 +  type hol_context = {
    24.9      thy: theory,
   24.10      ctxt: Proof.context,
   24.11      max_bisim_depth: int,
   24.12 @@ -46,12 +46,24 @@
   24.13      wf_cache: wf_cache Unsynchronized.ref,
   24.14      constr_cache: (typ * styp list) list Unsynchronized.ref}
   24.15  
   24.16 +  datatype fixpoint_kind = Lfp | Gfp | NoFp
   24.17 +  datatype boxability =
   24.18 +    InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2
   24.19 +
   24.20    val name_sep : string
   24.21    val numeral_prefix : string
   24.22 +  val ubfp_prefix : string
   24.23 +  val lbfp_prefix : string
   24.24    val skolem_prefix : string
   24.25 +  val special_prefix : string
   24.26 +  val uncurry_prefix : string
   24.27    val eval_prefix : string
   24.28    val original_name : string -> string
   24.29    val s_conj : term * term -> term
   24.30 +  val s_disj : term * term -> term
   24.31 +  val strip_any_connective : term -> term list * term
   24.32 +  val conjuncts_of : term -> term list
   24.33 +  val disjuncts_of : term -> term list
   24.34    val unbit_and_unbox_type : typ -> typ
   24.35    val string_for_type : Proof.context -> typ -> string
   24.36    val prefix_name : string -> string -> string
   24.37 @@ -76,6 +88,7 @@
   24.38    val is_record_type : typ -> bool
   24.39    val is_number_type : theory -> typ -> bool
   24.40    val const_for_iterator_type : typ -> styp
   24.41 +  val strip_n_binders : int -> typ -> typ list * typ
   24.42    val nth_range_type : int -> typ -> typ
   24.43    val num_factors_in_type : typ -> int
   24.44    val num_binder_types : typ -> int
   24.45 @@ -96,16 +109,20 @@
   24.46    val is_rep_fun : theory -> styp -> bool
   24.47    val is_quot_abs_fun : Proof.context -> styp -> bool
   24.48    val is_quot_rep_fun : Proof.context -> styp -> bool
   24.49 +  val mate_of_rep_fun : theory -> styp -> styp
   24.50 +  val is_constr_like : theory -> styp -> bool
   24.51 +  val is_stale_constr : theory -> styp -> bool
   24.52    val is_constr : theory -> styp -> bool
   24.53 -  val is_stale_constr : theory -> styp -> bool
   24.54    val is_sel : string -> bool
   24.55    val is_sel_like_and_no_discr : string -> bool
   24.56 +  val box_type : hol_context -> boxability -> typ -> typ
   24.57    val discr_for_constr : styp -> styp
   24.58    val num_sels_for_constr_type : typ -> int
   24.59    val nth_sel_name_for_constr_name : string -> int -> string
   24.60    val nth_sel_for_constr : styp -> int -> styp
   24.61 -  val boxed_nth_sel_for_constr : extended_context -> styp -> int -> styp
   24.62 +  val boxed_nth_sel_for_constr : hol_context -> styp -> int -> styp
   24.63    val sel_no_from_name : string -> int
   24.64 +  val close_form : term -> term
   24.65    val eta_expand : typ list -> term -> int -> term
   24.66    val extensionalize : term -> term
   24.67    val distinctness_formula : typ -> term list -> term
   24.68 @@ -113,19 +130,25 @@
   24.69    val unregister_frac_type : string -> theory -> theory
   24.70    val register_codatatype : typ -> string -> styp list -> theory -> theory
   24.71    val unregister_codatatype : typ -> theory -> theory
   24.72 -  val datatype_constrs : extended_context -> typ -> styp list
   24.73 -  val boxed_datatype_constrs : extended_context -> typ -> styp list
   24.74 -  val num_datatype_constrs : extended_context -> typ -> int
   24.75 +  val datatype_constrs : hol_context -> typ -> styp list
   24.76 +  val boxed_datatype_constrs : hol_context -> typ -> styp list
   24.77 +  val num_datatype_constrs : hol_context -> typ -> int
   24.78    val constr_name_for_sel_like : string -> string
   24.79 -  val boxed_constr_for_sel : extended_context -> styp -> styp
   24.80 +  val boxed_constr_for_sel : hol_context -> styp -> styp
   24.81 +  val discriminate_value : hol_context -> styp -> term -> term
   24.82 +  val select_nth_constr_arg : theory -> styp -> term -> int -> typ -> term
   24.83 +  val construct_value : theory -> styp -> term list -> term
   24.84    val card_of_type : (typ * int) list -> typ -> int
   24.85    val bounded_card_of_type : int -> int -> (typ * int) list -> typ -> int
   24.86    val bounded_exact_card_of_type :
   24.87 -    extended_context -> int -> int -> (typ * int) list -> typ -> int
   24.88 -  val is_finite_type : extended_context -> typ -> bool
   24.89 +    hol_context -> int -> int -> (typ * int) list -> typ -> int
   24.90 +  val is_finite_type : hol_context -> typ -> bool
   24.91 +  val special_bounds : term list -> (indexname * typ) list
   24.92 +  val is_funky_typedef : theory -> typ -> bool
   24.93    val all_axioms_of : theory -> term list * term list * term list
   24.94    val arity_of_built_in_const : bool -> styp -> int option
   24.95    val is_built_in_const : bool -> styp -> bool
   24.96 +  val term_under_def : term -> term
   24.97    val case_const_names : theory -> (string * int) list
   24.98    val const_def_table : Proof.context -> term list -> const_table
   24.99    val const_nondef_table : term list -> const_table
  24.100 @@ -134,22 +157,33 @@
  24.101    val inductive_intro_table : Proof.context -> const_table -> const_table
  24.102    val ground_theorem_table : theory -> term list Inttab.table
  24.103    val ersatz_table : theory -> (string * string) list
  24.104 +  val add_simps : const_table Unsynchronized.ref -> string -> term list -> unit
  24.105 +  val inverse_axioms_for_rep_fun : theory -> styp -> term list
  24.106 +  val optimized_typedef_axioms : theory -> string * typ list -> term list
  24.107 +  val optimized_quot_type_axioms : theory -> string * typ list -> term list
  24.108    val def_of_const : theory -> const_table -> styp -> term option
  24.109 -  val is_inductive_pred : extended_context -> styp -> bool
  24.110 +  val fixpoint_kind_of_const :
  24.111 +    theory -> const_table -> string * typ -> fixpoint_kind
  24.112 +  val is_inductive_pred : hol_context -> styp -> bool
  24.113 +  val is_equational_fun : hol_context -> styp -> bool
  24.114    val is_constr_pattern_lhs : theory -> term -> bool
  24.115    val is_constr_pattern_formula : theory -> term -> bool
  24.116 +  val unfold_defs_in_term : hol_context -> term -> term
  24.117 +  val codatatype_bisim_axioms : hol_context -> typ -> term list
  24.118 +  val is_well_founded_inductive_pred : hol_context -> styp -> bool
  24.119 +  val unrolled_inductive_pred_const : hol_context -> bool -> styp -> term
  24.120 +  val equational_fun_axioms : hol_context -> styp -> term list
  24.121 +  val is_equational_fun_surely_complete : hol_context -> styp -> bool
  24.122    val merge_type_vars_in_terms : term list -> term list
  24.123 -  val ground_types_in_type : extended_context -> typ -> typ list
  24.124 -  val ground_types_in_terms : extended_context -> term list -> typ list
  24.125 +  val ground_types_in_type : hol_context -> typ -> typ list
  24.126 +  val ground_types_in_terms : hol_context -> term list -> typ list
  24.127    val format_type : int list -> int list -> typ -> typ
  24.128    val format_term_type :
  24.129      theory -> const_table -> (term option * int list) list -> term -> typ
  24.130    val user_friendly_const :
  24.131 -   extended_context -> string * string -> (term option * int list) list
  24.132 +   hol_context -> string * string -> (term option * int list) list
  24.133     -> styp -> term * typ
  24.134    val assign_operator_for_const : styp -> string
  24.135 -  val preprocess_term :
  24.136 -    extended_context -> term -> ((term list * term list) * (bool * bool)) * term
  24.137  end;
  24.138  
  24.139  structure Nitpick_HOL : NITPICK_HOL =
  24.140 @@ -162,7 +196,7 @@
  24.141  type unrolled = styp * styp
  24.142  type wf_cache = (styp * (bool * bool)) list
  24.143  
  24.144 -type extended_context = {
  24.145 +type hol_context = {
  24.146    thy: theory,
  24.147    ctxt: Proof.context,
  24.148    max_bisim_depth: int,
  24.149 @@ -195,6 +229,10 @@
  24.150    wf_cache: wf_cache Unsynchronized.ref,
  24.151    constr_cache: (typ * styp list) list Unsynchronized.ref}
  24.152  
  24.153 +datatype fixpoint_kind = Lfp | Gfp | NoFp
  24.154 +datatype boxability =
  24.155 +  InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2
  24.156 +
  24.157  structure Data = Theory_Data(
  24.158    type T = {frac_types: (string * (string * string) list) list,
  24.159              codatatypes: (string * (string * styp list)) list}
  24.160 @@ -222,20 +260,11 @@
  24.161  val special_prefix = nitpick_prefix ^ "sp"
  24.162  val uncurry_prefix = nitpick_prefix ^ "unc"
  24.163  val eval_prefix = nitpick_prefix ^ "eval"
  24.164 -val bound_var_prefix = "b"
  24.165 -val cong_var_prefix = "c"
  24.166  val iter_var_prefix = "i"
  24.167 -val val_var_prefix = nitpick_prefix ^ "v"
  24.168  val arg_var_prefix = "x"
  24.169  
  24.170  (* int -> string *)
  24.171  fun sel_prefix_for j = sel_prefix ^ string_of_int j ^ name_sep
  24.172 -fun special_prefix_for j = special_prefix ^ string_of_int j ^ name_sep
  24.173 -(* int -> int -> string *)
  24.174 -fun skolem_prefix_for k j =
  24.175 -  skolem_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
  24.176 -fun uncurry_prefix_for k j =
  24.177 -  uncurry_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
  24.178  
  24.179  (* string -> string * string *)
  24.180  val strip_first_name_sep =
  24.181 @@ -260,9 +289,6 @@
  24.182    | s_disj (t1, t2) =
  24.183      if t1 = @{const True} orelse t2 = @{const True} then @{const True}
  24.184      else HOLogic.mk_disj (t1, t2)
  24.185 -(* term -> term -> term *)
  24.186 -fun mk_exists v t =
  24.187 -  HOLogic.exists_const (fastype_of v) $ lambda v (incr_boundvars 1 t)
  24.188  
  24.189  (* term -> term -> term list *)
  24.190  fun strip_connective conn_t (t as (t0 $ t1 $ t2)) =
  24.191 @@ -276,8 +302,8 @@
  24.192        ([t], @{const Not})
  24.193    | strip_any_connective t = ([t], @{const Not})
  24.194  (* term -> term list *)
  24.195 -val conjuncts = strip_connective @{const "op &"}
  24.196 -val disjuncts = strip_connective @{const "op |"}
  24.197 +val conjuncts_of = strip_connective @{const "op &"}
  24.198 +val disjuncts_of = strip_connective @{const "op |"}
  24.199  
  24.200  (* When you add constants to these lists, make sure to handle them in
  24.201     "Nitpick_Nut.nut_from_term", and perhaps in "Nitpick_Mono.consider_term" as
  24.202 @@ -373,8 +399,6 @@
  24.203  fun shortest_name s = List.last (space_explode "." s) handle List.Empty => ""
  24.204  (* string -> term -> term *)
  24.205  val prefix_abs_vars = Term.map_abs_vars o prefix_name
  24.206 -(* term -> term *)
  24.207 -val shorten_abs_vars = Term.map_abs_vars shortest_name
  24.208  (* string -> string *)
  24.209  fun short_name s =
  24.210    case space_explode name_sep s of
  24.211 @@ -441,7 +465,7 @@
  24.212    | const_for_iterator_type T =
  24.213      raise TYPE ("Nitpick_HOL.const_for_iterator_type", [T], [])
  24.214  
  24.215 -(* int -> typ -> typ * typ *)
  24.216 +(* int -> typ -> typ list * typ *)
  24.217  fun strip_n_binders 0 T = ([], T)
  24.218    | strip_n_binders n (Type ("fun", [T1, T2])) =
  24.219      strip_n_binders (n - 1) T2 |>> cons T1
  24.220 @@ -552,7 +576,7 @@
  24.221  val is_real_datatype = is_some oo Datatype.get_info
  24.222  (* theory -> typ -> bool *)
  24.223  fun is_quot_type _ (Type ("IntEx.my_int", _)) = true (* FIXME *)
  24.224 -  | is_quot_type _ (Type ("FSet.fset", _)) = true (* FIXME *)
  24.225 +  | is_quot_type _ (Type ("FSet.fset", _)) = true
  24.226    | is_quot_type _ _ = false
  24.227  fun is_codatatype thy (T as Type (s, _)) =
  24.228      not (null (AList.lookup (op =) (#codatatypes (Data.get thy)) s
  24.229 @@ -619,11 +643,11 @@
  24.230       | NONE => false)
  24.231    | is_rep_fun _ _ = false
  24.232  (* Proof.context -> styp -> bool *)
  24.233 -fun is_quot_abs_fun _ ("IntEx.abs_my_int", _) = true (* FIXME *)
  24.234 -  | is_quot_abs_fun _ ("FSet.abs_fset", _) = true (* FIXME *)
  24.235 +fun is_quot_abs_fun _ ("IntEx.abs_my_int", _) = true
  24.236 +  | is_quot_abs_fun _ ("FSet.abs_fset", _) = true
  24.237    | is_quot_abs_fun _ _ = false
  24.238 -fun is_quot_rep_fun _ ("IntEx.rep_my_int", _) = true (* FIXME *)
  24.239 -  | is_quot_rep_fun _ ("FSet.rep_fset", _) = true (* FIXME *)
  24.240 +fun is_quot_rep_fun _ ("IntEx.rep_my_int", _) = true
  24.241 +  | is_quot_rep_fun _ ("FSet.rep_fset", _) = true
  24.242    | is_quot_rep_fun _ _ = false
  24.243  
  24.244  (* theory -> styp -> styp *)
  24.245 @@ -682,9 +706,6 @@
  24.246    String.isPrefix sel_prefix
  24.247    orf (member (op =) [@{const_name fst}, @{const_name snd}])
  24.248  
  24.249 -datatype boxability =
  24.250 -  InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2
  24.251 -
  24.252  (* boxability -> boxability *)
  24.253  fun in_fun_lhs_for InConstr = InSel
  24.254    | in_fun_lhs_for _ = InFunLHS
  24.255 @@ -693,8 +714,8 @@
  24.256    | in_fun_rhs_for InFunRHS1 = InFunRHS2
  24.257    | in_fun_rhs_for _ = InFunRHS1
  24.258  
  24.259 -(* extended_context -> boxability -> typ -> bool *)
  24.260 -fun is_boxing_worth_it (ext_ctxt : extended_context) boxy T =
  24.261 +(* hol_context -> boxability -> typ -> bool *)
  24.262 +fun is_boxing_worth_it (hol_ctxt : hol_context) boxy T =
  24.263    case T of
  24.264      Type ("fun", _) =>
  24.265      (boxy = InPair orelse boxy = InFunLHS) andalso
  24.266 @@ -702,31 +723,31 @@
  24.267    | Type ("*", Ts) =>
  24.268      boxy = InPair orelse boxy = InFunRHS1 orelse boxy = InFunRHS2 orelse
  24.269      ((boxy = InExpr orelse boxy = InFunLHS) andalso
  24.270 -     exists (is_boxing_worth_it ext_ctxt InPair)
  24.271 -            (map (box_type ext_ctxt InPair) Ts))
  24.272 +     exists (is_boxing_worth_it hol_ctxt InPair)
  24.273 +            (map (box_type hol_ctxt InPair) Ts))
  24.274    | _ => false
  24.275 -(* extended_context -> boxability -> string * typ list -> string *)
  24.276 -and should_box_type (ext_ctxt as {thy, boxes, ...}) boxy (z as (s, Ts)) =
  24.277 +(* hol_context -> boxability -> string * typ list -> string *)
  24.278 +and should_box_type (hol_ctxt as {thy, boxes, ...}) boxy (z as (s, Ts)) =
  24.279    case triple_lookup (type_match thy) boxes (Type z) of
  24.280      SOME (SOME box_me) => box_me
  24.281 -  | _ => is_boxing_worth_it ext_ctxt boxy (Type z)
  24.282 -(* extended_context -> boxability -> typ -> typ *)
  24.283 -and box_type ext_ctxt boxy T =
  24.284 +  | _ => is_boxing_worth_it hol_ctxt boxy (Type z)
  24.285 +(* hol_context -> boxability -> typ -> typ *)
  24.286 +and box_type hol_ctxt boxy T =
  24.287    case T of
  24.288      Type (z as ("fun", [T1, T2])) =>
  24.289      if boxy <> InConstr andalso boxy <> InSel andalso
  24.290 -       should_box_type ext_ctxt boxy z then
  24.291 +       should_box_type hol_ctxt boxy z then
  24.292        Type (@{type_name fun_box},
  24.293 -            [box_type ext_ctxt InFunLHS T1, box_type ext_ctxt InFunRHS1 T2])
  24.294 +            [box_type hol_ctxt InFunLHS T1, box_type hol_ctxt InFunRHS1 T2])
  24.295      else
  24.296 -      box_type ext_ctxt (in_fun_lhs_for boxy) T1
  24.297 -      --> box_type ext_ctxt (in_fun_rhs_for boxy) T2
  24.298 +      box_type hol_ctxt (in_fun_lhs_for boxy) T1
  24.299 +      --> box_type hol_ctxt (in_fun_rhs_for boxy) T2
  24.300    | Type (z as ("*", Ts)) =>
  24.301      if boxy <> InConstr andalso boxy <> InSel
  24.302 -       andalso should_box_type ext_ctxt boxy z then
  24.303 -      Type (@{type_name pair_box}, map (box_type ext_ctxt InSel) Ts)
  24.304 +       andalso should_box_type hol_ctxt boxy z then
  24.305 +      Type (@{type_name pair_box}, map (box_type hol_ctxt InSel) Ts)
  24.306      else
  24.307 -      Type ("*", map (box_type ext_ctxt
  24.308 +      Type ("*", map (box_type hol_ctxt
  24.309                            (if boxy = InConstr orelse boxy = InSel then boxy
  24.310                             else InPair)) Ts)
  24.311    | _ => T
  24.312 @@ -747,9 +768,9 @@
  24.313    | nth_sel_for_constr (s, T) n =
  24.314      (nth_sel_name_for_constr_name s n,
  24.315       body_type T --> nth (maybe_curried_binder_types T) n)
  24.316 -(* extended_context -> styp -> int -> styp *)
  24.317 -fun boxed_nth_sel_for_constr ext_ctxt =
  24.318 -  apsnd (box_type ext_ctxt InSel) oo nth_sel_for_constr
  24.319 +(* hol_context -> styp -> int -> styp *)
  24.320 +fun boxed_nth_sel_for_constr hol_ctxt =
  24.321 +  apsnd (box_type hol_ctxt InSel) oo nth_sel_for_constr
  24.322  
  24.323  (* string -> int *)
  24.324  fun sel_no_from_name s =
  24.325 @@ -762,6 +783,22 @@
  24.326    else
  24.327      0
  24.328  
  24.329 +(* term -> term *)
  24.330 +val close_form =
  24.331 +  let
  24.332 +    (* (indexname * typ) list -> (indexname * typ) list -> term -> term *)
  24.333 +    fun close_up zs zs' =
  24.334 +      fold (fn (z as ((s, _), T)) => fn t' =>
  24.335 +               Term.all T $ Abs (s, T, abstract_over (Var z, t')))
  24.336 +           (take (length zs' - length zs) zs')
  24.337 +    (* (indexname * typ) list -> term -> term *)
  24.338 +    fun aux zs (@{const "==>"} $ t1 $ t2) =
  24.339 +        let val zs' = Term.add_vars t1 zs in
  24.340 +          close_up zs zs' (Logic.mk_implies (t1, aux zs' t2))
  24.341 +        end
  24.342 +      | aux zs t = close_up zs (Term.add_vars t zs) t
  24.343 +  in aux [] end
  24.344 +
  24.345  (* typ list -> term -> int -> term *)
  24.346  fun eta_expand _ t 0 = t
  24.347    | eta_expand Ts (Abs (s, T, t')) n =
  24.348 @@ -791,8 +828,8 @@
  24.349  fun zero_const T = Const (@{const_name zero_nat_inst.zero_nat}, T)
  24.350  fun suc_const T = Const (@{const_name Suc}, T --> T)
  24.351  
  24.352 -(* extended_context -> typ -> styp list *)
  24.353 -fun uncached_datatype_constrs ({thy, stds, ...} : extended_context)
  24.354 +(* hol_context -> typ -> styp list *)
  24.355 +fun uncached_datatype_constrs ({thy, stds, ...} : hol_context)
  24.356                                (T as Type (s, Ts)) =
  24.357      (case AList.lookup (op =) (#codatatypes (Data.get thy)) s of
  24.358         SOME (_, xs' as (_ :: _)) => map (apsnd (repair_constr_type thy T)) xs'
  24.359 @@ -829,49 +866,49 @@
  24.360         else
  24.361           [])
  24.362    | uncached_datatype_constrs _ _ = []
  24.363 -(* extended_context -> typ -> styp list *)
  24.364 -fun datatype_constrs (ext_ctxt as {constr_cache, ...}) T =
  24.365 +(* hol_context -> typ -> styp list *)
  24.366 +fun datatype_constrs (hol_ctxt as {constr_cache, ...}) T =
  24.367    case AList.lookup (op =) (!constr_cache) T of
  24.368      SOME xs => xs
  24.369    | NONE =>
  24.370 -    let val xs = uncached_datatype_constrs ext_ctxt T in
  24.371 +    let val xs = uncached_datatype_constrs hol_ctxt T in
  24.372        (Unsynchronized.change constr_cache (cons (T, xs)); xs)
  24.373      end
  24.374 -fun boxed_datatype_constrs ext_ctxt =
  24.375 -  map (apsnd (box_type ext_ctxt InConstr)) o datatype_constrs ext_ctxt
  24.376 -(* extended_context -> typ -> int *)
  24.377 +fun boxed_datatype_constrs hol_ctxt =
  24.378 +  map (apsnd (box_type hol_ctxt InConstr)) o datatype_constrs hol_ctxt
  24.379 +(* hol_context -> typ -> int *)
  24.380  val num_datatype_constrs = length oo datatype_constrs
  24.381  
  24.382  (* string -> string *)
  24.383  fun constr_name_for_sel_like @{const_name fst} = @{const_name Pair}
  24.384    | constr_name_for_sel_like @{const_name snd} = @{const_name Pair}
  24.385    | constr_name_for_sel_like s' = original_name s'
  24.386 -(* extended_context -> styp -> styp *)
  24.387 -fun boxed_constr_for_sel ext_ctxt (s', T') =
  24.388 +(* hol_context -> styp -> styp *)
  24.389 +fun boxed_constr_for_sel hol_ctxt (s', T') =
  24.390    let val s = constr_name_for_sel_like s' in
  24.391 -    AList.lookup (op =) (boxed_datatype_constrs ext_ctxt (domain_type T')) s
  24.392 +    AList.lookup (op =) (boxed_datatype_constrs hol_ctxt (domain_type T')) s
  24.393      |> the |> pair s
  24.394    end
  24.395  
  24.396 -(* extended_context -> styp -> term *)
  24.397 -fun discr_term_for_constr ext_ctxt (x as (s, T)) =
  24.398 +(* hol_context -> styp -> term *)
  24.399 +fun discr_term_for_constr hol_ctxt (x as (s, T)) =
  24.400    let val dataT = body_type T in
  24.401      if s = @{const_name Suc} then
  24.402        Abs (Name.uu, dataT,
  24.403             @{const Not} $ HOLogic.mk_eq (zero_const dataT, Bound 0))
  24.404 -    else if num_datatype_constrs ext_ctxt dataT >= 2 then
  24.405 +    else if num_datatype_constrs hol_ctxt dataT >= 2 then
  24.406        Const (discr_for_constr x)
  24.407      else
  24.408        Abs (Name.uu, dataT, @{const True})
  24.409    end
  24.410 -(* extended_context -> styp -> term -> term *)
  24.411 -fun discriminate_value (ext_ctxt as {thy, ...}) (x as (_, T)) t =
  24.412 +(* hol_context -> styp -> term -> term *)
  24.413 +fun discriminate_value (hol_ctxt as {thy, ...}) (x as (_, T)) t =
  24.414    case strip_comb t of
  24.415      (Const x', args) =>
  24.416      if x = x' then @{const True}
  24.417      else if is_constr_like thy x' then @{const False}
  24.418 -    else betapply (discr_term_for_constr ext_ctxt x, t)
  24.419 -  | _ => betapply (discr_term_for_constr ext_ctxt x, t)
  24.420 +    else betapply (discr_term_for_constr hol_ctxt x, t)
  24.421 +  | _ => betapply (discr_term_for_constr hol_ctxt x, t)
  24.422  
  24.423  (* styp -> term -> term *)
  24.424  fun nth_arg_sel_term_for_constr (x as (s, T)) n =
  24.425 @@ -920,25 +957,9 @@
  24.426        | _ => list_comb (Const x, args)
  24.427      end
  24.428  
  24.429 -(* extended_context -> typ -> term -> term *)
  24.430 -fun constr_expand (ext_ctxt as {thy, ...}) T t =
  24.431 -  (case head_of t of
  24.432 -     Const x => if is_constr_like thy x then t else raise SAME ()
  24.433 -   | _ => raise SAME ())
  24.434 -  handle SAME () =>
  24.435 -         let
  24.436 -           val x' as (_, T') =
  24.437 -             if is_pair_type T then
  24.438 -               let val (T1, T2) = HOLogic.dest_prodT T in
  24.439 -                 (@{const_name Pair}, T1 --> T2 --> T)
  24.440 -               end
  24.441 -             else
  24.442 -               datatype_constrs ext_ctxt T |> hd
  24.443 -           val arg_Ts = binder_types T'
  24.444 -         in
  24.445 -           list_comb (Const x', map2 (select_nth_constr_arg thy x' t)
  24.446 -                                     (index_seq 0 (length arg_Ts)) arg_Ts)
  24.447 -         end
  24.448 +(* The higher this number is, the more nonstandard models can be generated. It's
  24.449 +   not important enough to be a user option, though. *)
  24.450 +val xi_card = 8
  24.451  
  24.452  (* (typ * int) list -> typ -> int *)
  24.453  fun card_of_type assigns (Type ("fun", [T1, T2])) =
  24.454 @@ -949,6 +970,7 @@
  24.455    | card_of_type _ @{typ prop} = 2
  24.456    | card_of_type _ @{typ bool} = 2
  24.457    | card_of_type _ @{typ unit} = 1
  24.458 +  | card_of_type _ @{typ \<xi>} = xi_card
  24.459    | card_of_type assigns T =
  24.460      case AList.lookup (op =) assigns T of
  24.461        SOME k => k
  24.462 @@ -975,8 +997,8 @@
  24.463                      card_of_type assigns T
  24.464                      handle TYPE ("Nitpick_HOL.card_of_type", _, _) =>
  24.465                             default_card)
  24.466 -(* extended_context -> int -> (typ * int) list -> typ -> int *)
  24.467 -fun bounded_exact_card_of_type ext_ctxt max default_card assigns T =
  24.468 +(* hol_context -> int -> (typ * int) list -> typ -> int *)
  24.469 +fun bounded_exact_card_of_type hol_ctxt max default_card assigns T =
  24.470    let
  24.471      (* typ list -> typ -> int *)
  24.472      fun aux avoid T =
  24.473 @@ -1005,14 +1027,15 @@
  24.474         | @{typ prop} => 2
  24.475         | @{typ bool} => 2
  24.476         | @{typ unit} => 1
  24.477 +       | @{typ \<xi>} => xi_card
  24.478         | Type _ =>
  24.479 -         (case datatype_constrs ext_ctxt T of
  24.480 +         (case datatype_constrs hol_ctxt T of
  24.481              [] => if is_integer_type T orelse is_bit_type T then 0
  24.482                    else raise SAME ()
  24.483            | constrs =>
  24.484              let
  24.485                val constr_cards =
  24.486 -                datatype_constrs ext_ctxt T
  24.487 +                datatype_constrs hol_ctxt T
  24.488                  |> map (Integer.prod o map (aux (T :: avoid)) o binder_types
  24.489                          o snd)
  24.490              in
  24.491 @@ -1024,9 +1047,9 @@
  24.492               AList.lookup (op =) assigns T |> the_default default_card
  24.493    in Int.min (max, aux [] T) end
  24.494  
  24.495 -(* extended_context -> typ -> bool *)
  24.496 -fun is_finite_type ext_ctxt =
  24.497 -  not_equal 0 o bounded_exact_card_of_type ext_ctxt 1 2 []
  24.498 +(* hol_context -> typ -> bool *)
  24.499 +fun is_finite_type hol_ctxt =
  24.500 +  not_equal 0 o bounded_exact_card_of_type hol_ctxt 1 2 []
  24.501  
  24.502  (* term -> bool *)
  24.503  fun is_ground_term (t1 $ t2) = is_ground_term t1 andalso is_ground_term t2
  24.504 @@ -1052,7 +1075,7 @@
  24.505    member (op =) [@{type_name unit}, @{type_name "*"}, @{type_name "+"},
  24.506                   @{type_name int}] s orelse
  24.507    is_frac_type thy (Type (s, []))
  24.508 -(* theory -> term -> bool *)
  24.509 +(* theory -> typ -> bool *)
  24.510  fun is_funky_typedef thy (Type (s, _)) = is_funky_typedef_name thy s
  24.511    | is_funky_typedef _ _ = false
  24.512  (* term -> bool *)
  24.513 @@ -1199,8 +1222,6 @@
  24.514        |> normalized_rhs_of thy |> Option.map (prefix_abs_vars s)
  24.515      handle List.Empty => NONE
  24.516  
  24.517 -datatype fixpoint_kind = Lfp | Gfp | NoFp
  24.518 -
  24.519  (* term -> fixpoint_kind *)
  24.520  fun fixpoint_kind_of_rhs (Abs (_, _, t)) = fixpoint_kind_of_rhs t
  24.521    | fixpoint_kind_of_rhs (Const (@{const_name lfp}, _) $ Abs _) = Lfp
  24.522 @@ -1299,35 +1320,6 @@
  24.523    Unsynchronized.change simp_table
  24.524        (Symtab.update (s, eqs @ these (Symtab.lookup (!simp_table) s)))
  24.525  
  24.526 -(* Similar to "Refute.specialize_type" but returns all matches rather than only
  24.527 -   the first (preorder) match. *)
  24.528 -(* theory -> styp -> term -> term list *)
  24.529 -fun multi_specialize_type thy slack (x as (s, T)) t =
  24.530 -  let
  24.531 -    (* term -> (typ * term) list -> (typ * term) list *)
  24.532 -    fun aux (Const (s', T')) ys =
  24.533 -        if s = s' then
  24.534 -          ys |> (if AList.defined (op =) ys T' then
  24.535 -                   I
  24.536 -                 else
  24.537 -                  cons (T', Refute.monomorphic_term
  24.538 -                                (Sign.typ_match thy (T', T) Vartab.empty) t)
  24.539 -                  handle Type.TYPE_MATCH => I
  24.540 -                       | Refute.REFUTE _ =>
  24.541 -                         if slack then
  24.542 -                           I
  24.543 -                         else
  24.544 -                           raise NOT_SUPPORTED ("too much polymorphism in \
  24.545 -                                                \axiom involving " ^ quote s))
  24.546 -        else
  24.547 -          ys
  24.548 -      | aux _ ys = ys
  24.549 -  in map snd (fold_aterms aux t []) end
  24.550 -
  24.551 -(* theory -> bool -> const_table -> styp -> term list *)
  24.552 -fun nondef_props_for_const thy slack table (x as (s, _)) =
  24.553 -  these (Symtab.lookup table s) |> maps (multi_specialize_type thy slack x)
  24.554 -
  24.555  (* theory -> styp -> term list *)
  24.556  fun inverse_axioms_for_rep_fun thy (x as (_, T)) =
  24.557    let val abs_T = domain_type T in
  24.558 @@ -1336,7 +1328,7 @@
  24.559      |> pairself (Refute.specialize_type thy x o prop_of o the)
  24.560      ||> single |> op ::
  24.561    end
  24.562 -(* theory -> styp list -> term list *)
  24.563 +(* theory -> string * typ list -> term list *)
  24.564  fun optimized_typedef_axioms thy (abs_z as (abs_s, abs_Ts)) =
  24.565    let val abs_T = Type abs_z in
  24.566      if is_univ_typedef thy abs_T then
  24.567 @@ -1392,15 +1384,15 @@
  24.568      list_comb (Bound j, map2 (select_nth_constr_arg thy x (Bound 0))
  24.569                               (index_seq 0 (length arg_Ts)) arg_Ts)
  24.570    end
  24.571 -(* extended_context -> typ -> int * styp -> term -> term *)
  24.572 -fun add_constr_case (ext_ctxt as {thy, ...}) res_T (j, x) res_t =
  24.573 +(* hol_context -> typ -> int * styp -> term -> term *)
  24.574 +fun add_constr_case (hol_ctxt as {thy, ...}) res_T (j, x) res_t =
  24.575    Const (@{const_name If}, bool_T --> res_T --> res_T --> res_T)
  24.576 -  $ discriminate_value ext_ctxt x (Bound 0) $ constr_case_body thy (j, x)
  24.577 +  $ discriminate_value hol_ctxt x (Bound 0) $ constr_case_body thy (j, x)
  24.578    $ res_t
  24.579 -(* extended_context -> typ -> typ -> term *)
  24.580 -fun optimized_case_def (ext_ctxt as {thy, ...}) dataT res_T =
  24.581 +(* hol_context -> typ -> typ -> term *)
  24.582 +fun optimized_case_def (hol_ctxt as {thy, ...}) dataT res_T =
  24.583    let
  24.584 -    val xs = datatype_constrs ext_ctxt dataT
  24.585 +    val xs = datatype_constrs hol_ctxt dataT
  24.586      val xs' = filter_out (fn (s, _) => s = @{const_name NonStd}) xs
  24.587      val func_Ts = map ((fn T => binder_types T ---> res_T) o snd) xs'
  24.588    in
  24.589 @@ -1409,19 +1401,19 @@
  24.590           val (xs'', x) = split_last xs'
  24.591         in
  24.592           constr_case_body thy (1, x)
  24.593 -         |> fold_rev (add_constr_case ext_ctxt res_T)
  24.594 +         |> fold_rev (add_constr_case hol_ctxt res_T)
  24.595                       (length xs' downto 2 ~~ xs'')
  24.596         end
  24.597       else
  24.598         Const (@{const_name undefined}, dataT --> res_T) $ Bound 0
  24.599 -       |> fold_rev (add_constr_case ext_ctxt res_T)
  24.600 +       |> fold_rev (add_constr_case hol_ctxt res_T)
  24.601                     (length xs' downto 1 ~~ xs'))
  24.602      |> fold_rev (curry absdummy) (func_Ts @ [dataT])
  24.603    end
  24.604  
  24.605 -(* extended_context -> string -> typ -> typ -> term -> term *)
  24.606 -fun optimized_record_get (ext_ctxt as {thy, ...}) s rec_T res_T t =
  24.607 -  let val constr_x = hd (datatype_constrs ext_ctxt rec_T) in
  24.608 +(* hol_context -> string -> typ -> typ -> term -> term *)
  24.609 +fun optimized_record_get (hol_ctxt as {thy, ...}) s rec_T res_T t =
  24.610 +  let val constr_x = hd (datatype_constrs hol_ctxt rec_T) in
  24.611      case no_of_record_field thy s rec_T of
  24.612        ~1 => (case rec_T of
  24.613                 Type (_, Ts as _ :: _) =>
  24.614 @@ -1430,16 +1422,16 @@
  24.615                   val j = num_record_fields thy rec_T - 1
  24.616                 in
  24.617                   select_nth_constr_arg thy constr_x t j res_T
  24.618 -                 |> optimized_record_get ext_ctxt s rec_T' res_T
  24.619 +                 |> optimized_record_get hol_ctxt s rec_T' res_T
  24.620                 end
  24.621               | _ => raise TYPE ("Nitpick_HOL.optimized_record_get", [rec_T],
  24.622                                  []))
  24.623      | j => select_nth_constr_arg thy constr_x t j res_T
  24.624    end
  24.625 -(* extended_context -> string -> typ -> term -> term -> term *)
  24.626 -fun optimized_record_update (ext_ctxt as {thy, ...}) s rec_T fun_t rec_t =
  24.627 +(* hol_context -> string -> typ -> term -> term -> term *)
  24.628 +fun optimized_record_update (hol_ctxt as {thy, ...}) s rec_T fun_t rec_t =
  24.629    let
  24.630 -    val constr_x as (_, constr_T) = hd (datatype_constrs ext_ctxt rec_T)
  24.631 +    val constr_x as (_, constr_T) = hd (datatype_constrs hol_ctxt rec_T)
  24.632      val Ts = binder_types constr_T
  24.633      val n = length Ts
  24.634      val special_j = no_of_record_field thy s rec_T
  24.635 @@ -1450,7 +1442,7 @@
  24.636                          if j = special_j then
  24.637                            betapply (fun_t, t)
  24.638                          else if j = n - 1 andalso special_j = ~1 then
  24.639 -                          optimized_record_update ext_ctxt s
  24.640 +                          optimized_record_update hol_ctxt s
  24.641                                (rec_T |> dest_Type |> snd |> List.last) fun_t t
  24.642                          else
  24.643                            t
  24.644 @@ -1473,19 +1465,19 @@
  24.645      fixpoint_kind_of_rhs (the (def_of_const thy table x))
  24.646      handle Option.Option => NoFp
  24.647  
  24.648 -(* extended_context -> styp -> bool *)
  24.649 +(* hol_context -> styp -> bool *)
  24.650  fun is_real_inductive_pred ({thy, fast_descrs, def_table, intro_table, ...}
  24.651 -                            : extended_context) x =
  24.652 +                            : hol_context) x =
  24.653    not (null (def_props_for_const thy fast_descrs intro_table x)) andalso
  24.654    fixpoint_kind_of_const thy def_table x <> NoFp
  24.655  fun is_real_equational_fun ({thy, fast_descrs, simp_table, psimp_table, ...}
  24.656 -                            : extended_context) x =
  24.657 +                            : hol_context) x =
  24.658    exists (fn table => not (null (def_props_for_const thy fast_descrs table x)))
  24.659           [!simp_table, psimp_table]
  24.660 -fun is_inductive_pred ext_ctxt =
  24.661 -  is_real_inductive_pred ext_ctxt andf (not o is_real_equational_fun ext_ctxt)
  24.662 -fun is_equational_fun (ext_ctxt as {thy, def_table, ...}) =
  24.663 -  (is_real_equational_fun ext_ctxt orf is_real_inductive_pred ext_ctxt
  24.664 +fun is_inductive_pred hol_ctxt =
  24.665 +  is_real_inductive_pred hol_ctxt andf (not o is_real_equational_fun hol_ctxt)
  24.666 +fun is_equational_fun (hol_ctxt as {thy, def_table, ...}) =
  24.667 +  (is_real_equational_fun hol_ctxt orf is_real_inductive_pred hol_ctxt
  24.668     orf (String.isPrefix ubfp_prefix orf String.isPrefix lbfp_prefix) o fst)
  24.669    andf (not o has_trivial_definition thy def_table)
  24.670  
  24.671 @@ -1522,11 +1514,11 @@
  24.672      SOME t' => is_constr_pattern_lhs thy t'
  24.673    | NONE => false
  24.674  
  24.675 +(* Prevents divergence in case of cyclic or infinite definition dependencies. *)
  24.676  val unfold_max_depth = 255
  24.677 -val axioms_max_depth = 255
  24.678  
  24.679 -(* extended_context -> term -> term *)
  24.680 -fun unfold_defs_in_term (ext_ctxt as {thy, destroy_constrs, fast_descrs,
  24.681 +(* hol_context -> term -> term *)
  24.682 +fun unfold_defs_in_term (hol_ctxt as {thy, destroy_constrs, fast_descrs,
  24.683                                        case_names, def_table, ground_thm_table,
  24.684                                        ersatz_table, ...}) =
  24.685    let
  24.686 @@ -1600,7 +1592,7 @@
  24.687                  val (dataT, res_T) = nth_range_type n T
  24.688                                       |> pairf domain_type range_type
  24.689                in
  24.690 -                (optimized_case_def ext_ctxt dataT res_T
  24.691 +                (optimized_case_def hol_ctxt dataT res_T
  24.692                   |> do_term (depth + 1) Ts, ts)
  24.693                end
  24.694              | _ =>
  24.695 @@ -1628,11 +1620,11 @@
  24.696                else if is_record_get thy x then
  24.697                  case length ts of
  24.698                    0 => (do_term depth Ts (eta_expand Ts t 1), [])
  24.699 -                | _ => (optimized_record_get ext_ctxt s (domain_type T)
  24.700 +                | _ => (optimized_record_get hol_ctxt s (domain_type T)
  24.701                              (range_type T) (do_term depth Ts (hd ts)), tl ts)
  24.702                else if is_record_update thy x then
  24.703                  case length ts of
  24.704 -                  2 => (optimized_record_update ext_ctxt
  24.705 +                  2 => (optimized_record_update hol_ctxt
  24.706                              (unsuffix Record.updateN s) (nth_range_type 2 T)
  24.707                              (do_term depth Ts (hd ts))
  24.708                              (do_term depth Ts (nth ts 1)), [])
  24.709 @@ -1645,7 +1637,7 @@
  24.710                    else
  24.711                      (Const x, ts)
  24.712                  end
  24.713 -              else if is_equational_fun ext_ctxt x then
  24.714 +              else if is_equational_fun hol_ctxt x then
  24.715                  (Const x, ts)
  24.716                else case def_of_const thy def_table x of
  24.717                  SOME def =>
  24.718 @@ -1662,10 +1654,10 @@
  24.719          in s_betapplys (const, map (do_term depth Ts) ts) |> Envir.beta_norm end
  24.720    in do_term 0 [] end
  24.721  
  24.722 -(* extended_context -> typ -> term list *)
  24.723 -fun codatatype_bisim_axioms (ext_ctxt as {thy, ...}) T =
  24.724 +(* hol_context -> typ -> term list *)
  24.725 +fun codatatype_bisim_axioms (hol_ctxt as {thy, ...}) T =
  24.726    let
  24.727 -    val xs = datatype_constrs ext_ctxt T
  24.728 +    val xs = datatype_constrs hol_ctxt T
  24.729      val set_T = T --> bool_T
  24.730      val iter_T = @{typ bisim_iterator}
  24.731      val bisim_const = Const (@{const_name bisim}, iter_T --> T --> T --> bool_T)
  24.732 @@ -1688,14 +1680,14 @@
  24.733        let
  24.734          val arg_Ts = binder_types T
  24.735          val core_t =
  24.736 -          discriminate_value ext_ctxt x y_var ::
  24.737 +          discriminate_value hol_ctxt x y_var ::
  24.738            map2 (nth_sub_bisim x) (index_seq 0 (length arg_Ts)) arg_Ts
  24.739            |> foldr1 s_conj
  24.740        in List.foldr absdummy core_t arg_Ts end
  24.741    in
  24.742      [HOLogic.eq_const bool_T $ (bisim_const $ n_var $ x_var $ y_var)
  24.743       $ (@{term "op |"} $ (HOLogic.eq_const iter_T $ n_var $ zero_const iter_T)
  24.744 -        $ (betapplys (optimized_case_def ext_ctxt T bool_T,
  24.745 +        $ (betapplys (optimized_case_def hol_ctxt T bool_T,
  24.746                        map case_func xs @ [x_var]))),
  24.747       HOLogic.eq_const set_T $ (bisim_const $ bisim_max $ x_var)
  24.748       $ (Const (@{const_name insert}, T --> set_T --> set_T)
  24.749 @@ -1754,10 +1746,10 @@
  24.750  val termination_tacs = [Lexicographic_Order.lex_order_tac true,
  24.751                          ScnpReconstruct.sizechange_tac]
  24.752  
  24.753 -(* extended_context -> const_table -> styp -> bool *)
  24.754 +(* hol_context -> const_table -> styp -> bool *)
  24.755  fun uncached_is_well_founded_inductive_pred
  24.756          ({thy, ctxt, debug, fast_descrs, tac_timeout, intro_table, ...}
  24.757 -         : extended_context) (x as (_, T)) =
  24.758 +         : hol_context) (x as (_, T)) =
  24.759    case def_props_for_const thy fast_descrs intro_table x of
  24.760      [] => raise TERM ("Nitpick_HOL.uncached_is_well_founded_inductive",
  24.761                        [Const x])
  24.762 @@ -1797,11 +1789,11 @@
  24.763      handle List.Empty => false
  24.764           | NO_TRIPLE () => false
  24.765  
  24.766 -(* The type constraint below is a workaround for a Poly/ML bug. *)
  24.767 +(* The type constraint below is a workaround for a Poly/ML crash. *)
  24.768  
  24.769 -(* extended_context -> styp -> bool *)
  24.770 +(* hol_context -> styp -> bool *)
  24.771  fun is_well_founded_inductive_pred
  24.772 -        (ext_ctxt as {thy, wfs, def_table, wf_cache, ...} : extended_context)
  24.773 +        (hol_ctxt as {thy, wfs, def_table, wf_cache, ...} : hol_context)
  24.774          (x as (s, _)) =
  24.775    case triple_lookup (const_match thy) wfs x of
  24.776      SOME (SOME b) => b
  24.777 @@ -1811,7 +1803,7 @@
  24.778                  | NONE =>
  24.779                    let
  24.780                      val gfp = (fixpoint_kind_of_const thy def_table x = Gfp)
  24.781 -                    val wf = uncached_is_well_founded_inductive_pred ext_ctxt x
  24.782 +                    val wf = uncached_is_well_founded_inductive_pred hol_ctxt x
  24.783                    in
  24.784                      Unsynchronized.change wf_cache (cons (x, (gfp, wf))); wf
  24.785                    end
  24.786 @@ -1842,14 +1834,14 @@
  24.787        | do_disjunct j t =
  24.788          case num_occs_of_bound_in_term j t of
  24.789            0 => true
  24.790 -        | 1 => exists (curry (op =) (Bound j) o head_of) (conjuncts t)
  24.791 +        | 1 => exists (curry (op =) (Bound j) o head_of) (conjuncts_of t)
  24.792          | _ => false
  24.793      (* term -> bool *)
  24.794      fun do_lfp_def (Const (@{const_name lfp}, _) $ t2) =
  24.795          let val (xs, body) = strip_abs t2 in
  24.796            case length xs of
  24.797              1 => false
  24.798 -          | n => forall (do_disjunct (n - 1)) (disjuncts body)
  24.799 +          | n => forall (do_disjunct (n - 1)) (disjuncts_of body)
  24.800          end
  24.801        | do_lfp_def _ = false
  24.802    in do_lfp_def o strip_abs_body end
  24.803 @@ -1887,7 +1879,7 @@
  24.804                end
  24.805            val (nonrecs, recs) =
  24.806              List.partition (curry (op =) 0 o num_occs_of_bound_in_term j)
  24.807 -                           (disjuncts body)
  24.808 +                           (disjuncts_of body)
  24.809            val base_body = nonrecs |> List.foldl s_disj @{const False}
  24.810            val step_body = recs |> map (repair_rec j)
  24.811                                 |> List.foldl s_disj @{const False} 
  24.812 @@ -1901,8 +1893,8 @@
  24.813          raise TERM ("Nitpick_HOL.linear_pred_base_and_step_rhss.aux", [t])
  24.814    in aux end
  24.815  
  24.816 -(* extended_context -> styp -> term -> term *)
  24.817 -fun starred_linear_pred_const (ext_ctxt as {simp_table, ...}) (x as (s, T))
  24.818 +(* hol_context -> styp -> term -> term *)
  24.819 +fun starred_linear_pred_const (hol_ctxt as {simp_table, ...}) (x as (s, T))
  24.820                                def =
  24.821    let
  24.822      val j = maxidx_of_term def + 1
  24.823 @@ -1933,11 +1925,11 @@
  24.824                      $ list_comb (Const step_x, outer_bounds)))
  24.825                $ list_comb (Const base_x, outer_bounds)
  24.826                |> ap_curry tuple_arg_Ts tuple_T bool_T)
  24.827 -    |> unfold_defs_in_term ext_ctxt
  24.828 +    |> unfold_defs_in_term hol_ctxt
  24.829    end
  24.830  
  24.831 -(* extended_context -> bool -> styp -> term *)
  24.832 -fun unrolled_inductive_pred_const (ext_ctxt as {thy, star_linear_preds,
  24.833 +(* hol_context -> bool -> styp -> term *)
  24.834 +fun unrolled_inductive_pred_const (hol_ctxt as {thy, star_linear_preds,
  24.835                                                  def_table, simp_table, ...})
  24.836                                    gfp (x as (s, T)) =
  24.837    let
  24.838 @@ -1946,11 +1938,11 @@
  24.839      val unrolled_const = Const x' $ zero_const iter_T
  24.840      val def = the (def_of_const thy def_table x)
  24.841    in
  24.842 -    if is_equational_fun ext_ctxt x' then
  24.843 +    if is_equational_fun hol_ctxt x' then
  24.844        unrolled_const (* already done *)
  24.845      else if not gfp andalso is_linear_inductive_pred_def def andalso
  24.846           star_linear_preds then
  24.847 -      starred_linear_pred_const ext_ctxt x def
  24.848 +      starred_linear_pred_const hol_ctxt x def
  24.849      else
  24.850        let
  24.851          val j = maxidx_of_term def + 1
  24.852 @@ -1973,8 +1965,8 @@
  24.853        in unrolled_const end
  24.854    end
  24.855  
  24.856 -(* extended_context -> styp -> term *)
  24.857 -fun raw_inductive_pred_axiom ({thy, def_table, ...} : extended_context) x =
  24.858 +(* hol_context -> styp -> term *)
  24.859 +fun raw_inductive_pred_axiom ({thy, def_table, ...} : hol_context) x =
  24.860    let
  24.861      val def = the (def_of_const thy def_table x)
  24.862      val (outer, fp_app) = strip_abs def
  24.863 @@ -1992,24 +1984,29 @@
  24.864      HOLogic.mk_eq (list_comb (Const x, bounds), naked_rhs)
  24.865      |> HOLogic.mk_Trueprop |> curry subst_bounds (rev vars)
  24.866    end
  24.867 -fun inductive_pred_axiom ext_ctxt (x as (s, T)) =
  24.868 +fun inductive_pred_axiom hol_ctxt (x as (s, T)) =
  24.869    if String.isPrefix ubfp_prefix s orelse String.isPrefix lbfp_prefix s then
  24.870      let val x' = (after_name_sep s, T) in
  24.871 -      raw_inductive_pred_axiom ext_ctxt x' |> subst_atomic [(Const x', Const x)]
  24.872 +      raw_inductive_pred_axiom hol_ctxt x' |> subst_atomic [(Const x', Const x)]
  24.873      end
  24.874    else
  24.875 -    raw_inductive_pred_axiom ext_ctxt x
  24.876 +    raw_inductive_pred_axiom hol_ctxt x
  24.877  
  24.878 -(* extended_context -> styp -> term list *)
  24.879 -fun raw_equational_fun_axioms (ext_ctxt as {thy, fast_descrs, simp_table,
  24.880 +(* hol_context -> styp -> term list *)
  24.881 +fun raw_equational_fun_axioms (hol_ctxt as {thy, fast_descrs, simp_table,
  24.882                                              psimp_table, ...}) (x as (s, _)) =
  24.883    case def_props_for_const thy fast_descrs (!simp_table) x of
  24.884      [] => (case def_props_for_const thy fast_descrs psimp_table x of
  24.885 -             [] => [inductive_pred_axiom ext_ctxt x]
  24.886 +             [] => [inductive_pred_axiom hol_ctxt x]
  24.887             | psimps => psimps)
  24.888    | simps => simps
  24.889 -
  24.890  val equational_fun_axioms = map extensionalize oo raw_equational_fun_axioms
  24.891 +(* hol_context -> styp -> bool *)
  24.892 +fun is_equational_fun_surely_complete hol_ctxt x =
  24.893 +  case raw_equational_fun_axioms hol_ctxt x of
  24.894 +    [@{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t1 $ _)] =>
  24.895 +    strip_comb t1 |> snd |> forall is_Var
  24.896 +  | _ => false
  24.897  
  24.898  (* term list -> term list *)
  24.899  fun merge_type_vars_in_terms ts =
  24.900 @@ -2028,1261 +2025,29 @@
  24.901        | coalesce T = T
  24.902    in map (map_types (map_atyps coalesce)) ts end
  24.903  
  24.904 -(* extended_context -> typ -> typ list -> typ list *)
  24.905 -fun add_ground_types ext_ctxt T accum =
  24.906 +(* hol_context -> typ -> typ list -> typ list *)
  24.907 +fun add_ground_types hol_ctxt T accum =
  24.908    case T of
  24.909 -    Type ("fun", Ts) => fold (add_ground_types ext_ctxt) Ts accum
  24.910 -  | Type ("*", Ts) => fold (add_ground_types ext_ctxt) Ts accum
  24.911 -  | Type (@{type_name itself}, [T1]) => add_ground_types ext_ctxt T1 accum
  24.912 +    Type ("fun", Ts) => fold (add_ground_types hol_ctxt) Ts accum
  24.913 +  | Type ("*", Ts) => fold (add_ground_types hol_ctxt) Ts accum
  24.914 +  | Type (@{type_name itself}, [T1]) => add_ground_types hol_ctxt T1 accum
  24.915    | Type (_, Ts) =>
  24.916 -    if member (op =) (@{typ prop} :: @{typ bool} :: @{typ unit} :: accum) T then
  24.917 +    if member (op =) (@{typ prop} :: @{typ bool} :: @{typ unit} ::
  24.918 +                      @{typ \<xi>} :: accum) T then
  24.919        accum
  24.920      else
  24.921        T :: accum
  24.922 -      |> fold (add_ground_types ext_ctxt)
  24.923 -              (case boxed_datatype_constrs ext_ctxt T of
  24.924 +      |> fold (add_ground_types hol_ctxt)
  24.925 +              (case boxed_datatype_constrs hol_ctxt T of
  24.926                   [] => Ts
  24.927                 | xs => map snd xs)
  24.928    | _ => insert (op =) T accum
  24.929 -(* extended_context -> typ -> typ list *)
  24.930 -fun ground_types_in_type ext_ctxt T = add_ground_types ext_ctxt T []
  24.931 -(* extended_context -> term list -> typ list *)
  24.932 -fun ground_types_in_terms ext_ctxt ts =
  24.933 -  fold (fold_types (add_ground_types ext_ctxt)) ts []
  24.934  
  24.935 -(* typ list -> int -> term -> bool *)
  24.936 -fun has_heavy_bounds_or_vars Ts level t =
  24.937 -  let
  24.938 -    (* typ list -> bool *)
  24.939 -    fun aux [] = false
  24.940 -      | aux [T] = is_fun_type T orelse is_pair_type T
  24.941 -      | aux _ = true
  24.942 -  in aux (map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t)) end
  24.943 -
  24.944 -(* typ list -> int -> int -> int -> term -> term *)
  24.945 -fun fresh_value_var Ts k n j t =
  24.946 -  Var ((val_var_prefix ^ nat_subscript (n - j), k), fastype_of1 (Ts, t))
  24.947 -
  24.948 -(* theory -> typ list -> bool -> int -> int -> term -> term list -> term list
  24.949 -   -> term * term list *)
  24.950 -fun pull_out_constr_comb thy Ts relax k level t args seen =
  24.951 -  let val t_comb = list_comb (t, args) in
  24.952 -    case t of
  24.953 -      Const x =>
  24.954 -      if not relax andalso is_constr thy x andalso
  24.955 -         not (is_fun_type (fastype_of1 (Ts, t_comb))) andalso
  24.956 -         has_heavy_bounds_or_vars Ts level t_comb andalso
  24.957 -         not (loose_bvar (t_comb, level)) then
  24.958 -        let
  24.959 -          val (j, seen) = case find_index (curry (op =) t_comb) seen of
  24.960 -                            ~1 => (0, t_comb :: seen)
  24.961 -                          | j => (j, seen)
  24.962 -        in (fresh_value_var Ts k (length seen) j t_comb, seen) end
  24.963 -      else
  24.964 -        (t_comb, seen)
  24.965 -    | _ => (t_comb, seen)
  24.966 -  end
  24.967 -
  24.968 -(* (term -> term) -> typ list -> int -> term list -> term list *)
  24.969 -fun equations_for_pulled_out_constrs mk_eq Ts k seen =
  24.970 -  let val n = length seen in
  24.971 -    map2 (fn j => fn t => mk_eq (fresh_value_var Ts k n j t, t))
  24.972 -         (index_seq 0 n) seen
  24.973 -  end
  24.974 -
  24.975 -(* theory -> bool -> term -> term *)
  24.976 -fun pull_out_universal_constrs thy def t =
  24.977 -  let
  24.978 -    val k = maxidx_of_term t + 1
  24.979 -    (* typ list -> bool -> term -> term list -> term list -> term * term list *)
  24.980 -    fun do_term Ts def t args seen =
  24.981 -      case t of
  24.982 -        (t0 as Const (@{const_name "=="}, _)) $ t1 $ t2 =>
  24.983 -        do_eq_or_imp Ts true def t0 t1 t2 seen
  24.984 -      | (t0 as @{const "==>"}) $ t1 $ t2 =>
  24.985 -        if def then (t, []) else do_eq_or_imp Ts false def t0 t1 t2 seen
  24.986 -      | (t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2 =>
  24.987 -        do_eq_or_imp Ts true def t0 t1 t2 seen
  24.988 -      | (t0 as @{const "op -->"}) $ t1 $ t2 =>
  24.989 -        do_eq_or_imp Ts false def t0 t1 t2 seen
  24.990 -      | Abs (s, T, t') =>
  24.991 -        let val (t', seen) = do_term (T :: Ts) def t' [] seen in
  24.992 -          (list_comb (Abs (s, T, t'), args), seen)
  24.993 -        end
  24.994 -      | t1 $ t2 =>
  24.995 -        let val (t2, seen) = do_term Ts def t2 [] seen in
  24.996 -          do_term Ts def t1 (t2 :: args) seen
  24.997 -        end
  24.998 -      | _ => pull_out_constr_comb thy Ts def k 0 t args seen
  24.999 -    (* typ list -> bool -> bool -> term -> term -> term -> term list
 24.1000 -       -> term * term list *)
 24.1001 -    and do_eq_or_imp Ts eq def t0 t1 t2 seen =
 24.1002 -      let
 24.1003 -        val (t2, seen) = if eq andalso def then (t2, seen)
 24.1004 -                         else do_term Ts false t2 [] seen
 24.1005 -        val (t1, seen) = do_term Ts false t1 [] seen
 24.1006 -      in (t0 $ t1 $ t2, seen) end
 24.1007 -    val (concl, seen) = do_term [] def t [] []
 24.1008 -  in
 24.1009 -    Logic.list_implies (equations_for_pulled_out_constrs Logic.mk_equals [] k
 24.1010 -                                                         seen, concl)
 24.1011 -  end
 24.1012 -
 24.1013 -(* extended_context -> bool -> term -> term *)
 24.1014 -fun destroy_pulled_out_constrs (ext_ctxt as {thy, ...}) axiom t =
 24.1015 -  let
 24.1016 -    (* styp -> int *)
 24.1017 -    val num_occs_of_var =
 24.1018 -      fold_aterms (fn Var z => (fn f => fn z' => f z' |> z = z' ? Integer.add 1)
 24.1019 -                    | _ => I) t (K 0)
 24.1020 -    (* bool -> term -> term *)
 24.1021 -    fun aux careful ((t0 as Const (@{const_name "=="}, _)) $ t1 $ t2) =
 24.1022 -        aux_eq careful true t0 t1 t2
 24.1023 -      | aux careful ((t0 as @{const "==>"}) $ t1 $ t2) =
 24.1024 -        t0 $ aux false t1 $ aux careful t2
 24.1025 -      | aux careful ((t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2) =
 24.1026 -        aux_eq careful true t0 t1 t2
 24.1027 -      | aux careful ((t0 as @{const "op -->"}) $ t1 $ t2) =
 24.1028 -        t0 $ aux false t1 $ aux careful t2
 24.1029 -      | aux careful (Abs (s, T, t')) = Abs (s, T, aux careful t')
 24.1030 -      | aux careful (t1 $ t2) = aux careful t1 $ aux careful t2
 24.1031 -      | aux _ t = t
 24.1032 -    (* bool -> bool -> term -> term -> term -> term *)
 24.1033 -    and aux_eq careful pass1 t0 t1 t2 =
 24.1034 -      ((if careful then
 24.1035 -          raise SAME ()
 24.1036 -        else if axiom andalso is_Var t2 andalso
 24.1037 -                num_occs_of_var (dest_Var t2) = 1 then
 24.1038 -          @{const True}
 24.1039 -        else case strip_comb t2 of
 24.1040 -          (* The first case is not as general as it could be. *)
 24.1041 -          (Const (@{const_name PairBox}, _),
 24.1042 -                  [Const (@{const_name fst}, _) $ Var z1,
 24.1043 -                   Const (@{const_name snd}, _) $ Var z2]) =>
 24.1044 -          if z1 = z2 andalso num_occs_of_var z1 = 2 then @{const True}
 24.1045 -          else raise SAME ()
 24.1046 -        | (Const (x as (s, T)), args) =>
 24.1047 -          let val arg_Ts = binder_types T in
 24.1048 -            if length arg_Ts = length args andalso
 24.1049 -               (is_constr thy x orelse s = @{const_name Pair} orelse
 24.1050 -                x = (@{const_name Suc}, nat_T --> nat_T)) andalso
 24.1051 -               (not careful orelse not (is_Var t1) orelse
 24.1052 -                String.isPrefix val_var_prefix (fst (fst (dest_Var t1)))) then
 24.1053 -              discriminate_value ext_ctxt x t1 ::
 24.1054 -              map3 (sel_eq x t1) (index_seq 0 (length args)) arg_Ts args
 24.1055 -              |> foldr1 s_conj
 24.1056 -            else
 24.1057 -              raise SAME ()
 24.1058 -          end
 24.1059 -        | _ => raise SAME ())
 24.1060 -       |> body_type (type_of t0) = prop_T ? HOLogic.mk_Trueprop)
 24.1061 -      handle SAME () => if pass1 then aux_eq careful false t0 t2 t1
 24.1062 -                        else t0 $ aux false t2 $ aux false t1
 24.1063 -    (* styp -> term -> int -> typ -> term -> term *)
 24.1064 -    and sel_eq x t n nth_T nth_t =
 24.1065 -      HOLogic.eq_const nth_T $ nth_t $ select_nth_constr_arg thy x t n nth_T
 24.1066 -      |> aux false
 24.1067 -  in aux axiom t end
 24.1068 -
 24.1069 -(* theory -> term -> term *)
 24.1070 -fun simplify_constrs_and_sels thy t =
 24.1071 -  let
 24.1072 -    (* term -> int -> term *)
 24.1073 -    fun is_nth_sel_on t' n (Const (s, _) $ t) =
 24.1074 -        (t = t' andalso is_sel_like_and_no_discr s andalso
 24.1075 -         sel_no_from_name s = n)
 24.1076 -      | is_nth_sel_on _ _ _ = false
 24.1077 -    (* term -> term list -> term *)
 24.1078 -    fun do_term (Const (@{const_name Rep_Frac}, _)
 24.1079 -                 $ (Const (@{const_name Abs_Frac}, _) $ t1)) [] = do_term t1 []
 24.1080 -      | do_term (Const (@{const_name Abs_Frac}, _)
 24.1081 -                 $ (Const (@{const_name Rep_Frac}, _) $ t1)) [] = do_term t1 []
 24.1082 -      | do_term (t1 $ t2) args = do_term t1 (do_term t2 [] :: args)
 24.1083 -      | do_term (t as Const (x as (s, T))) (args as _ :: _) =
 24.1084 -        ((if is_constr_like thy x then
 24.1085 -            if length args = num_binder_types T then
 24.1086 -              case hd args of
 24.1087 -                Const (x' as (_, T')) $ t' =>
 24.1088 -                if domain_type T' = body_type T andalso
 24.1089 -                   forall (uncurry (is_nth_sel_on t'))
 24.1090 -                          (index_seq 0 (length args) ~~ args) then
 24.1091 -                  t'
 24.1092 -                else
 24.1093 -                  raise SAME ()
 24.1094 -              | _ => raise SAME ()
 24.1095 -            else
 24.1096 -              raise SAME ()
 24.1097 -          else if is_sel_like_and_no_discr s then
 24.1098 -            case strip_comb (hd args) of
 24.1099 -              (Const (x' as (s', T')), ts') =>
 24.1100 -              if is_constr_like thy x' andalso
 24.1101 -                 constr_name_for_sel_like s = s' andalso
 24.1102 -                 not (exists is_pair_type (binder_types T')) then
 24.1103 -                list_comb (nth ts' (sel_no_from_name s), tl args)
 24.1104 -              else
 24.1105 -                raise SAME ()
 24.1106 -            | _ => raise SAME ()
 24.1107 -          else
 24.1108 -            raise SAME ())
 24.1109 -         handle SAME () => betapplys (t, args))
 24.1110 -      | do_term (Abs (s, T, t')) args =
 24.1111 -        betapplys (Abs (s, T, do_term t' []), args)
 24.1112 -      | do_term t args = betapplys (t, args)
 24.1113 -  in do_term t [] end
 24.1114 -
 24.1115 -(* term -> term *)
 24.1116 -fun curry_assms (@{const "==>"} $ (@{const Trueprop}
 24.1117 -                                   $ (@{const "op &"} $ t1 $ t2)) $ t3) =
 24.1118 -    curry_assms (Logic.list_implies ([t1, t2] |> map HOLogic.mk_Trueprop, t3))
 24.1119 -  | curry_assms (@{const "==>"} $ t1 $ t2) =
 24.1120 -    @{const "==>"} $ curry_assms t1 $ curry_assms t2
 24.1121 -  | curry_assms t = t
 24.1122 -
 24.1123 -(* term -> term *)
 24.1124 -val destroy_universal_equalities =
 24.1125 -  let
 24.1126 -    (* term list -> (indexname * typ) list -> term -> term *)
 24.1127 -    fun aux prems zs t =
 24.1128 -      case t of
 24.1129 -        @{const "==>"} $ t1 $ t2 => aux_implies prems zs t1 t2
 24.1130 -      | _ => Logic.list_implies (rev prems, t)
 24.1131 -    (* term list -> (indexname * typ) list -> term -> term -> term *)
 24.1132 -    and aux_implies prems zs t1 t2 =
 24.1133 -      case t1 of
 24.1134 -        Const (@{const_name "=="}, _) $ Var z $ t' => aux_eq prems zs z t' t1 t2
 24.1135 -      | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ Var z $ t') =>
 24.1136 -        aux_eq prems zs z t' t1 t2
 24.1137 -      | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t' $ Var z) =>
 24.1138 -        aux_eq prems zs z t' t1 t2
 24.1139 -      | _ => aux (t1 :: prems) (Term.add_vars t1 zs) t2
 24.1140 -    (* term list -> (indexname * typ) list -> indexname * typ -> term -> term
 24.1141 -       -> term -> term *)
 24.1142 -    and aux_eq prems zs z t' t1 t2 =
 24.1143 -      if not (member (op =) zs z) andalso
 24.1144 -         not (exists_subterm (curry (op =) (Var z)) t') then
 24.1145 -        aux prems zs (subst_free [(Var z, t')] t2)
 24.1146 -      else
 24.1147 -        aux (t1 :: prems) (Term.add_vars t1 zs) t2
 24.1148 -  in aux [] [] end
 24.1149 -
 24.1150 -(* theory -> term -> term *)
 24.1151 -fun pull_out_existential_constrs thy t =
 24.1152 -  let
 24.1153 -    val k = maxidx_of_term t + 1
 24.1154 -    (* typ list -> int -> term -> term list -> term list -> term * term list *)
 24.1155 -    fun aux Ts num_exists t args seen =
 24.1156 -      case t of
 24.1157 -        (t0 as Const (@{const_name Ex}, _)) $ Abs (s1, T1, t1) =>
 24.1158 -        let
 24.1159 -          val (t1, seen') = aux (T1 :: Ts) (num_exists + 1) t1 [] []
 24.1160 -          val n = length seen'
 24.1161 -          (* unit -> term list *)
 24.1162 -          fun vars () = map2 (fresh_value_var Ts k n) (index_seq 0 n) seen'
 24.1163 -        in
 24.1164 -          (equations_for_pulled_out_constrs HOLogic.mk_eq Ts k seen'
 24.1165 -           |> List.foldl s_conj t1 |> fold mk_exists (vars ())
 24.1166 -           |> curry3 Abs s1 T1 |> curry (op $) t0, seen)
 24.1167 -        end
 24.1168 -      | t1 $ t2 =>
 24.1169 -        let val (t2, seen) = aux Ts num_exists t2 [] seen in
 24.1170 -          aux Ts num_exists t1 (t2 :: args) seen
 24.1171 -        end
 24.1172 -      | Abs (s, T, t') =>
 24.1173 -        let
 24.1174 -          val (t', seen) = aux (T :: Ts) 0 t' [] (map (incr_boundvars 1) seen)
 24.1175 -        in (list_comb (Abs (s, T, t'), args), map (incr_boundvars ~1) seen) end
 24.1176 -      | _ =>
 24.1177 -        if num_exists > 0 then
 24.1178 -          pull_out_constr_comb thy Ts false k num_exists t args seen
 24.1179 -        else
 24.1180 -          (list_comb (t, args), seen)
 24.1181 -  in aux [] 0 t [] [] |> fst end
 24.1182 -
 24.1183 -(* theory -> int -> term list -> term list -> (term * term list) option *)
 24.1184 -fun find_bound_assign _ _ _ [] = NONE
 24.1185 -  | find_bound_assign thy j seen (t :: ts) =
 24.1186 -    let
 24.1187 -      (* bool -> term -> term -> (term * term list) option *)
 24.1188 -      fun aux pass1 t1 t2 =
 24.1189 -        (if loose_bvar1 (t2, j) then
 24.1190 -           if pass1 then aux false t2 t1 else raise SAME ()
 24.1191 -         else case t1 of
 24.1192 -           Bound j' => if j' = j then SOME (t2, ts @ seen) else raise SAME ()
 24.1193 -         | Const (s, Type ("fun", [T1, T2])) $ Bound j' =>
 24.1194 -           if j' = j andalso s = sel_prefix_for 0 ^ @{const_name FunBox} then
 24.1195 -             SOME (construct_value thy (@{const_name FunBox}, T2 --> T1) [t2],
 24.1196 -                   ts @ seen)
 24.1197 -           else
 24.1198 -             raise SAME ()
 24.1199 -         | _ => raise SAME ())
 24.1200 -        handle SAME () => find_bound_assign thy j (t :: seen) ts
 24.1201 -    in
 24.1202 -      case t of
 24.1203 -        Const (@{const_name "op ="}, _) $ t1 $ t2 => aux true t1 t2
 24.1204 -      | _ => find_bound_assign thy j (t :: seen) ts
 24.1205 -    end
 24.1206 -
 24.1207 -(* int -> term -> term -> term *)
 24.1208 -fun subst_one_bound j arg t =
 24.1209 -  let
 24.1210 -    fun aux (Bound i, lev) =
 24.1211 -        if i < lev then raise SAME ()
 24.1212 -        else if i = lev then incr_boundvars (lev - j) arg
 24.1213 -        else Bound (i - 1)
 24.1214 -      | aux (Abs (a, T, body), lev) = Abs (a, T, aux (body, lev + 1))
 24.1215 -      | aux (f $ t, lev) =
 24.1216 -        (aux (f, lev) $ (aux (t, lev) handle SAME () => t)
 24.1217 -         handle SAME () => f $ aux (t, lev))
 24.1218 -      | aux _ = raise SAME ()
 24.1219 -  in aux (t, j) handle SAME () => t end
 24.1220 -
 24.1221 -(* theory -> term -> term *)
 24.1222 -fun destroy_existential_equalities thy =
 24.1223 -  let
 24.1224 -    (* string list -> typ list -> term list -> term *)
 24.1225 -    fun kill [] [] ts = foldr1 s_conj ts
 24.1226 -      | kill (s :: ss) (T :: Ts) ts =
 24.1227 -        (case find_bound_assign thy (length ss) [] ts of
 24.1228 -           SOME (_, []) => @{const True}
 24.1229 -         | SOME (arg_t, ts) =>
 24.1230 -           kill ss Ts (map (subst_one_bound (length ss)
 24.1231 -                                (incr_bv (~1, length ss + 1, arg_t))) ts)
 24.1232 -         | NONE =>
 24.1233 -           Const (@{const_name Ex}, (T --> bool_T) --> bool_T)
 24.1234 -           $ Abs (s, T, kill ss Ts ts))
 24.1235 -      | kill _ _ _ = raise UnequalLengths
 24.1236 -    (* string list -> typ list -> term -> term *)
 24.1237 -    fun gather ss Ts ((t0 as Const (@{const_name Ex}, _)) $ Abs (s1, T1, t1)) =
 24.1238 -        gather (ss @ [s1]) (Ts @ [T1]) t1
 24.1239 -      | gather [] [] (Abs (s, T, t1)) = Abs (s, T, gather [] [] t1)
 24.1240 -      | gather [] [] (t1 $ t2) = gather [] [] t1 $ gather [] [] t2
 24.1241 -      | gather [] [] t = t
 24.1242 -      | gather ss Ts t = kill ss Ts (conjuncts (gather [] [] t))
 24.1243 -  in gather [] [] end
 24.1244 -
 24.1245 -(* term -> term *)
 24.1246 -fun distribute_quantifiers t =
 24.1247 -  case t of
 24.1248 -    (t0 as Const (@{const_name All}, T0)) $ Abs (s, T1, t1) =>
 24.1249 -    (case t1 of
 24.1250 -       (t10 as @{const "op &"}) $ t11 $ t12 =>
 24.1251 -       t10 $ distribute_quantifiers (t0 $ Abs (s, T1, t11))
 24.1252 -           $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
 24.1253 -     | (t10 as @{const Not}) $ t11 =>
 24.1254 -       t10 $ distribute_quantifiers (Const (@{const_name Ex}, T0)
 24.1255 -                                     $ Abs (s, T1, t11))
 24.1256 -     | t1 =>
 24.1257 -       if not (loose_bvar1 (t1, 0)) then
 24.1258 -         distribute_quantifiers (incr_boundvars ~1 t1)
 24.1259 -       else
 24.1260 -         t0 $ Abs (s, T1, distribute_quantifiers t1))
 24.1261 -  | (t0 as Const (@{const_name Ex}, T0)) $ Abs (s, T1, t1) =>
 24.1262 -    (case distribute_quantifiers t1 of
 24.1263 -       (t10 as @{const "op |"}) $ t11 $ t12 =>
 24.1264 -       t10 $ distribute_quantifiers (t0 $ Abs (s, T1, t11))
 24.1265 -           $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
 24.1266 -     | (t10 as @{const "op -->"}) $ t11 $ t12 =>
 24.1267 -       t10 $ distribute_quantifiers (Const (@{const_name All}, T0)
 24.1268 -                                     $ Abs (s, T1, t11))
 24.1269 -           $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
 24.1270 -     | (t10 as @{const Not}) $ t11 =>
 24.1271 -       t10 $ distribute_quantifiers (Const (@{const_name All}, T0)
 24.1272 -                                     $ Abs (s, T1, t11))
 24.1273 -     | t1 =>
 24.1274 -       if not (loose_bvar1 (t1, 0)) then
 24.1275 -         distribute_quantifiers (incr_boundvars ~1 t1)
 24.1276 -       else
 24.1277 -         t0 $ Abs (s, T1, distribute_quantifiers t1))
 24.1278 -  | t1 $ t2 => distribute_quantifiers t1 $ distribute_quantifiers t2
 24.1279 -  | Abs (s, T, t') => Abs (s, T, distribute_quantifiers t')
 24.1280 -  | _ => t
 24.1281 -
 24.1282 -(* int -> int -> (int -> int) -> term -> term *)
 24.1283 -fun renumber_bounds j n f t =
 24.1284 -  case t of
 24.1285 -    t1 $ t2 => renumber_bounds j n f t1 $ renumber_bounds j n f t2
 24.1286 -  | Abs (s, T, t') => Abs (s, T, renumber_bounds (j + 1) n f t')
 24.1287 -  | Bound j' =>
 24.1288 -    Bound (if j' >= j andalso j' < j + n then f (j' - j) + j else j')
 24.1289 -  | _ => t
 24.1290 -
 24.1291 -val quantifier_cluster_threshold = 7
 24.1292 -
 24.1293 -(* theory -> term -> term *)
 24.1294 -fun push_quantifiers_inward thy =
 24.1295 -  let
 24.1296 -    (* string -> string list -> typ list -> term -> term *)
 24.1297 -    fun aux quant_s ss Ts t =
 24.1298 -      (case t of
 24.1299 -         (t0 as Const (s0, _)) $ Abs (s1, T1, t1 as _ $ _) =>
 24.1300 -         if s0 = quant_s then
 24.1301 -           aux s0 (s1 :: ss) (T1 :: Ts) t1
 24.1302 -         else if quant_s = "" andalso
 24.1303 -                 (s0 = @{const_name All} orelse s0 = @{const_name Ex}) then
 24.1304 -           aux s0 [s1] [T1] t1
 24.1305 -         else
 24.1306 -           raise SAME ()
 24.1307 -       | _ => raise SAME ())
 24.1308 -      handle SAME () =>
 24.1309 -             case t of
 24.1310 -               t1 $ t2 =>
 24.1311 -               if quant_s = "" then
 24.1312 -                 aux "" [] [] t1 $ aux "" [] [] t2
 24.1313 -               else
 24.1314 -                 let
 24.1315 -                   val typical_card = 4
 24.1316 -                   (* ('a -> ''b list) -> 'a list -> ''b list *)
 24.1317 -                   fun big_union proj ps =
 24.1318 -                     fold (fold (insert (op =)) o proj) ps []
 24.1319 -                   val (ts, connective) = strip_any_connective t
 24.1320 -                   val T_costs =
 24.1321 -                     map (bounded_card_of_type 65536 typical_card []) Ts
 24.1322 -                   val t_costs = map size_of_term ts
 24.1323 -                   val num_Ts = length Ts
 24.1324 -                   (* int -> int *)
 24.1325 -                   val flip = curry (op -) (num_Ts - 1)
 24.1326 -                   val t_boundss = map (map flip o loose_bnos) ts
 24.1327 -                   (* (int list * int) list -> int list
 24.1328 -                      -> (int list * int) list *)
 24.1329 -                   fun merge costly_boundss [] = costly_boundss
 24.1330 -                     | merge costly_boundss (j :: js) =
 24.1331 -                       let
 24.1332 -                         val (yeas, nays) =
 24.1333 -                           List.partition (fn (bounds, _) =>
 24.1334 -                                              member (op =) bounds j)
 24.1335 -                                          costly_boundss
 24.1336 -                         val yeas_bounds = big_union fst yeas
 24.1337 -                         val yeas_cost = Integer.sum (map snd yeas)
 24.1338 -                                         * nth T_costs j
 24.1339 -                       in merge ((yeas_bounds, yeas_cost) :: nays) js end
 24.1340 -                   (* (int list * int) list -> int list -> int *)
 24.1341 -                   val cost = Integer.sum o map snd oo merge
 24.1342 -                   (* Inspired by Claessen & Sörensson's polynomial binary
 24.1343 -                      splitting heuristic (p. 5 of their MODEL 2003 paper). *)
 24.1344 -                   (* (int list * int) list -> int list -> int list *)
 24.1345 -                   fun heuristically_best_permutation _ [] = []
 24.1346 -                     | heuristically_best_permutation costly_boundss js =
 24.1347 -                       let
 24.1348 -                         val (costly_boundss, (j, js)) =
 24.1349 -                           js |> map (`(merge costly_boundss o single))
 24.1350 -                              |> sort (int_ord
 24.1351 -                                       o pairself (Integer.sum o map snd o fst))
 24.1352 -                              |> split_list |>> hd ||> pairf hd tl
 24.1353 -                       in
 24.1354 -                         j :: heuristically_best_permutation costly_boundss js
 24.1355 -                       end
 24.1356 -                   val js =
 24.1357 -                     if length Ts <= quantifier_cluster_threshold then
 24.1358 -                       all_permutations (index_seq 0 num_Ts)
 24.1359 -                       |> map (`(cost (t_boundss ~~ t_costs)))
 24.1360 -                       |> sort (int_ord o pairself fst) |> hd |> snd
 24.1361 -                     else
 24.1362 -                       heuristically_best_permutation (t_boundss ~~ t_costs)
 24.1363 -                                                      (index_seq 0 num_Ts)
 24.1364 -                   val back_js = map (fn j => find_index (curry (op =) j) js)
 24.1365 -                                     (index_seq 0 num_Ts)
 24.1366 -                   val ts = map (renumber_bounds 0 num_Ts (nth back_js o flip))
 24.1367 -                                ts
 24.1368 -                   (* (term * int list) list -> term *)
 24.1369 -                   fun mk_connection [] =
 24.1370 -                       raise ARG ("Nitpick_HOL.push_quantifiers_inward.aux.\
 24.1371 -                                  \mk_connection", "")
 24.1372 -                     | mk_connection ts_cum_bounds =
 24.1373 -                       ts_cum_bounds |> map fst
 24.1374 -                       |> foldr1 (fn (t1, t2) => connective $ t1 $ t2)
 24.1375 -                   (* (term * int list) list -> int list -> term *)
 24.1376 -                   fun build ts_cum_bounds [] = ts_cum_bounds |> mk_connection
 24.1377 -                     | build ts_cum_bounds (j :: js) =
 24.1378 -                       let
 24.1379 -                         val (yeas, nays) =
 24.1380 -                           List.partition (fn (_, bounds) =>
 24.1381 -                                              member (op =) bounds j)
 24.1382 -                                          ts_cum_bounds
 24.1383 -                           ||> map (apfst (incr_boundvars ~1))
 24.1384 -                       in
 24.1385 -                         if null yeas then
 24.1386 -                           build nays js
 24.1387 -                         else
 24.1388 -                           let val T = nth Ts (flip j) in
 24.1389 -                             build ((Const (quant_s, (T --> bool_T) --> bool_T)
 24.1390 -                                     $ Abs (nth ss (flip j), T,
 24.1391 -                                            mk_connection yeas),
 24.1392 -                                      big_union snd yeas) :: nays) js
 24.1393 -                           end
 24.1394 -                       end
 24.1395 -                 in build (ts ~~ t_boundss) js end
 24.1396 -             | Abs (s, T, t') => Abs (s, T, aux "" [] [] t')
 24.1397 -             | _ => t
 24.1398 -  in aux "" [] [] end
 24.1399 -
 24.1400 -(* polarity -> string -> bool *)
 24.1401 -fun is_positive_existential polar quant_s =
 24.1402 -  (polar = Pos andalso quant_s = @{const_name Ex}) orelse
 24.1403 -  (polar = Neg andalso quant_s <> @{const_name Ex})
 24.1404 -
 24.1405 -(* extended_context -> int -> term -> term *)
 24.1406 -fun skolemize_term_and_more (ext_ctxt as {thy, def_table, skolems, ...})
 24.1407 -                            skolem_depth =
 24.1408 -  let
 24.1409 -    (* int list -> int list *)
 24.1410 -    val incrs = map (Integer.add 1)
 24.1411 -    (* string list -> typ list -> int list -> int -> polarity -> term -> term *)
 24.1412 -    fun aux ss Ts js depth polar t =
 24.1413 -      let
 24.1414 -        (* string -> typ -> string -> typ -> term -> term *)
 24.1415 -        fun do_quantifier quant_s quant_T abs_s abs_T t =
 24.1416 -          if not (loose_bvar1 (t, 0)) then
 24.1417 -            aux ss Ts js depth polar (incr_boundvars ~1 t)
 24.1418 -          else if depth <= skolem_depth andalso
 24.1419 -                  is_positive_existential polar quant_s then
 24.1420 -            let
 24.1421 -              val j = length (!skolems) + 1
 24.1422 -              val sko_s = skolem_prefix_for (length js) j ^ abs_s
 24.1423 -              val _ = Unsynchronized.change skolems (cons (sko_s, ss))
 24.1424 -              val sko_t = list_comb (Const (sko_s, rev Ts ---> abs_T),
 24.1425 -                                     map Bound (rev js))
 24.1426 -              val abs_t = Abs (abs_s, abs_T, aux ss Ts (incrs js) depth polar t)
 24.1427 -            in
 24.1428 -              if null js then betapply (abs_t, sko_t)
 24.1429 -              else Const (@{const_name Let}, abs_T --> quant_T) $ sko_t $ abs_t
 24.1430 -            end
 24.1431 -          else
 24.1432 -            Const (quant_s, quant_T)
 24.1433 -            $ Abs (abs_s, abs_T,
 24.1434 -                   if is_higher_order_type abs_T then
 24.1435 -                     t
 24.1436 -                   else
 24.1437 -                     aux (abs_s :: ss) (abs_T :: Ts) (0 :: incrs js)
 24.1438 -                         (depth + 1) polar t)
 24.1439 -      in
 24.1440 -        case t of
 24.1441 -          Const (s0 as @{const_name all}, T0) $ Abs (s1, T1, t1) =>
 24.1442 -          do_quantifier s0 T0 s1 T1 t1
 24.1443 -        | @{const "==>"} $ t1 $ t2 =>
 24.1444 -          @{const "==>"} $ aux ss Ts js depth (flip_polarity polar) t1
 24.1445 -          $ aux ss Ts js depth polar t2
 24.1446 -        | @{const Pure.conjunction} $ t1 $ t2 =>
 24.1447 -          @{const Pure.conjunction} $ aux ss Ts js depth polar t1
 24.1448 -          $ aux ss Ts js depth polar t2
 24.1449 -        | @{const Trueprop} $ t1 =>
 24.1450 -          @{const Trueprop} $ aux ss Ts js depth polar t1
 24.1451 -        | @{const Not} $ t1 =>
 24.1452 -          @{const Not} $ aux ss Ts js depth (flip_polarity polar) t1
 24.1453 -        | Const (s0 as @{const_name All}, T0) $ Abs (s1, T1, t1) =>
 24.1454 -          do_quantifier s0 T0 s1 T1 t1
 24.1455 -        | Const (s0 as @{const_name Ex}, T0) $ Abs (s1, T1, t1) =>
 24.1456 -          do_quantifier s0 T0 s1 T1 t1
 24.1457 -        | @{const "op &"} $ t1 $ t2 =>
 24.1458 -          @{const "op &"} $ aux ss Ts js depth polar t1
 24.1459 -          $ aux ss Ts js depth polar t2
 24.1460 -        | @{const "op |"} $ t1 $ t2 =>
 24.1461 -          @{const "op |"} $ aux ss Ts js depth polar t1
 24.1462 -          $ aux ss Ts js depth polar t2
 24.1463 -        | @{const "op -->"} $ t1 $ t2 =>
 24.1464 -          @{const "op -->"} $ aux ss Ts js depth (flip_polarity polar) t1
 24.1465 -          $ aux ss Ts js depth polar t2
 24.1466 -        | (t0 as Const (@{const_name Let}, T0)) $ t1 $ t2 =>
 24.1467 -          t0 $ t1 $ aux ss Ts js depth polar t2
 24.1468 -        | Const (x as (s, T)) =>
 24.1469 -          if is_inductive_pred ext_ctxt x andalso
 24.1470 -             not (is_well_founded_inductive_pred ext_ctxt x) then
 24.1471 -            let
 24.1472 -              val gfp = (fixpoint_kind_of_const thy def_table x = Gfp)
 24.1473 -              val (pref, connective, set_oper) =
 24.1474 -                if gfp then
 24.1475 -                  (lbfp_prefix,
 24.1476 -                   @{const "op |"},
 24.1477 -                   @{const_name semilattice_sup_fun_inst.sup_fun})
 24.1478 -                else
 24.1479 -                  (ubfp_prefix,
 24.1480 -                   @{const "op &"},
 24.1481 -                   @{const_name semilattice_inf_fun_inst.inf_fun})
 24.1482 -              (* unit -> term *)
 24.1483 -              fun pos () = unrolled_inductive_pred_const ext_ctxt gfp x
 24.1484 -                           |> aux ss Ts js depth polar
 24.1485 -              fun neg () = Const (pref ^ s, T)
 24.1486 -            in
 24.1487 -              (case polar |> gfp ? flip_polarity of
 24.1488 -                 Pos => pos ()
 24.1489 -               | Neg => neg ()
 24.1490 -               | Neut =>
 24.1491 -                 if is_fun_type T then
 24.1492 -                   let
 24.1493 -                     val ((trunk_arg_Ts, rump_arg_T), body_T) =
 24.1494 -                       T |> strip_type |>> split_last
 24.1495 -                     val set_T = rump_arg_T --> body_T
 24.1496 -                     (* (unit -> term) -> term *)
 24.1497 -                     fun app f =
 24.1498 -                       list_comb (f (),
 24.1499 -                                  map Bound (length trunk_arg_Ts - 1 downto 0))
 24.1500 -                   in
 24.1501 -                     List.foldr absdummy
 24.1502 -                                (Const (set_oper, set_T --> set_T --> set_T)
 24.1503 -                                        $ app pos $ app neg) trunk_arg_Ts
 24.1504 -                   end
 24.1505 -                 else
 24.1506 -                   connective $ pos () $ neg ())
 24.1507 -            end
 24.1508 -          else
 24.1509 -            Const x
 24.1510 -        | t1 $ t2 =>
 24.1511 -          betapply (aux ss Ts [] (skolem_depth + 1) polar t1,
 24.1512 -                    aux ss Ts [] depth Neut t2)
 24.1513 -        | Abs (s, T, t1) => Abs (s, T, aux ss Ts (incrs js) depth polar t1)
 24.1514 -        | _ => t
 24.1515 -      end
 24.1516 -  in aux [] [] [] 0 Pos end
 24.1517 -
 24.1518 -(* extended_context -> styp -> (int * term option) list *)
 24.1519 -fun static_args_in_term ({ersatz_table, ...} : extended_context) x t =
 24.1520 -  let
 24.1521 -    (* term -> term list -> term list -> term list list *)
 24.1522 -    fun fun_calls (Abs (_, _, t)) _ = fun_calls t []
 24.1523 -      | fun_calls (t1 $ t2) args = fun_calls t2 [] #> fun_calls t1 (t2 :: args)
 24.1524 -      | fun_calls t args =
 24.1525 -        (case t of
 24.1526 -           Const (x' as (s', T')) =>
 24.1527 -           x = x' orelse (case AList.lookup (op =) ersatz_table s' of
 24.1528 -                            SOME s'' => x = (s'', T')
 24.1529 -                          | NONE => false)
 24.1530 -         | _ => false) ? cons args
 24.1531 -    (* term list list -> term list list -> term list -> term list list *)
 24.1532 -    fun call_sets [] [] vs = [vs]
 24.1533 -      | call_sets [] uss vs = vs :: call_sets uss [] []
 24.1534 -      | call_sets ([] :: _) _ _ = []
 24.1535 -      | call_sets ((t :: ts) :: tss) uss vs =
 24.1536 -        OrdList.insert TermOrd.term_ord t vs |> call_sets tss (ts :: uss)
 24.1537 -    val sets = call_sets (fun_calls t [] []) [] []
 24.1538 -    val indexed_sets = sets ~~ (index_seq 0 (length sets))
 24.1539 -  in
 24.1540 -    fold_rev (fn (set, j) =>
 24.1541 -                 case set of
 24.1542 -                   [Var _] => AList.lookup (op =) indexed_sets set = SOME j
 24.1543 -                              ? cons (j, NONE)
 24.1544 -                 | [t as Const _] => cons (j, SOME t)
 24.1545 -                 | [t as Free _] => cons (j, SOME t)
 24.1546 -                 | _ => I) indexed_sets []
 24.1547 -  end
 24.1548 -(* extended_context -> styp -> term list -> (int * term option) list *)
 24.1549 -fun static_args_in_terms ext_ctxt x =
 24.1550 -  map (static_args_in_term ext_ctxt x)
 24.1551 -  #> fold1 (OrdList.inter (prod_ord int_ord (option_ord TermOrd.term_ord)))
 24.1552 -
 24.1553 -(* term -> term list *)
 24.1554 -fun params_in_equation (@{const "==>"} $ _ $ t2) = params_in_equation t2
 24.1555 -  | params_in_equation (@{const Trueprop} $ t1) = params_in_equation t1
 24.1556 -  | params_in_equation (Const (@{const_name "op ="}, _) $ t1 $ _) =
 24.1557 -    snd (strip_comb t1)
 24.1558 -  | params_in_equation _ = []
 24.1559 -
 24.1560 -(* styp -> styp -> int list -> term list -> term list -> term -> term *)
 24.1561 -fun specialize_fun_axiom x x' fixed_js fixed_args extra_args t =
 24.1562 -  let
 24.1563 -    val k = fold Integer.max (map maxidx_of_term (fixed_args @ extra_args)) 0
 24.1564 -            + 1
 24.1565 -    val t = map_aterms (fn Var ((s, i), T) => Var ((s, k + i), T) | t' => t') t
 24.1566 -    val fixed_params = filter_indices fixed_js (params_in_equation t)
 24.1567 -    (* term list -> term -> term *)
 24.1568 -    fun aux args (Abs (s, T, t)) = list_comb (Abs (s, T, aux [] t), args)
 24.1569 -      | aux args (t1 $ t2) = aux (aux [] t2 :: args) t1
 24.1570 -      | aux args t =
 24.1571 -        if t = Const x then
 24.1572 -          list_comb (Const x', extra_args @ filter_out_indices fixed_js args)
 24.1573 -        else
 24.1574 -          let val j = find_index (curry (op =) t) fixed_params in
 24.1575 -            list_comb (if j >= 0 then nth fixed_args j else t, args)
 24.1576 -          end
 24.1577 -  in aux [] t end
 24.1578 -
 24.1579 -(* typ list -> term -> bool *)
 24.1580 -fun is_eligible_arg Ts t =
 24.1581 -  let val bad_Ts = map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t) in
 24.1582 -    null bad_Ts orelse
 24.1583 -    (is_higher_order_type (fastype_of1 (Ts, t)) andalso
 24.1584 -     forall (not o is_higher_order_type) bad_Ts)
 24.1585 -  end
 24.1586 -
 24.1587 -(* (int * term option) list -> (int * term) list -> int list *)
 24.1588 -fun overlapping_indices [] _ = []
 24.1589 -  | overlapping_indices _ [] = []
 24.1590 -  | overlapping_indices (ps1 as (j1, t1) :: ps1') (ps2 as (j2, t2) :: ps2') =
 24.1591 -    if j1 < j2 then overlapping_indices ps1' ps2
 24.1592 -    else if j1 > j2 then overlapping_indices ps1 ps2'
 24.1593 -    else overlapping_indices ps1' ps2' |> the_default t2 t1 = t2 ? cons j1
 24.1594 -
 24.1595 -val special_depth = 20
 24.1596 -
 24.1597 -(* extended_context -> int -> term -> term *)
 24.1598 -fun specialize_consts_in_term (ext_ctxt as {thy, specialize, simp_table,
 24.1599 -                                            special_funs, ...}) depth t =
 24.1600 -  if not specialize orelse depth > special_depth then
 24.1601 -    t
 24.1602 -  else
 24.1603 -    let
 24.1604 -      val blacklist = if depth = 0 then []
 24.1605 -                      else case term_under_def t of Const x => [x] | _ => []
 24.1606 -      (* term list -> typ list -> term -> term *)
 24.1607 -      fun aux args Ts (Const (x as (s, T))) =
 24.1608 -          ((if not (member (op =) blacklist x) andalso not (null args) andalso
 24.1609 -               not (String.isPrefix special_prefix s) andalso
 24.1610 -               is_equational_fun ext_ctxt x then
 24.1611 -              let
 24.1612 -                val eligible_args = filter (is_eligible_arg Ts o snd)
 24.1613 -                                           (index_seq 0 (length args) ~~ args)
 24.1614 -                val _ = not (null eligible_args) orelse raise SAME ()
 24.1615 -                val old_axs = equational_fun_axioms ext_ctxt x
 24.1616 -                              |> map (destroy_existential_equalities thy)
 24.1617 -                val static_params = static_args_in_terms ext_ctxt x old_axs
 24.1618 -                val fixed_js = overlapping_indices static_params eligible_args
 24.1619 -                val _ = not (null fixed_js) orelse raise SAME ()
 24.1620 -                val fixed_args = filter_indices fixed_js args
 24.1621 -                val vars = fold Term.add_vars fixed_args []
 24.1622 -                           |> sort (TermOrd.fast_indexname_ord o pairself fst)
 24.1623 -                val bound_js = fold (fn t => fn js => add_loose_bnos (t, 0, js))
 24.1624 -                                    fixed_args []
 24.1625 -                               |> sort int_ord
 24.1626 -                val live_args = filter_out_indices fixed_js args
 24.1627 -                val extra_args = map Var vars @ map Bound bound_js @ live_args
 24.1628 -                val extra_Ts = map snd vars @ filter_indices bound_js Ts
 24.1629 -                val k = maxidx_of_term t + 1
 24.1630 -                (* int -> term *)
 24.1631 -                fun var_for_bound_no j =
 24.1632 -                  Var ((bound_var_prefix ^
 24.1633 -                        nat_subscript (find_index (curry (op =) j) bound_js
 24.1634 -                                       + 1), k),
 24.1635 -                       nth Ts j)
 24.1636 -                val fixed_args_in_axiom =
 24.1637 -                  map (curry subst_bounds
 24.1638 -                             (map var_for_bound_no (index_seq 0 (length Ts))))
 24.1639 -                      fixed_args
 24.1640 -              in
 24.1641 -                case AList.lookup (op =) (!special_funs)
 24.1642 -                                  (x, fixed_js, fixed_args_in_axiom) of
 24.1643 -                  SOME x' => list_comb (Const x', extra_args)
 24.1644 -                | NONE =>
 24.1645 -                  let
 24.1646 -                    val extra_args_in_axiom =
 24.1647 -                      map Var vars @ map var_for_bound_no bound_js
 24.1648 -                    val x' as (s', _) =
 24.1649 -                      (special_prefix_for (length (!special_funs) + 1) ^ s,
 24.1650 -                       extra_Ts @ filter_out_indices fixed_js (binder_types T)
 24.1651 -                       ---> body_type T)
 24.1652 -                    val new_axs =
 24.1653 -                      map (specialize_fun_axiom x x' fixed_js
 24.1654 -                               fixed_args_in_axiom extra_args_in_axiom) old_axs
 24.1655 -                    val _ =
 24.1656 -                      Unsynchronized.change special_funs
 24.1657 -                          (cons ((x, fixed_js, fixed_args_in_axiom), x'))
 24.1658 -                    val _ = add_simps simp_table s' new_axs
 24.1659 -                  in list_comb (Const x', extra_args) end
 24.1660 -              end
 24.1661 -            else
 24.1662 -              raise SAME ())
 24.1663 -           handle SAME () => list_comb (Const x, args))
 24.1664 -        | aux args Ts (Abs (s, T, t)) =
 24.1665 -          list_comb (Abs (s, T, aux [] (T :: Ts) t), args)
 24.1666 -        | aux args Ts (t1 $ t2) = aux (aux [] Ts t2 :: args) Ts t1
 24.1667 -        | aux args _ t = list_comb (t, args)
 24.1668 -    in aux [] [] t end
 24.1669 -
 24.1670 -(* theory -> term -> int Termtab.tab -> int Termtab.tab *)
 24.1671 -fun add_to_uncurry_table thy t =
 24.1672 -  let
 24.1673 -    (* term -> term list -> int Termtab.tab -> int Termtab.tab *)
 24.1674 -    fun aux (t1 $ t2) args table =
 24.1675 -        let val table = aux t2 [] table in aux t1 (t2 :: args) table end
 24.1676 -      | aux (Abs (_, _, t')) _ table = aux t' [] table
 24.1677 -      | aux (t as Const (x as (s, _))) args table =
 24.1678 -        if is_built_in_const true x orelse is_constr_like thy x orelse
 24.1679 -           is_sel s orelse s = @{const_name Sigma} then
 24.1680 -          table
 24.1681 -        else
 24.1682 -          Termtab.map_default (t, 65536) (curry Int.min (length args)) table
 24.1683 -      | aux _ _ table = table
 24.1684 -  in aux t [] end
 24.1685 -
 24.1686 -(* int Termtab.tab term -> term *)
 24.1687 -fun uncurry_term table t =
 24.1688 -  let
 24.1689 -    (* term -> term list -> term *)
 24.1690 -    fun aux (t1 $ t2) args = aux t1 (aux t2 [] :: args)
 24.1691 -      | aux (Abs (s, T, t')) args = betapplys (Abs (s, T, aux t' []), args)
 24.1692 -      | aux (t as Const (s, T)) args =
 24.1693 -        (case Termtab.lookup table t of
 24.1694 -           SOME n =>
 24.1695 -           if n >= 2 then
 24.1696 -             let
 24.1697 -               val (arg_Ts, rest_T) = strip_n_binders n T
 24.1698 -               val j =
 24.1699 -                 if hd arg_Ts = @{typ bisim_iterator} orelse
 24.1700 -                    is_fp_iterator_type (hd arg_Ts) then
 24.1701 -                   1
 24.1702 -                 else case find_index (not_equal bool_T) arg_Ts of
 24.1703 -                   ~1 => n
 24.1704 -                 | j => j
 24.1705 -               val ((before_args, tuple_args), after_args) =
 24.1706 -                 args |> chop n |>> chop j
 24.1707 -               val ((before_arg_Ts, tuple_arg_Ts), rest_T) =
 24.1708 -                 T |> strip_n_binders n |>> chop j
 24.1709 -               val tuple_T = HOLogic.mk_tupleT tuple_arg_Ts
 24.1710 -             in
 24.1711 -               if n - j < 2 then
 24.1712 -                 betapplys (t, args)
 24.1713 -               else
 24.1714 -                 betapplys (Const (uncurry_prefix_for (n - j) j ^ s,
 24.1715 -                                   before_arg_Ts ---> tuple_T --> rest_T),
 24.1716 -                            before_args @ [mk_flat_tuple tuple_T tuple_args] @
 24.1717 -                            after_args)
 24.1718 -             end
 24.1719 -           else
 24.1720 -             betapplys (t, args)
 24.1721 -         | NONE => betapplys (t, args))
 24.1722 -      | aux t args = betapplys (t, args)
 24.1723 -  in aux t [] end
 24.1724 -
 24.1725 -(* (term -> term) -> int -> term -> term *)
 24.1726 -fun coerce_bound_no f j t =
 24.1727 -  case t of
 24.1728 -    t1 $ t2 => coerce_bound_no f j t1 $ coerce_bound_no f j t2
 24.1729 -  | Abs (s, T, t') => Abs (s, T, coerce_bound_no f (j + 1) t')
 24.1730 -  | Bound j' => if j' = j then f t else t
 24.1731 -  | _ => t
 24.1732 -
 24.1733 -(* extended_context -> bool -> term -> term *)
 24.1734 -fun box_fun_and_pair_in_term (ext_ctxt as {thy, fast_descrs, ...}) def orig_t =
 24.1735 -  let
 24.1736 -    (* typ -> typ *)
 24.1737 -    fun box_relational_operator_type (Type ("fun", Ts)) =
 24.1738 -        Type ("fun", map box_relational_operator_type Ts)
 24.1739 -      | box_relational_operator_type (Type ("*", Ts)) =
 24.1740 -        Type ("*", map (box_type ext_ctxt InPair) Ts)
 24.1741 -      | box_relational_operator_type T = T
 24.1742 -    (* typ -> typ -> term -> term *)
 24.1743 -    fun coerce_bound_0_in_term new_T old_T =
 24.1744 -      old_T <> new_T ? coerce_bound_no (coerce_term [new_T] old_T new_T) 0
 24.1745 -    (* typ list -> typ -> term -> term *)
 24.1746 -    and coerce_term Ts new_T old_T t =
 24.1747 -      if old_T = new_T then
 24.1748 -        t
 24.1749 -      else
 24.1750 -        case (new_T, old_T) of
 24.1751 -          (Type (new_s, new_Ts as [new_T1, new_T2]),
 24.1752 -           Type ("fun", [old_T1, old_T2])) =>
 24.1753 -          (case eta_expand Ts t 1 of
 24.1754 -             Abs (s, _, t') =>
 24.1755 -             Abs (s, new_T1,
 24.1756 -                  t' |> coerce_bound_0_in_term new_T1 old_T1
 24.1757 -                     |> coerce_term (new_T1 :: Ts) new_T2 old_T2)
 24.1758 -             |> Envir.eta_contract
 24.1759 -             |> new_s <> "fun"
 24.1760 -                ? construct_value thy (@{const_name FunBox},
 24.1761 -                                       Type ("fun", new_Ts) --> new_T) o single
 24.1762 -           | t' => raise TERM ("Nitpick_HOL.box_fun_and_pair_in_term.\
 24.1763 -                               \coerce_term", [t']))
 24.1764 -        | (Type (new_s, new_Ts as [new_T1, new_T2]),
 24.1765 -           Type (old_s, old_Ts as [old_T1, old_T2])) =>
 24.1766 -          if old_s = @{type_name fun_box} orelse
 24.1767 -             old_s = @{type_name pair_box} orelse old_s = "*" then
 24.1768 -            case constr_expand ext_ctxt old_T t of
 24.1769 -              Const (@{const_name FunBox}, _) $ t1 =>
 24.1770 -              if new_s = "fun" then
 24.1771 -                coerce_term Ts new_T (Type ("fun", old_Ts)) t1
 24.1772 -              else
 24.1773 -                construct_value thy
 24.1774 -                    (@{const_name FunBox}, Type ("fun", new_Ts) --> new_T)
 24.1775 -                     [coerce_term Ts (Type ("fun", new_Ts))
 24.1776 -                                  (Type ("fun", old_Ts)) t1]
 24.1777 -            | Const _ $ t1 $ t2 =>
 24.1778 -              construct_value thy
 24.1779 -                  (if new_s = "*" then @{const_name Pair}
 24.1780 -                   else @{const_name PairBox}, new_Ts ---> new_T)
 24.1781 -                  [coerce_term Ts new_T1 old_T1 t1,
 24.1782 -                   coerce_term Ts new_T2 old_T2 t2]
 24.1783 -            | t' => raise TERM ("Nitpick_HOL.box_fun_and_pair_in_term.\
 24.1784 -                                \coerce_term", [t'])
 24.1785 -          else
 24.1786 -            raise TYPE ("coerce_term", [new_T, old_T], [t])
 24.1787 -        | _ => raise TYPE ("coerce_term", [new_T, old_T], [t])
 24.1788 -    (* indexname * typ -> typ * term -> typ option list -> typ option list *)
 24.1789 -    fun add_boxed_types_for_var (z as (_, T)) (T', t') =
 24.1790 -      case t' of
 24.1791 -        Var z' => z' = z ? insert (op =) T'
 24.1792 -      | Const (@{const_name Pair}, _) $ t1 $ t2 =>
 24.1793 -        (case T' of
 24.1794 -           Type (_, [T1, T2]) =>
 24.1795 -           fold (add_boxed_types_for_var z) [(T1, t1), (T2, t2)]
 24.1796 -         | _ => raise TYPE ("Nitpick_HOL.box_fun_and_pair_in_term.\
 24.1797 -                            \add_boxed_types_for_var", [T'], []))
 24.1798 -      | _ => exists_subterm (curry (op =) (Var z)) t' ? insert (op =) T
 24.1799 -    (* typ list -> typ list -> term -> indexname * typ -> typ *)
 24.1800 -    fun box_var_in_def new_Ts old_Ts t (z as (_, T)) =
 24.1801 -      case t of
 24.1802 -        @{const Trueprop} $ t1 => box_var_in_def new_Ts old_Ts t1 z
 24.1803 -      | Const (s0, _) $ t1 $ _ =>
 24.1804 -        if s0 = @{const_name "=="} orelse s0 = @{const_name "op ="} then
 24.1805 -          let
 24.1806 -            val (t', args) = strip_comb t1
 24.1807 -            val T' = fastype_of1 (new_Ts, do_term new_Ts old_Ts Neut t')
 24.1808 -          in
 24.1809 -            case fold (add_boxed_types_for_var z)
 24.1810 -                      (fst (strip_n_binders (length args) T') ~~ args) [] of
 24.1811 -              [T''] => T''
 24.1812 -            | _ => T
 24.1813 -          end
 24.1814 -        else
 24.1815 -          T
 24.1816 -      | _ => T
 24.1817 -    (* typ list -> typ list -> polarity -> string -> typ -> string -> typ
 24.1818 -       -> term -> term *)
 24.1819 -    and do_quantifier new_Ts old_Ts polar quant_s quant_T abs_s abs_T t =
 24.1820 -      let
 24.1821 -        val abs_T' =
 24.1822 -          if polar = Neut orelse is_positive_existential polar quant_s then
 24.1823 -            box_type ext_ctxt InFunLHS abs_T
 24.1824 -          else
 24.1825 -            abs_T
 24.1826 -        val body_T = body_type quant_T
 24.1827 -      in
 24.1828 -        Const (quant_s, (abs_T' --> body_T) --> body_T)
 24.1829 -        $ Abs (abs_s, abs_T',
 24.1830 -               t |> do_term (abs_T' :: new_Ts) (abs_T :: old_Ts) polar)
 24.1831 -      end
 24.1832 -    (* typ list -> typ list -> string -> typ -> term -> term -> term *)
 24.1833 -    and do_equals new_Ts old_Ts s0 T0 t1 t2 =
 24.1834 -      let
 24.1835 -        val (t1, t2) = pairself (do_term new_Ts old_Ts Neut) (t1, t2)
 24.1836 -        val (T1, T2) = pairself (curry fastype_of1 new_Ts) (t1, t2)
 24.1837 -        val T = [T1, T2] |> sort TermOrd.typ_ord |> List.last
 24.1838 -      in
 24.1839 -        list_comb (Const (s0, T --> T --> body_type T0),
 24.1840 -                   map2 (coerce_term new_Ts T) [T1, T2] [t1, t2])
 24.1841 -      end
 24.1842 -    (* string -> typ -> term *)
 24.1843 -    and do_description_operator s T =
 24.1844 -      let val T1 = box_type ext_ctxt InFunLHS (range_type T) in
 24.1845 -        Const (s, (T1 --> bool_T) --> T1)
 24.1846 -      end
 24.1847 -    (* typ list -> typ list -> polarity -> term -> term *)
 24.1848 -    and do_term new_Ts old_Ts polar t =
 24.1849 -      case t of
 24.1850 -        Const (s0 as @{const_name all}, T0) $ Abs (s1, T1, t1) =>
 24.1851 -        do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
 24.1852 -      | Const (s0 as @{const_name "=="}, T0) $ t1 $ t2 =>
 24.1853 -        do_equals new_Ts old_Ts s0 T0 t1 t2
 24.1854 -      | @{const "==>"} $ t1 $ t2 =>
 24.1855 -        @{const "==>"} $ do_term new_Ts old_Ts (flip_polarity polar) t1
 24.1856 -        $ do_term new_Ts old_Ts polar t2
 24.1857 -      | @{const Pure.conjunction} $ t1 $ t2 =>
 24.1858 -        @{const Pure.conjunction} $ do_term new_Ts old_Ts polar t1
 24.1859 -        $ do_term new_Ts old_Ts polar t2
 24.1860 -      | @{const Trueprop} $ t1 =>
 24.1861 -        @{const Trueprop} $ do_term new_Ts old_Ts polar t1
 24.1862 -      | @{const Not} $ t1 =>
 24.1863 -        @{const Not} $ do_term new_Ts old_Ts (flip_polarity polar) t1
 24.1864 -      | Const (s0 as @{const_name All}, T0) $ Abs (s1, T1, t1) =>
 24.1865 -        do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
 24.1866 -      | Const (s0 as @{const_name Ex}, T0) $ Abs (s1, T1, t1) =>
 24.1867 -        do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
 24.1868 -      | Const (s0 as @{const_name "op ="}, T0) $ t1 $ t2 =>
 24.1869 -        do_equals new_Ts old_Ts s0 T0 t1 t2
 24.1870 -      | @{const "op &"} $ t1 $ t2 =>
 24.1871 -        @{const "op &"} $ do_term new_Ts old_Ts polar t1
 24.1872 -        $ do_term new_Ts old_Ts polar t2
 24.1873 -      | @{const "op |"} $ t1 $ t2 =>
 24.1874 -        @{const "op |"} $ do_term new_Ts old_Ts polar t1
 24.1875 -        $ do_term new_Ts old_Ts polar t2
 24.1876 -      | @{const "op -->"} $ t1 $ t2 =>
 24.1877 -        @{const "op -->"} $ do_term new_Ts old_Ts (flip_polarity polar) t1
 24.1878 -        $ do_term new_Ts old_Ts polar t2
 24.1879 -      | Const (s as @{const_name The}, T) => do_description_operator s T
 24.1880 -      | Const (s as @{const_name Eps}, T) => do_description_operator s T
 24.1881 -      | Const (@{const_name quot_normal}, Type ("fun", [_, T2])) =>
 24.1882 -        let val T' = box_type ext_ctxt InSel T2 in
 24.1883 -          Const (@{const_name quot_normal}, T' --> T')
 24.1884 -        end
 24.1885 -      | Const (s as @{const_name Tha}, T) => do_description_operator s T
 24.1886 -      | Const (x as (s, T)) =>
 24.1887 -        Const (s, if s = @{const_name converse} orelse
 24.1888 -                     s = @{const_name trancl} then
 24.1889 -                    box_relational_operator_type T
 24.1890 -                  else if is_built_in_const fast_descrs x orelse
 24.1891 -                          s = @{const_name Sigma} then
 24.1892 -                    T
 24.1893 -                  else if is_constr_like thy x then
 24.1894 -                    box_type ext_ctxt InConstr T
 24.1895 -                  else if is_sel s
 24.1896 -                       orelse is_rep_fun thy x then
 24.1897 -                    box_type ext_ctxt InSel T
 24.1898 -                  else
 24.1899 -                    box_type ext_ctxt InExpr T)
 24.1900 -      | t1 $ Abs (s, T, t2') =>
 24.1901 -        let
 24.1902 -          val t1 = do_term new_Ts old_Ts Neut t1
 24.1903 -          val T1 = fastype_of1 (new_Ts, t1)
 24.1904 -          val (s1, Ts1) = dest_Type T1
 24.1905 -          val T' = hd (snd (dest_Type (hd Ts1)))
 24.1906 -          val t2 = Abs (s, T', do_term (T' :: new_Ts) (T :: old_Ts) Neut t2')
 24.1907 -          val T2 = fastype_of1 (new_Ts, t2)
 24.1908 -          val t2 = coerce_term new_Ts (hd Ts1) T2 t2
 24.1909 -        in
 24.1910 -          betapply (if s1 = "fun" then
 24.1911 -                      t1
 24.1912 -                    else
 24.1913 -                      select_nth_constr_arg thy
 24.1914 -                          (@{const_name FunBox}, Type ("fun", Ts1) --> T1) t1 0
 24.1915 -                          (Type ("fun", Ts1)), t2)
 24.1916 -        end
 24.1917 -      | t1 $ t2 =>
 24.1918 -        let
 24.1919 -          val t1 = do_term new_Ts old_Ts Neut t1
 24.1920 -          val T1 = fastype_of1 (new_Ts, t1)
 24.1921 -          val (s1, Ts1) = dest_Type T1
 24.1922 -          val t2 = do_term new_Ts old_Ts Neut t2
 24.1923 -          val T2 = fastype_of1 (new_Ts, t2)
 24.1924 -          val t2 = coerce_term new_Ts (hd Ts1) T2 t2
 24.1925 -        in
 24.1926 -          betapply (if s1 = "fun" then
 24.1927 -                      t1
 24.1928 -                    else
 24.1929 -                      select_nth_constr_arg thy
 24.1930 -                          (@{const_name FunBox}, Type ("fun", Ts1) --> T1) t1 0
 24.1931 -                          (Type ("fun", Ts1)), t2)
 24.1932 -        end
 24.1933 -      | Free (s, T) => Free (s, box_type ext_ctxt InExpr T)
 24.1934 -      | Var (z as (x, T)) =>
 24.1935 -        Var (x, if def then box_var_in_def new_Ts old_Ts orig_t z
 24.1936 -                else box_type ext_ctxt InExpr T)
 24.1937 -      | Bound _ => t
 24.1938 -      | Abs (s, T, t') =>
 24.1939 -        Abs (s, T, do_term (T :: new_Ts) (T :: old_Ts) Neut t')
 24.1940 -  in do_term [] [] Pos orig_t end
 24.1941 -
 24.1942 -(* int -> term -> term *)
 24.1943 -fun eval_axiom_for_term j t =
 24.1944 -  Logic.mk_equals (Const (eval_prefix ^ string_of_int j, fastype_of t), t)
 24.1945 -
 24.1946 -(* extended_context -> styp -> bool *)
 24.1947 -fun is_equational_fun_surely_complete ext_ctxt x =
 24.1948 -  case raw_equational_fun_axioms ext_ctxt x of
 24.1949 -    [@{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t1 $ _)] =>
 24.1950 -    strip_comb t1 |> snd |> forall is_Var
 24.1951 -  | _ => false
 24.1952 -
 24.1953 -type special = int list * term list * styp
 24.1954 -
 24.1955 -(* styp -> special -> special -> term *)
 24.1956 -fun special_congruence_axiom (s, T) (js1, ts1, x1) (js2, ts2, x2) =
 24.1957 -  let
 24.1958 -    val (bounds1, bounds2) = pairself (map Var o special_bounds) (ts1, ts2)
 24.1959 -    val Ts = binder_types T
 24.1960 -    val max_j = fold (fold Integer.max) [js1, js2] ~1
 24.1961 -    val (eqs, (args1, args2)) =
 24.1962 -      fold (fn j => case pairself (fn ps => AList.lookup (op =) ps j)
 24.1963 -                                  (js1 ~~ ts1, js2 ~~ ts2) of
 24.1964 -                      (SOME t1, SOME t2) => apfst (cons (t1, t2))
 24.1965 -                    | (SOME t1, NONE) => apsnd (apsnd (cons t1))
 24.1966 -                    | (NONE, SOME t2) => apsnd (apfst (cons t2))
 24.1967 -                    | (NONE, NONE) =>
 24.1968 -                      let val v = Var ((cong_var_prefix ^ nat_subscript j, 0),
 24.1969 -                                       nth Ts j) in
 24.1970 -                        apsnd (pairself (cons v))
 24.1971 -                      end) (max_j downto 0) ([], ([], []))
 24.1972 -  in
 24.1973 -    Logic.list_implies (eqs |> filter_out (op =) |> distinct (op =)
 24.1974 -                            |> map Logic.mk_equals,
 24.1975 -                        Logic.mk_equals (list_comb (Const x1, bounds1 @ args1),
 24.1976 -                                         list_comb (Const x2, bounds2 @ args2)))
 24.1977 -    |> Refute.close_form (* TODO: needed? *)
 24.1978 -  end
 24.1979 -
 24.1980 -(* extended_context -> styp list -> term list *)
 24.1981 -fun special_congruence_axioms (ext_ctxt as {special_funs, ...}) xs =
 24.1982 -  let
 24.1983 -    val groups =
 24.1984 -      !special_funs
 24.1985 -      |> map (fn ((x, js, ts), x') => (x, (js, ts, x')))
 24.1986 -      |> AList.group (op =)
 24.1987 -      |> filter_out (is_equational_fun_surely_complete ext_ctxt o fst)
 24.1988 -      |> map (fn (x, zs) => (x, zs |> member (op =) xs x ? cons ([], [], x)))
 24.1989 -    (* special -> int *)
 24.1990 -    fun generality (js, _, _) = ~(length js)
 24.1991 -    (* special -> special -> bool *)
 24.1992 -    fun is_more_specific (j1, t1, x1) (j2, t2, x2) =
 24.1993 -      x1 <> x2 andalso OrdList.subset (prod_ord int_ord TermOrd.term_ord)
 24.1994 -                                      (j2 ~~ t2, j1 ~~ t1)
 24.1995 -    (* styp -> special list -> special list -> special list -> term list
 24.1996 -       -> term list *)
 24.1997 -    fun do_pass_1 _ [] [_] [_] = I
 24.1998 -      | do_pass_1 x skipped _ [] = do_pass_2 x skipped
 24.1999 -      | do_pass_1 x skipped all (z :: zs) =
 24.2000 -        case filter (is_more_specific z) all
 24.2001 -             |> sort (int_ord o pairself generality) of
 24.2002 -          [] => do_pass_1 x (z :: skipped) all zs
 24.2003 -        | (z' :: _) => cons (special_congruence_axiom x z z')
 24.2004 -                       #> do_pass_1 x skipped all zs
 24.2005 -    (* styp -> special list -> term list -> term list *)
 24.2006 -    and do_pass_2 _ [] = I
 24.2007 -      | do_pass_2 x (z :: zs) =
 24.2008 -        fold (cons o special_congruence_axiom x z) zs #> do_pass_2 x zs
 24.2009 -  in fold (fn (x, zs) => do_pass_1 x [] zs zs) groups [] end
 24.2010 -
 24.2011 -(* term -> bool *)
 24.2012 -val is_trivial_equation = the_default false o try (op aconv o Logic.dest_equals)
 24.2013 -
 24.2014 -(* 'a Symtab.table -> 'a list *)
 24.2015 -fun all_table_entries table = Symtab.fold (append o snd) table []
 24.2016 -(* const_table -> string -> const_table *)
 24.2017 -fun extra_table table s = Symtab.make [(s, all_table_entries table)]
 24.2018 -
 24.2019 -(* extended_context -> term -> (term list * term list) * (bool * bool) *)
 24.2020 -fun axioms_for_term
 24.2021 -        (ext_ctxt as {thy, max_bisim_depth, user_axioms, fast_descrs, evals,
 24.2022 -                      def_table, nondef_table, user_nondefs, ...}) t =
 24.2023 -  let
 24.2024 -    type accumulator = styp list * (term list * term list)
 24.2025 -    (* (term list * term list -> term list)
 24.2026 -       -> ((term list -> term list) -> term list * term list
 24.2027 -           -> term list * term list)
 24.2028 -       -> int -> term -> accumulator -> accumulator *)
 24.2029 -    fun add_axiom get app depth t (accum as (xs, axs)) =
 24.2030 -      let
 24.2031 -        val t = t |> unfold_defs_in_term ext_ctxt
 24.2032 -                  |> skolemize_term_and_more ext_ctxt ~1
 24.2033 -      in
 24.2034 -        if is_trivial_equation t then
 24.2035 -          accum
 24.2036 -        else
 24.2037 -          let val t' = t |> specialize_consts_in_term ext_ctxt depth in
 24.2038 -            if exists (member (op aconv) (get axs)) [t, t'] then accum
 24.2039 -            else add_axioms_for_term (depth + 1) t' (xs, app (cons t') axs)
 24.2040 -          end
 24.2041 -      end
 24.2042 -    (* int -> term -> accumulator -> accumulator *)
 24.2043 -    and add_def_axiom depth = add_axiom fst apfst depth
 24.2044 -    and add_nondef_axiom depth = add_axiom snd apsnd depth
 24.2045 -    and add_maybe_def_axiom depth t =
 24.2046 -      (if head_of t <> @{const "==>"} then add_def_axiom
 24.2047 -       else add_nondef_axiom) depth t
 24.2048 -    and add_eq_axiom depth t =
 24.2049 -      (if is_constr_pattern_formula thy t then add_def_axiom
 24.2050 -       else add_nondef_axiom) depth t
 24.2051 -    (* int -> term -> accumulator -> accumulator *)
 24.2052 -    and add_axioms_for_term depth t (accum as (xs, axs)) =
 24.2053 -      case t of
 24.2054 -        t1 $ t2 => accum |> fold (add_axioms_for_term depth) [t1, t2]
 24.2055 -      | Const (x as (s, T)) =>
 24.2056 -        (if member (op =) xs x orelse is_built_in_const fast_descrs x then
 24.2057 -           accum
 24.2058 -         else
 24.2059 -           let val accum as (xs, _) = (x :: xs, axs) in
 24.2060 -             if depth > axioms_max_depth then
 24.2061 -               raise TOO_LARGE ("Nitpick_HOL.axioms_for_term.\
 24.2062 -                                \add_axioms_for_term",
 24.2063 -                                "too many nested axioms (" ^
 24.2064 -                                string_of_int depth ^ ")")
 24.2065 -             else if Refute.is_const_of_class thy x then
 24.2066 -               let
 24.2067 -                 val class = Logic.class_of_const s
 24.2068 -                 val of_class = Logic.mk_of_class (TVar (("'a", 0), [class]),
 24.2069 -                                                   class)
 24.2070 -                 val ax1 = try (Refute.specialize_type thy x) of_class
 24.2071 -                 val ax2 = Option.map (Refute.specialize_type thy x o snd)
 24.2072 -                                      (Refute.get_classdef thy class)
 24.2073 -               in
 24.2074 -                 fold (add_maybe_def_axiom depth) (map_filter I [ax1, ax2])
 24.2075 -                      accum
 24.2076 -               end
 24.2077 -             else if is_constr thy x then
 24.2078 -               accum
 24.2079 -             else if is_equational_fun ext_ctxt x then
 24.2080 -               fold (add_eq_axiom depth) (equational_fun_axioms ext_ctxt x)
 24.2081 -                    accum
 24.2082 -             else if is_abs_fun thy x then
 24.2083 -               if is_quot_type thy (range_type T) then
 24.2084 -                 raise NOT_SUPPORTED "\"Abs_\" function of quotient type"
 24.2085 -               else
 24.2086 -                 accum |> fold (add_nondef_axiom depth)
 24.2087 -                               (nondef_props_for_const thy false nondef_table x)
 24.2088 -                       |> is_funky_typedef thy (range_type T)
 24.2089 -                          ? fold (add_maybe_def_axiom depth)
 24.2090 -                                 (nondef_props_for_const thy true
 24.2091 -                                                    (extra_table def_table s) x)
 24.2092 -             else if is_rep_fun thy x then
 24.2093 -               if is_quot_type thy (domain_type T) then
 24.2094 -                 raise NOT_SUPPORTED "\"Rep_\" function of quotient type"
 24.2095 -               else
 24.2096 -                 accum |> fold (add_nondef_axiom depth)
 24.2097 -                               (nondef_props_for_const thy false nondef_table x)
 24.2098 -                       |> is_funky_typedef thy (range_type T)
 24.2099 -                          ? fold (add_maybe_def_axiom depth)
 24.2100 -                                 (nondef_props_for_const thy true
 24.2101 -                                                    (extra_table def_table s) x)
 24.2102 -                       |> add_axioms_for_term depth
 24.2103 -                                              (Const (mate_of_rep_fun thy x))
 24.2104 -                       |> fold (add_def_axiom depth)
 24.2105 -                               (inverse_axioms_for_rep_fun thy x)
 24.2106 -             else
 24.2107 -               accum |> user_axioms <> SOME false
 24.2108 -                        ? fold (add_nondef_axiom depth)
 24.2109 -                               (nondef_props_for_const thy false nondef_table x)
 24.2110 -           end)
 24.2111 -        |> add_axioms_for_type depth T
 24.2112 -      | Free (_, T) => add_axioms_for_type depth T accum
 24.2113 -      | Var (_, T) => add_axioms_for_type depth T accum
 24.2114 -      | Bound _ => accum
 24.2115 -      | Abs (_, T, t) => accum |> add_axioms_for_term depth t
 24.2116 -                               |> add_axioms_for_type depth T
 24.2117 -    (* int -> typ -> accumulator -> accumulator *)
 24.2118 -    and add_axioms_for_type depth T =
 24.2119 -      case T of
 24.2120 -        Type ("fun", Ts) => fold (add_axioms_for_type depth) Ts
 24.2121 -      | Type ("*", Ts) => fold (add_axioms_for_type depth) Ts
 24.2122 -      | @{typ prop} => I
 24.2123 -      | @{typ bool} => I
 24.2124 -      | @{typ unit} => I
 24.2125 -      | TFree (_, S) => add_axioms_for_sort depth T S
 24.2126 -      | TVar (_, S) => add_axioms_for_sort depth T S
 24.2127 -      | Type (z as (s, Ts)) =>
 24.2128 -        fold (add_axioms_for_type depth) Ts
 24.2129 -        #> (if is_pure_typedef thy T then
 24.2130 -              fold (add_maybe_def_axiom depth) (optimized_typedef_axioms thy z)
 24.2131 -            else if is_quot_type thy T then
 24.2132 -              fold (add_def_axiom depth) (optimized_quot_type_axioms thy z)
 24.2133 -            else if max_bisim_depth >= 0 andalso is_codatatype thy T then
 24.2134 -              fold (add_maybe_def_axiom depth)
 24.2135 -                   (codatatype_bisim_axioms ext_ctxt T)
 24.2136 -            else
 24.2137 -              I)
 24.2138 -    (* int -> typ -> sort -> accumulator -> accumulator *)
 24.2139 -    and add_axioms_for_sort depth T S =
 24.2140 -      let
 24.2141 -        val supers = Sign.complete_sort thy S
 24.2142 -        val class_axioms =
 24.2143 -          maps (fn class => map prop_of (AxClass.get_info thy class |> #axioms
 24.2144 -                                         handle ERROR _ => [])) supers
 24.2145 -        val monomorphic_class_axioms =
 24.2146 -          map (fn t => case Term.add_tvars t [] of
 24.2147 -                         [] => t
 24.2148 -                       | [(x, S)] =>
 24.2149 -                         Refute.monomorphic_term (Vartab.make [(x, (S, T))]) t
 24.2150 -                       | _ => raise TERM ("Nitpick_HOL.axioms_for_term.\
 24.2151 -                                          \add_axioms_for_sort", [t]))
 24.2152 -              class_axioms
 24.2153 -      in fold (add_nondef_axiom depth) monomorphic_class_axioms end
 24.2154 -    val (mono_user_nondefs, poly_user_nondefs) =
 24.2155 -      List.partition (null o Term.hidden_polymorphism) user_nondefs
 24.2156 -    val eval_axioms = map2 eval_axiom_for_term (index_seq 0 (length evals))
 24.2157 -                           evals
 24.2158 -    val (xs, (defs, nondefs)) =
 24.2159 -      ([], ([], [])) |> add_axioms_for_term 1 t 
 24.2160 -                     |> fold_rev (add_def_axiom 1) eval_axioms
 24.2161 -                     |> user_axioms = SOME true
 24.2162 -                        ? fold (add_nondef_axiom 1) mono_user_nondefs
 24.2163 -    val defs = defs @ special_congruence_axioms ext_ctxt xs
 24.2164 -  in
 24.2165 -    ((defs, nondefs), (user_axioms = SOME true orelse null mono_user_nondefs,
 24.2166 -                       null poly_user_nondefs))
 24.2167 -  end
 24.2168 +(* hol_context -> typ -> typ list *)
 24.2169 +fun ground_types_in_type hol_ctxt T = add_ground_types hol_ctxt T []
 24.2170 +(* hol_context -> term list -> typ list *)
 24.2171 +fun ground_types_in_terms hol_ctxt ts =
 24.2172 +  fold (fold_types (add_ground_types hol_ctxt)) ts []
 24.2173  
 24.2174  (* theory -> const_table -> styp -> int list *)
 24.2175  fun const_format thy def_table (x as (s, T)) =
 24.2176 @@ -3356,10 +2121,10 @@
 24.2177                   |> map (rev o filter_out (member (op =) js))
 24.2178                   |> filter_out null |> map length |> rev
 24.2179  
 24.2180 -(* extended_context -> string * string -> (term option * int list) list
 24.2181 +(* hol_context -> string * string -> (term option * int list) list
 24.2182     -> styp -> term * typ *)
 24.2183  fun user_friendly_const ({thy, evals, def_table, skolems, special_funs, ...}
 24.2184 -                         : extended_context) (base_name, step_name) formats =
 24.2185 +                         : hol_context) (base_name, step_name) formats =
 24.2186    let
 24.2187      val default_format = the (AList.lookup (op =) formats NONE)
 24.2188      (* styp -> term * typ *)
 24.2189 @@ -3460,7 +2225,7 @@
 24.2190             (t, format_term_type thy def_table formats t)
 24.2191           end)
 24.2192        |>> map_types unbit_and_unbox_type
 24.2193 -      |>> shorten_names_in_term |>> shorten_abs_vars
 24.2194 +      |>> shorten_names_in_term |>> Term.map_abs_vars shortest_name
 24.2195    in do_const end
 24.2196  
 24.2197  (* styp -> string *)
 24.2198 @@ -3474,84 +2239,4 @@
 24.2199    else
 24.2200      "="
 24.2201  
 24.2202 -val binary_int_threshold = 4
 24.2203 -
 24.2204 -(* term -> bool *)
 24.2205 -fun may_use_binary_ints (t1 $ t2) =
 24.2206 -    may_use_binary_ints t1 andalso may_use_binary_ints t2
 24.2207 -  | may_use_binary_ints (t as Const (s, _)) =
 24.2208 -    t <> @{const Suc} andalso
 24.2209 -    not (member (op =) [@{const_name Abs_Frac}, @{const_name Rep_Frac},
 24.2210 -                        @{const_name nat_gcd}, @{const_name nat_lcm},
 24.2211 -                        @{const_name Frac}, @{const_name norm_frac}] s)
 24.2212 -  | may_use_binary_ints (Abs (_, _, t')) = may_use_binary_ints t'
 24.2213 -  | may_use_binary_ints _ = true
 24.2214 -fun should_use_binary_ints (t1 $ t2) =
 24.2215 -    should_use_binary_ints t1 orelse should_use_binary_ints t2
 24.2216 -  | should_use_binary_ints (Const (s, _)) =
 24.2217 -    member (op =) [@{const_name times_nat_inst.times_nat},
 24.2218 -                   @{const_name div_nat_inst.div_nat},
 24.2219 -                   @{const_name times_int_inst.times_int},
 24.2220 -                   @{const_name div_int_inst.div_int}] s orelse
 24.2221 -    (String.isPrefix numeral_prefix s andalso
 24.2222 -     let val n = the (Int.fromString (unprefix numeral_prefix s)) in
 24.2223 -       n <= ~ binary_int_threshold orelse n >= binary_int_threshold
 24.2224 -     end)
 24.2225 -  | should_use_binary_ints (Abs (_, _, t')) = should_use_binary_ints t'
 24.2226 -  | should_use_binary_ints _ = false
 24.2227 -
 24.2228 -(* typ -> typ *)
 24.2229 -fun binarize_nat_and_int_in_type @{typ nat} = @{typ "unsigned_bit word"}
 24.2230 -  | binarize_nat_and_int_in_type @{typ int} = @{typ "signed_bit word"}
 24.2231 -  | binarize_nat_and_int_in_type (Type (s, Ts)) =
 24.2232 -    Type (s, map binarize_nat_and_int_in_type Ts)
 24.2233 -  | binarize_nat_and_int_in_type T = T
 24.2234 -(* term -> term *)
 24.2235 -val binarize_nat_and_int_in_term = map_types binarize_nat_and_int_in_type
 24.2236 -
 24.2237 -(* extended_context -> term
 24.2238 -   -> ((term list * term list) * (bool * bool)) * term *)
 24.2239 -fun preprocess_term (ext_ctxt as {thy, binary_ints, destroy_constrs, boxes,
 24.2240 -                                  skolemize, uncurry, ...}) t =
 24.2241 -  let
 24.2242 -    val skolem_depth = if skolemize then 4 else ~1
 24.2243 -    val (((def_ts, nondef_ts), (got_all_mono_user_axioms, no_poly_user_axioms)),
 24.2244 -         core_t) = t |> unfold_defs_in_term ext_ctxt
 24.2245 -                     |> Refute.close_form
 24.2246 -                     |> skolemize_term_and_more ext_ctxt skolem_depth
 24.2247 -                     |> specialize_consts_in_term ext_ctxt 0
 24.2248 -                     |> `(axioms_for_term ext_ctxt)
 24.2249 -    val binarize =
 24.2250 -      case binary_ints of
 24.2251 -        SOME false => false
 24.2252 -      | _ =>
 24.2253 -        forall may_use_binary_ints (core_t :: def_ts @ nondef_ts) andalso
 24.2254 -        (binary_ints = SOME true orelse
 24.2255 -         exists should_use_binary_ints (core_t :: def_ts @ nondef_ts))
 24.2256 -    val box = exists (not_equal (SOME false) o snd) boxes
 24.2257 -    val table =
 24.2258 -      Termtab.empty |> uncurry
 24.2259 -        ? fold (add_to_uncurry_table thy) (core_t :: def_ts @ nondef_ts)
 24.2260 -    (* bool -> bool -> term -> term *)
 24.2261 -    fun do_rest def core =
 24.2262 -      binarize ? binarize_nat_and_int_in_term
 24.2263 -      #> uncurry ? uncurry_term table
 24.2264 -      #> box ? box_fun_and_pair_in_term ext_ctxt def
 24.2265 -      #> destroy_constrs ? (pull_out_universal_constrs thy def
 24.2266 -                            #> pull_out_existential_constrs thy
 24.2267 -                            #> destroy_pulled_out_constrs ext_ctxt def)
 24.2268 -      #> curry_assms
 24.2269 -      #> destroy_universal_equalities
 24.2270 -      #> destroy_existential_equalities thy
 24.2271 -      #> simplify_constrs_and_sels thy
 24.2272 -      #> distribute_quantifiers
 24.2273 -      #> push_quantifiers_inward thy
 24.2274 -      #> not core ? Refute.close_form
 24.2275 -      #> shorten_abs_vars
 24.2276 -  in
 24.2277 -    (((map (do_rest true false) def_ts, map (do_rest false false) nondef_ts),
 24.2278 -      (got_all_mono_user_axioms, no_poly_user_axioms)),
 24.2279 -     do_rest false true core_t)
 24.2280 -  end
 24.2281 -
 24.2282  end;
    25.1 --- a/src/HOL/Tools/Nitpick/nitpick_kodkod.ML	Tue Feb 09 13:54:27 2010 +0100
    25.2 +++ b/src/HOL/Tools/Nitpick/nitpick_kodkod.ML	Tue Feb 09 17:06:05 2010 +0100
    25.3 @@ -7,7 +7,7 @@
    25.4  
    25.5  signature NITPICK_KODKOD =
    25.6  sig
    25.7 -  type extended_context = Nitpick_HOL.extended_context
    25.8 +  type hol_context = Nitpick_HOL.hol_context
    25.9    type dtype_spec = Nitpick_Scope.dtype_spec
   25.10    type kodkod_constrs = Nitpick_Peephole.kodkod_constrs
   25.11    type nut = Nitpick_Nut.nut
   25.12 @@ -33,7 +33,7 @@
   25.13    val merge_bounds : Kodkod.bound list -> Kodkod.bound list
   25.14    val declarative_axiom_for_plain_rel : kodkod_constrs -> nut -> Kodkod.formula
   25.15    val declarative_axioms_for_datatypes :
   25.16 -    extended_context -> int -> int Typtab.table -> kodkod_constrs
   25.17 +    hol_context -> int -> int Typtab.table -> kodkod_constrs
   25.18      -> nut NameTable.table -> dtype_spec list -> Kodkod.formula list
   25.19    val kodkod_formula_from_nut :
   25.20      int -> int Typtab.table -> bool -> kodkod_constrs -> nut -> Kodkod.formula
   25.21 @@ -316,7 +316,15 @@
   25.22             if R2 = Formula Neut then
   25.23               [ts] |> not exclusive ? cons (KK.TupleSet [])
   25.24             else
   25.25 -             [KK.TupleSet [], KK.TupleProduct (ts, upper_bound_for_rep R2)]
   25.26 +             [KK.TupleSet [],
   25.27 +              if (* ### exclusive andalso*) T1 = T2 andalso epsilon > delta then
   25.28 +                index_seq delta (epsilon - delta)
   25.29 +                |> map (fn j =>
   25.30 +                           KK.TupleProduct (KK.TupleSet [Kodkod.Tuple [j + j0]],
   25.31 +                                            KK.TupleAtomSeq (j, j0)))
   25.32 +                |> foldl1 KK.TupleUnion
   25.33 +              else
   25.34 +                KK.TupleProduct (ts, upper_bound_for_rep R2)]
   25.35           end)
   25.36      end
   25.37    | bound_for_sel_rel _ _ _ u =
   25.38 @@ -732,12 +740,12 @@
   25.39  (* nut NameTable.table -> styp -> KK.rel_expr *)
   25.40  fun discr_rel_expr rel_table = #1 o const_triple rel_table o discr_for_constr
   25.41  
   25.42 -(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
   25.43 +(* hol_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
   25.44     -> styp -> int -> nfa_transition list *)
   25.45 -fun nfa_transitions_for_sel ext_ctxt ({kk_project, ...} : kodkod_constrs)
   25.46 +fun nfa_transitions_for_sel hol_ctxt ({kk_project, ...} : kodkod_constrs)
   25.47                              rel_table (dtypes : dtype_spec list) constr_x n =
   25.48    let
   25.49 -    val x as (_, T) = boxed_nth_sel_for_constr ext_ctxt constr_x n
   25.50 +    val x as (_, T) = boxed_nth_sel_for_constr hol_ctxt constr_x n
   25.51      val (r, R, arity) = const_triple rel_table x
   25.52      val type_schema = type_schema_of_rep T R
   25.53    in
   25.54 @@ -746,17 +754,17 @@
   25.55                     else SOME (kk_project r (map KK.Num [0, j]), T))
   25.56                 (index_seq 1 (arity - 1) ~~ tl type_schema)
   25.57    end
   25.58 -(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
   25.59 +(* hol_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
   25.60     -> styp -> nfa_transition list *)
   25.61 -fun nfa_transitions_for_constr ext_ctxt kk rel_table dtypes (x as (_, T)) =
   25.62 -  maps (nfa_transitions_for_sel ext_ctxt kk rel_table dtypes x)
   25.63 +fun nfa_transitions_for_constr hol_ctxt kk rel_table dtypes (x as (_, T)) =
   25.64 +  maps (nfa_transitions_for_sel hol_ctxt kk rel_table dtypes x)
   25.65         (index_seq 0 (num_sels_for_constr_type T))
   25.66 -(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
   25.67 +(* hol_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
   25.68     -> dtype_spec -> nfa_entry option *)
   25.69  fun nfa_entry_for_datatype _ _ _ _ ({co = true, ...} : dtype_spec) = NONE
   25.70    | nfa_entry_for_datatype _ _ _ _ {deep = false, ...} = NONE
   25.71 -  | nfa_entry_for_datatype ext_ctxt kk rel_table dtypes {typ, constrs, ...} =
   25.72 -    SOME (typ, maps (nfa_transitions_for_constr ext_ctxt kk rel_table dtypes
   25.73 +  | nfa_entry_for_datatype hol_ctxt kk rel_table dtypes {typ, constrs, ...} =
   25.74 +    SOME (typ, maps (nfa_transitions_for_constr hol_ctxt kk rel_table dtypes
   25.75                       o #const) constrs)
   25.76  
   25.77  val empty_rel = KK.Product (KK.None, KK.None)
   25.78 @@ -812,23 +820,23 @@
   25.79  fun acyclicity_axiom_for_datatype dtypes kk nfa start =
   25.80    #kk_no kk (#kk_intersect kk
   25.81                   (loop_path_rel_expr kk nfa (map fst nfa) start) KK.Iden)
   25.82 -(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
   25.83 +(* hol_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
   25.84     -> KK.formula list *)
   25.85 -fun acyclicity_axioms_for_datatypes ext_ctxt kk rel_table dtypes =
   25.86 -  map_filter (nfa_entry_for_datatype ext_ctxt kk rel_table dtypes) dtypes
   25.87 +fun acyclicity_axioms_for_datatypes hol_ctxt kk rel_table dtypes =
   25.88 +  map_filter (nfa_entry_for_datatype hol_ctxt kk rel_table dtypes) dtypes
   25.89    |> strongly_connected_sub_nfas
   25.90    |> maps (fn nfa => map (acyclicity_axiom_for_datatype dtypes kk nfa o fst)
   25.91                           nfa)
   25.92  
   25.93 -(* extended_context -> int -> kodkod_constrs -> nut NameTable.table
   25.94 -   -> KK.rel_expr -> constr_spec -> int -> KK.formula *)
   25.95 -fun sel_axiom_for_sel ext_ctxt j0
   25.96 +(* hol_context -> int -> kodkod_constrs -> nut NameTable.table -> KK.rel_expr
   25.97 +   -> constr_spec -> int -> KK.formula *)
   25.98 +fun sel_axiom_for_sel hol_ctxt j0
   25.99          (kk as {kk_all, kk_implies, kk_formula_if, kk_subset, kk_rel_eq, kk_no,
  25.100                  kk_join, ...}) rel_table dom_r
  25.101          ({const, delta, epsilon, exclusive, explicit_max, ...} : constr_spec)
  25.102          n =
  25.103    let
  25.104 -    val x as (_, T) = boxed_nth_sel_for_constr ext_ctxt const n
  25.105 +    val x as (_, T) = boxed_nth_sel_for_constr hol_ctxt const n
  25.106      val (r, R, arity) = const_triple rel_table x
  25.107      val R2 = dest_Func R |> snd
  25.108      val z = (epsilon - delta, delta + j0)
  25.109 @@ -842,9 +850,9 @@
  25.110                                (kk_n_ary_function kk R2 r') (kk_no r'))
  25.111        end
  25.112    end
  25.113 -(* extended_context -> int -> int -> kodkod_constrs -> nut NameTable.table
  25.114 +(* hol_context -> int -> int -> kodkod_constrs -> nut NameTable.table
  25.115     -> constr_spec -> KK.formula list *)
  25.116 -fun sel_axioms_for_constr ext_ctxt bits j0 kk rel_table
  25.117 +fun sel_axioms_for_constr hol_ctxt bits j0 kk rel_table
  25.118          (constr as {const, delta, epsilon, explicit_max, ...}) =
  25.119    let
  25.120      val honors_explicit_max =
  25.121 @@ -866,19 +874,19 @@
  25.122                               " too small for \"max\"")
  25.123        in
  25.124          max_axiom ::
  25.125 -        map (sel_axiom_for_sel ext_ctxt j0 kk rel_table ran_r constr)
  25.126 +        map (sel_axiom_for_sel hol_ctxt j0 kk rel_table ran_r constr)
  25.127              (index_seq 0 (num_sels_for_constr_type (snd const)))
  25.128        end
  25.129    end
  25.130 -(* extended_context -> int -> int -> kodkod_constrs -> nut NameTable.table
  25.131 +(* hol_context -> int -> int -> kodkod_constrs -> nut NameTable.table
  25.132     -> dtype_spec -> KK.formula list *)
  25.133 -fun sel_axioms_for_datatype ext_ctxt bits j0 kk rel_table
  25.134 +fun sel_axioms_for_datatype hol_ctxt bits j0 kk rel_table
  25.135                              ({constrs, ...} : dtype_spec) =
  25.136 -  maps (sel_axioms_for_constr ext_ctxt bits j0 kk rel_table) constrs
  25.137 +  maps (sel_axioms_for_constr hol_ctxt bits j0 kk rel_table) constrs
  25.138  
  25.139 -(* extended_context -> kodkod_constrs -> nut NameTable.table -> constr_spec
  25.140 +(* hol_context -> kodkod_constrs -> nut NameTable.table -> constr_spec
  25.141     -> KK.formula list *)
  25.142 -fun uniqueness_axiom_for_constr ext_ctxt
  25.143 +fun uniqueness_axiom_for_constr hol_ctxt
  25.144          ({kk_all, kk_implies, kk_and, kk_rel_eq, kk_lone, kk_join, ...}
  25.145           : kodkod_constrs) rel_table ({const, ...} : constr_spec) =
  25.146    let
  25.147 @@ -887,7 +895,7 @@
  25.148        kk_rel_eq (kk_join (KK.Var (1, 0)) r) (kk_join (KK.Var (1, 1)) r)
  25.149      val num_sels = num_sels_for_constr_type (snd const)
  25.150      val triples = map (const_triple rel_table
  25.151 -                       o boxed_nth_sel_for_constr ext_ctxt const)
  25.152 +                       o boxed_nth_sel_for_constr hol_ctxt const)
  25.153                        (~1 upto num_sels - 1)
  25.154      val j0 = case triples |> hd |> #2 of
  25.155                 Func (Atom (_, j0), _) => j0
  25.156 @@ -903,11 +911,11 @@
  25.157                    (fold1 kk_and (map (conjunct_for_sel o #1) (tl triples)))
  25.158                    (kk_rel_eq (KK.Var (1, 0)) (KK.Var (1, 1))))
  25.159    end
  25.160 -(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec
  25.161 +(* hol_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec
  25.162     -> KK.formula list *)
  25.163 -fun uniqueness_axioms_for_datatype ext_ctxt kk rel_table
  25.164 +fun uniqueness_axioms_for_datatype hol_ctxt kk rel_table
  25.165                                     ({constrs, ...} : dtype_spec) =
  25.166 -  map (uniqueness_axiom_for_constr ext_ctxt kk rel_table) constrs
  25.167 +  map (uniqueness_axiom_for_constr hol_ctxt kk rel_table) constrs
  25.168  
  25.169  (* constr_spec -> int *)
  25.170  fun effective_constr_max ({delta, epsilon, ...} : constr_spec) = epsilon - delta
  25.171 @@ -924,31 +932,31 @@
  25.172         kk_disjoint_sets kk rs]
  25.173      end
  25.174  
  25.175 -(* extended_context -> int -> int Typtab.table -> kodkod_constrs
  25.176 +(* hol_context -> int -> int Typtab.table -> kodkod_constrs
  25.177     -> nut NameTable.table -> dtype_spec -> KK.formula list *)
  25.178  fun other_axioms_for_datatype _ _ _ _ _ {deep = false, ...} = []
  25.179 -  | other_axioms_for_datatype ext_ctxt bits ofs kk rel_table
  25.180 +  | other_axioms_for_datatype hol_ctxt bits ofs kk rel_table
  25.181                                (dtype as {typ, ...}) =
  25.182      let val j0 = offset_of_type ofs typ in
  25.183 -      sel_axioms_for_datatype ext_ctxt bits j0 kk rel_table dtype @
  25.184 -      uniqueness_axioms_for_datatype ext_ctxt kk rel_table dtype @
  25.185 +      sel_axioms_for_datatype hol_ctxt bits j0 kk rel_table dtype @
  25.186 +      uniqueness_axioms_for_datatype hol_ctxt kk rel_table dtype @
  25.187        partition_axioms_for_datatype j0 kk rel_table dtype
  25.188      end
  25.189  
  25.190 -(* extended_context -> int -> int Typtab.table -> kodkod_constrs
  25.191 +(* hol_context -> int -> int Typtab.table -> kodkod_constrs
  25.192     -> nut NameTable.table -> dtype_spec list -> KK.formula list *)
  25.193 -fun declarative_axioms_for_datatypes ext_ctxt bits ofs kk rel_table dtypes =
  25.194 -  acyclicity_axioms_for_datatypes ext_ctxt kk rel_table dtypes @
  25.195 -  maps (other_axioms_for_datatype ext_ctxt bits ofs kk rel_table) dtypes
  25.196 +fun declarative_axioms_for_datatypes hol_ctxt bits ofs kk rel_table dtypes =
  25.197 +  acyclicity_axioms_for_datatypes hol_ctxt kk rel_table dtypes @
  25.198 +  maps (other_axioms_for_datatype hol_ctxt bits ofs kk rel_table) dtypes
  25.199  
  25.200  (* int -> int Typtab.table -> bool -> kodkod_constrs -> nut -> KK.formula *)
  25.201  fun kodkod_formula_from_nut bits ofs liberal
  25.202          (kk as {kk_all, kk_exist, kk_formula_let, kk_formula_if, kk_or, kk_not,
  25.203 -                kk_iff, kk_implies, kk_and, kk_subset, kk_rel_eq, kk_no, kk_one,
  25.204 -                kk_some, kk_rel_let, kk_rel_if, kk_union, kk_difference,
  25.205 -                kk_intersect, kk_product, kk_join, kk_closure, kk_comprehension,
  25.206 -                kk_project, kk_project_seq, kk_not3, kk_nat_less, kk_int_less,
  25.207 -                ...}) u =
  25.208 +                kk_iff, kk_implies, kk_and, kk_subset, kk_rel_eq, kk_no,
  25.209 +                kk_lone, kk_one, kk_some, kk_rel_let, kk_rel_if, kk_union,
  25.210 +                kk_difference, kk_intersect, kk_product, kk_join, kk_closure,
  25.211 +                kk_comprehension, kk_project, kk_project_seq, kk_not3,
  25.212 +                kk_nat_less, kk_int_less, ...}) u =
  25.213    let
  25.214      val main_j0 = offset_of_type ofs bool_T
  25.215      val bool_j0 = main_j0
  25.216 @@ -1108,7 +1116,7 @@
  25.217                       else
  25.218                         if is_lone_rep min_R then
  25.219                           if arity_of_rep min_R = 1 then
  25.220 -                           kk_subset (kk_product r1 r2) KK.Iden
  25.221 +                           kk_lone (kk_union r1 r2)
  25.222                           else if not both_opt then
  25.223                             (r1, r2) |> is_opt_rep (rep_of u2) ? swap
  25.224                                      |-> kk_subset
    26.1 --- a/src/HOL/Tools/Nitpick/nitpick_model.ML	Tue Feb 09 13:54:27 2010 +0100
    26.2 +++ b/src/HOL/Tools/Nitpick/nitpick_model.ML	Tue Feb 09 17:06:05 2010 +0100
    26.3 @@ -56,26 +56,36 @@
    26.4  val opt_flag = nitpick_prefix ^ "opt"
    26.5  val non_opt_flag = nitpick_prefix ^ "non_opt"
    26.6  
    26.7 -(* string -> int -> string *)
    26.8 -fun atom_suffix s j =
    26.9 -  nat_subscript (j + 1)
   26.10 +type atom_pool = ((string * int) * int list) list
   26.11 +
   26.12 +(* atom_pool Unsynchronized.ref -> string -> int -> int -> string *)
   26.13 +fun nth_atom_suffix pool s j k =
   26.14 +  (case AList.lookup (op =) (!pool) (s, k) of
   26.15 +     SOME js =>
   26.16 +     (case find_index (curry (op =) j) js of
   26.17 +        ~1 => (Unsynchronized.change pool (cons ((s, k), j :: js));
   26.18 +               length js + 1)
   26.19 +      | n => length js - n)
   26.20 +   | NONE => (Unsynchronized.change pool (cons ((s, k), [j])); 1))
   26.21 +  |> nat_subscript
   26.22    |> (s <> "" andalso Symbol.is_ascii_digit (List.last (explode s)))
   26.23       ? prefix "\<^isub>,"
   26.24 -(* string -> typ -> int -> string *)
   26.25 -fun atom_name prefix (T as Type (s, _)) j =
   26.26 +(* atom_pool Unsynchronized.ref -> string -> typ -> int -> int -> string *)
   26.27 +fun nth_atom_name pool prefix (T as Type (s, _)) j k =
   26.28      let val s' = shortest_name s in
   26.29        prefix ^ (if String.isPrefix "\\" s' then s' else substring (s', 0, 1)) ^
   26.30 -      atom_suffix s j
   26.31 +      nth_atom_suffix pool s j k
   26.32      end
   26.33 -  | atom_name prefix (T as TFree (s, _)) j =
   26.34 -    prefix ^ perhaps (try (unprefix "'")) s ^ atom_suffix s j
   26.35 -  | atom_name _ T _ = raise TYPE ("Nitpick_Model.atom_name", [T], [])
   26.36 -(* bool -> typ -> int -> term *)
   26.37 -fun atom for_auto T j =
   26.38 +  | nth_atom_name pool prefix (T as TFree (s, _)) j k =
   26.39 +    prefix ^ perhaps (try (unprefix "'")) s ^ nth_atom_suffix pool s j k
   26.40 +  | nth_atom_name _ _ T _ _ =
   26.41 +    raise TYPE ("Nitpick_Model.nth_atom_name", [T], [])
   26.42 +(* atom_pool Unsynchronized.ref -> bool -> typ -> int -> int -> term *)
   26.43 +fun nth_atom pool for_auto T j k =
   26.44    if for_auto then
   26.45 -    Free (atom_name (hd (space_explode "." nitpick_prefix)) T j, T)
   26.46 +    Free (nth_atom_name pool (hd (space_explode "." nitpick_prefix)) T j k, T)
   26.47    else
   26.48 -    Const (atom_name "" T j, T)
   26.49 +    Const (nth_atom_name pool "" T j k, T)
   26.50  
   26.51  (* term -> real *)
   26.52  fun extract_real_number (Const (@{const_name Algebras.divide}, _) $ t1 $ t2) =
   26.53 @@ -251,9 +261,10 @@
   26.54     -> nut list -> nut NameTable.table -> KK.raw_bound list -> typ -> typ -> rep
   26.55     -> int list list -> term *)
   26.56  fun reconstruct_term (maybe_name, base_name, step_name, abs_name)
   26.57 -        ({ext_ctxt as {thy, ctxt, ...}, card_assigns, bits, datatypes, ofs, ...}
   26.58 +        ({hol_ctxt as {thy, ctxt, ...}, card_assigns, bits, datatypes, ofs, ...}
   26.59           : scope) sel_names rel_table bounds =
   26.60    let
   26.61 +    val pool = Unsynchronized.ref []
   26.62      val for_auto = (maybe_name = "")
   26.63      (* int list list -> int *)
   26.64      fun value_of_bits jss =
   26.65 @@ -348,7 +359,7 @@
   26.66                                   (unbit_and_unbox_type T1)
   26.67                                   (unbit_and_unbox_type T2)
   26.68      (* (typ * int) list -> typ -> typ -> int -> term *)
   26.69 -    fun term_for_atom seen (T as Type ("fun", [T1, T2])) T' j =
   26.70 +    fun term_for_atom seen (T as Type ("fun", [T1, T2])) T' j k =
   26.71          let
   26.72            val k1 = card_of_type card_assigns T1
   26.73            val k2 = card_of_type card_assigns T2
   26.74 @@ -360,37 +371,39 @@
   26.75                              signed_string_of_int j ^ " for " ^
   26.76                              string_for_rep (Vect (k1, Atom (k2, 0))))
   26.77          end
   26.78 -      | term_for_atom seen (Type ("*", [T1, T2])) _ j =
   26.79 -        let val k1 = card_of_type card_assigns T1 in
   26.80 +      | term_for_atom seen (Type ("*", [T1, T2])) _ j k =
   26.81 +        let
   26.82 +          val k1 = card_of_type card_assigns T1
   26.83 +          val k2 = k div k1
   26.84 +        in
   26.85            list_comb (HOLogic.pair_const T1 T2,
   26.86 -                     map2 (fn T => term_for_atom seen T T) [T1, T2]
   26.87 -                          [j div k1, j mod k1])
   26.88 +                     map3 (fn T => term_for_atom seen T T) [T1, T2]
   26.89 +                          [j div k2, j mod k2] [k1, k2]) (* ### k2 or k1? FIXME *)
   26.90          end
   26.91 -      | term_for_atom seen @{typ prop} _ j =
   26.92 -        HOLogic.mk_Trueprop (term_for_atom seen bool_T bool_T j)
   26.93 -      | term_for_atom _ @{typ bool} _ j =
   26.94 +      | term_for_atom seen @{typ prop} _ j k =
   26.95 +        HOLogic.mk_Trueprop (term_for_atom seen bool_T bool_T j k)
   26.96 +      | term_for_atom _ @{typ bool} _ j _ =
   26.97          if j = 0 then @{const False} else @{const True}
   26.98 -      | term_for_atom _ @{typ unit} _ _ = @{const Unity}
   26.99 -      | term_for_atom seen T _ j =
  26.100 +      | term_for_atom _ @{typ unit} _ _ _ = @{const Unity}
  26.101 +      | term_for_atom seen T _ j k =
  26.102          if T = nat_T then
  26.103            HOLogic.mk_number nat_T j
  26.104          else if T = int_T then
  26.105 -          HOLogic.mk_number int_T
  26.106 -              (int_for_atom (card_of_type card_assigns int_T, 0) j)
  26.107 +          HOLogic.mk_number int_T (int_for_atom (k, 0) j)
  26.108          else if is_fp_iterator_type T then
  26.109 -          HOLogic.mk_number nat_T (card_of_type card_assigns T - j - 1)
  26.110 +          HOLogic.mk_number nat_T (k - j - 1)
  26.111          else if T = @{typ bisim_iterator} then
  26.112            HOLogic.mk_number nat_T j
  26.113          else case datatype_spec datatypes T of
  26.114 -          NONE => atom for_auto T j
  26.115 -        | SOME {deep = false, ...} => atom for_auto T j
  26.116 +          NONE => nth_atom pool for_auto T j k
  26.117 +        | SOME {deep = false, ...} => nth_atom pool for_auto T j k
  26.118          | SOME {co, constrs, ...} =>
  26.119            let
  26.120              (* styp -> int list *)
  26.121              fun tuples_for_const (s, T) =
  26.122                tuple_list_for_name rel_table bounds (ConstName (s, T, Any))
  26.123              (* unit -> indexname * typ *)
  26.124 -            fun var () = ((atom_name "" T j, 0), T)
  26.125 +            fun var () = ((nth_atom_name pool "" T j k, 0), T)
  26.126              val discr_jsss = map (tuples_for_const o discr_for_constr o #const)
  26.127                                   constrs
  26.128              val real_j = j + offset_of_type ofs T
  26.129 @@ -400,7 +413,7 @@
  26.130                              else NONE)
  26.131                          (discr_jsss ~~ constrs) |> the
  26.132              val arg_Ts = curried_binder_types constr_T
  26.133 -            val sel_xs = map (boxed_nth_sel_for_constr ext_ctxt constr_x)
  26.134 +            val sel_xs = map (boxed_nth_sel_for_constr hol_ctxt constr_x)
  26.135                               (index_seq 0 (length arg_Ts))
  26.136              val sel_Rs =
  26.137                map (fn x => get_first
  26.138 @@ -479,13 +492,14 @@
  26.139      (* (typ * int) list -> int -> rep -> typ -> typ -> typ -> int list
  26.140         -> term *)
  26.141      and term_for_vect seen k R T1 T2 T' js =
  26.142 -      make_fun true T1 T2 T' (map (term_for_atom seen T1 T1) (index_seq 0 k))
  26.143 +      make_fun true T1 T2 T'
  26.144 +               (map (fn j => term_for_atom seen T1 T1 j k) (index_seq 0 k))
  26.145                 (map (term_for_rep seen T2 T2 R o single)
  26.146                      (batch_list (arity_of_rep R) js))
  26.147      (* (typ * int) list -> typ -> typ -> rep -> int list list -> term *)
  26.148 -    and term_for_rep seen T T' Unit [[]] = term_for_atom seen T T' 0
  26.149 +    and term_for_rep seen T T' Unit [[]] = term_for_atom seen T T' 0 1
  26.150        | term_for_rep seen T T' (R as Atom (k, j0)) [[j]] =
  26.151 -        if j >= j0 andalso j < j0 + k then term_for_atom seen T T' (j - j0)
  26.152 +        if j >= j0 andalso j < j0 + k then term_for_atom seen T T' (j - j0) k
  26.153          else raise REP ("Nitpick_Model.reconstruct_term.term_for_rep", [R])
  26.154        | term_for_rep seen (Type ("*", [T1, T2])) _ (Struct [R1, R2]) [js] =
  26.155          let
  26.156 @@ -586,7 +600,7 @@
  26.157    -> nut list -> nut list -> nut NameTable.table -> KK.raw_bound list
  26.158    -> Pretty.T * bool *)
  26.159  fun reconstruct_hol_model {show_skolems, show_datatypes, show_consts}
  26.160 -        ({ext_ctxt as {thy, ctxt, max_bisim_depth, boxes, stds, wfs,
  26.161 +        ({hol_ctxt as {thy, ctxt, max_bisim_depth, boxes, stds, wfs,
  26.162                         user_axioms, debug, binary_ints, destroy_constrs,
  26.163                         specialize, skolemize, star_linear_preds, uncurry,
  26.164                         fast_descrs, tac_timeout, evals, case_names, def_table,
  26.165 @@ -598,7 +612,7 @@
  26.166    let
  26.167      val (wacky_names as (_, base_name, step_name, _), ctxt) =
  26.168        add_wacky_syntax ctxt
  26.169 -    val ext_ctxt =
  26.170 +    val hol_ctxt =
  26.171        {thy = thy, ctxt = ctxt, max_bisim_depth = max_bisim_depth, boxes = boxes,
  26.172         stds = stds, wfs = wfs, user_axioms = user_axioms, debug = debug,
  26.173         binary_ints = binary_ints, destroy_constrs = destroy_constrs,
  26.174 @@ -612,7 +626,7 @@
  26.175         ersatz_table = ersatz_table, skolems = skolems,
  26.176         special_funs = special_funs, unrolled_preds = unrolled_preds,
  26.177         wf_cache = wf_cache, constr_cache = constr_cache}
  26.178 -    val scope = {ext_ctxt = ext_ctxt, card_assigns = card_assigns,
  26.179 +    val scope = {hol_ctxt = hol_ctxt, card_assigns = card_assigns,
  26.180                   bits = bits, bisim_depth = bisim_depth, datatypes = datatypes,
  26.181                   ofs = ofs}
  26.182      (* typ -> typ -> rep -> int list list -> term *)
  26.183 @@ -644,7 +658,7 @@
  26.184              end
  26.185            | ConstName (s, T, _) =>
  26.186              (assign_operator_for_const (s, T),
  26.187 -             user_friendly_const ext_ctxt (base_name, step_name) formats (s, T),
  26.188 +             user_friendly_const hol_ctxt (base_name, step_name) formats (s, T),
  26.189               T)
  26.190            | _ => raise NUT ("Nitpick_Model.reconstruct_hol_model.\
  26.191                              \pretty_for_assign", [name])
  26.192 @@ -724,15 +738,16 @@
  26.193  
  26.194  (* scope -> Time.time option -> nut list -> nut list -> nut NameTable.table
  26.195     -> KK.raw_bound list -> term -> bool option *)
  26.196 -fun prove_hol_model (scope as {ext_ctxt as {thy, ctxt, debug, ...},
  26.197 +fun prove_hol_model (scope as {hol_ctxt as {thy, ctxt, debug, ...},
  26.198                                 card_assigns, ...})
  26.199                      auto_timeout free_names sel_names rel_table bounds prop =
  26.200    let
  26.201 +    val pool = Unsynchronized.ref []
  26.202      (* typ * int -> term *)
  26.203      fun free_type_assm (T, k) =
  26.204        let
  26.205          (* int -> term *)
  26.206 -        val atom = atom true T
  26.207 +        fun atom j = nth_atom pool true T j k
  26.208          fun equation_for_atom j = HOLogic.eq_const T $ Bound 0 $ atom j
  26.209          val eqs = map equation_for_atom (index_seq 0 k)
  26.210          val compreh_assm =
    27.1 --- a/src/HOL/Tools/Nitpick/nitpick_mono.ML	Tue Feb 09 13:54:27 2010 +0100
    27.2 +++ b/src/HOL/Tools/Nitpick/nitpick_mono.ML	Tue Feb 09 17:06:05 2010 +0100
    27.3 @@ -8,10 +8,10 @@
    27.4  signature NITPICK_MONO =
    27.5  sig
    27.6    datatype sign = Plus | Minus
    27.7 -  type extended_context = Nitpick_HOL.extended_context
    27.8 +  type hol_context = Nitpick_HOL.hol_context
    27.9  
   27.10    val formulas_monotonic :
   27.11 -    extended_context -> typ -> sign -> term list -> term list -> term -> bool
   27.12 +    hol_context -> typ -> sign -> term list -> term list -> term -> bool
   27.13  end;
   27.14  
   27.15  structure Nitpick_Mono : NITPICK_MONO =
   27.16 @@ -35,7 +35,7 @@
   27.17    CRec of string * typ list
   27.18  
   27.19  type cdata =
   27.20 -  {ext_ctxt: extended_context,
   27.21 +  {hol_ctxt: hol_context,
   27.22     alpha_T: typ,
   27.23     max_fresh: int Unsynchronized.ref,
   27.24     datatype_cache: ((string * typ list) * ctype) list Unsynchronized.ref,
   27.25 @@ -114,9 +114,9 @@
   27.26    | flatten_ctype (CType (_, Cs)) = maps flatten_ctype Cs
   27.27    | flatten_ctype C = [C]
   27.28  
   27.29 -(* extended_context -> typ -> cdata *)
   27.30 -fun initial_cdata ext_ctxt alpha_T =
   27.31 -  ({ext_ctxt = ext_ctxt, alpha_T = alpha_T, max_fresh = Unsynchronized.ref 0,
   27.32 +(* hol_context -> typ -> cdata *)
   27.33 +fun initial_cdata hol_ctxt alpha_T =
   27.34 +  ({hol_ctxt = hol_ctxt, alpha_T = alpha_T, max_fresh = Unsynchronized.ref 0,
   27.35      datatype_cache = Unsynchronized.ref [],
   27.36      constr_cache = Unsynchronized.ref []} : cdata)
   27.37  
   27.38 @@ -188,7 +188,7 @@
   27.39    in List.app repair_one (!constr_cache) end
   27.40  
   27.41  (* cdata -> typ -> ctype *)
   27.42 -fun fresh_ctype_for_type ({ext_ctxt as {thy, ...}, alpha_T, max_fresh,
   27.43 +fun fresh_ctype_for_type ({hol_ctxt as {thy, ...}, alpha_T, max_fresh,
   27.44                             datatype_cache, constr_cache, ...} : cdata) =
   27.45    let
   27.46      (* typ -> typ -> ctype *)
   27.47 @@ -217,7 +217,7 @@
   27.48            | NONE =>
   27.49              let
   27.50                val _ = Unsynchronized.change datatype_cache (cons (z, CRec z))
   27.51 -              val xs = datatype_constrs ext_ctxt T
   27.52 +              val xs = datatype_constrs hol_ctxt T
   27.53                val (all_Cs, constr_Cs) =
   27.54                  fold_rev (fn (_, T') => fn (all_Cs, constr_Cs) =>
   27.55                               let
   27.56 @@ -264,7 +264,7 @@
   27.57    end
   27.58  
   27.59  (* cdata -> styp -> ctype *)
   27.60 -fun ctype_for_constr (cdata as {ext_ctxt as {thy, ...}, alpha_T, constr_cache,
   27.61 +fun ctype_for_constr (cdata as {hol_ctxt as {thy, ...}, alpha_T, constr_cache,
   27.62                                  ...}) (x as (_, T)) =
   27.63    if could_exist_alpha_sub_ctype thy alpha_T T then
   27.64      case AList.lookup (op =) (!constr_cache) x of
   27.65 @@ -278,8 +278,8 @@
   27.66                   AList.lookup (op =) (!constr_cache) x |> the)
   27.67    else
   27.68      fresh_ctype_for_type cdata T
   27.69 -fun ctype_for_sel (cdata as {ext_ctxt, ...}) (x as (s, _)) =
   27.70 -  x |> boxed_constr_for_sel ext_ctxt |> ctype_for_constr cdata
   27.71 +fun ctype_for_sel (cdata as {hol_ctxt, ...}) (x as (s, _)) =
   27.72 +  x |> boxed_constr_for_sel hol_ctxt |> ctype_for_constr cdata
   27.73      |> sel_ctype_from_constr_ctype s
   27.74  
   27.75  (* literal list -> ctype -> ctype *)
   27.76 @@ -549,7 +549,7 @@
   27.77    handle List.Empty => initial_gamma
   27.78  
   27.79  (* cdata -> term -> accumulator -> ctype * accumulator *)
   27.80 -fun consider_term (cdata as {ext_ctxt as {ctxt, thy, def_table, ...}, alpha_T,
   27.81 +fun consider_term (cdata as {hol_ctxt as {ctxt, thy, def_table, ...}, alpha_T,
   27.82                               max_fresh, ...}) =
   27.83    let
   27.84      (* typ -> ctype *)
   27.85 @@ -806,7 +806,7 @@
   27.86    in do_term end
   27.87  
   27.88  (* cdata -> sign -> term -> accumulator -> accumulator *)
   27.89 -fun consider_general_formula (cdata as {ext_ctxt as {ctxt, ...}, ...}) =
   27.90 +fun consider_general_formula (cdata as {hol_ctxt as {ctxt, ...}, ...}) =
   27.91    let
   27.92      (* typ -> ctype *)
   27.93      val ctype_for = fresh_ctype_for_type cdata
   27.94 @@ -895,7 +895,7 @@
   27.95    not (is_harmless_axiom t) ? consider_general_formula cdata sn t
   27.96  
   27.97  (* cdata -> term -> accumulator -> accumulator *)
   27.98 -fun consider_definitional_axiom (cdata as {ext_ctxt as {thy, ...}, ...}) t =
   27.99 +fun consider_definitional_axiom (cdata as {hol_ctxt as {thy, ...}, ...}) t =
  27.100    if not (is_constr_pattern_formula thy t) then
  27.101      consider_nondefinitional_axiom cdata Plus t
  27.102    else if is_harmless_axiom t then
  27.103 @@ -945,13 +945,13 @@
  27.104    map (fn (x, C) => string_for_ctype_of_term ctxt lits (Const x) C) consts
  27.105    |> cat_lines |> print_g
  27.106  
  27.107 -(* extended_context -> typ -> sign -> term list -> term list -> term -> bool *)
  27.108 -fun formulas_monotonic (ext_ctxt as {ctxt, ...}) alpha_T sn def_ts nondef_ts
  27.109 +(* hol_context -> typ -> sign -> term list -> term list -> term -> bool *)
  27.110 +fun formulas_monotonic (hol_ctxt as {ctxt, ...}) alpha_T sn def_ts nondef_ts
  27.111                         core_t =
  27.112    let
  27.113      val _ = print_g ("****** " ^ string_for_ctype CAlpha ^ " is " ^
  27.114                       Syntax.string_of_typ ctxt alpha_T)
  27.115 -    val cdata as {max_fresh, ...} = initial_cdata ext_ctxt alpha_T
  27.116 +    val cdata as {max_fresh, ...} = initial_cdata hol_ctxt alpha_T
  27.117      val (gamma, cset) =
  27.118        (initial_gamma, slack)
  27.119        |> fold (consider_definitional_axiom cdata) def_ts
    28.1 --- a/src/HOL/Tools/Nitpick/nitpick_nut.ML	Tue Feb 09 13:54:27 2010 +0100
    28.2 +++ b/src/HOL/Tools/Nitpick/nitpick_nut.ML	Tue Feb 09 17:06:05 2010 +0100
    28.3 @@ -8,7 +8,7 @@
    28.4  signature NITPICK_NUT =
    28.5  sig
    28.6    type special_fun = Nitpick_HOL.special_fun
    28.7 -  type extended_context = Nitpick_HOL.extended_context
    28.8 +  type hol_context = Nitpick_HOL.hol_context
    28.9    type scope = Nitpick_Scope.scope
   28.10    type name_pool = Nitpick_Peephole.name_pool
   28.11    type rep = Nitpick_Rep.rep
   28.12 @@ -106,7 +106,7 @@
   28.13    val name_ord : (nut * nut) -> order
   28.14    val the_name : 'a NameTable.table -> nut -> 'a
   28.15    val the_rel : nut NameTable.table -> nut -> Kodkod.n_ary_index
   28.16 -  val nut_from_term : extended_context -> op2 -> term -> nut
   28.17 +  val nut_from_term : hol_context -> op2 -> term -> nut
   28.18    val choose_reps_for_free_vars :
   28.19      scope -> nut list -> rep NameTable.table -> nut list * rep NameTable.table
   28.20    val choose_reps_for_consts :
   28.21 @@ -466,8 +466,8 @@
   28.22  fun factorize (z as (Type ("*", _), _)) = maps factorize [mk_fst z, mk_snd z]
   28.23    | factorize z = [z]
   28.24  
   28.25 -(* extended_context -> op2 -> term -> nut *)
   28.26 -fun nut_from_term (ext_ctxt as {thy, fast_descrs, special_funs, ...}) eq =
   28.27 +(* hol_context -> op2 -> term -> nut *)
   28.28 +fun nut_from_term (hol_ctxt as {thy, fast_descrs, special_funs, ...}) eq =
   28.29    let
   28.30      (* string list -> typ list -> term -> nut *)
   28.31      fun aux eq ss Ts t =
   28.32 @@ -597,7 +597,7 @@
   28.33            Op2 (Image, nth_range_type 2 T, Any, sub t1, sub t2)
   28.34          | (Const (@{const_name Suc}, T), []) => Cst (Suc, T, Any)
   28.35          | (Const (@{const_name finite}, T), [t1]) =>
   28.36 -          (if is_finite_type ext_ctxt (domain_type T) then
   28.37 +          (if is_finite_type hol_ctxt (domain_type T) then
   28.38               Cst (True, bool_T, Any)
   28.39             else case t1 of
   28.40               Const (@{const_name top}, _) => Cst (False, bool_T, Any)
   28.41 @@ -712,7 +712,7 @@
   28.42    in (v :: vs, NameTable.update (v, R) table) end
   28.43  (* scope -> bool -> nut -> nut list * rep NameTable.table
   28.44     -> nut list * rep NameTable.table *)
   28.45 -fun choose_rep_for_const (scope as {ext_ctxt as {thy, ctxt, ...}, datatypes,
   28.46 +fun choose_rep_for_const (scope as {hol_ctxt as {thy, ctxt, ...}, datatypes,
   28.47                                      ofs, ...}) all_exact v (vs, table) =
   28.48    let
   28.49      val x as (s, T) = (nickname_of v, type_of v)
   28.50 @@ -747,10 +747,10 @@
   28.51  
   28.52  (* scope -> styp -> int -> nut list * rep NameTable.table
   28.53     -> nut list * rep NameTable.table *)
   28.54 -fun choose_rep_for_nth_sel_for_constr (scope as {ext_ctxt, ...}) (x as (_, T)) n
   28.55 +fun choose_rep_for_nth_sel_for_constr (scope as {hol_ctxt, ...}) (x as (_, T)) n
   28.56                                        (vs, table) =
   28.57    let
   28.58 -    val (s', T') = boxed_nth_sel_for_constr ext_ctxt x n
   28.59 +    val (s', T') = boxed_nth_sel_for_constr hol_ctxt x n
   28.60      val R' = if n = ~1 orelse is_word_type (body_type T) orelse
   28.61                  (is_fun_type (range_type T') andalso
   28.62                   is_boolean_type (body_type T')) then
   28.63 @@ -890,7 +890,7 @@
   28.64    | untuple f u = if rep_of u = Unit then [] else [f u]
   28.65  
   28.66  (* scope -> bool -> rep NameTable.table -> bool -> nut -> nut *)
   28.67 -fun choose_reps_in_nut (scope as {ext_ctxt as {thy, ctxt, ...}, card_assigns,
   28.68 +fun choose_reps_in_nut (scope as {hol_ctxt as {thy, ctxt, ...}, card_assigns,
   28.69                                    bits, datatypes, ofs, ...})
   28.70                         liberal table def =
   28.71    let
    29.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    29.2 +++ b/src/HOL/Tools/Nitpick/nitpick_preproc.ML	Tue Feb 09 17:06:05 2010 +0100
    29.3 @@ -0,0 +1,1431 @@
    29.4 +(*  Title:      HOL/Tools/Nitpick/nitpick_preproc.ML
    29.5 +    Author:     Jasmin Blanchette, TU Muenchen
    29.6 +    Copyright   2008, 2009, 2010
    29.7 +
    29.8 +Nitpick's HOL preprocessor.
    29.9 +*)
   29.10 +
   29.11 +signature NITPICK_PREPROC =
   29.12 +sig
   29.13 +  type hol_context = Nitpick_HOL.hol_context
   29.14 +  val preprocess_term :
   29.15 +    hol_context -> term -> ((term list * term list) * (bool * bool)) * term
   29.16 +end
   29.17 +
   29.18 +structure Nitpick_Preproc : NITPICK_PREPROC =
   29.19 +struct
   29.20 +
   29.21 +open Nitpick_Util
   29.22 +open Nitpick_HOL
   29.23 +
   29.24 +(* polarity -> string -> bool *)
   29.25 +fun is_positive_existential polar quant_s =
   29.26 +  (polar = Pos andalso quant_s = @{const_name Ex}) orelse
   29.27 +  (polar = Neg andalso quant_s <> @{const_name Ex})
   29.28 +
   29.29 +(** Binary coding of integers **)
   29.30 +
   29.31 +(* If a formula contains a numeral whose absolute value is more than this
   29.32 +   threshold, the unary coding is likely not to work well and we prefer the
   29.33 +   binary coding. *)
   29.34 +val binary_int_threshold = 3
   29.35 +
   29.36 +(* term -> bool *)
   29.37 +fun may_use_binary_ints (t1 $ t2) =
   29.38 +    may_use_binary_ints t1 andalso may_use_binary_ints t2
   29.39 +  | may_use_binary_ints (t as Const (s, _)) =
   29.40 +    t <> @{const Suc} andalso
   29.41 +    not (member (op =) [@{const_name Abs_Frac}, @{const_name Rep_Frac},
   29.42 +                        @{const_name nat_gcd}, @{const_name nat_lcm},
   29.43 +                        @{const_name Frac}, @{const_name norm_frac}] s)
   29.44 +  | may_use_binary_ints (Abs (_, _, t')) = may_use_binary_ints t'
   29.45 +  | may_use_binary_ints _ = true
   29.46 +fun should_use_binary_ints (t1 $ t2) =
   29.47 +    should_use_binary_ints t1 orelse should_use_binary_ints t2
   29.48 +  | should_use_binary_ints (Const (s, _)) =
   29.49 +    member (op =) [@{const_name times_nat_inst.times_nat},
   29.50 +                   @{const_name div_nat_inst.div_nat},
   29.51 +                   @{const_name times_int_inst.times_int},
   29.52 +                   @{const_name div_int_inst.div_int}] s orelse
   29.53 +    (String.isPrefix numeral_prefix s andalso
   29.54 +     let val n = the (Int.fromString (unprefix numeral_prefix s)) in
   29.55 +       n < ~ binary_int_threshold orelse n > binary_int_threshold
   29.56 +     end)
   29.57 +  | should_use_binary_ints (Abs (_, _, t')) = should_use_binary_ints t'
   29.58 +  | should_use_binary_ints _ = false
   29.59 +
   29.60 +(* typ -> typ *)
   29.61 +fun binarize_nat_and_int_in_type @{typ nat} = @{typ "unsigned_bit word"}
   29.62 +  | binarize_nat_and_int_in_type @{typ int} = @{typ "signed_bit word"}
   29.63 +  | binarize_nat_and_int_in_type (Type (s, Ts)) =
   29.64 +    Type (s, map binarize_nat_and_int_in_type Ts)
   29.65 +  | binarize_nat_and_int_in_type T = T
   29.66 +(* term -> term *)
   29.67 +val binarize_nat_and_int_in_term = map_types binarize_nat_and_int_in_type
   29.68 +
   29.69 +(** Uncurrying **)
   29.70 +
   29.71 +(* theory -> term -> int Termtab.tab -> int Termtab.tab *)
   29.72 +fun add_to_uncurry_table thy t =
   29.73 +  let
   29.74 +    (* term -> term list -> int Termtab.tab -> int Termtab.tab *)
   29.75 +    fun aux (t1 $ t2) args table =
   29.76 +        let val table = aux t2 [] table in aux t1 (t2 :: args) table end
   29.77 +      | aux (Abs (_, _, t')) _ table = aux t' [] table
   29.78 +      | aux (t as Const (x as (s, _))) args table =
   29.79 +        if is_built_in_const true x orelse is_constr_like thy x orelse
   29.80 +           is_sel s orelse s = @{const_name Sigma} then
   29.81 +          table
   29.82 +        else
   29.83 +          Termtab.map_default (t, 65536) (curry Int.min (length args)) table
   29.84 +      | aux _ _ table = table
   29.85 +  in aux t [] end
   29.86 +
   29.87 +(* int -> int -> string *)
   29.88 +fun uncurry_prefix_for k j =
   29.89 +  uncurry_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
   29.90 +
   29.91 +(* int Termtab.tab term -> term *)
   29.92 +fun uncurry_term table t =
   29.93 +  let
   29.94 +    (* term -> term list -> term *)
   29.95 +    fun aux (t1 $ t2) args = aux t1 (aux t2 [] :: args)
   29.96 +      | aux (Abs (s, T, t')) args = betapplys (Abs (s, T, aux t' []), args)
   29.97 +      | aux (t as Const (s, T)) args =
   29.98 +        (case Termtab.lookup table t of
   29.99 +           SOME n =>
  29.100 +           if n >= 2 then
  29.101 +             let
  29.102 +               val (arg_Ts, rest_T) = strip_n_binders n T
  29.103 +               val j =
  29.104 +                 if hd arg_Ts = @{typ bisim_iterator} orelse
  29.105 +                    is_fp_iterator_type (hd arg_Ts) then
  29.106 +                   1
  29.107 +                 else case find_index (not_equal bool_T) arg_Ts of
  29.108 +                   ~1 => n
  29.109 +                 | j => j
  29.110 +               val ((before_args, tuple_args), after_args) =
  29.111 +                 args |> chop n |>> chop j
  29.112 +               val ((before_arg_Ts, tuple_arg_Ts), rest_T) =
  29.113 +                 T |> strip_n_binders n |>> chop j
  29.114 +               val tuple_T = HOLogic.mk_tupleT tuple_arg_Ts
  29.115 +             in
  29.116 +               if n - j < 2 then
  29.117 +                 betapplys (t, args)
  29.118 +               else
  29.119 +                 betapplys (Const (uncurry_prefix_for (n - j) j ^ s,
  29.120 +                                   before_arg_Ts ---> tuple_T --> rest_T),
  29.121 +                            before_args @ [mk_flat_tuple tuple_T tuple_args] @
  29.122 +                            after_args)
  29.123 +             end
  29.124 +           else
  29.125 +             betapplys (t, args)
  29.126 +         | NONE => betapplys (t, args))
  29.127 +      | aux t args = betapplys (t, args)
  29.128 +  in aux t [] end
  29.129 +
  29.130 +(** Boxing **)
  29.131 +
  29.132 +(* hol_context -> typ -> term -> term *)
  29.133 +fun constr_expand (hol_ctxt as {thy, ...}) T t =
  29.134 +  (case head_of t of
  29.135 +     Const x => if is_constr_like thy x then t else raise SAME ()
  29.136 +   | _ => raise SAME ())
  29.137 +  handle SAME () =>
  29.138 +         let
  29.139 +           val x' as (_, T') =
  29.140 +             if is_pair_type T then
  29.141 +               let val (T1, T2) = HOLogic.dest_prodT T in
  29.142 +                 (@{const_name Pair}, T1 --> T2 --> T)
  29.143 +               end
  29.144 +             else
  29.145 +               datatype_constrs hol_ctxt T |> hd
  29.146 +           val arg_Ts = binder_types T'
  29.147 +         in
  29.148 +           list_comb (Const x', map2 (select_nth_constr_arg thy x' t)
  29.149 +                                     (index_seq 0 (length arg_Ts)) arg_Ts)
  29.150 +         end
  29.151 +
  29.152 +(* hol_context -> bool -> term -> term *)
  29.153 +fun box_fun_and_pair_in_term (hol_ctxt as {thy, fast_descrs, ...}) def orig_t =
  29.154 +  let
  29.155 +    (* typ -> typ *)
  29.156 +    fun box_relational_operator_type (Type ("fun", Ts)) =
  29.157 +        Type ("fun", map box_relational_operator_type Ts)
  29.158 +      | box_relational_operator_type (Type ("*", Ts)) =
  29.159 +        Type ("*", map (box_type hol_ctxt InPair) Ts)
  29.160 +      | box_relational_operator_type T = T
  29.161 +    (* (term -> term) -> int -> term -> term *)
  29.162 +    fun coerce_bound_no f j t =
  29.163 +      case t of
  29.164 +        t1 $ t2 => coerce_bound_no f j t1 $ coerce_bound_no f j t2
  29.165 +      | Abs (s, T, t') => Abs (s, T, coerce_bound_no f (j + 1) t')
  29.166 +      | Bound j' => if j' = j then f t else t
  29.167 +      | _ => t
  29.168 +    (* typ -> typ -> term -> term *)
  29.169 +    fun coerce_bound_0_in_term new_T old_T =
  29.170 +      old_T <> new_T ? coerce_bound_no (coerce_term [new_T] old_T new_T) 0
  29.171 +    (* typ list -> typ -> term -> term *)
  29.172 +    and coerce_term Ts new_T old_T t =
  29.173 +      if old_T = new_T then
  29.174 +        t
  29.175 +      else
  29.176 +        case (new_T, old_T) of
  29.177 +          (Type (new_s, new_Ts as [new_T1, new_T2]),
  29.178 +           Type ("fun", [old_T1, old_T2])) =>
  29.179 +          (case eta_expand Ts t 1 of
  29.180 +             Abs (s, _, t') =>
  29.181 +             Abs (s, new_T1,
  29.182 +                  t' |> coerce_bound_0_in_term new_T1 old_T1
  29.183 +                     |> coerce_term (new_T1 :: Ts) new_T2 old_T2)
  29.184 +             |> Envir.eta_contract
  29.185 +             |> new_s <> "fun"
  29.186 +                ? construct_value thy (@{const_name FunBox},
  29.187 +                                       Type ("fun", new_Ts) --> new_T) o single
  29.188 +           | t' => raise TERM ("Nitpick_Preproc.box_fun_and_pair_in_term.\
  29.189 +                               \coerce_term", [t']))
  29.190 +        | (Type (new_s, new_Ts as [new_T1, new_T2]),
  29.191 +           Type (old_s, old_Ts as [old_T1, old_T2])) =>
  29.192 +          if old_s = @{type_name fun_box} orelse
  29.193 +             old_s = @{type_name pair_box} orelse old_s = "*" then
  29.194 +            case constr_expand hol_ctxt old_T t of
  29.195 +              Const (@{const_name FunBox}, _) $ t1 =>
  29.196 +              if new_s = "fun" then
  29.197 +                coerce_term Ts new_T (Type ("fun", old_Ts)) t1
  29.198 +              else
  29.199 +                construct_value thy
  29.200 +                    (@{const_name FunBox}, Type ("fun", new_Ts) --> new_T)
  29.201 +                     [coerce_term Ts (Type ("fun", new_Ts))
  29.202 +                                  (Type ("fun", old_Ts)) t1]
  29.203 +            | Const _ $ t1 $ t2 =>
  29.204 +              construct_value thy
  29.205 +                  (if new_s = "*" then @{const_name Pair}
  29.206 +                   else @{const_name PairBox}, new_Ts ---> new_T)
  29.207 +                  [coerce_term Ts new_T1 old_T1 t1,
  29.208 +                   coerce_term Ts new_T2 old_T2 t2]
  29.209 +            | t' => raise TERM ("Nitpick_Preproc.box_fun_and_pair_in_term.\
  29.210 +                                \coerce_term", [t'])
  29.211 +          else
  29.212 +            raise TYPE ("coerce_term", [new_T, old_T], [t])
  29.213 +        | _ => raise TYPE ("coerce_term", [new_T, old_T], [t])
  29.214 +    (* indexname * typ -> typ * term -> typ option list -> typ option list *)
  29.215 +    fun add_boxed_types_for_var (z as (_, T)) (T', t') =
  29.216 +      case t' of
  29.217 +        Var z' => z' = z ? insert (op =) T'
  29.218 +      | Const (@{const_name Pair}, _) $ t1 $ t2 =>
  29.219 +        (case T' of
  29.220 +           Type (_, [T1, T2]) =>
  29.221 +           fold (add_boxed_types_for_var z) [(T1, t1), (T2, t2)]
  29.222 +         | _ => raise TYPE ("Nitpick_Preproc.box_fun_and_pair_in_term.\
  29.223 +                            \add_boxed_types_for_var", [T'], []))
  29.224 +      | _ => exists_subterm (curry (op =) (Var z)) t' ? insert (op =) T
  29.225 +    (* typ list -> typ list -> term -> indexname * typ -> typ *)
  29.226 +    fun box_var_in_def new_Ts old_Ts t (z as (_, T)) =
  29.227 +      case t of
  29.228 +        @{const Trueprop} $ t1 => box_var_in_def new_Ts old_Ts t1 z
  29.229 +      | Const (s0, _) $ t1 $ _ =>
  29.230 +        if s0 = @{const_name "=="} orelse s0 = @{const_name "op ="} then
  29.231 +          let
  29.232 +            val (t', args) = strip_comb t1
  29.233 +            val T' = fastype_of1 (new_Ts, do_term new_Ts old_Ts Neut t')
  29.234 +          in
  29.235 +            case fold (add_boxed_types_for_var z)
  29.236 +                      (fst (strip_n_binders (length args) T') ~~ args) [] of
  29.237 +              [T''] => T''
  29.238 +            | _ => T
  29.239 +          end
  29.240 +        else
  29.241 +          T
  29.242 +      | _ => T
  29.243 +    (* typ list -> typ list -> polarity -> string -> typ -> string -> typ
  29.244 +       -> term -> term *)
  29.245 +    and do_quantifier new_Ts old_Ts polar quant_s quant_T abs_s abs_T t =
  29.246 +      let
  29.247 +        val abs_T' =
  29.248 +          if polar = Neut orelse is_positive_existential polar quant_s then
  29.249 +            box_type hol_ctxt InFunLHS abs_T
  29.250 +          else
  29.251 +            abs_T
  29.252 +        val body_T = body_type quant_T
  29.253 +      in
  29.254 +        Const (quant_s, (abs_T' --> body_T) --> body_T)
  29.255 +        $ Abs (abs_s, abs_T',
  29.256 +               t |> do_term (abs_T' :: new_Ts) (abs_T :: old_Ts) polar)
  29.257 +      end
  29.258 +    (* typ list -> typ list -> string -> typ -> term -> term -> term *)
  29.259 +    and do_equals new_Ts old_Ts s0 T0 t1 t2 =
  29.260 +      let
  29.261 +        val (t1, t2) = pairself (do_term new_Ts old_Ts Neut) (t1, t2)
  29.262 +        val (T1, T2) = pairself (curry fastype_of1 new_Ts) (t1, t2)
  29.263 +        val T = [T1, T2] |> sort TermOrd.typ_ord |> List.last
  29.264 +      in
  29.265 +        list_comb (Const (s0, T --> T --> body_type T0),
  29.266 +                   map2 (coerce_term new_Ts T) [T1, T2] [t1, t2])
  29.267 +      end
  29.268 +    (* string -> typ -> term *)
  29.269 +    and do_description_operator s T =
  29.270 +      let val T1 = box_type hol_ctxt InFunLHS (range_type T) in
  29.271 +        Const (s, (T1 --> bool_T) --> T1)
  29.272 +      end
  29.273 +    (* typ list -> typ list -> polarity -> term -> term *)
  29.274 +    and do_term new_Ts old_Ts polar t =
  29.275 +      case t of
  29.276 +        Const (s0 as @{const_name all}, T0) $ Abs (s1, T1, t1) =>
  29.277 +        do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
  29.278 +      | Const (s0 as @{const_name "=="}, T0) $ t1 $ t2 =>
  29.279 +        do_equals new_Ts old_Ts s0 T0 t1 t2
  29.280 +      | @{const "==>"} $ t1 $ t2 =>
  29.281 +        @{const "==>"} $ do_term new_Ts old_Ts (flip_polarity polar) t1
  29.282 +        $ do_term new_Ts old_Ts polar t2
  29.283 +      | @{const Pure.conjunction} $ t1 $ t2 =>
  29.284 +        @{const Pure.conjunction} $ do_term new_Ts old_Ts polar t1
  29.285 +        $ do_term new_Ts old_Ts polar t2
  29.286 +      | @{const Trueprop} $ t1 =>
  29.287 +        @{const Trueprop} $ do_term new_Ts old_Ts polar t1
  29.288 +      | @{const Not} $ t1 =>
  29.289 +        @{const Not} $ do_term new_Ts old_Ts (flip_polarity polar) t1
  29.290 +      | Const (s0 as @{const_name All}, T0) $ Abs (s1, T1, t1) =>
  29.291 +        do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
  29.292 +      | Const (s0 as @{const_name Ex}, T0) $ Abs (s1, T1, t1) =>
  29.293 +        do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
  29.294 +      | Const (s0 as @{const_name "op ="}, T0) $ t1 $ t2 =>
  29.295 +        do_equals new_Ts old_Ts s0 T0 t1 t2
  29.296 +      | @{const "op &"} $ t1 $ t2 =>
  29.297 +        @{const "op &"} $ do_term new_Ts old_Ts polar t1
  29.298 +        $ do_term new_Ts old_Ts polar t2
  29.299 +      | @{const "op |"} $ t1 $ t2 =>
  29.300 +        @{const "op |"} $ do_term new_Ts old_Ts polar t1
  29.301 +        $ do_term new_Ts old_Ts polar t2
  29.302 +      | @{const "op -->"} $ t1 $ t2 =>
  29.303 +        @{const "op -->"} $ do_term new_Ts old_Ts (flip_polarity polar) t1
  29.304 +        $ do_term new_Ts old_Ts polar t2
  29.305 +      | Const (s as @{const_name The}, T) => do_description_operator s T
  29.306 +      | Const (s as @{const_name Eps}, T) => do_description_operator s T
  29.307 +      | Const (@{const_name quot_normal}, Type ("fun", [_, T2])) =>
  29.308 +        let val T' = box_type hol_ctxt InSel T2 in
  29.309 +          Const (@{const_name quot_normal}, T' --> T')
  29.310 +        end
  29.311 +      | Const (s as @{const_name Tha}, T) => do_description_operator s T
  29.312 +      | Const (x as (s, T)) =>
  29.313 +        Const (s, if s = @{const_name converse} orelse
  29.314 +                     s = @{const_name trancl} then
  29.315 +                    box_relational_operator_type T
  29.316 +                  else if is_built_in_const fast_descrs x orelse
  29.317 +                          s = @{const_name Sigma} then
  29.318 +                    T
  29.319 +                  else if is_constr_like thy x then
  29.320 +                    box_type hol_ctxt InConstr T
  29.321 +                  else if is_sel s
  29.322 +                       orelse is_rep_fun thy x then
  29.323 +                    box_type hol_ctxt InSel T
  29.324 +                  else
  29.325 +                    box_type hol_ctxt InExpr T)
  29.326 +      | t1 $ Abs (s, T, t2') =>
  29.327 +        let
  29.328 +          val t1 = do_term new_Ts old_Ts Neut t1
  29.329 +          val T1 = fastype_of1 (new_Ts, t1)
  29.330 +          val (s1, Ts1) = dest_Type T1
  29.331 +          val T' = hd (snd (dest_Type (hd Ts1)))
  29.332 +          val t2 = Abs (s, T', do_term (T' :: new_Ts) (T :: old_Ts) Neut t2')
  29.333 +          val T2 = fastype_of1 (new_Ts, t2)
  29.334 +          val t2 = coerce_term new_Ts (hd Ts1) T2 t2
  29.335 +        in
  29.336 +          betapply (if s1 = "fun" then
  29.337 +                      t1
  29.338 +                    else
  29.339 +                      select_nth_constr_arg thy
  29.340 +                          (@{const_name FunBox}, Type ("fun", Ts1) --> T1) t1 0
  29.341 +                          (Type ("fun", Ts1)), t2)
  29.342 +        end
  29.343 +      | t1 $ t2 =>
  29.344 +        let
  29.345 +          val t1 = do_term new_Ts old_Ts Neut t1
  29.346 +          val T1 = fastype_of1 (new_Ts, t1)
  29.347 +          val (s1, Ts1) = dest_Type T1
  29.348 +          val t2 = do_term new_Ts old_Ts Neut t2
  29.349 +          val T2 = fastype_of1 (new_Ts, t2)
  29.350 +          val t2 = coerce_term new_Ts (hd Ts1) T2 t2
  29.351 +        in
  29.352 +          betapply (if s1 = "fun" then
  29.353 +                      t1
  29.354 +                    else
  29.355 +                      select_nth_constr_arg thy
  29.356 +                          (@{const_name FunBox}, Type ("fun", Ts1) --> T1) t1 0
  29.357 +                          (Type ("fun", Ts1)), t2)
  29.358 +        end
  29.359 +      | Free (s, T) => Free (s, box_type hol_ctxt InExpr T)
  29.360 +      | Var (z as (x, T)) =>
  29.361 +        Var (x, if def then box_var_in_def new_Ts old_Ts orig_t z
  29.362 +                else box_type hol_ctxt InExpr T)
  29.363 +      | Bound _ => t
  29.364 +      | Abs (s, T, t') =>
  29.365 +        Abs (s, T, do_term (T :: new_Ts) (T :: old_Ts) Neut t')
  29.366 +  in do_term [] [] Pos orig_t end
  29.367 +
  29.368 +(** Destruction of constructors **)
  29.369 +
  29.370 +val val_var_prefix = nitpick_prefix ^ "v"
  29.371 +
  29.372 +(* typ list -> int -> int -> int -> term -> term *)
  29.373 +fun fresh_value_var Ts k n j t =
  29.374 +  Var ((val_var_prefix ^ nat_subscript (n - j), k), fastype_of1 (Ts, t))
  29.375 +
  29.376 +(* typ list -> int -> term -> bool *)
  29.377 +fun has_heavy_bounds_or_vars Ts level t =
  29.378 +  let
  29.379 +    (* typ list -> bool *)
  29.380 +    fun aux [] = false
  29.381 +      | aux [T] = is_fun_type T orelse is_pair_type T
  29.382 +      | aux _ = true
  29.383 +  in aux (map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t)) end
  29.384 +
  29.385 +(* theory -> typ list -> bool -> int -> int -> term -> term list -> term list
  29.386 +   -> term * term list *)
  29.387 +fun pull_out_constr_comb thy Ts relax k level t args seen =
  29.388 +  let val t_comb = list_comb (t, args) in
  29.389 +    case t of
  29.390 +      Const x =>
  29.391 +      if not relax andalso is_constr thy x andalso
  29.392 +         not (is_fun_type (fastype_of1 (Ts, t_comb))) andalso
  29.393 +         has_heavy_bounds_or_vars Ts level t_comb andalso
  29.394 +         not (loose_bvar (t_comb, level)) then
  29.395 +        let
  29.396 +          val (j, seen) = case find_index (curry (op =) t_comb) seen of
  29.397 +                            ~1 => (0, t_comb :: seen)
  29.398 +                          | j => (j, seen)
  29.399 +        in (fresh_value_var Ts k (length seen) j t_comb, seen) end
  29.400 +      else
  29.401 +        (t_comb, seen)
  29.402 +    | _ => (t_comb, seen)
  29.403 +  end
  29.404 +
  29.405 +(* (term -> term) -> typ list -> int -> term list -> term list *)
  29.406 +fun equations_for_pulled_out_constrs mk_eq Ts k seen =
  29.407 +  let val n = length seen in
  29.408 +    map2 (fn j => fn t => mk_eq (fresh_value_var Ts k n j t, t))
  29.409 +         (index_seq 0 n) seen
  29.410 +  end
  29.411 +
  29.412 +(* theory -> bool -> term -> term *)
  29.413 +fun pull_out_universal_constrs thy def t =
  29.414 +  let
  29.415 +    val k = maxidx_of_term t + 1
  29.416 +    (* typ list -> bool -> term -> term list -> term list -> term * term list *)
  29.417 +    fun do_term Ts def t args seen =
  29.418 +      case t of
  29.419 +        (t0 as Const (@{const_name "=="}, _)) $ t1 $ t2 =>
  29.420 +        do_eq_or_imp Ts true def t0 t1 t2 seen
  29.421 +      | (t0 as @{const "==>"}) $ t1 $ t2 =>
  29.422 +        if def then (t, []) else do_eq_or_imp Ts false def t0 t1 t2 seen
  29.423 +      | (t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2 =>
  29.424 +        do_eq_or_imp Ts true def t0 t1 t2 seen
  29.425 +      | (t0 as @{const "op -->"}) $ t1 $ t2 =>
  29.426 +        do_eq_or_imp Ts false def t0 t1 t2 seen
  29.427 +      | Abs (s, T, t') =>
  29.428 +        let val (t', seen) = do_term (T :: Ts) def t' [] seen in
  29.429 +          (list_comb (Abs (s, T, t'), args), seen)
  29.430 +        end
  29.431 +      | t1 $ t2 =>
  29.432 +        let val (t2, seen) = do_term Ts def t2 [] seen in
  29.433 +          do_term Ts def t1 (t2 :: args) seen
  29.434 +        end
  29.435 +      | _ => pull_out_constr_comb thy Ts def k 0 t args seen
  29.436 +    (* typ list -> bool -> bool -> term -> term -> term -> term list
  29.437 +       -> term * term list *)
  29.438 +    and do_eq_or_imp Ts eq def t0 t1 t2 seen =
  29.439 +      let
  29.440 +        val (t2, seen) = if eq andalso def then (t2, seen)
  29.441 +                         else do_term Ts false t2 [] seen
  29.442 +        val (t1, seen) = do_term Ts false t1 [] seen
  29.443 +      in (t0 $ t1 $ t2, seen) end
  29.444 +    val (concl, seen) = do_term [] def t [] []
  29.445 +  in
  29.446 +    Logic.list_implies (equations_for_pulled_out_constrs Logic.mk_equals [] k
  29.447 +                                                         seen, concl)
  29.448 +  end
  29.449 +
  29.450 +(* term -> term -> term *)
  29.451 +fun mk_exists v t =
  29.452 +  HOLogic.exists_const (fastype_of v) $ lambda v (incr_boundvars 1 t)
  29.453 +
  29.454 +(* theory -> term -> term *)
  29.455 +fun pull_out_existential_constrs thy t =
  29.456 +  let
  29.457 +    val k = maxidx_of_term t + 1
  29.458 +    (* typ list -> int -> term -> term list -> term list -> term * term list *)
  29.459 +    fun aux Ts num_exists t args seen =
  29.460 +      case t of
  29.461 +        (t0 as Const (@{const_name Ex}, _)) $ Abs (s1, T1, t1) =>
  29.462 +        let
  29.463 +          val (t1, seen') = aux (T1 :: Ts) (num_exists + 1) t1 [] []
  29.464 +          val n = length seen'
  29.465 +          (* unit -> term list *)
  29.466 +          fun vars () = map2 (fresh_value_var Ts k n) (index_seq 0 n) seen'
  29.467 +        in
  29.468 +          (equations_for_pulled_out_constrs HOLogic.mk_eq Ts k seen'
  29.469 +           |> List.foldl s_conj t1 |> fold mk_exists (vars ())
  29.470 +           |> curry3 Abs s1 T1 |> curry (op $) t0, seen)
  29.471 +        end
  29.472 +      | t1 $ t2 =>
  29.473 +        let val (t2, seen) = aux Ts num_exists t2 [] seen in
  29.474 +          aux Ts num_exists t1 (t2 :: args) seen
  29.475 +        end
  29.476 +      | Abs (s, T, t') =>
  29.477 +        let
  29.478 +          val (t', seen) = aux (T :: Ts) 0 t' [] (map (incr_boundvars 1) seen)
  29.479 +        in (list_comb (Abs (s, T, t'), args), map (incr_boundvars ~1) seen) end
  29.480 +      | _ =>
  29.481 +        if num_exists > 0 then
  29.482 +          pull_out_constr_comb thy Ts false k num_exists t args seen
  29.483 +        else
  29.484 +          (list_comb (t, args), seen)
  29.485 +  in aux [] 0 t [] [] |> fst end
  29.486 +
  29.487 +(* hol_context -> bool -> term -> term *)
  29.488 +fun destroy_pulled_out_constrs (hol_ctxt as {thy, ...}) axiom t =
  29.489 +  let
  29.490 +    (* styp -> int *)
  29.491 +    val num_occs_of_var =
  29.492 +      fold_aterms (fn Var z => (fn f => fn z' => f z' |> z = z' ? Integer.add 1)
  29.493 +                    | _ => I) t (K 0)
  29.494 +    (* bool -> term -> term *)
  29.495 +    fun aux careful ((t0 as Const (@{const_name "=="}, _)) $ t1 $ t2) =
  29.496 +        aux_eq careful true t0 t1 t2
  29.497 +      | aux careful ((t0 as @{const "==>"}) $ t1 $ t2) =
  29.498 +        t0 $ aux false t1 $ aux careful t2
  29.499 +      | aux careful ((t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2) =
  29.500 +        aux_eq careful true t0 t1 t2
  29.501 +      | aux careful ((t0 as @{const "op -->"}) $ t1 $ t2) =
  29.502 +        t0 $ aux false t1 $ aux careful t2
  29.503 +      | aux careful (Abs (s, T, t')) = Abs (s, T, aux careful t')
  29.504 +      | aux careful (t1 $ t2) = aux careful t1 $ aux careful t2
  29.505 +      | aux _ t = t
  29.506 +    (* bool -> bool -> term -> term -> term -> term *)
  29.507 +    and aux_eq careful pass1 t0 t1 t2 =
  29.508 +      ((if careful then
  29.509 +          raise SAME ()
  29.510 +        else if axiom andalso is_Var t2 andalso
  29.511 +                num_occs_of_var (dest_Var t2) = 1 then
  29.512 +          @{const True}
  29.513 +        else case strip_comb t2 of
  29.514 +          (* The first case is not as general as it could be. *)
  29.515 +          (Const (@{const_name PairBox}, _),
  29.516 +                  [Const (@{const_name fst}, _) $ Var z1,
  29.517 +                   Const (@{const_name snd}, _) $ Var z2]) =>
  29.518 +          if z1 = z2 andalso num_occs_of_var z1 = 2 then @{const True}
  29.519 +          else raise SAME ()
  29.520 +        | (Const (x as (s, T)), args) =>
  29.521 +          let val arg_Ts = binder_types T in
  29.522 +            if length arg_Ts = length args andalso
  29.523 +               (is_constr thy x orelse s = @{const_name Pair} orelse
  29.524 +                x = (@{const_name Suc}, nat_T --> nat_T)) andalso
  29.525 +               (not careful orelse not (is_Var t1) orelse
  29.526 +                String.isPrefix val_var_prefix (fst (fst (dest_Var t1)))) then
  29.527 +              discriminate_value hol_ctxt x t1 ::
  29.528 +              map3 (sel_eq x t1) (index_seq 0 (length args)) arg_Ts args
  29.529 +              |> foldr1 s_conj
  29.530 +            else
  29.531 +              raise SAME ()
  29.532 +          end
  29.533 +        | _ => raise SAME ())
  29.534 +       |> body_type (type_of t0) = prop_T ? HOLogic.mk_Trueprop)
  29.535 +      handle SAME () => if pass1 then aux_eq careful false t0 t2 t1
  29.536 +                        else t0 $ aux false t2 $ aux false t1
  29.537 +    (* styp -> term -> int -> typ -> term -> term *)
  29.538 +    and sel_eq x t n nth_T nth_t =
  29.539 +      HOLogic.eq_const nth_T $ nth_t $ select_nth_constr_arg thy x t n nth_T
  29.540 +      |> aux false
  29.541 +  in aux axiom t end
  29.542 +
  29.543 +(** Destruction of universal and existential equalities **)
  29.544 +
  29.545 +(* term -> term *)
  29.546 +fun curry_assms (@{const "==>"} $ (@{const Trueprop}
  29.547 +                                   $ (@{const "op &"} $ t1 $ t2)) $ t3) =
  29.548 +    curry_assms (Logic.list_implies ([t1, t2] |> map HOLogic.mk_Trueprop, t3))
  29.549 +  | curry_assms (@{const "==>"} $ t1 $ t2) =
  29.550 +    @{const "==>"} $ curry_assms t1 $ curry_assms t2
  29.551 +  | curry_assms t = t
  29.552 +
  29.553 +(* term -> term *)
  29.554 +val destroy_universal_equalities =
  29.555 +  let
  29.556 +    (* term list -> (indexname * typ) list -> term -> term *)
  29.557 +    fun aux prems zs t =
  29.558 +      case t of
  29.559 +        @{const "==>"} $ t1 $ t2 => aux_implies prems zs t1 t2
  29.560 +      | _ => Logic.list_implies (rev prems, t)
  29.561 +    (* term list -> (indexname * typ) list -> term -> term -> term *)
  29.562 +    and aux_implies prems zs t1 t2 =
  29.563 +      case t1 of
  29.564 +        Const (@{const_name "=="}, _) $ Var z $ t' => aux_eq prems zs z t' t1 t2
  29.565 +      | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ Var z $ t') =>
  29.566 +        aux_eq prems zs z t' t1 t2
  29.567 +      | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t' $ Var z) =>
  29.568 +        aux_eq prems zs z t' t1 t2
  29.569 +      | _ => aux (t1 :: prems) (Term.add_vars t1 zs) t2
  29.570 +    (* term list -> (indexname * typ) list -> indexname * typ -> term -> term
  29.571 +       -> term -> term *)
  29.572 +    and aux_eq prems zs z t' t1 t2 =
  29.573 +      if not (member (op =) zs z) andalso
  29.574 +         not (exists_subterm (curry (op =) (Var z)) t') then
  29.575 +        aux prems zs (subst_free [(Var z, t')] t2)
  29.576 +      else
  29.577 +        aux (t1 :: prems) (Term.add_vars t1 zs) t2
  29.578 +  in aux [] [] end
  29.579 +
  29.580 +(* theory -> int -> term list -> term list -> (term * term list) option *)
  29.581 +fun find_bound_assign _ _ _ [] = NONE
  29.582 +  | find_bound_assign thy j seen (t :: ts) =
  29.583 +    let
  29.584 +      (* bool -> term -> term -> (term * term list) option *)
  29.585 +      fun aux pass1 t1 t2 =
  29.586 +        (if loose_bvar1 (t2, j) then
  29.587 +           if pass1 then aux false t2 t1 else raise SAME ()
  29.588 +         else case t1 of
  29.589 +           Bound j' => if j' = j then SOME (t2, ts @ seen) else raise SAME ()
  29.590 +         | Const (s, Type ("fun", [T1, T2])) $ Bound j' =>
  29.591 +           if j' = j andalso
  29.592 +              s = nth_sel_name_for_constr_name @{const_name FunBox} 0 then
  29.593 +             SOME (construct_value thy (@{const_name FunBox}, T2 --> T1) [t2],
  29.594 +                   ts @ seen)
  29.595 +           else
  29.596 +             raise SAME ()
  29.597 +         | _ => raise SAME ())
  29.598 +        handle SAME () => find_bound_assign thy j (t :: seen) ts
  29.599 +    in
  29.600 +      case t of
  29.601 +        Const (@{const_name "op ="}, _) $ t1 $ t2 => aux true t1 t2
  29.602 +      | _ => find_bound_assign thy j (t :: seen) ts
  29.603 +    end
  29.604 +
  29.605 +(* int -> term -> term -> term *)
  29.606 +fun subst_one_bound j arg t =
  29.607 +  let
  29.608 +    fun aux (Bound i, lev) =
  29.609 +        if i < lev then raise SAME ()
  29.610 +        else if i = lev then incr_boundvars (lev - j) arg
  29.611 +        else Bound (i - 1)
  29.612 +      | aux (Abs (a, T, body), lev) = Abs (a, T, aux (body, lev + 1))
  29.613 +      | aux (f $ t, lev) =
  29.614 +        (aux (f, lev) $ (aux (t, lev) handle SAME () => t)
  29.615 +         handle SAME () => f $ aux (t, lev))
  29.616 +      | aux _ = raise SAME ()
  29.617 +  in aux (t, j) handle SAME () => t end
  29.618 +
  29.619 +(* theory -> term -> term *)
  29.620 +fun destroy_existential_equalities thy =
  29.621 +  let
  29.622 +    (* string list -> typ list -> term list -> term *)
  29.623 +    fun kill [] [] ts = foldr1 s_conj ts
  29.624 +      | kill (s :: ss) (T :: Ts) ts =
  29.625 +        (case find_bound_assign thy (length ss) [] ts of
  29.626 +           SOME (_, []) => @{const True}
  29.627 +         | SOME (arg_t, ts) =>
  29.628 +           kill ss Ts (map (subst_one_bound (length ss)
  29.629 +                                (incr_bv (~1, length ss + 1, arg_t))) ts)
  29.630 +         | NONE =>
  29.631 +           Const (@{const_name Ex}, (T --> bool_T) --> bool_T)
  29.632 +           $ Abs (s, T, kill ss Ts ts))
  29.633 +      | kill _ _ _ = raise UnequalLengths
  29.634 +    (* string list -> typ list -> term -> term *)
  29.635 +    fun gather ss Ts ((t0 as Const (@{const_name Ex}, _)) $ Abs (s1, T1, t1)) =
  29.636 +        gather (ss @ [s1]) (Ts @ [T1]) t1
  29.637 +      | gather [] [] (Abs (s, T, t1)) = Abs (s, T, gather [] [] t1)
  29.638 +      | gather [] [] (t1 $ t2) = gather [] [] t1 $ gather [] [] t2
  29.639 +      | gather [] [] t = t
  29.640 +      | gather ss Ts t = kill ss Ts (conjuncts_of (gather [] [] t))
  29.641 +  in gather [] [] end
  29.642 +
  29.643 +(** Skolemization **)
  29.644 +
  29.645 +(* int -> int -> string *)
  29.646 +fun skolem_prefix_for k j =
  29.647 +  skolem_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
  29.648 +
  29.649 +(* hol_context -> int -> term -> term *)
  29.650 +fun skolemize_term_and_more (hol_ctxt as {thy, def_table, skolems, ...})
  29.651 +                            skolem_depth =
  29.652 +  let
  29.653 +    (* int list -> int list *)
  29.654 +    val incrs = map (Integer.add 1)
  29.655 +    (* string list -> typ list -> int list -> int -> polarity -> term -> term *)
  29.656 +    fun aux ss Ts js depth polar t =
  29.657 +      let
  29.658 +        (* string -> typ -> string -> typ -> term -> term *)
  29.659 +        fun do_quantifier quant_s quant_T abs_s abs_T t =
  29.660 +          if not (loose_bvar1 (t, 0)) then
  29.661 +            aux ss Ts js depth polar (incr_boundvars ~1 t)
  29.662 +          else if depth <= skolem_depth andalso
  29.663 +                  is_positive_existential polar quant_s then
  29.664 +            let
  29.665 +              val j = length (!skolems) + 1
  29.666 +              val sko_s = skolem_prefix_for (length js) j ^ abs_s
  29.667 +              val _ = Unsynchronized.change skolems (cons (sko_s, ss))
  29.668 +              val sko_t = list_comb (Const (sko_s, rev Ts ---> abs_T),
  29.669 +                                     map Bound (rev js))
  29.670 +              val abs_t = Abs (abs_s, abs_T, aux ss Ts (incrs js) depth polar t)
  29.671 +            in
  29.672 +              if null js then betapply (abs_t, sko_t)
  29.673 +              else Const (@{const_name Let}, abs_T --> quant_T) $ sko_t $ abs_t
  29.674 +            end
  29.675 +          else
  29.676 +            Const (quant_s, quant_T)
  29.677 +            $ Abs (abs_s, abs_T,
  29.678 +                   if is_higher_order_type abs_T then
  29.679 +                     t
  29.680 +                   else
  29.681 +                     aux (abs_s :: ss) (abs_T :: Ts) (0 :: incrs js)
  29.682 +                         (depth + 1) polar t)
  29.683 +      in
  29.684 +        case t of
  29.685 +          Const (s0 as @{const_name all}, T0) $ Abs (s1, T1, t1) =>
  29.686 +          do_quantifier s0 T0 s1 T1 t1
  29.687 +        | @{const "==>"} $ t1 $ t2 =>
  29.688 +          @{const "==>"} $ aux ss Ts js depth (flip_polarity polar) t1
  29.689 +          $ aux ss Ts js depth polar t2
  29.690 +        | @{const Pure.conjunction} $ t1 $ t2 =>
  29.691 +          @{const Pure.conjunction} $ aux ss Ts js depth polar t1
  29.692 +          $ aux ss Ts js depth polar t2
  29.693 +        | @{const Trueprop} $ t1 =>
  29.694 +          @{const Trueprop} $ aux ss Ts js depth polar t1
  29.695 +        | @{const Not} $ t1 =>
  29.696 +          @{const Not} $ aux ss Ts js depth (flip_polarity polar) t1
  29.697 +        | Const (s0 as @{const_name All}, T0) $ Abs (s1, T1, t1) =>
  29.698 +          do_quantifier s0 T0 s1 T1 t1
  29.699 +        | Const (s0 as @{const_name Ex}, T0) $ Abs (s1, T1, t1) =>
  29.700 +          do_quantifier s0 T0 s1 T1 t1
  29.701 +        | @{const "op &"} $ t1 $ t2 =>
  29.702 +          @{const "op &"} $ aux ss Ts js depth polar t1
  29.703 +          $ aux ss Ts js depth polar t2
  29.704 +        | @{const "op |"} $ t1 $ t2 =>
  29.705 +          @{const "op |"} $ aux ss Ts js depth polar t1
  29.706 +          $ aux ss Ts js depth polar t2
  29.707 +        | @{const "op -->"} $ t1 $ t2 =>
  29.708 +          @{const "op -->"} $ aux ss Ts js depth (flip_polarity polar) t1
  29.709 +          $ aux ss Ts js depth polar t2
  29.710 +        | (t0 as Const (@{const_name Let}, T0)) $ t1 $ t2 =>
  29.711 +          t0 $ t1 $ aux ss Ts js depth polar t2
  29.712 +        | Const (x as (s, T)) =>
  29.713 +          if is_inductive_pred hol_ctxt x andalso
  29.714 +             not (is_well_founded_inductive_pred hol_ctxt x) then
  29.715 +            let
  29.716 +              val gfp = (fixpoint_kind_of_const thy def_table x = Gfp)
  29.717 +              val (pref, connective, set_oper) =
  29.718 +                if gfp then
  29.719 +                  (lbfp_prefix,
  29.720 +                   @{const "op |"},
  29.721 +                   @{const_name semilattice_sup_fun_inst.sup_fun})
  29.722 +                else
  29.723 +                  (ubfp_prefix,
  29.724 +                   @{const "op &"},
  29.725 +                   @{const_name semilattice_inf_fun_inst.inf_fun})
  29.726 +              (* unit -> term *)
  29.727 +              fun pos () = unrolled_inductive_pred_const hol_ctxt gfp x
  29.728 +                           |> aux ss Ts js depth polar
  29.729 +              fun neg () = Const (pref ^ s, T)
  29.730 +            in
  29.731 +              (case polar |> gfp ? flip_polarity of
  29.732 +                 Pos => pos ()
  29.733 +               | Neg => neg ()
  29.734 +               | Neut =>
  29.735 +                 if is_fun_type T then
  29.736 +                   let
  29.737 +                     val ((trunk_arg_Ts, rump_arg_T), body_T) =
  29.738 +                       T |> strip_type |>> split_last
  29.739 +                     val set_T = rump_arg_T --> body_T
  29.740 +                     (* (unit -> term) -> term *)
  29.741 +                     fun app f =
  29.742 +                       list_comb (f (),
  29.743 +                                  map Bound (length trunk_arg_Ts - 1 downto 0))
  29.744 +                   in
  29.745 +                     List.foldr absdummy
  29.746 +                                (Const (set_oper, set_T --> set_T --> set_T)
  29.747 +                                        $ app pos $ app neg) trunk_arg_Ts
  29.748 +                   end
  29.749 +                 else
  29.750 +                   connective $ pos () $ neg ())
  29.751 +            end
  29.752 +          else
  29.753 +            Const x
  29.754 +        | t1 $ t2 =>
  29.755 +          betapply (aux ss Ts [] (skolem_depth + 1) polar t1,
  29.756 +                    aux ss Ts [] depth Neut t2)
  29.757 +        | Abs (s, T, t1) => Abs (s, T, aux ss Ts (incrs js) depth polar t1)
  29.758 +        | _ => t
  29.759 +      end
  29.760 +  in aux [] [] [] 0 Pos end
  29.761 +
  29.762 +(** Function specialization **)
  29.763 +
  29.764 +(* term -> term list *)
  29.765 +fun params_in_equation (@{const "==>"} $ _ $ t2) = params_in_equation t2
  29.766 +  | params_in_equation (@{const Trueprop} $ t1) = params_in_equation t1
  29.767 +  | params_in_equation (Const (@{const_name "op ="}, _) $ t1 $ _) =
  29.768 +    snd (strip_comb t1)
  29.769 +  | params_in_equation _ = []
  29.770 +
  29.771 +(* styp -> styp -> int list -> term list -> term list -> term -> term *)
  29.772 +fun specialize_fun_axiom x x' fixed_js fixed_args extra_args t =
  29.773 +  let
  29.774 +    val k = fold Integer.max (map maxidx_of_term (fixed_args @ extra_args)) 0
  29.775 +            + 1
  29.776 +    val t = map_aterms (fn Var ((s, i), T) => Var ((s, k + i), T) | t' => t') t
  29.777 +    val fixed_params = filter_indices fixed_js (params_in_equation t)
  29.778 +    (* term list -> term -> term *)
  29.779 +    fun aux args (Abs (s, T, t)) = list_comb (Abs (s, T, aux [] t), args)
  29.780 +      | aux args (t1 $ t2) = aux (aux [] t2 :: args) t1
  29.781 +      | aux args t =
  29.782 +        if t = Const x then
  29.783 +          list_comb (Const x', extra_args @ filter_out_indices fixed_js args)
  29.784 +        else
  29.785 +          let val j = find_index (curry (op =) t) fixed_params in
  29.786 +            list_comb (if j >= 0 then nth fixed_args j else t, args)
  29.787 +          end
  29.788 +  in aux [] t end
  29.789 +
  29.790 +(* hol_context -> styp -> (int * term option) list *)
  29.791 +fun static_args_in_term ({ersatz_table, ...} : hol_context) x t =
  29.792 +  let
  29.793 +    (* term -> term list -> term list -> term list list *)
  29.794 +    fun fun_calls (Abs (_, _, t)) _ = fun_calls t []
  29.795 +      | fun_calls (t1 $ t2) args = fun_calls t2 [] #> fun_calls t1 (t2 :: args)
  29.796 +      | fun_calls t args =
  29.797 +        (case t of
  29.798 +           Const (x' as (s', T')) =>
  29.799 +           x = x' orelse (case AList.lookup (op =) ersatz_table s' of
  29.800 +                            SOME s'' => x = (s'', T')
  29.801 +                          | NONE => false)
  29.802 +         | _ => false) ? cons args
  29.803 +    (* term list list -> term list list -> term list -> term list list *)
  29.804 +    fun call_sets [] [] vs = [vs]
  29.805 +      | call_sets [] uss vs = vs :: call_sets uss [] []
  29.806 +      | call_sets ([] :: _) _ _ = []
  29.807 +      | call_sets ((t :: ts) :: tss) uss vs =
  29.808 +        OrdList.insert TermOrd.term_ord t vs |> call_sets tss (ts :: uss)
  29.809 +    val sets = call_sets (fun_calls t [] []) [] []
  29.810 +    val indexed_sets = sets ~~ (index_seq 0 (length sets))
  29.811 +  in
  29.812 +    fold_rev (fn (set, j) =>
  29.813 +                 case set of
  29.814 +                   [Var _] => AList.lookup (op =) indexed_sets set = SOME j
  29.815 +                              ? cons (j, NONE)
  29.816 +                 | [t as Const _] => cons (j, SOME t)
  29.817 +                 | [t as Free _] => cons (j, SOME t)
  29.818 +                 | _ => I) indexed_sets []
  29.819 +  end
  29.820 +(* hol_context -> styp -> term list -> (int * term option) list *)
  29.821 +fun static_args_in_terms hol_ctxt x =
  29.822 +  map (static_args_in_term hol_ctxt x)
  29.823 +  #> fold1 (OrdList.inter (prod_ord int_ord (option_ord TermOrd.term_ord)))
  29.824 +
  29.825 +(* (int * term option) list -> (int * term) list -> int list *)
  29.826 +fun overlapping_indices [] _ = []
  29.827 +  | overlapping_indices _ [] = []
  29.828 +  | overlapping_indices (ps1 as (j1, t1) :: ps1') (ps2 as (j2, t2) :: ps2') =
  29.829 +    if j1 < j2 then overlapping_indices ps1' ps2
  29.830 +    else if j1 > j2 then overlapping_indices ps1 ps2'
  29.831 +    else overlapping_indices ps1' ps2' |> the_default t2 t1 = t2 ? cons j1
  29.832 +
  29.833 +(* typ list -> term -> bool *)
  29.834 +fun is_eligible_arg Ts t =
  29.835 +  let val bad_Ts = map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t) in
  29.836 +    null bad_Ts orelse
  29.837 +    (is_higher_order_type (fastype_of1 (Ts, t)) andalso
  29.838 +     forall (not o is_higher_order_type) bad_Ts)
  29.839 +  end
  29.840 +
  29.841 +(* int -> string *)
  29.842 +fun special_prefix_for j = special_prefix ^ string_of_int j ^ name_sep
  29.843 +
  29.844 +(* If a constant's definition is picked up deeper than this threshold, we
  29.845 +   prevent excessive specialization by not specializing it. *)
  29.846 +val special_max_depth = 20
  29.847 +
  29.848 +val bound_var_prefix = "b"
  29.849 +
  29.850 +(* hol_context -> int -> term -> term *)
  29.851 +fun specialize_consts_in_term (hol_ctxt as {thy, specialize, simp_table,
  29.852 +                                            special_funs, ...}) depth t =
  29.853 +  if not specialize orelse depth > special_max_depth then
  29.854 +    t
  29.855 +  else
  29.856 +    let
  29.857 +      val blacklist = if depth = 0 then []
  29.858 +                      else case term_under_def t of Const x => [x] | _ => []
  29.859 +      (* term list -> typ list -> term -> term *)
  29.860 +      fun aux args Ts (Const (x as (s, T))) =
  29.861 +          ((if not (member (op =) blacklist x) andalso not (null args) andalso
  29.862 +               not (String.isPrefix special_prefix s) andalso
  29.863 +               is_equational_fun hol_ctxt x then
  29.864 +              let
  29.865 +                val eligible_args = filter (is_eligible_arg Ts o snd)
  29.866 +                                           (index_seq 0 (length args) ~~ args)
  29.867 +                val _ = not (null eligible_args) orelse raise SAME ()
  29.868 +                val old_axs = equational_fun_axioms hol_ctxt x
  29.869 +                              |> map (destroy_existential_equalities thy)
  29.870 +                val static_params = static_args_in_terms hol_ctxt x old_axs
  29.871 +                val fixed_js = overlapping_indices static_params eligible_args
  29.872 +                val _ = not (null fixed_js) orelse raise SAME ()
  29.873 +                val fixed_args = filter_indices fixed_js args
  29.874 +                val vars = fold Term.add_vars fixed_args []
  29.875 +                           |> sort (TermOrd.fast_indexname_ord o pairself fst)
  29.876 +                val bound_js = fold (fn t => fn js => add_loose_bnos (t, 0, js))
  29.877 +                                    fixed_args []
  29.878 +                               |> sort int_ord
  29.879 +                val live_args = filter_out_indices fixed_js args
  29.880 +                val extra_args = map Var vars @ map Bound bound_js @ live_args
  29.881 +                val extra_Ts = map snd vars @ filter_indices bound_js Ts
  29.882 +                val k = maxidx_of_term t + 1
  29.883 +                (* int -> term *)
  29.884 +                fun var_for_bound_no j =
  29.885 +                  Var ((bound_var_prefix ^
  29.886 +                        nat_subscript (find_index (curry (op =) j) bound_js
  29.887 +                                       + 1), k),
  29.888 +                       nth Ts j)
  29.889 +                val fixed_args_in_axiom =
  29.890 +                  map (curry subst_bounds
  29.891 +                             (map var_for_bound_no (index_seq 0 (length Ts))))
  29.892 +                      fixed_args
  29.893 +              in
  29.894 +                case AList.lookup (op =) (!special_funs)
  29.895 +                                  (x, fixed_js, fixed_args_in_axiom) of
  29.896 +                  SOME x' => list_comb (Const x', extra_args)
  29.897 +                | NONE =>
  29.898 +                  let
  29.899 +                    val extra_args_in_axiom =
  29.900 +                      map Var vars @ map var_for_bound_no bound_js
  29.901 +                    val x' as (s', _) =
  29.902 +                      (special_prefix_for (length (!special_funs) + 1) ^ s,
  29.903 +                       extra_Ts @ filter_out_indices fixed_js (binder_types T)
  29.904 +                       ---> body_type T)
  29.905 +                    val new_axs =
  29.906 +                      map (specialize_fun_axiom x x' fixed_js
  29.907 +                               fixed_args_in_axiom extra_args_in_axiom) old_axs
  29.908 +                    val _ =
  29.909 +                      Unsynchronized.change special_funs
  29.910 +                          (cons ((x, fixed_js, fixed_args_in_axiom), x'))
  29.911 +                    val _ = add_simps simp_table s' new_axs
  29.912 +                  in list_comb (Const x', extra_args) end
  29.913 +              end
  29.914 +            else
  29.915 +              raise SAME ())
  29.916 +           handle SAME () => list_comb (Const x, args))
  29.917 +        | aux args Ts (Abs (s, T, t)) =
  29.918 +          list_comb (Abs (s, T, aux [] (T :: Ts) t), args)
  29.919 +        | aux args Ts (t1 $ t2) = aux (aux [] Ts t2 :: args) Ts t1
  29.920 +        | aux args _ t = list_comb (t, args)
  29.921 +    in aux [] [] t end
  29.922 +
  29.923 +type special_triple = int list * term list * styp
  29.924 +
  29.925 +val cong_var_prefix = "c"
  29.926 +
  29.927 +(* styp -> special_triple -> special_triple -> term *)
  29.928 +fun special_congruence_axiom (s, T) (js1, ts1, x1) (js2, ts2, x2) =
  29.929 +  let
  29.930 +    val (bounds1, bounds2) = pairself (map Var o special_bounds) (ts1, ts2)
  29.931 +    val Ts = binder_types T
  29.932 +    val max_j = fold (fold Integer.max) [js1, js2] ~1
  29.933 +    val (eqs, (args1, args2)) =
  29.934 +      fold (fn j => case pairself (fn ps => AList.lookup (op =) ps j)
  29.935 +                                  (js1 ~~ ts1, js2 ~~ ts2) of
  29.936 +                      (SOME t1, SOME t2) => apfst (cons (t1, t2))
  29.937 +                    | (SOME t1, NONE) => apsnd (apsnd (cons t1))
  29.938 +                    | (NONE, SOME t2) => apsnd (apfst (cons t2))
  29.939 +                    | (NONE, NONE) =>
  29.940 +                      let val v = Var ((cong_var_prefix ^ nat_subscript j, 0),
  29.941 +                                       nth Ts j) in
  29.942 +                        apsnd (pairself (cons v))
  29.943 +                      end) (max_j downto 0) ([], ([], []))
  29.944 +  in
  29.945 +    Logic.list_implies (eqs |> filter_out (op =) |> distinct (op =)
  29.946 +                            |> map Logic.mk_equals,
  29.947 +                        Logic.mk_equals (list_comb (Const x1, bounds1 @ args1),
  29.948 +                                         list_comb (Const x2, bounds2 @ args2)))
  29.949 +    |> close_form (* TODO: needed? *)
  29.950 +  end
  29.951 +
  29.952 +(* hol_context -> styp list -> term list *)
  29.953 +fun special_congruence_axioms (hol_ctxt as {special_funs, ...}) xs =
  29.954 +  let
  29.955 +    val groups =
  29.956 +      !special_funs
  29.957 +      |> map (fn ((x, js, ts), x') => (x, (js, ts, x')))
  29.958 +      |> AList.group (op =)
  29.959 +      |> filter_out (is_equational_fun_surely_complete hol_ctxt o fst)
  29.960 +      |> map (fn (x, zs) => (x, zs |> member (op =) xs x ? cons ([], [], x)))
  29.961 +    (* special_triple -> int *)
  29.962 +    fun generality (js, _, _) = ~(length js)
  29.963 +    (* special_triple -> special_triple -> bool *)
  29.964 +    fun is_more_specific (j1, t1, x1) (j2, t2, x2) =
  29.965 +      x1 <> x2 andalso OrdList.subset (prod_ord int_ord TermOrd.term_ord)
  29.966 +                                      (j2 ~~ t2, j1 ~~ t1)
  29.967 +    (* styp -> special_triple list -> special_triple list -> special_triple list
  29.968 +       -> term list -> term list *)
  29.969 +    fun do_pass_1 _ [] [_] [_] = I
  29.970 +      | do_pass_1 x skipped _ [] = do_pass_2 x skipped
  29.971 +      | do_pass_1 x skipped all (z :: zs) =
  29.972 +        case filter (is_more_specific z) all
  29.973 +             |> sort (int_ord o pairself generality) of
  29.974 +          [] => do_pass_1 x (z :: skipped) all zs
  29.975 +        | (z' :: _) => cons (special_congruence_axiom x z z')
  29.976 +                       #> do_pass_1 x skipped all zs
  29.977 +    (* styp -> special_triple list -> term list -> term list *)
  29.978 +    and do_pass_2 _ [] = I
  29.979 +      | do_pass_2 x (z :: zs) =
  29.980 +        fold (cons o special_congruence_axiom x z) zs #> do_pass_2 x zs
  29.981 +  in fold (fn (x, zs) => do_pass_1 x [] zs zs) groups [] end
  29.982 +
  29.983 +(** Axiom selection **)
  29.984 +
  29.985 +(* Similar to "Refute.specialize_type" but returns all matches rather than only
  29.986 +   the first (preorder) match. *)
  29.987 +(* theory -> styp -> term -> term list *)
  29.988 +fun multi_specialize_type thy slack (x as (s, T)) t =
  29.989 +  let
  29.990 +    (* term -> (typ * term) list -> (typ * term) list *)
  29.991 +    fun aux (Const (s', T')) ys =
  29.992 +        if s = s' then
  29.993 +          ys |> (if AList.defined (op =) ys T' then
  29.994 +                   I
  29.995 +                 else
  29.996 +                  cons (T', Refute.monomorphic_term
  29.997 +                                (Sign.typ_match thy (T', T) Vartab.empty) t)
  29.998 +                  handle Type.TYPE_MATCH => I
  29.999 +                       | Refute.REFUTE _ =>
 29.1000 +                         if slack then
 29.1001 +                           I
 29.1002 +                         else
 29.1003 +                           raise NOT_SUPPORTED ("too much polymorphism in \
 29.1004 +                                                \axiom involving " ^ quote s))
 29.1005 +        else
 29.1006 +          ys
 29.1007 +      | aux _ ys = ys
 29.1008 +  in map snd (fold_aterms aux t []) end
 29.1009 +
 29.1010 +(* theory -> bool -> const_table -> styp -> term list *)
 29.1011 +fun nondef_props_for_const thy slack table (x as (s, _)) =
 29.1012 +  these (Symtab.lookup table s) |> maps (multi_specialize_type thy slack x)
 29.1013 +
 29.1014 +(* 'a Symtab.table -> 'a list *)
 29.1015 +fun all_table_entries table = Symtab.fold (append o snd) table []
 29.1016 +(* const_table -> string -> const_table *)
 29.1017 +fun extra_table table s = Symtab.make [(s, all_table_entries table)]
 29.1018 +
 29.1019 +(* int -> term -> term *)
 29.1020 +fun eval_axiom_for_term j t =
 29.1021 +  Logic.mk_equals (Const (eval_prefix ^ string_of_int j, fastype_of t), t)
 29.1022 +
 29.1023 +(* term -> bool *)
 29.1024 +val is_trivial_equation = the_default false o try (op aconv o Logic.dest_equals)
 29.1025 +
 29.1026 +(* Prevents divergence in case of cyclic or infinite axiom dependencies. *)
 29.1027 +val axioms_max_depth = 255
 29.1028 +
 29.1029 +(* hol_context -> term -> (term list * term list) * (bool * bool) *)
 29.1030 +fun axioms_for_term
 29.1031 +        (hol_ctxt as {thy, max_bisim_depth, user_axioms, fast_descrs, evals,
 29.1032 +                      def_table, nondef_table, user_nondefs, ...}) t =
 29.1033 +  let
 29.1034 +    type accumulator = styp list * (term list * term list)
 29.1035 +    (* (term list * term list -> term list)
 29.1036 +       -> ((term list -> term list) -> term list * term list
 29.1037 +           -> term list * term list)
 29.1038 +       -> int -> term -> accumulator -> accumulator *)
 29.1039 +    fun add_axiom get app depth t (accum as (xs, axs)) =
 29.1040 +      let
 29.1041 +        val t = t |> unfold_defs_in_term hol_ctxt
 29.1042 +                  |> skolemize_term_and_more hol_ctxt ~1
 29.1043 +      in
 29.1044 +        if is_trivial_equation t then
 29.1045 +          accum
 29.1046 +        else
 29.1047 +          let val t' = t |> specialize_consts_in_term hol_ctxt depth in
 29.1048 +            if exists (member (op aconv) (get axs)) [t, t'] then accum
 29.1049 +            else add_axioms_for_term (depth + 1) t' (xs, app (cons t') axs)
 29.1050 +          end
 29.1051 +      end
 29.1052 +    (* int -> term -> accumulator -> accumulator *)
 29.1053 +    and add_def_axiom depth = add_axiom fst apfst depth
 29.1054 +    and add_nondef_axiom depth = add_axiom snd apsnd depth
 29.1055 +    and add_maybe_def_axiom depth t =
 29.1056 +      (if head_of t <> @{const "==>"} then add_def_axiom
 29.1057 +       else add_nondef_axiom) depth t
 29.1058 +    and add_eq_axiom depth t =
 29.1059 +      (if is_constr_pattern_formula thy t then add_def_axiom
 29.1060 +       else add_nondef_axiom) depth t
 29.1061 +    (* int -> term -> accumulator -> accumulator *)
 29.1062 +    and add_axioms_for_term depth t (accum as (xs, axs)) =
 29.1063 +      case t of
 29.1064 +        t1 $ t2 => accum |> fold (add_axioms_for_term depth) [t1, t2]
 29.1065 +      | Const (x as (s, T)) =>
 29.1066 +        (if member (op =) xs x orelse is_built_in_const fast_descrs x then
 29.1067 +           accum
 29.1068 +         else
 29.1069 +           let val accum as (xs, _) = (x :: xs, axs) in
 29.1070 +             if depth > axioms_max_depth then
 29.1071 +               raise TOO_LARGE ("Nitpick_Preproc.axioms_for_term.\
 29.1072 +                                \add_axioms_for_term",
 29.1073 +                                "too many nested axioms (" ^
 29.1074 +                                string_of_int depth ^ ")")
 29.1075 +             else if Refute.is_const_of_class thy x then
 29.1076 +               let
 29.1077 +                 val class = Logic.class_of_const s
 29.1078 +                 val of_class = Logic.mk_of_class (TVar (("'a", 0), [class]),
 29.1079 +                                                   class)
 29.1080 +                 val ax1 = try (Refute.specialize_type thy x) of_class
 29.1081 +                 val ax2 = Option.map (Refute.specialize_type thy x o snd)
 29.1082 +                                      (Refute.get_classdef thy class)
 29.1083 +               in
 29.1084 +                 fold (add_maybe_def_axiom depth) (map_filter I [ax1, ax2])
 29.1085 +                      accum
 29.1086 +               end
 29.1087 +             else if is_constr thy x then
 29.1088 +               accum
 29.1089 +             else if is_equational_fun hol_ctxt x then
 29.1090 +               fold (add_eq_axiom depth) (equational_fun_axioms hol_ctxt x)
 29.1091 +                    accum
 29.1092 +             else if is_abs_fun thy x then
 29.1093 +               if is_quot_type thy (range_type T) then
 29.1094 +                 raise NOT_SUPPORTED "\"Abs_\" function of quotient type"
 29.1095 +               else
 29.1096 +                 accum |> fold (add_nondef_axiom depth)
 29.1097 +                               (nondef_props_for_const thy false nondef_table x)
 29.1098 +                       |> is_funky_typedef thy (range_type T)
 29.1099 +                          ? fold (add_maybe_def_axiom depth)
 29.1100 +                                 (nondef_props_for_const thy true
 29.1101 +                                                    (extra_table def_table s) x)
 29.1102 +             else if is_rep_fun thy x then
 29.1103 +               if is_quot_type thy (domain_type T) then
 29.1104 +                 raise NOT_SUPPORTED "\"Rep_\" function of quotient type"
 29.1105 +               else
 29.1106 +                 accum |> fold (add_nondef_axiom depth)
 29.1107 +                               (nondef_props_for_const thy false nondef_table x)
 29.1108 +                       |> is_funky_typedef thy (range_type T)
 29.1109 +                          ? fold (add_maybe_def_axiom depth)
 29.1110 +                                 (nondef_props_for_const thy true
 29.1111 +                                                    (extra_table def_table s) x)
 29.1112 +                       |> add_axioms_for_term depth
 29.1113 +                                              (Const (mate_of_rep_fun thy x))
 29.1114 +                       |> fold (add_def_axiom depth)
 29.1115 +                               (inverse_axioms_for_rep_fun thy x)
 29.1116 +             else
 29.1117 +               accum |> user_axioms <> SOME false
 29.1118 +                        ? fold (add_nondef_axiom depth)
 29.1119 +                               (nondef_props_for_const thy false nondef_table x)
 29.1120 +           end)
 29.1121 +        |> add_axioms_for_type depth T
 29.1122 +      | Free (_, T) => add_axioms_for_type depth T accum
 29.1123 +      | Var (_, T) => add_axioms_for_type depth T accum
 29.1124 +      | Bound _ => accum
 29.1125 +      | Abs (_, T, t) => accum |> add_axioms_for_term depth t
 29.1126 +                               |> add_axioms_for_type depth T
 29.1127 +    (* int -> typ -> accumulator -> accumulator *)
 29.1128 +    and add_axioms_for_type depth T =
 29.1129 +      case T of
 29.1130 +        Type ("fun", Ts) => fold (add_axioms_for_type depth) Ts
 29.1131 +      | Type ("*", Ts) => fold (add_axioms_for_type depth) Ts
 29.1132 +      | @{typ prop} => I
 29.1133 +      | @{typ bool} => I
 29.1134 +      | @{typ unit} => I
 29.1135 +      | TFree (_, S) => add_axioms_for_sort depth T S
 29.1136 +      | TVar (_, S) => add_axioms_for_sort depth T S
 29.1137 +      | Type (z as (s, Ts)) =>
 29.1138 +        fold (add_axioms_for_type depth) Ts
 29.1139 +        #> (if is_pure_typedef thy T then
 29.1140 +              fold (add_maybe_def_axiom depth) (optimized_typedef_axioms thy z)
 29.1141 +            else if is_quot_type thy T then
 29.1142 +              fold (add_def_axiom depth) (optimized_quot_type_axioms thy z)
 29.1143 +            else if max_bisim_depth >= 0 andalso is_codatatype thy T then
 29.1144 +              fold (add_maybe_def_axiom depth)
 29.1145 +                   (codatatype_bisim_axioms hol_ctxt T)
 29.1146 +            else
 29.1147 +              I)
 29.1148 +    (* int -> typ -> sort -> accumulator -> accumulator *)
 29.1149 +    and add_axioms_for_sort depth T S =
 29.1150 +      let
 29.1151 +        val supers = Sign.complete_sort thy S
 29.1152 +        val class_axioms =
 29.1153 +          maps (fn class => map prop_of (AxClass.get_info thy class |> #axioms
 29.1154 +                                         handle ERROR _ => [])) supers
 29.1155 +        val monomorphic_class_axioms =
 29.1156 +          map (fn t => case Term.add_tvars t [] of
 29.1157 +                         [] => t
 29.1158 +                       | [(x, S)] =>
 29.1159 +                         Refute.monomorphic_term (Vartab.make [(x, (S, T))]) t
 29.1160 +                       | _ => raise TERM ("Nitpick_Preproc.axioms_for_term.\
 29.1161 +                                          \add_axioms_for_sort", [t]))
 29.1162 +              class_axioms
 29.1163 +      in fold (add_nondef_axiom depth) monomorphic_class_axioms end
 29.1164 +    val (mono_user_nondefs, poly_user_nondefs) =
 29.1165 +      List.partition (null o Term.hidden_polymorphism) user_nondefs
 29.1166 +    val eval_axioms = map2 eval_axiom_for_term (index_seq 0 (length evals))
 29.1167 +                           evals
 29.1168 +    val (xs, (defs, nondefs)) =
 29.1169 +      ([], ([], [])) |> add_axioms_for_term 1 t 
 29.1170 +                     |> fold_rev (add_def_axiom 1) eval_axioms
 29.1171 +                     |> user_axioms = SOME true
 29.1172 +                        ? fold (add_nondef_axiom 1) mono_user_nondefs
 29.1173 +    val defs = defs @ special_congruence_axioms hol_ctxt xs
 29.1174 +  in
 29.1175 +    ((defs, nondefs), (user_axioms = SOME true orelse null mono_user_nondefs,
 29.1176 +                       null poly_user_nondefs))
 29.1177 +  end
 29.1178 +
 29.1179 +(** Simplification of constructor/selector terms **)
 29.1180 +
 29.1181 +(* theory -> term -> term *)
 29.1182 +fun simplify_constrs_and_sels thy t =
 29.1183 +  let
 29.1184 +    (* term -> int -> term *)
 29.1185 +    fun is_nth_sel_on t' n (Const (s, _) $ t) =
 29.1186 +        (t = t' andalso is_sel_like_and_no_discr s andalso
 29.1187 +         sel_no_from_name s = n)
 29.1188 +      | is_nth_sel_on _ _ _ = false
 29.1189 +    (* term -> term list -> term *)
 29.1190 +    fun do_term (Const (@{const_name Rep_Frac}, _)
 29.1191 +                 $ (Const (@{const_name Abs_Frac}, _) $ t1)) [] = do_term t1 []
 29.1192 +      | do_term (Const (@{const_name Abs_Frac}, _)
 29.1193 +                 $ (Const (@{const_name Rep_Frac}, _) $ t1)) [] = do_term t1 []
 29.1194 +      | do_term (t1 $ t2) args = do_term t1 (do_term t2 [] :: args)
 29.1195 +      | do_term (t as Const (x as (s, T))) (args as _ :: _) =
 29.1196 +        ((if is_constr_like thy x then
 29.1197 +            if length args = num_binder_types T then
 29.1198 +              case hd args of
 29.1199 +                Const (x' as (_, T')) $ t' =>
 29.1200 +                if domain_type T' = body_type T andalso
 29.1201 +                   forall (uncurry (is_nth_sel_on t'))
 29.1202 +                          (index_seq 0 (length args) ~~ args) then
 29.1203 +                  t'
 29.1204 +                else
 29.1205 +                  raise SAME ()
 29.1206 +              | _ => raise SAME ()
 29.1207 +            else
 29.1208 +              raise SAME ()
 29.1209 +          else if is_sel_like_and_no_discr s then
 29.1210 +            case strip_comb (hd args) of
 29.1211 +              (Const (x' as (s', T')), ts') =>
 29.1212 +              if is_constr_like thy x' andalso
 29.1213 +                 constr_name_for_sel_like s = s' andalso
 29.1214 +                 not (exists is_pair_type (binder_types T')) then
 29.1215 +                list_comb (nth ts' (sel_no_from_name s), tl args)
 29.1216 +              else
 29.1217 +                raise SAME ()
 29.1218 +            | _ => raise SAME ()
 29.1219 +          else
 29.1220 +            raise SAME ())
 29.1221 +         handle SAME () => betapplys (t, args))
 29.1222 +      | do_term (Abs (s, T, t')) args =
 29.1223 +        betapplys (Abs (s, T, do_term t' []), args)
 29.1224 +      | do_term t args = betapplys (t, args)
 29.1225 +  in do_term t [] end
 29.1226 +
 29.1227 +(** Quantifier massaging: Distributing quantifiers **)
 29.1228 +
 29.1229 +(* term -> term *)
 29.1230 +fun distribute_quantifiers t =
 29.1231 +  case t of
 29.1232 +    (t0 as Const (@{const_name All}, T0)) $ Abs (s, T1, t1) =>
 29.1233 +    (case t1 of
 29.1234 +       (t10 as @{const "op &"}) $ t11 $ t12 =>
 29.1235 +       t10 $ distribute_quantifiers (t0 $ Abs (s, T1, t11))
 29.1236 +           $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
 29.1237 +     | (t10 as @{const Not}) $ t11 =>
 29.1238 +       t10 $ distribute_quantifiers (Const (@{const_name Ex}, T0)
 29.1239 +                                     $ Abs (s, T1, t11))
 29.1240 +     | t1 =>
 29.1241 +       if not (loose_bvar1 (t1, 0)) then
 29.1242 +         distribute_quantifiers (incr_boundvars ~1 t1)
 29.1243 +       else
 29.1244 +         t0 $ Abs (s, T1, distribute_quantifiers t1))
 29.1245 +  | (t0 as Const (@{const_name Ex}, T0)) $ Abs (s, T1, t1) =>
 29.1246 +    (case distribute_quantifiers t1 of
 29.1247 +       (t10 as @{const "op |"}) $ t11 $ t12 =>
 29.1248 +       t10 $ distribute_quantifiers (t0 $ Abs (s, T1, t11))
 29.1249 +           $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
 29.1250 +     | (t10 as @{const "op -->"}) $ t11 $ t12 =>
 29.1251 +       t10 $ distribute_quantifiers (Const (@{const_name All}, T0)
 29.1252 +                                     $ Abs (s, T1, t11))
 29.1253 +           $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
 29.1254 +     | (t10 as @{const Not}) $ t11 =>
 29.1255 +       t10 $ distribute_quantifiers (Const (@{const_name All}, T0)
 29.1256 +                                     $ Abs (s, T1, t11))
 29.1257 +     | t1 =>
 29.1258 +       if not (loose_bvar1 (t1, 0)) then
 29.1259 +         distribute_quantifiers (incr_boundvars ~1 t1)
 29.1260 +       else
 29.1261 +         t0 $ Abs (s, T1, distribute_quantifiers t1))
 29.1262 +  | t1 $ t2 => distribute_quantifiers t1 $ distribute_quantifiers t2
 29.1263 +  | Abs (s, T, t') => Abs (s, T, distribute_quantifiers t')
 29.1264 +  | _ => t
 29.1265 +
 29.1266 +(** Quantifier massaging: Pushing quantifiers inward **)
 29.1267 +
 29.1268 +(* int -> int -> (int -> int) -> term -> term *)
 29.1269 +fun renumber_bounds j n f t =
 29.1270 +  case t of
 29.1271 +    t1 $ t2 => renumber_bounds j n f t1 $ renumber_bounds j n f t2
 29.1272 +  | Abs (s, T, t') => Abs (s, T, renumber_bounds (j + 1) n f t')
 29.1273 +  | Bound j' =>
 29.1274 +    Bound (if j' >= j andalso j' < j + n then f (j' - j) + j else j')
 29.1275 +  | _ => t
 29.1276 +
 29.1277 +(* Maximum number of quantifiers in a cluster for which the exponential
 29.1278 +   algorithm is used. Larger clusters use a heuristic inspired by Claessen &
 29.1279 +   Sörensson's polynomial binary splitting procedure (p. 5 of their MODEL 2003
 29.1280 +   paper). *)
 29.1281 +val quantifier_cluster_threshold = 7
 29.1282 +
 29.1283 +(* theory -> term -> term *)
 29.1284 +fun push_quantifiers_inward thy =
 29.1285 +  let
 29.1286 +    (* string -> string list -> typ list -> term -> term *)
 29.1287 +    fun aux quant_s ss Ts t =
 29.1288 +      (case t of
 29.1289 +         (t0 as Const (s0, _)) $ Abs (s1, T1, t1 as _ $ _) =>
 29.1290 +         if s0 = quant_s then
 29.1291 +           aux s0 (s1 :: ss) (T1 :: Ts) t1
 29.1292 +         else if quant_s = "" andalso
 29.1293 +                 (s0 = @{const_name All} orelse s0 = @{const_name Ex}) then
 29.1294 +           aux s0 [s1] [T1] t1
 29.1295 +         else
 29.1296 +           raise SAME ()
 29.1297 +       | _ => raise SAME ())
 29.1298 +      handle SAME () =>
 29.1299 +             case t of
 29.1300 +               t1 $ t2 =>
 29.1301 +               if quant_s = "" then
 29.1302 +                 aux "" [] [] t1 $ aux "" [] [] t2
 29.1303 +               else
 29.1304 +                 let
 29.1305 +                   val typical_card = 4
 29.1306 +                   (* ('a -> ''b list) -> 'a list -> ''b list *)
 29.1307 +                   fun big_union proj ps =
 29.1308 +                     fold (fold (insert (op =)) o proj) ps []
 29.1309 +                   val (ts, connective) = strip_any_connective t
 29.1310 +                   val T_costs =
 29.1311 +                     map (bounded_card_of_type 65536 typical_card []) Ts
 29.1312 +                   val t_costs = map size_of_term ts
 29.1313 +                   val num_Ts = length Ts
 29.1314 +                   (* int -> int *)
 29.1315 +                   val flip = curry (op -) (num_Ts - 1)
 29.1316 +                   val t_boundss = map (map flip o loose_bnos) ts
 29.1317 +                   (* (int list * int) list -> int list
 29.1318 +                      -> (int list * int) list *)
 29.1319 +                   fun merge costly_boundss [] = costly_boundss
 29.1320 +                     | merge costly_boundss (j :: js) =
 29.1321 +                       let
 29.1322 +                         val (yeas, nays) =
 29.1323 +                           List.partition (fn (bounds, _) =>
 29.1324 +                                              member (op =) bounds j)
 29.1325 +                                          costly_boundss
 29.1326 +                         val yeas_bounds = big_union fst yeas
 29.1327 +                         val yeas_cost = Integer.sum (map snd yeas)
 29.1328 +                                         * nth T_costs j
 29.1329 +                       in merge ((yeas_bounds, yeas_cost) :: nays) js end
 29.1330 +                   (* (int list * int) list -> int list -> int *)
 29.1331 +                   val cost = Integer.sum o map snd oo merge
 29.1332 +                   (* (int list * int) list -> int list -> int list *)
 29.1333 +                   fun heuristically_best_permutation _ [] = []
 29.1334 +                     | heuristically_best_permutation costly_boundss js =
 29.1335 +                       let
 29.1336 +                         val (costly_boundss, (j, js)) =
 29.1337 +                           js |> map (`(merge costly_boundss o single))
 29.1338 +                              |> sort (int_ord
 29.1339 +                                       o pairself (Integer.sum o map snd o fst))
 29.1340 +                              |> split_list |>> hd ||> pairf hd tl
 29.1341 +                       in
 29.1342 +                         j :: heuristically_best_permutation costly_boundss js
 29.1343 +                       end
 29.1344 +                   val js =
 29.1345 +                     if length Ts <= quantifier_cluster_threshold then
 29.1346 +                       all_permutations (index_seq 0 num_Ts)
 29.1347 +                       |> map (`(cost (t_boundss ~~ t_costs)))
 29.1348 +                       |> sort (int_ord o pairself fst) |> hd |> snd
 29.1349 +                     else
 29.1350 +                       heuristically_best_permutation (t_boundss ~~ t_costs)
 29.1351 +                                                      (index_seq 0 num_Ts)
 29.1352 +                   val back_js = map (fn j => find_index (curry (op =) j) js)
 29.1353 +                                     (index_seq 0 num_Ts)
 29.1354 +                   val ts = map (renumber_bounds 0 num_Ts (nth back_js o flip))
 29.1355 +                                ts
 29.1356 +                   (* (term * int list) list -> term *)
 29.1357 +                   fun mk_connection [] =
 29.1358 +                       raise ARG ("Nitpick_Preproc.push_quantifiers_inward.aux.\
 29.1359 +                                  \mk_connection", "")
 29.1360 +                     | mk_connection ts_cum_bounds =
 29.1361 +                       ts_cum_bounds |> map fst
 29.1362 +                       |> foldr1 (fn (t1, t2) => connective $ t1 $ t2)
 29.1363 +                   (* (term * int list) list -> int list -> term *)
 29.1364 +                   fun build ts_cum_bounds [] = ts_cum_bounds |> mk_connection
 29.1365 +                     | build ts_cum_bounds (j :: js) =
 29.1366 +                       let
 29.1367 +                         val (yeas, nays) =
 29.1368 +                           List.partition (fn (_, bounds) =>
 29.1369 +                                              member (op =) bounds j)
 29.1370 +                                          ts_cum_bounds
 29.1371 +                           ||> map (apfst (incr_boundvars ~1))
 29.1372 +                       in
 29.1373 +                         if null yeas then
 29.1374 +                           build nays js
 29.1375 +                         else
 29.1376 +                           let val T = nth Ts (flip j) in
 29.1377 +                             build ((Const (quant_s, (T --> bool_T) --> bool_T)
 29.1378 +                                     $ Abs (nth ss (flip j), T,
 29.1379 +                                            mk_connection yeas),
 29.1380 +                                      big_union snd yeas) :: nays) js
 29.1381 +                           end
 29.1382 +                       end
 29.1383 +                 in build (ts ~~ t_boundss) js end
 29.1384 +             | Abs (s, T, t') => Abs (s, T, aux "" [] [] t')
 29.1385 +             | _ => t
 29.1386 +  in aux "" [] [] end
 29.1387 +
 29.1388 +(** Preprocessor entry point **)
 29.1389 +
 29.1390 +(* hol_context -> term -> ((term list * term list) * (bool * bool)) * term *)
 29.1391 +fun preprocess_term (hol_ctxt as {thy, binary_ints, destroy_constrs, boxes,
 29.1392 +                                  skolemize, uncurry, ...}) t =
 29.1393 +  let
 29.1394 +    val skolem_depth = if skolemize then 4 else ~1
 29.1395 +    val (((def_ts, nondef_ts), (got_all_mono_user_axioms, no_poly_user_axioms)),
 29.1396 +         core_t) = t |> unfold_defs_in_term hol_ctxt
 29.1397 +                     |> close_form
 29.1398 +                     |> skolemize_term_and_more hol_ctxt skolem_depth
 29.1399 +                     |> specialize_consts_in_term hol_ctxt 0
 29.1400 +                     |> `(axioms_for_term hol_ctxt)
 29.1401 +    val binarize =
 29.1402 +      case binary_ints of
 29.1403 +        SOME false => false
 29.1404 +      | _ =>
 29.1405 +        forall may_use_binary_ints (core_t :: def_ts @ nondef_ts) andalso
 29.1406 +        (binary_ints = SOME true orelse
 29.1407 +         exists should_use_binary_ints (core_t :: def_ts @ nondef_ts))
 29.1408 +    val box = exists (not_equal (SOME false) o snd) boxes
 29.1409 +    val table =
 29.1410 +      Termtab.empty |> uncurry
 29.1411 +        ? fold (add_to_uncurry_table thy) (core_t :: def_ts @ nondef_ts)
 29.1412 +    (* bool -> bool -> term -> term *)
 29.1413 +    fun do_rest def core =
 29.1414 +      binarize ? binarize_nat_and_int_in_term
 29.1415 +      #> uncurry ? uncurry_term table
 29.1416 +      #> box ? box_fun_and_pair_in_term hol_ctxt def
 29.1417 +      #> destroy_constrs ? (pull_out_universal_constrs thy def
 29.1418 +                            #> pull_out_existential_constrs thy
 29.1419 +                            #> destroy_pulled_out_constrs hol_ctxt def)
 29.1420 +      #> curry_assms
 29.1421 +      #> destroy_universal_equalities
 29.1422 +      #> destroy_existential_equalities thy
 29.1423 +      #> simplify_constrs_and_sels thy
 29.1424 +      #> distribute_quantifiers
 29.1425 +      #> push_quantifiers_inward thy
 29.1426 +      #> close_form
 29.1427 +      #> Term.map_abs_vars shortest_name
 29.1428 +  in
 29.1429 +    (((map (do_rest true false) def_ts, map (do_rest false false) nondef_ts),
 29.1430 +      (got_all_mono_user_axioms, no_poly_user_axioms)),
 29.1431 +     do_rest false true core_t)
 29.1432 +  end
 29.1433 +
 29.1434 +end;
    30.1 --- a/src/HOL/Tools/Nitpick/nitpick_scope.ML	Tue Feb 09 13:54:27 2010 +0100
    30.2 +++ b/src/HOL/Tools/Nitpick/nitpick_scope.ML	Tue Feb 09 17:06:05 2010 +0100
    30.3 @@ -8,7 +8,7 @@
    30.4  signature NITPICK_SCOPE =
    30.5  sig
    30.6    type styp = Nitpick_Util.styp
    30.7 -  type extended_context = Nitpick_HOL.extended_context
    30.8 +  type hol_context = Nitpick_HOL.hol_context
    30.9  
   30.10    type constr_spec = {
   30.11      const: styp,
   30.12 @@ -28,7 +28,7 @@
   30.13      constrs: constr_spec list}
   30.14  
   30.15    type scope = {
   30.16 -    ext_ctxt: extended_context,
   30.17 +    hol_ctxt: hol_context,
   30.18      card_assigns: (typ * int) list,
   30.19      bits: int,
   30.20      bisim_depth: int,
   30.21 @@ -47,7 +47,7 @@
   30.22    val scopes_equivalent : scope -> scope -> bool
   30.23    val scope_less_eq : scope -> scope -> bool
   30.24    val all_scopes :
   30.25 -    extended_context -> int -> (typ option * int list) list
   30.26 +    hol_context -> int -> (typ option * int list) list
   30.27      -> (styp option * int list) list -> (styp option * int list) list
   30.28      -> int list -> int list -> typ list -> typ list -> typ list
   30.29      -> int * scope list
   30.30 @@ -77,7 +77,7 @@
   30.31    constrs: constr_spec list}
   30.32  
   30.33  type scope = {
   30.34 -  ext_ctxt: extended_context,
   30.35 +  hol_ctxt: hol_context,
   30.36    card_assigns: (typ * int) list,
   30.37    bits: int,
   30.38    bisim_depth: int,
   30.39 @@ -131,10 +131,10 @@
   30.40  
   30.41  (* (string -> string) -> scope
   30.42     -> string list * string list * string list * string list * string list *)
   30.43 -fun quintuple_for_scope quote ({ext_ctxt as {thy, ctxt, ...}, card_assigns,
   30.44 +fun quintuple_for_scope quote ({hol_ctxt as {thy, ctxt, ...}, card_assigns,
   30.45                                  bits, bisim_depth, datatypes, ...} : scope) =
   30.46    let
   30.47 -    val boring_Ts = [@{typ unsigned_bit}, @{typ signed_bit}, @{typ \<xi>},
   30.48 +    val boring_Ts = [@{typ unsigned_bit}, @{typ signed_bit},
   30.49                       @{typ bisim_iterator}]
   30.50      val (iter_assigns, card_assigns) =
   30.51        card_assigns |> filter_out (member (op =) boring_Ts o fst)
   30.52 @@ -240,10 +240,9 @@
   30.53  
   30.54  val max_bits = 31 (* Kodkod limit *)
   30.55  
   30.56 -(* extended_context -> (typ option * int list) list
   30.57 -   -> (styp option * int list) list -> (styp option * int list) list -> int list
   30.58 -   -> int list -> typ -> block *)
   30.59 -fun block_for_type (ext_ctxt as {thy, ...}) cards_assigns maxes_assigns
   30.60 +(* hol_context -> (typ option * int list) list -> (styp option * int list) list
   30.61 +   -> (styp option * int list) list -> int list -> int list -> typ -> block *)
   30.62 +fun block_for_type (hol_ctxt as {thy, ...}) cards_assigns maxes_assigns
   30.63                     iters_assigns bitss bisim_depths T =
   30.64    if T = @{typ unsigned_bit} then
   30.65      [(Card T, map (Integer.min max_bits o Integer.max 1) bitss)]
   30.66 @@ -261,18 +260,18 @@
   30.67                                              (const_for_iterator_type T)))]
   30.68    else
   30.69      (Card T, lookup_type_ints_assign thy cards_assigns T) ::
   30.70 -    (case datatype_constrs ext_ctxt T of
   30.71 +    (case datatype_constrs hol_ctxt T of
   30.72         [_] => []
   30.73       | constrs => map_filter (row_for_constr thy maxes_assigns) constrs)
   30.74  
   30.75 -(* extended_context -> (typ option * int list) list
   30.76 -   -> (styp option * int list) list -> (styp option * int list) list -> int list
   30.77 -   -> int list -> typ list -> typ list -> block list *)
   30.78 -fun blocks_for_types ext_ctxt cards_assigns maxes_assigns iters_assigns bitss
   30.79 +(* hol_context -> (typ option * int list) list -> (styp option * int list) list
   30.80 +   -> (styp option * int list) list -> int list -> int list -> typ list
   30.81 +   -> typ list -> block list *)
   30.82 +fun blocks_for_types hol_ctxt cards_assigns maxes_assigns iters_assigns bitss
   30.83                       bisim_depths mono_Ts nonmono_Ts =
   30.84    let
   30.85      (* typ -> block *)
   30.86 -    val block_for = block_for_type ext_ctxt cards_assigns maxes_assigns
   30.87 +    val block_for = block_for_type hol_ctxt cards_assigns maxes_assigns
   30.88                                     iters_assigns bitss bisim_depths
   30.89      val mono_block = maps block_for mono_Ts
   30.90      val nonmono_blocks = map block_for nonmono_Ts
   30.91 @@ -313,10 +312,10 @@
   30.92  
   30.93  type scope_desc = (typ * int) list * (styp * int) list
   30.94  
   30.95 -(* extended_context -> scope_desc -> typ * int -> bool *)
   30.96 -fun is_surely_inconsistent_card_assign ext_ctxt (card_assigns, max_assigns)
   30.97 +(* hol_context -> scope_desc -> typ * int -> bool *)
   30.98 +fun is_surely_inconsistent_card_assign hol_ctxt (card_assigns, max_assigns)
   30.99                                         (T, k) =
  30.100 -  case datatype_constrs ext_ctxt T of
  30.101 +  case datatype_constrs hol_ctxt T of
  30.102      [] => false
  30.103    | xs =>
  30.104      let
  30.105 @@ -329,20 +328,20 @@
  30.106          | effective_max card max = Int.min (card, max)
  30.107        val max = map2 effective_max dom_cards maxes |> Integer.sum
  30.108      in max < k end
  30.109 -(* extended_context -> (typ * int) list -> (typ * int) list
  30.110 -   -> (styp * int) list -> bool *)
  30.111 -fun is_surely_inconsistent_scope_description ext_ctxt seen rest max_assigns =
  30.112 -  exists (is_surely_inconsistent_card_assign ext_ctxt
  30.113 +(* hol_context -> (typ * int) list -> (typ * int) list -> (styp * int) list
  30.114 +   -> bool *)
  30.115 +fun is_surely_inconsistent_scope_description hol_ctxt seen rest max_assigns =
  30.116 +  exists (is_surely_inconsistent_card_assign hol_ctxt
  30.117                                               (seen @ rest, max_assigns)) seen
  30.118  
  30.119 -(* extended_context -> scope_desc -> (typ * int) list option *)
  30.120 -fun repair_card_assigns ext_ctxt (card_assigns, max_assigns) =
  30.121 +(* hol_context -> scope_desc -> (typ * int) list option *)
  30.122 +fun repair_card_assigns hol_ctxt (card_assigns, max_assigns) =
  30.123    let
  30.124      (* (typ * int) list -> (typ * int) list -> (typ * int) list option *)
  30.125      fun aux seen [] = SOME seen
  30.126        | aux seen ((T, 0) :: _) = NONE
  30.127        | aux seen ((T, k) :: rest) =
  30.128 -        (if is_surely_inconsistent_scope_description ext_ctxt ((T, k) :: seen)
  30.129 +        (if is_surely_inconsistent_scope_description hol_ctxt ((T, k) :: seen)
  30.130                                                       rest max_assigns then
  30.131             raise SAME ()
  30.132           else
  30.133 @@ -374,12 +373,12 @@
  30.134  (* block -> scope_desc *)
  30.135  fun scope_descriptor_from_block block =
  30.136    fold_rev add_row_to_scope_descriptor block ([], [])
  30.137 -(* extended_context -> block list -> int list -> scope_desc option *)
  30.138 -fun scope_descriptor_from_combination (ext_ctxt as {thy, ...}) blocks columns =
  30.139 +(* hol_context -> block list -> int list -> scope_desc option *)
  30.140 +fun scope_descriptor_from_combination (hol_ctxt as {thy, ...}) blocks columns =
  30.141    let
  30.142      val (card_assigns, max_assigns) =
  30.143        maps project_block (columns ~~ blocks) |> scope_descriptor_from_block
  30.144 -    val card_assigns = repair_card_assigns ext_ctxt (card_assigns, max_assigns)
  30.145 +    val card_assigns = repair_card_assigns hol_ctxt (card_assigns, max_assigns)
  30.146                         |> the
  30.147    in
  30.148      SOME (map (repair_iterator_assign thy card_assigns) card_assigns,
  30.149 @@ -427,15 +426,21 @@
  30.150            {delta = delta, epsilon = delta, exclusive = true, total = false}
  30.151          end
  30.152        else if not co andalso num_self_recs > 0 then
  30.153 -        if not self_rec andalso num_non_self_recs = 1 andalso
  30.154 -           domain_card 2 card_assigns T = 1 then
  30.155 -          {delta = 0, epsilon = 1,
  30.156 -           exclusive = (s = @{const_name Nil} andalso length constrs = 2),
  30.157 -           total = true}
  30.158 -        else if s = @{const_name Cons} andalso length constrs = 2 then
  30.159 -          {delta = 1, epsilon = card, exclusive = true, total = false}
  30.160 -        else
  30.161 -          {delta = 0, epsilon = card, exclusive = false, total = false}
  30.162 +        (if num_self_recs = 1 andalso num_non_self_recs = 1 then
  30.163 +           if self_rec then
  30.164 +             case constrs of
  30.165 +               [{delta = 0, epsilon = 1, exclusive = true, ...}] =>
  30.166 +               {delta = 1, epsilon = card, exclusive = true, total = false}
  30.167 +             | _ => raise SAME ()
  30.168 +           else
  30.169 +             if domain_card 2 card_assigns T = 1 then
  30.170 +               {delta = 0, epsilon = 1, exclusive = true, total = true}
  30.171 +             else
  30.172 +               raise SAME ()
  30.173 +         else
  30.174 +           raise SAME ())
  30.175 +        handle SAME () =>
  30.176 +               {delta = 0, epsilon = card, exclusive = false, total = false}
  30.177        else if card = sum_dom_cards (card + 1) then
  30.178          let val delta = next_delta () in
  30.179            {delta = delta, epsilon = delta + domain_card card card_assigns T,
  30.180 @@ -449,31 +454,32 @@
  30.181       explicit_max = max, total = total} :: constrs
  30.182    end
  30.183  
  30.184 -(* extended_context -> (typ * int) list -> typ -> bool *)
  30.185 -fun has_exact_card ext_ctxt card_assigns T =
  30.186 +(* hol_context -> (typ * int) list -> typ -> bool *)
  30.187 +fun has_exact_card hol_ctxt card_assigns T =
  30.188    let val card = card_of_type card_assigns T in
  30.189 -    card = bounded_exact_card_of_type ext_ctxt (card + 1) 0 card_assigns T
  30.190 +    card = bounded_exact_card_of_type hol_ctxt (card + 1) 0 card_assigns T
  30.191    end
  30.192  
  30.193 -(* extended_context -> typ list -> scope_desc -> typ * int -> dtype_spec *)
  30.194 -fun datatype_spec_from_scope_descriptor (ext_ctxt as {thy, ...}) deep_dataTs
  30.195 +(* hol_context -> typ list -> scope_desc -> typ * int -> dtype_spec *)
  30.196 +fun datatype_spec_from_scope_descriptor (hol_ctxt as {thy, ...}) deep_dataTs
  30.197                                          (desc as (card_assigns, _)) (T, card) =
  30.198    let
  30.199      val deep = member (op =) deep_dataTs T
  30.200      val co = is_codatatype thy T
  30.201 -    val xs = boxed_datatype_constrs ext_ctxt T
  30.202 +    val xs = boxed_datatype_constrs hol_ctxt T
  30.203      val self_recs = map (is_self_recursive_constr_type o snd) xs
  30.204      val (num_self_recs, num_non_self_recs) =
  30.205        List.partition I self_recs |> pairself length
  30.206 -    val complete = has_exact_card ext_ctxt card_assigns T
  30.207 +    val complete = has_exact_card hol_ctxt card_assigns T
  30.208      val concrete = xs |> maps (binder_types o snd) |> maps binder_types
  30.209 -                      |> forall (has_exact_card ext_ctxt card_assigns)
  30.210 +                      |> forall (has_exact_card hol_ctxt card_assigns)
  30.211      (* int -> int *)
  30.212      fun sum_dom_cards max =
  30.213        map (domain_card max card_assigns o snd) xs |> Integer.sum
  30.214      val constrs =
  30.215        fold_rev (add_constr_spec desc co card sum_dom_cards num_self_recs
  30.216 -                                num_non_self_recs) (self_recs ~~ xs) []
  30.217 +                                num_non_self_recs)
  30.218 +               (sort (bool_ord o swap o pairself fst) (self_recs ~~ xs)) []
  30.219    in
  30.220      {typ = T, card = card, co = co, complete = complete, concrete = concrete,
  30.221       deep = deep, constrs = constrs}
  30.222 @@ -487,12 +493,12 @@
  30.223      min_bits_for_nat_value (fold Integer.max
  30.224          (map snd card_assigns @ map snd max_assigns) 0)
  30.225  
  30.226 -(* extended_context -> int -> typ list -> scope_desc -> scope *)
  30.227 -fun scope_from_descriptor (ext_ctxt as {thy, ...}) sym_break deep_dataTs
  30.228 +(* hol_context -> int -> typ list -> scope_desc -> scope *)
  30.229 +fun scope_from_descriptor (hol_ctxt as {thy, ...}) sym_break deep_dataTs
  30.230                            (desc as (card_assigns, _)) =
  30.231    let
  30.232      val datatypes =
  30.233 -      map (datatype_spec_from_scope_descriptor ext_ctxt deep_dataTs desc)
  30.234 +      map (datatype_spec_from_scope_descriptor hol_ctxt deep_dataTs desc)
  30.235            (filter (is_datatype thy o fst) card_assigns)
  30.236      val bits = card_of_type card_assigns @{typ signed_bit} - 1
  30.237                 handle TYPE ("Nitpick_HOL.card_of_type", _, _) =>
  30.238 @@ -500,7 +506,7 @@
  30.239                        handle TYPE ("Nitpick_HOL.card_of_type", _, _) => 0
  30.240      val bisim_depth = card_of_type card_assigns @{typ bisim_iterator} - 1
  30.241    in
  30.242 -    {ext_ctxt = ext_ctxt, card_assigns = card_assigns, datatypes = datatypes,
  30.243 +    {hol_ctxt = hol_ctxt, card_assigns = card_assigns, datatypes = datatypes,
  30.244       bits = bits, bisim_depth = bisim_depth,
  30.245       ofs = if sym_break <= 0 then Typtab.empty
  30.246             else offset_table_for_card_assigns thy card_assigns datatypes}
  30.247 @@ -521,26 +527,26 @@
  30.248  val max_scopes = 4096
  30.249  val distinct_threshold = 512
  30.250  
  30.251 -(* extended_context -> int -> (typ option * int list) list
  30.252 +(* hol_context -> int -> (typ option * int list) list
  30.253     -> (styp option * int list) list -> (styp option * int list) list -> int list
  30.254     -> typ list -> typ list -> typ list -> int * scope list *)
  30.255 -fun all_scopes (ext_ctxt as {thy, ...}) sym_break cards_assigns maxes_assigns
  30.256 +fun all_scopes (hol_ctxt as {thy, ...}) sym_break cards_assigns maxes_assigns
  30.257                 iters_assigns bitss bisim_depths mono_Ts nonmono_Ts deep_dataTs =
  30.258    let
  30.259      val cards_assigns = repair_cards_assigns_wrt_boxing thy mono_Ts
  30.260                                                          cards_assigns
  30.261 -    val blocks = blocks_for_types ext_ctxt cards_assigns maxes_assigns
  30.262 +    val blocks = blocks_for_types hol_ctxt cards_assigns maxes_assigns
  30.263                                    iters_assigns bitss bisim_depths mono_Ts
  30.264                                    nonmono_Ts
  30.265      val ranks = map rank_of_block blocks
  30.266      val all = all_combinations_ordered_smartly (map (rpair 0) ranks)
  30.267      val head = take max_scopes all
  30.268 -    val descs = map_filter (scope_descriptor_from_combination ext_ctxt blocks)
  30.269 +    val descs = map_filter (scope_descriptor_from_combination hol_ctxt blocks)
  30.270                             head
  30.271    in
  30.272      (length all - length head,
  30.273       descs |> length descs <= distinct_threshold ? distinct (op =)
  30.274 -           |> map (scope_from_descriptor ext_ctxt sym_break deep_dataTs))
  30.275 +           |> map (scope_from_descriptor hol_ctxt sym_break deep_dataTs))
  30.276    end
  30.277  
  30.278  end;
    31.1 --- a/src/Tools/quickcheck.ML	Tue Feb 09 13:54:27 2010 +0100
    31.2 +++ b/src/Tools/quickcheck.ML	Tue Feb 09 17:06:05 2010 +0100
    31.3 @@ -153,9 +153,9 @@
    31.4        |> ObjectLogic.atomize_term thy;
    31.5    in test_term ctxt quiet generator_name size iterations gi' end;
    31.6  
    31.7 -fun pretty_counterex ctxt NONE = Pretty.str "No counterexamples found."
    31.8 +fun pretty_counterex ctxt NONE = Pretty.str "Quickcheck found no counterexample."
    31.9    | pretty_counterex ctxt (SOME cex) =
   31.10 -      Pretty.chunks (Pretty.str "Counterexample found:\n" ::
   31.11 +      Pretty.chunks (Pretty.str "Quickcheck found a counterexample:\n" ::
   31.12          map (fn (s, t) =>
   31.13            Pretty.block [Pretty.str (s ^ " ="), Pretty.brk 1, Syntax.pretty_term ctxt t]) cex);
   31.14