added Nitpick's theory and ML files to Isabelle/HOL;
authorblanchet
Thu Oct 22 14:51:47 2009 +0200 (2009-10-22)
changeset 3319208a39a957ed7
parent 33191 fe3c65d9c577
child 33193 6f6baa3ef4dd
added Nitpick's theory and ML files to Isabelle/HOL;
the examples and the documentation are on their way.
CONTRIBUTORS
NEWS
src/HOL/IsaMakefile
src/HOL/Main.thy
src/HOL/Nitpick.thy
src/HOL/Tools/Nitpick/kodkod.ML
src/HOL/Tools/Nitpick/kodkod_sat.ML
src/HOL/Tools/Nitpick/minipick.ML
src/HOL/Tools/Nitpick/nitpick.ML
src/HOL/Tools/Nitpick/nitpick_hol.ML
src/HOL/Tools/Nitpick/nitpick_isar.ML
src/HOL/Tools/Nitpick/nitpick_kodkod.ML
src/HOL/Tools/Nitpick/nitpick_model.ML
src/HOL/Tools/Nitpick/nitpick_mono.ML
src/HOL/Tools/Nitpick/nitpick_nut.ML
src/HOL/Tools/Nitpick/nitpick_peephole.ML
src/HOL/Tools/Nitpick/nitpick_rep.ML
src/HOL/Tools/Nitpick/nitpick_scope.ML
src/HOL/Tools/Nitpick/nitpick_tests.ML
src/HOL/Tools/Nitpick/nitpick_util.ML
     1.1 --- a/CONTRIBUTORS	Thu Oct 22 14:45:20 2009 +0200
     1.2 +++ b/CONTRIBUTORS	Thu Oct 22 14:51:47 2009 +0200
     1.3 @@ -7,6 +7,9 @@
     1.4  Contributions to this Isabelle version
     1.5  --------------------------------------
     1.6  
     1.7 +* October 2009: Jasmin Blanchette, TUM
     1.8 +  Nitpick: yet another counterexample generator for Isabelle/HOL
     1.9 +
    1.10  * October 2009: Sascha Boehme, TUM
    1.11    Extension of SMT method: proof-reconstruction for the SMT solver Z3
    1.12  
     2.1 --- a/NEWS	Thu Oct 22 14:45:20 2009 +0200
     2.2 +++ b/NEWS	Thu Oct 22 14:51:47 2009 +0200
     2.3 @@ -50,6 +50,9 @@
     2.4  this method is proof-producing. Certificates are provided to
     2.5  avoid calling the external solvers solely for re-checking proofs.
     2.6  
     2.7 +* New counterexample generator tool "nitpick" based on the Kodkod
     2.8 +relational model finder.
     2.9 +
    2.10  * Reorganization of number theory:
    2.11    * former session NumberTheory now named Old_Number_Theory
    2.12    * new session Number_Theory by Jeremy Avigad; if possible, prefer this.
     3.1 --- a/src/HOL/IsaMakefile	Thu Oct 22 14:45:20 2009 +0200
     3.2 +++ b/src/HOL/IsaMakefile	Thu Oct 22 14:51:47 2009 +0200
     3.3 @@ -131,6 +131,7 @@
     3.4    Inductive.thy \
     3.5    Lattices.thy \
     3.6    Nat.thy \
     3.7 +  Nitpick.thy \
     3.8    Option.thy \
     3.9    OrderedGroup.thy \
    3.10    Orderings.thy \
    3.11 @@ -176,6 +177,21 @@
    3.12    Tools/Function/size.ML \
    3.13    Tools/Function/sum_tree.ML \
    3.14    Tools/Function/termination.ML \
    3.15 +  Tools/Nitpick/kodkod.ML \
    3.16 +  Tools/Nitpick/kodkod_sat.ML \
    3.17 +  Tools/Nitpick/minipick.ML \
    3.18 +  Tools/Nitpick/nitpick.ML \
    3.19 +  Tools/Nitpick/nitpick_hol.ML \
    3.20 +  Tools/Nitpick/nitpick_isar.ML \
    3.21 +  Tools/Nitpick/nitpick_kodkod.ML \
    3.22 +  Tools/Nitpick/nitpick_model.ML \
    3.23 +  Tools/Nitpick/nitpick_mono.ML \
    3.24 +  Tools/Nitpick/nitpick_nut.ML \
    3.25 +  Tools/Nitpick/nitpick_peephole.ML \
    3.26 +  Tools/Nitpick/nitpick_rep.ML \
    3.27 +  Tools/Nitpick/nitpick_scope.ML \
    3.28 +  Tools/Nitpick/nitpick_tests.ML \
    3.29 +  Tools/Nitpick/nitpick_util.ML \
    3.30    Tools/inductive_codegen.ML \
    3.31    Tools/inductive.ML \
    3.32    Tools/inductive_realizer.ML \
     4.1 --- a/src/HOL/Main.thy	Thu Oct 22 14:45:20 2009 +0200
     4.2 +++ b/src/HOL/Main.thy	Thu Oct 22 14:51:47 2009 +0200
     4.3 @@ -1,7 +1,7 @@
     4.4  header {* Main HOL *}
     4.5  
     4.6  theory Main
     4.7 -imports Plain Quickcheck Map Recdef SAT
     4.8 +imports Plain Nitpick Quickcheck Recdef
     4.9  begin
    4.10  
    4.11  text {*
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/HOL/Nitpick.thy	Thu Oct 22 14:51:47 2009 +0200
     5.3 @@ -0,0 +1,240 @@
     5.4 +(*  Title:      HOL/Nitpick.thy
     5.5 +    Author:     Jasmin Blanchette, TU Muenchen
     5.6 +    Copyright   2008, 2009
     5.7 +
     5.8 +Nitpick: Yet another counterexample generator for Isabelle/HOL.
     5.9 +*)
    5.10 +
    5.11 +header {* Nitpick: Yet Another Counterexample Generator for Isabelle/HOL *}
    5.12 +
    5.13 +theory Nitpick
    5.14 +imports Map SAT
    5.15 +uses ("Tools/Nitpick/kodkod.ML")
    5.16 +     ("Tools/Nitpick/kodkod_sat.ML")
    5.17 +     ("Tools/Nitpick/nitpick_util.ML")
    5.18 +     ("Tools/Nitpick/nitpick_hol.ML")
    5.19 +     ("Tools/Nitpick/nitpick_mono.ML")
    5.20 +     ("Tools/Nitpick/nitpick_scope.ML")
    5.21 +     ("Tools/Nitpick/nitpick_peephole.ML")
    5.22 +     ("Tools/Nitpick/nitpick_rep.ML")
    5.23 +     ("Tools/Nitpick/nitpick_nut.ML")
    5.24 +     ("Tools/Nitpick/nitpick_kodkod.ML")
    5.25 +     ("Tools/Nitpick/nitpick_model.ML")
    5.26 +     ("Tools/Nitpick/nitpick.ML")
    5.27 +     ("Tools/Nitpick/nitpick_isar.ML")
    5.28 +     ("Tools/Nitpick/nitpick_tests.ML")
    5.29 +     ("Tools/Nitpick/minipick.ML")
    5.30 +begin
    5.31 +
    5.32 +typedecl bisim_iterator
    5.33 +
    5.34 +(* FIXME: use axiomatization (here and elsewhere) *)
    5.35 +axiomatization unknown :: 'a
    5.36 +           and undefined_fast_The :: 'a
    5.37 +           and undefined_fast_Eps :: 'a
    5.38 +           and bisim :: "bisim_iterator \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
    5.39 +           and bisim_iterator_max :: bisim_iterator
    5.40 +           and Tha :: "('a \<Rightarrow> bool) \<Rightarrow> 'a"
    5.41 +
    5.42 +datatype ('a, 'b) pair_box = PairBox 'a 'b
    5.43 +datatype ('a, 'b) fun_box = FunBox "'a \<Rightarrow> 'b"
    5.44 +
    5.45 +text {*
    5.46 +Alternative definitions.
    5.47 +*}
    5.48 +
    5.49 +lemma If_def [nitpick_def]:
    5.50 +"(if P then Q else R) \<equiv> (P \<longrightarrow> Q) \<and> (\<not> P \<longrightarrow> R)"
    5.51 +by (rule eq_reflection) (rule if_bool_eq_conj)
    5.52 +
    5.53 +lemma Ex1_def [nitpick_def]:
    5.54 +"Ex1 P \<equiv> \<exists>x. P = {x}"
    5.55 +apply (rule eq_reflection)
    5.56 +apply (simp add: Ex1_def expand_set_eq)
    5.57 +apply (rule iffI)
    5.58 + apply (erule exE)
    5.59 + apply (erule conjE)
    5.60 + apply (rule_tac x = x in exI)
    5.61 + apply (rule allI)
    5.62 + apply (rename_tac y)
    5.63 + apply (erule_tac x = y in allE)
    5.64 +by (auto simp: mem_def)
    5.65 +
    5.66 +lemma rtrancl_def [nitpick_def]: "r\<^sup>* \<equiv> (r\<^sup>+)\<^sup>="
    5.67 +by simp
    5.68 +
    5.69 +lemma rtranclp_def [nitpick_def]:
    5.70 +"rtranclp r a b \<equiv> (a = b \<or> tranclp r a b)"
    5.71 +by (rule eq_reflection) (auto dest: rtranclpD)
    5.72 +
    5.73 +lemma tranclp_def [nitpick_def]:
    5.74 +"tranclp r a b \<equiv> trancl (split r) (a, b)"
    5.75 +by (simp add: trancl_def Collect_def mem_def)
    5.76 +
    5.77 +definition refl' :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
    5.78 +"refl' r \<equiv> \<forall>x. (x, x) \<in> r"
    5.79 +
    5.80 +definition wf' :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
    5.81 +"wf' r \<equiv> acyclic r \<and> (finite r \<or> unknown)"
    5.82 +
    5.83 +axiomatization wf_wfrec :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
    5.84 +
    5.85 +definition wf_wfrec' :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
    5.86 +[nitpick_simp]: "wf_wfrec' R F x = F (Recdef.cut (wf_wfrec R F) R x) x"
    5.87 +
    5.88 +definition wfrec' ::  "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
    5.89 +"wfrec' R F x \<equiv> if wf R then wf_wfrec' R F x
    5.90 +                else THE y. wfrec_rel R (%f x. F (Recdef.cut f R x) x) x y"
    5.91 +
    5.92 +definition card' :: "('a \<Rightarrow> bool) \<Rightarrow> nat" where
    5.93 +"card' X \<equiv> length (SOME xs. set xs = X \<and> distinct xs)"
    5.94 +
    5.95 +definition setsum' :: "('a \<Rightarrow> 'b\<Colon>comm_monoid_add) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'b" where
    5.96 +"setsum' f A \<equiv> if finite A then listsum (map f (SOME xs. set xs = A \<and> distinct xs)) else 0"
    5.97 +
    5.98 +inductive fold_graph' :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> bool" where
    5.99 +"fold_graph' f z {} z" |
   5.100 +"\<lbrakk>x \<in> A; fold_graph' f z (A - {x}) y\<rbrakk> \<Longrightarrow> fold_graph' f z A (f x y)"
   5.101 +
   5.102 +text {*
   5.103 +The following lemmas are not strictly necessary but they help the
   5.104 +\textit{special\_level} optimization.
   5.105 +*}
   5.106 +
   5.107 +lemma The_psimp [nitpick_psimp]:
   5.108 +"P = {x} \<Longrightarrow> The P = x"
   5.109 +by (subgoal_tac "{x} = (\<lambda>y. y = x)") (auto simp: mem_def)
   5.110 +
   5.111 +lemma Eps_psimp [nitpick_psimp]:
   5.112 +"\<lbrakk>P x; \<not> P y; Eps P = y\<rbrakk> \<Longrightarrow> Eps P = x"
   5.113 +apply (case_tac "P (Eps P)")
   5.114 + apply auto
   5.115 +apply (erule contrapos_np)
   5.116 +by (rule someI)
   5.117 +
   5.118 +lemma unit_case_def [nitpick_def]:
   5.119 +"unit_case x u \<equiv> x"
   5.120 +apply (subgoal_tac "u = ()")
   5.121 + apply (simp only: unit.cases)
   5.122 +by simp
   5.123 +
   5.124 +lemma nat_case_def [nitpick_def]:
   5.125 +"nat_case x f n \<equiv> if n = 0 then x else f (n - 1)"
   5.126 +apply (rule eq_reflection)
   5.127 +by (case_tac n) auto
   5.128 +
   5.129 +lemmas dvd_def = dvd_eq_mod_eq_0 [THEN eq_reflection, nitpick_def]
   5.130 +
   5.131 +lemma list_size_simp [nitpick_simp]:
   5.132 +"list_size f xs = (if xs = [] then 0
   5.133 +                   else Suc (f (hd xs) + list_size f (tl xs)))"
   5.134 +"size xs = (if xs = [] then 0 else Suc (size (tl xs)))"
   5.135 +by (case_tac xs) auto
   5.136 +
   5.137 +text {*
   5.138 +Auxiliary definitions used to provide an alternative representation for
   5.139 +@{text rat} and @{text real}.
   5.140 +*}
   5.141 +
   5.142 +function nat_gcd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
   5.143 +[simp del]: "nat_gcd x y = (if y = 0 then x else nat_gcd y (x mod y))"
   5.144 +by auto
   5.145 +termination
   5.146 +apply (relation "measure (\<lambda>(x, y). x + y + (if y > x then 1 else 0))")
   5.147 + apply auto
   5.148 + apply (metis mod_less_divisor xt1(9))
   5.149 +by (metis mod_mod_trivial mod_self nat_neq_iff xt1(10))
   5.150 +
   5.151 +definition nat_lcm :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
   5.152 +"nat_lcm x y = x * y div (nat_gcd x y)"
   5.153 +
   5.154 +definition int_gcd :: "int \<Rightarrow> int \<Rightarrow> int" where
   5.155 +"int_gcd x y = int (nat_gcd (nat (abs x)) (nat (abs y)))"
   5.156 +
   5.157 +definition int_lcm :: "int \<Rightarrow> int \<Rightarrow> int" where
   5.158 +"int_lcm x y = int (nat_lcm (nat (abs x)) (nat (abs y)))"
   5.159 +
   5.160 +definition Frac :: "int \<times> int \<Rightarrow> bool" where
   5.161 +"Frac \<equiv> \<lambda>(a, b). b > 0 \<and> int_gcd a b = 1"
   5.162 +
   5.163 +axiomatization Abs_Frac :: "int \<times> int \<Rightarrow> 'a"
   5.164 +           and Rep_Frac :: "'a \<Rightarrow> int \<times> int"
   5.165 +
   5.166 +definition zero_frac :: 'a where
   5.167 +"zero_frac \<equiv> Abs_Frac (0, 1)"
   5.168 +
   5.169 +definition one_frac :: 'a where
   5.170 +"one_frac \<equiv> Abs_Frac (1, 1)"
   5.171 +
   5.172 +definition num :: "'a \<Rightarrow> int" where
   5.173 +"num \<equiv> fst o Rep_Frac"
   5.174 +
   5.175 +definition denom :: "'a \<Rightarrow> int" where
   5.176 +"denom \<equiv> snd o Rep_Frac"
   5.177 +
   5.178 +function norm_frac :: "int \<Rightarrow> int \<Rightarrow> int \<times> int" where
   5.179 +[simp del]: "norm_frac a b = (if b < 0 then norm_frac (- a) (- b)
   5.180 +                              else if a = 0 \<or> b = 0 then (0, 1)
   5.181 +                              else let c = int_gcd a b in (a div c, b div c))"
   5.182 +by pat_completeness auto
   5.183 +termination by (relation "measure (\<lambda>(_, b). if b < 0 then 1 else 0)") auto
   5.184 +
   5.185 +definition frac :: "int \<Rightarrow> int \<Rightarrow> 'a" where
   5.186 +"frac a b \<equiv> Abs_Frac (norm_frac a b)"
   5.187 +
   5.188 +definition plus_frac :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
   5.189 +[nitpick_simp]:
   5.190 +"plus_frac q r = (let d = int_lcm (denom q) (denom r) in
   5.191 +                    frac (num q * (d div denom q) + num r * (d div denom r)) d)"
   5.192 +
   5.193 +definition times_frac :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
   5.194 +[nitpick_simp]:
   5.195 +"times_frac q r = frac (num q * num r) (denom q * denom r)"
   5.196 +
   5.197 +definition uminus_frac :: "'a \<Rightarrow> 'a" where
   5.198 +"uminus_frac q \<equiv> Abs_Frac (- num q, denom q)"
   5.199 +
   5.200 +definition number_of_frac :: "int \<Rightarrow> 'a" where
   5.201 +"number_of_frac n \<equiv> Abs_Frac (n, 1)"
   5.202 +
   5.203 +definition inverse_frac :: "'a \<Rightarrow> 'a" where
   5.204 +"inverse_frac q \<equiv> frac (denom q) (num q)"
   5.205 +
   5.206 +definition less_eq_frac :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
   5.207 +[nitpick_simp]:
   5.208 +"less_eq_frac q r \<longleftrightarrow> num (plus_frac q (uminus_frac r)) \<le> 0"
   5.209 +
   5.210 +definition of_frac :: "'a \<Rightarrow> 'b\<Colon>{inverse,ring_1}" where
   5.211 +"of_frac q \<equiv> of_int (num q) / of_int (denom q)"
   5.212 +
   5.213 +use "Tools/Nitpick/kodkod.ML"
   5.214 +use "Tools/Nitpick/kodkod_sat.ML"
   5.215 +use "Tools/Nitpick/nitpick_util.ML"
   5.216 +use "Tools/Nitpick/nitpick_hol.ML"
   5.217 +use "Tools/Nitpick/nitpick_mono.ML"
   5.218 +use "Tools/Nitpick/nitpick_scope.ML"
   5.219 +use "Tools/Nitpick/nitpick_peephole.ML"
   5.220 +use "Tools/Nitpick/nitpick_rep.ML"
   5.221 +use "Tools/Nitpick/nitpick_nut.ML"
   5.222 +use "Tools/Nitpick/nitpick_kodkod.ML"
   5.223 +use "Tools/Nitpick/nitpick_model.ML"
   5.224 +use "Tools/Nitpick/nitpick.ML"
   5.225 +use "Tools/Nitpick/nitpick_isar.ML"
   5.226 +use "Tools/Nitpick/nitpick_tests.ML"
   5.227 +use "Tools/Nitpick/minipick.ML"
   5.228 +
   5.229 +hide (open) const unknown undefined_fast_The undefined_fast_Eps bisim 
   5.230 +    bisim_iterator_max Tha refl' wf' wf_wfrec wf_wfrec' wfrec' card' setsum'
   5.231 +    fold_graph' nat_gcd nat_lcm int_gcd int_lcm Frac Abs_Frac Rep_Frac zero_frac
   5.232 +    one_frac num denom norm_frac frac plus_frac times_frac uminus_frac
   5.233 +    number_of_frac inverse_frac less_eq_frac of_frac
   5.234 +hide (open) type bisim_iterator pair_box fun_box
   5.235 +hide (open) fact If_def Ex1_def rtrancl_def rtranclp_def tranclp_def refl'_def
   5.236 +    wf'_def wf_wfrec'_def wfrec'_def card'_def setsum'_def fold_graph'_def
   5.237 +    The_psimp Eps_psimp unit_case_def nat_case_def dvd_def list_size_simp
   5.238 +    nat_gcd_def nat_lcm_def int_gcd_def int_lcm_def Frac_def zero_frac_def
   5.239 +    one_frac_def num_def denom_def norm_frac_def frac_def plus_frac_def
   5.240 +    times_frac_def uminus_frac_def number_of_frac_def inverse_frac_def
   5.241 +    less_eq_frac_def of_frac_def
   5.242 +
   5.243 +end
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/Tools/Nitpick/kodkod.ML	Thu Oct 22 14:51:47 2009 +0200
     6.3 @@ -0,0 +1,1087 @@
     6.4 +(*  Title:      HOL/Nitpick/Tools/kodkod.ML
     6.5 +    Author:     Jasmin Blanchette, TU Muenchen
     6.6 +    Copyright   2008, 2009
     6.7 +
     6.8 +ML interface on top of Kodkod.
     6.9 +*)
    6.10 +
    6.11 +signature KODKOD =
    6.12 +sig
    6.13 +  type n_ary_index = int * int
    6.14 +  type setting = string * string
    6.15 +
    6.16 +  datatype tuple =
    6.17 +    Tuple of int list |
    6.18 +    TupleIndex of n_ary_index |
    6.19 +    TupleReg of n_ary_index
    6.20 +
    6.21 +  datatype tuple_set =
    6.22 +    TupleUnion of tuple_set * tuple_set |
    6.23 +    TupleDifference of tuple_set * tuple_set |
    6.24 +    TupleIntersect of tuple_set * tuple_set |
    6.25 +    TupleProduct of tuple_set * tuple_set |
    6.26 +    TupleProject of tuple_set * int |
    6.27 +    TupleSet of tuple list |
    6.28 +    TupleRange of tuple * tuple |
    6.29 +    TupleArea of tuple * tuple |
    6.30 +    TupleAtomSeq of int * int |
    6.31 +    TupleSetReg of n_ary_index
    6.32 +
    6.33 +  datatype tuple_assign =
    6.34 +    AssignTuple of n_ary_index * tuple |
    6.35 +    AssignTupleSet of n_ary_index * tuple_set
    6.36 +
    6.37 +  type bound = (n_ary_index * string) list * tuple_set list
    6.38 +  type int_bound = int option * tuple_set list
    6.39 +
    6.40 +  datatype formula =
    6.41 +    All of decl list * formula |
    6.42 +    Exist of decl list * formula |
    6.43 +    FormulaLet of expr_assign list * formula |
    6.44 +    FormulaIf of formula * formula * formula |
    6.45 +    Or of formula * formula |
    6.46 +    Iff of formula * formula |
    6.47 +    Implies of formula * formula |
    6.48 +    And of formula * formula |
    6.49 +    Not of formula |
    6.50 +    Acyclic of n_ary_index |
    6.51 +    Function of n_ary_index * rel_expr * rel_expr |
    6.52 +    Functional of n_ary_index * rel_expr * rel_expr |
    6.53 +    TotalOrdering of n_ary_index * n_ary_index * n_ary_index * n_ary_index |
    6.54 +    Subset of rel_expr * rel_expr |
    6.55 +    RelEq of rel_expr * rel_expr |
    6.56 +    IntEq of int_expr * int_expr |
    6.57 +    LT of int_expr * int_expr |
    6.58 +    LE of int_expr * int_expr |
    6.59 +    No of rel_expr |
    6.60 +    Lone of rel_expr |
    6.61 +    One of rel_expr |
    6.62 +    Some of rel_expr |
    6.63 +    False |
    6.64 +    True |
    6.65 +    FormulaReg of int
    6.66 +  and rel_expr =
    6.67 +    RelLet of expr_assign list * rel_expr |
    6.68 +    RelIf of formula * rel_expr * rel_expr |
    6.69 +    Union of rel_expr * rel_expr |
    6.70 +    Difference of rel_expr * rel_expr |
    6.71 +    Override of rel_expr * rel_expr |
    6.72 +    Intersect of rel_expr * rel_expr |
    6.73 +    Product of rel_expr * rel_expr |
    6.74 +    IfNo of rel_expr * rel_expr |
    6.75 +    Project of rel_expr * int_expr list |
    6.76 +    Join of rel_expr * rel_expr |
    6.77 +    Closure of rel_expr |
    6.78 +    ReflexiveClosure of rel_expr |
    6.79 +    Transpose of rel_expr |
    6.80 +    Comprehension of decl list * formula |
    6.81 +    Bits of int_expr |
    6.82 +    Int of int_expr |
    6.83 +    Iden |
    6.84 +    Ints |
    6.85 +    None |
    6.86 +    Univ |
    6.87 +    Atom of int |
    6.88 +    AtomSeq of int * int |
    6.89 +    Rel of n_ary_index |
    6.90 +    Var of n_ary_index |
    6.91 +    RelReg of n_ary_index
    6.92 +  and int_expr =
    6.93 +    Sum of decl list * int_expr |
    6.94 +    IntLet of expr_assign list * int_expr |
    6.95 +    IntIf of formula * int_expr * int_expr |
    6.96 +    SHL of int_expr * int_expr |
    6.97 +    SHA of int_expr * int_expr |
    6.98 +    SHR of int_expr * int_expr |
    6.99 +    Add of int_expr * int_expr |
   6.100 +    Sub of int_expr * int_expr |
   6.101 +    Mult of int_expr * int_expr |
   6.102 +    Div of int_expr * int_expr |
   6.103 +    Mod of int_expr * int_expr |
   6.104 +    Cardinality of rel_expr |
   6.105 +    SetSum of rel_expr |
   6.106 +    BitOr of int_expr * int_expr |
   6.107 +    BitXor of int_expr * int_expr |
   6.108 +    BitAnd of int_expr * int_expr |
   6.109 +    BitNot of int_expr |
   6.110 +    Neg of int_expr |
   6.111 +    Absolute of int_expr |
   6.112 +    Signum of int_expr |
   6.113 +    Num of int |
   6.114 +    IntReg of int
   6.115 +  and decl =
   6.116 +    DeclNo of n_ary_index * rel_expr |
   6.117 +    DeclLone of n_ary_index * rel_expr |
   6.118 +    DeclOne of n_ary_index * rel_expr |
   6.119 +    DeclSome of n_ary_index * rel_expr |
   6.120 +    DeclSet of n_ary_index * rel_expr
   6.121 +  and expr_assign =
   6.122 +    AssignFormulaReg of int * formula |
   6.123 +    AssignRelReg of n_ary_index * rel_expr |
   6.124 +    AssignIntReg of int * int_expr
   6.125 +
   6.126 +  type 'a fold_expr_funcs = {
   6.127 +    formula_func: formula -> 'a -> 'a,
   6.128 +    rel_expr_func: rel_expr -> 'a -> 'a,
   6.129 +    int_expr_func: int_expr -> 'a -> 'a
   6.130 +  }
   6.131 +
   6.132 +  val fold_formula : 'a fold_expr_funcs -> formula -> 'a -> 'a
   6.133 +  val fold_rel_expr : 'a fold_expr_funcs -> rel_expr -> 'a -> 'a
   6.134 +  val fold_int_expr : 'a fold_expr_funcs -> int_expr -> 'a -> 'a
   6.135 +  val fold_decl : 'a fold_expr_funcs -> decl -> 'a -> 'a
   6.136 +  val fold_expr_assign : 'a fold_expr_funcs -> expr_assign -> 'a -> 'a
   6.137 +
   6.138 +  type 'a fold_tuple_funcs = {
   6.139 +    tuple_func: tuple -> 'a -> 'a,
   6.140 +    tuple_set_func: tuple_set -> 'a -> 'a
   6.141 +  }
   6.142 +
   6.143 +  val fold_tuple : 'a fold_tuple_funcs -> tuple -> 'a -> 'a
   6.144 +  val fold_tuple_set : 'a fold_tuple_funcs -> tuple_set -> 'a -> 'a
   6.145 +  val fold_tuple_assign : 'a fold_tuple_funcs -> tuple_assign -> 'a -> 'a
   6.146 +  val fold_bound :
   6.147 +      'a fold_expr_funcs -> 'a fold_tuple_funcs -> bound -> 'a -> 'a
   6.148 +  val fold_int_bound : 'a fold_tuple_funcs -> int_bound -> 'a -> 'a
   6.149 +
   6.150 +  type problem = {
   6.151 +    comment: string,
   6.152 +    settings: setting list,
   6.153 +    univ_card: int,
   6.154 +    tuple_assigns: tuple_assign list,
   6.155 +    bounds: bound list,
   6.156 +    int_bounds: int_bound list,
   6.157 +    expr_assigns: expr_assign list,
   6.158 +    formula: formula}
   6.159 +
   6.160 +  type raw_bound = n_ary_index * int list list
   6.161 +
   6.162 +  datatype outcome =
   6.163 +    Normal of (int * raw_bound list) list * int list |
   6.164 +    TimedOut of int list |
   6.165 +    Interrupted of int list option |
   6.166 +    Error of string * int list
   6.167 +
   6.168 +  exception SYNTAX of string * string
   6.169 +
   6.170 +  val max_arity : int -> int
   6.171 +  val arity_of_rel_expr : rel_expr -> int
   6.172 +  val problems_equivalent : problem -> problem -> bool
   6.173 +  val solve_any_problem :
   6.174 +    bool -> Time.time option -> int -> int -> problem list -> outcome
   6.175 +end;
   6.176 +
   6.177 +structure Kodkod : KODKOD =
   6.178 +struct
   6.179 +
   6.180 +type n_ary_index = int * int
   6.181 +
   6.182 +type setting = string * string
   6.183 +
   6.184 +datatype tuple =
   6.185 +  Tuple of int list |
   6.186 +  TupleIndex of n_ary_index |
   6.187 +  TupleReg of n_ary_index
   6.188 +
   6.189 +datatype tuple_set =
   6.190 +  TupleUnion of tuple_set * tuple_set |
   6.191 +  TupleDifference of tuple_set * tuple_set |
   6.192 +  TupleIntersect of tuple_set * tuple_set |
   6.193 +  TupleProduct of tuple_set * tuple_set |
   6.194 +  TupleProject of tuple_set * int |
   6.195 +  TupleSet of tuple list |
   6.196 +  TupleRange of tuple * tuple |
   6.197 +  TupleArea of tuple * tuple |
   6.198 +  TupleAtomSeq of int * int |
   6.199 +  TupleSetReg of n_ary_index
   6.200 +
   6.201 +datatype tuple_assign =
   6.202 +  AssignTuple of n_ary_index * tuple |
   6.203 +  AssignTupleSet of n_ary_index * tuple_set
   6.204 +
   6.205 +type bound = (n_ary_index * string) list * tuple_set list
   6.206 +type int_bound = int option * tuple_set list
   6.207 +
   6.208 +datatype formula =
   6.209 +  All of decl list * formula |
   6.210 +  Exist of decl list * formula |
   6.211 +  FormulaLet of expr_assign list * formula |
   6.212 +  FormulaIf of formula * formula * formula |
   6.213 +  Or of formula * formula |
   6.214 +  Iff of formula * formula |
   6.215 +  Implies of formula * formula |
   6.216 +  And of formula * formula |
   6.217 +  Not of formula |
   6.218 +  Acyclic of n_ary_index |
   6.219 +  Function of n_ary_index * rel_expr * rel_expr |
   6.220 +  Functional of n_ary_index * rel_expr * rel_expr |
   6.221 +  TotalOrdering of n_ary_index * n_ary_index * n_ary_index * n_ary_index |
   6.222 +  Subset of rel_expr * rel_expr |
   6.223 +  RelEq of rel_expr * rel_expr |
   6.224 +  IntEq of int_expr * int_expr |
   6.225 +  LT of int_expr * int_expr |
   6.226 +  LE of int_expr * int_expr |
   6.227 +  No of rel_expr |
   6.228 +  Lone of rel_expr |
   6.229 +  One of rel_expr |
   6.230 +  Some of rel_expr |
   6.231 +  False |
   6.232 +  True |
   6.233 +  FormulaReg of int
   6.234 +and rel_expr =
   6.235 +  RelLet of expr_assign list * rel_expr |
   6.236 +  RelIf of formula * rel_expr * rel_expr |
   6.237 +  Union of rel_expr * rel_expr |
   6.238 +  Difference of rel_expr * rel_expr |
   6.239 +  Override of rel_expr * rel_expr |
   6.240 +  Intersect of rel_expr * rel_expr |
   6.241 +  Product of rel_expr * rel_expr |
   6.242 +  IfNo of rel_expr * rel_expr |
   6.243 +  Project of rel_expr * int_expr list |
   6.244 +  Join of rel_expr * rel_expr |
   6.245 +  Closure of rel_expr |
   6.246 +  ReflexiveClosure of rel_expr |
   6.247 +  Transpose of rel_expr |
   6.248 +  Comprehension of decl list * formula |
   6.249 +  Bits of int_expr |
   6.250 +  Int of int_expr |
   6.251 +  Iden |
   6.252 +  Ints |
   6.253 +  None |
   6.254 +  Univ |
   6.255 +  Atom of int |
   6.256 +  AtomSeq of int * int |
   6.257 +  Rel of n_ary_index |
   6.258 +  Var of n_ary_index |
   6.259 +  RelReg of n_ary_index
   6.260 +and int_expr =
   6.261 +  Sum of decl list * int_expr |
   6.262 +  IntLet of expr_assign list * int_expr |
   6.263 +  IntIf of formula * int_expr * int_expr |
   6.264 +  SHL of int_expr * int_expr |
   6.265 +  SHA of int_expr * int_expr |
   6.266 +  SHR of int_expr * int_expr |
   6.267 +  Add of int_expr * int_expr |
   6.268 +  Sub of int_expr * int_expr |
   6.269 +  Mult of int_expr * int_expr |
   6.270 +  Div of int_expr * int_expr |
   6.271 +  Mod of int_expr * int_expr |
   6.272 +  Cardinality of rel_expr |
   6.273 +  SetSum of rel_expr |
   6.274 +  BitOr of int_expr * int_expr |
   6.275 +  BitXor of int_expr * int_expr |
   6.276 +  BitAnd of int_expr * int_expr |
   6.277 +  BitNot of int_expr |
   6.278 +  Neg of int_expr |
   6.279 +  Absolute of int_expr |
   6.280 +  Signum of int_expr |
   6.281 +  Num of int |
   6.282 +  IntReg of int
   6.283 +and decl =
   6.284 +  DeclNo of n_ary_index * rel_expr |
   6.285 +  DeclLone of n_ary_index * rel_expr |
   6.286 +  DeclOne of n_ary_index * rel_expr |
   6.287 +  DeclSome of n_ary_index * rel_expr |
   6.288 +  DeclSet of n_ary_index * rel_expr
   6.289 +and expr_assign =
   6.290 +  AssignFormulaReg of int * formula |
   6.291 +  AssignRelReg of n_ary_index * rel_expr |
   6.292 +  AssignIntReg of int * int_expr
   6.293 +
   6.294 +type problem = {
   6.295 +  comment: string,
   6.296 +  settings: setting list,
   6.297 +  univ_card: int,
   6.298 +  tuple_assigns: tuple_assign list,
   6.299 +  bounds: bound list,
   6.300 +  int_bounds: int_bound list,
   6.301 +  expr_assigns: expr_assign list,
   6.302 +  formula: formula}
   6.303 +
   6.304 +type raw_bound = n_ary_index * int list list
   6.305 +
   6.306 +datatype outcome =
   6.307 +  Normal of (int * raw_bound list) list * int list |
   6.308 +  TimedOut of int list |
   6.309 +  Interrupted of int list option |
   6.310 +  Error of string * int list
   6.311 +
   6.312 +exception SYNTAX of string * string
   6.313 +
   6.314 +type 'a fold_expr_funcs = {
   6.315 +  formula_func: formula -> 'a -> 'a,
   6.316 +  rel_expr_func: rel_expr -> 'a -> 'a,
   6.317 +  int_expr_func: int_expr -> 'a -> 'a
   6.318 +}
   6.319 +
   6.320 +(* 'a fold_expr_funcs -> formula -> 'a -> 'a *)
   6.321 +fun fold_formula (F : 'a fold_expr_funcs) formula =
   6.322 +  case formula of
   6.323 +    All (ds, f) => fold (fold_decl F) ds #> fold_formula F f
   6.324 +  | Exist (ds, f) => fold (fold_decl F) ds #> fold_formula F f
   6.325 +  | FormulaLet (bs, f) => fold (fold_expr_assign F) bs #> fold_formula F f
   6.326 +  | FormulaIf (f, f1, f2) =>
   6.327 +    fold_formula F f #> fold_formula F f1 #> fold_formula F f2
   6.328 +  | Or (f1, f2) => fold_formula F f1 #> fold_formula F f2
   6.329 +  | Iff (f1, f2) => fold_formula F f1 #> fold_formula F f2
   6.330 +  | Implies (f1, f2) => fold_formula F f1 #> fold_formula F f2
   6.331 +  | And (f1, f2) => fold_formula F f1 #> fold_formula F f2
   6.332 +  | Not f => fold_formula F f
   6.333 +  | Acyclic x => fold_rel_expr F (Rel x)
   6.334 +  | Function (x, r1, r2) =>
   6.335 +    fold_rel_expr F (Rel x) #> fold_rel_expr F r1 #> fold_rel_expr F r2
   6.336 +  | Functional (x, r1, r2) =>
   6.337 +    fold_rel_expr F (Rel x) #> fold_rel_expr F r1 #> fold_rel_expr F r2
   6.338 +  | TotalOrdering (x1, x2, x3, x4) =>
   6.339 +    fold_rel_expr F (Rel x1) #> fold_rel_expr F (Rel x2)
   6.340 +    #> fold_rel_expr F (Rel x3) #> fold_rel_expr F (Rel x4)
   6.341 +  | Subset (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
   6.342 +  | RelEq (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
   6.343 +  | IntEq (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.344 +  | LT (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.345 +  | LE (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.346 +  | No r => fold_rel_expr F r
   6.347 +  | Lone r => fold_rel_expr F r
   6.348 +  | One r => fold_rel_expr F r
   6.349 +  | Some r => fold_rel_expr F r
   6.350 +  | False => #formula_func F formula
   6.351 +  | True => #formula_func F formula
   6.352 +  | FormulaReg _ => #formula_func F formula
   6.353 +(* 'a fold_expr_funcs -> rel_expr -> 'a -> 'a *)
   6.354 +and fold_rel_expr F rel_expr =
   6.355 +  case rel_expr of
   6.356 +    RelLet (bs, r) => fold (fold_expr_assign F) bs #> fold_rel_expr F r
   6.357 +  | RelIf (f, r1, r2) =>
   6.358 +    fold_formula F f #> fold_rel_expr F r1 #> fold_rel_expr F r2
   6.359 +  | Union (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
   6.360 +  | Difference (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
   6.361 +  | Override (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
   6.362 +  | Intersect (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
   6.363 +  | Product (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
   6.364 +  | IfNo (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
   6.365 +  | Project (r1, is) => fold_rel_expr F r1 #> fold (fold_int_expr F) is
   6.366 +  | Join (r1, r2) => fold_rel_expr F r1 #> fold_rel_expr F r2
   6.367 +  | Closure r => fold_rel_expr F r
   6.368 +  | ReflexiveClosure r => fold_rel_expr F r
   6.369 +  | Transpose r => fold_rel_expr F r
   6.370 +  | Comprehension (ds, f) => fold (fold_decl F) ds #> fold_formula F f
   6.371 +  | Bits i => fold_int_expr F i
   6.372 +  | Int i => fold_int_expr F i
   6.373 +  | Iden => #rel_expr_func F rel_expr
   6.374 +  | Ints => #rel_expr_func F rel_expr
   6.375 +  | None => #rel_expr_func F rel_expr
   6.376 +  | Univ => #rel_expr_func F rel_expr
   6.377 +  | Atom _ => #rel_expr_func F rel_expr
   6.378 +  | AtomSeq _ => #rel_expr_func F rel_expr
   6.379 +  | Rel _ => #rel_expr_func F rel_expr
   6.380 +  | Var _ => #rel_expr_func F rel_expr
   6.381 +  | RelReg _ => #rel_expr_func F rel_expr
   6.382 +(* 'a fold_expr_funcs -> int_expr -> 'a -> 'a *)
   6.383 +and fold_int_expr F int_expr =
   6.384 +  case int_expr of
   6.385 +    Sum (ds, i) => fold (fold_decl F) ds #> fold_int_expr F i
   6.386 +  | IntLet (bs, i) => fold (fold_expr_assign F) bs #> fold_int_expr F i
   6.387 +  | IntIf (f, i1, i2) =>
   6.388 +    fold_formula F f #> fold_int_expr F i1 #> fold_int_expr F i2
   6.389 +  | SHL (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.390 +  | SHA (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.391 +  | SHR (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.392 +  | Add (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.393 +  | Sub (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.394 +  | Mult (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.395 +  | Div (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.396 +  | Mod (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.397 +  | Cardinality r => fold_rel_expr F r
   6.398 +  | SetSum r => fold_rel_expr F r
   6.399 +  | BitOr (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.400 +  | BitXor (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.401 +  | BitAnd (i1, i2) => fold_int_expr F i1 #> fold_int_expr F i2
   6.402 +  | BitNot i => fold_int_expr F i
   6.403 +  | Neg i => fold_int_expr F i
   6.404 +  | Absolute i => fold_int_expr F i
   6.405 +  | Signum i => fold_int_expr F i
   6.406 +  | Num _ => #int_expr_func F int_expr
   6.407 +  | IntReg _ => #int_expr_func F int_expr
   6.408 +(* 'a fold_expr_funcs -> decl -> 'a -> 'a *)
   6.409 +and fold_decl F decl =
   6.410 +  case decl of
   6.411 +    DeclNo (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
   6.412 +  | DeclLone (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
   6.413 +  | DeclOne (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
   6.414 +  | DeclSome (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
   6.415 +  | DeclSet (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
   6.416 +(* 'a fold_expr_funcs -> expr_assign -> 'a -> 'a *)
   6.417 +and fold_expr_assign F assign =
   6.418 +  case assign of
   6.419 +    AssignFormulaReg (x, f) => fold_formula F (FormulaReg x) #> fold_formula F f
   6.420 +  | AssignRelReg (x, r) => fold_rel_expr F (RelReg x) #> fold_rel_expr F r
   6.421 +  | AssignIntReg (x, i) => fold_int_expr F (IntReg x) #> fold_int_expr F i
   6.422 +
   6.423 +type 'a fold_tuple_funcs = {
   6.424 +  tuple_func: tuple -> 'a -> 'a,
   6.425 +  tuple_set_func: tuple_set -> 'a -> 'a
   6.426 +}
   6.427 +
   6.428 +(* 'a fold_tuple_funcs -> tuple -> 'a -> 'a *)
   6.429 +fun fold_tuple (F : 'a fold_tuple_funcs) = #tuple_func F
   6.430 +(* 'a fold_tuple_funcs -> tuple_set -> 'a -> 'a *)
   6.431 +fun fold_tuple_set F tuple_set =
   6.432 +  case tuple_set of
   6.433 +    TupleUnion (ts1, ts2) => fold_tuple_set F ts1 #> fold_tuple_set F ts2
   6.434 +  | TupleDifference (ts1, ts2) => fold_tuple_set F ts1 #> fold_tuple_set F ts2
   6.435 +  | TupleIntersect (ts1, ts2) => fold_tuple_set F ts1 #> fold_tuple_set F ts2
   6.436 +  | TupleProduct (ts1, ts2) => fold_tuple_set F ts1 #> fold_tuple_set F ts2
   6.437 +  | TupleProject (ts, _) => fold_tuple_set F ts
   6.438 +  | TupleSet ts => fold (fold_tuple F) ts
   6.439 +  | TupleRange (t1, t2) => fold_tuple F t1 #> fold_tuple F t2
   6.440 +  | TupleArea (t1, t2) => fold_tuple F t1 #> fold_tuple F t2
   6.441 +  | TupleAtomSeq _ => #tuple_set_func F tuple_set
   6.442 +  | TupleSetReg _ => #tuple_set_func F tuple_set
   6.443 +(* 'a fold_tuple_funcs -> tuple_assign -> 'a -> 'a *)
   6.444 +fun fold_tuple_assign F assign =
   6.445 +  case assign of
   6.446 +    AssignTuple (x, t) => fold_tuple F (TupleReg x) #> fold_tuple F t
   6.447 +  | AssignTupleSet (x, ts) =>
   6.448 +    fold_tuple_set F (TupleSetReg x) #> fold_tuple_set F ts
   6.449 +(* 'a fold_expr_funcs -> 'a fold_tuple_funcs -> bound -> 'a -> 'a *)
   6.450 +fun fold_bound expr_F tuple_F (zs, tss) =
   6.451 +  fold (fold_rel_expr expr_F) (map (Rel o fst) zs)
   6.452 +  #> fold (fold_tuple_set tuple_F) tss
   6.453 +(* 'a fold_tuple_funcs -> int_bound -> 'a -> 'a *)
   6.454 +fun fold_int_bound F (_, tss) = fold (fold_tuple_set F) tss
   6.455 +
   6.456 +(* int -> int *)
   6.457 +fun max_arity univ_card = floor (Math.ln 2147483647.0
   6.458 +                                 / Math.ln (Real.fromInt univ_card))
   6.459 +(* rel_expr -> int *)
   6.460 +fun arity_of_rel_expr (RelLet (_, r)) = arity_of_rel_expr r
   6.461 +  | arity_of_rel_expr (RelIf (_, r1, _)) = arity_of_rel_expr r1
   6.462 +  | arity_of_rel_expr (Union (r1, _)) = arity_of_rel_expr r1
   6.463 +  | arity_of_rel_expr (Difference (r1, _)) = arity_of_rel_expr r1
   6.464 +  | arity_of_rel_expr (Override (r1, _)) = arity_of_rel_expr r1
   6.465 +  | arity_of_rel_expr (Intersect (r1, _)) = arity_of_rel_expr r1
   6.466 +  | arity_of_rel_expr (Product (r1, r2)) = sum_arities_of_rel_exprs r1 r2
   6.467 +  | arity_of_rel_expr (IfNo (r1, _)) = arity_of_rel_expr r1
   6.468 +  | arity_of_rel_expr (Project (r, is)) = length is
   6.469 +  | arity_of_rel_expr (Join (r1, r2)) = sum_arities_of_rel_exprs r1 r2 - 2
   6.470 +  | arity_of_rel_expr (Closure _) = 2
   6.471 +  | arity_of_rel_expr (ReflexiveClosure _) = 2
   6.472 +  | arity_of_rel_expr (Transpose _) = 2
   6.473 +  | arity_of_rel_expr (Comprehension (ds, _)) =
   6.474 +    fold (curry op + o arity_of_decl) ds 0
   6.475 +  | arity_of_rel_expr (Bits _) = 1
   6.476 +  | arity_of_rel_expr (Int _) = 1
   6.477 +  | arity_of_rel_expr Iden = 2
   6.478 +  | arity_of_rel_expr Ints = 1
   6.479 +  | arity_of_rel_expr None = 1
   6.480 +  | arity_of_rel_expr Univ = 1
   6.481 +  | arity_of_rel_expr (Atom _) = 1
   6.482 +  | arity_of_rel_expr (AtomSeq _) = 1
   6.483 +  | arity_of_rel_expr (Rel (n, _)) = n
   6.484 +  | arity_of_rel_expr (Var (n, _)) = n
   6.485 +  | arity_of_rel_expr (RelReg (n, _)) = n
   6.486 +(* rel_expr -> rel_expr -> int *)
   6.487 +and sum_arities_of_rel_exprs r1 r2 = arity_of_rel_expr r1 + arity_of_rel_expr r2
   6.488 +(* decl -> int *)
   6.489 +and arity_of_decl (DeclNo ((n, _), _)) = n
   6.490 +  | arity_of_decl (DeclLone ((n, _), _)) = n
   6.491 +  | arity_of_decl (DeclOne ((n, _), _)) = n
   6.492 +  | arity_of_decl (DeclSome ((n, _), _)) = n
   6.493 +  | arity_of_decl (DeclSet ((n, _), _)) = n
   6.494 +
   6.495 +(* string -> bool *)
   6.496 +val is_relevant_setting = not o member (op =) ["solver", "delay"]
   6.497 +
   6.498 +(* problem -> problem -> bool *)
   6.499 +fun problems_equivalent (p1 : problem) (p2 : problem) =
   6.500 +  #univ_card p1 = #univ_card p2
   6.501 +  andalso #formula p1 = #formula p2
   6.502 +  andalso #bounds p1 = #bounds p2
   6.503 +  andalso #expr_assigns p1 = #expr_assigns p2
   6.504 +  andalso #tuple_assigns p1 = #tuple_assigns p2
   6.505 +  andalso #int_bounds p1 = #int_bounds p2
   6.506 +  andalso filter (is_relevant_setting o fst) (#settings p1)
   6.507 +          = filter (is_relevant_setting o fst) (#settings p2)
   6.508 +
   6.509 +(* int -> string *)
   6.510 +fun base_name j = if j < 0 then Int.toString (~j - 1) ^ "'" else Int.toString j
   6.511 +
   6.512 +(* n_ary_index -> string -> string -> string -> string *)
   6.513 +fun n_ary_name (1, j) prefix _ _ = prefix ^ base_name j
   6.514 +  | n_ary_name (2, j) _ prefix _ = prefix ^ base_name j
   6.515 +  | n_ary_name (n, j) _ _ prefix = prefix ^ Int.toString n ^ "_" ^ base_name j
   6.516 +
   6.517 +(* int -> string *)
   6.518 +fun atom_name j = "A" ^ base_name j
   6.519 +fun atom_seq_name (k, 0) = "u" ^ base_name k
   6.520 +  | atom_seq_name (k, j0) = "u" ^ base_name k ^ "@" ^ base_name j0
   6.521 +fun formula_reg_name j = "$f" ^ base_name j
   6.522 +fun rel_reg_name j = "$e" ^ base_name j
   6.523 +fun int_reg_name j = "$i" ^ base_name j
   6.524 +
   6.525 +(* n_ary_index -> string *)
   6.526 +fun tuple_name x = n_ary_name x "A" "P" "T"
   6.527 +fun rel_name x = n_ary_name x "s" "r" "m"
   6.528 +fun var_name x = n_ary_name x "S" "R" "M"
   6.529 +fun tuple_reg_name x = n_ary_name x "$A" "$P" "$T"
   6.530 +fun tuple_set_reg_name x = n_ary_name x "$a" "$p" "$t"
   6.531 +
   6.532 +(* string -> string *)
   6.533 +fun inline_comment "" = ""
   6.534 +  | inline_comment comment =
   6.535 +    " /* " ^ translate_string (fn "\n" => " " | "*" => "* " | s => s) comment ^
   6.536 +    " */"
   6.537 +fun block_comment "" = ""
   6.538 +  | block_comment comment = prefix_lines "// " comment ^ "\n"
   6.539 +
   6.540 +(* (n_ary_index * string) -> string *)
   6.541 +fun commented_rel_name (x, s) = rel_name x ^ inline_comment s
   6.542 +
   6.543 +(* tuple -> string *)
   6.544 +fun string_for_tuple (Tuple js) = "[" ^ commas (map atom_name js) ^ "]"
   6.545 +  | string_for_tuple (TupleIndex x) = tuple_name x
   6.546 +  | string_for_tuple (TupleReg x) = tuple_reg_name x
   6.547 +
   6.548 +val no_prec = 100
   6.549 +val prec_TupleUnion = 1
   6.550 +val prec_TupleIntersect = 2
   6.551 +val prec_TupleProduct = 3
   6.552 +val prec_TupleProject = 4
   6.553 +
   6.554 +(* tuple_set -> int *)
   6.555 +fun precedence_ts (TupleUnion _) = prec_TupleUnion
   6.556 +  | precedence_ts (TupleDifference _) = prec_TupleUnion
   6.557 +  | precedence_ts (TupleIntersect _) = prec_TupleIntersect
   6.558 +  | precedence_ts (TupleProduct _) = prec_TupleProduct
   6.559 +  | precedence_ts (TupleProject _) = prec_TupleProject
   6.560 +  | precedence_ts _ = no_prec
   6.561 +
   6.562 +(* tuple_set -> string *)
   6.563 +fun string_for_tuple_set tuple_set =
   6.564 +  let
   6.565 +    (* tuple_set -> int -> string *)
   6.566 +    fun sub tuple_set outer_prec =
   6.567 +      let
   6.568 +        val prec = precedence_ts tuple_set
   6.569 +        val need_parens = (prec < outer_prec)
   6.570 +      in
   6.571 +        (if need_parens then "(" else "") ^
   6.572 +        (case tuple_set of
   6.573 +           TupleUnion (ts1, ts2) => sub ts1 prec ^ " + " ^ sub ts2 (prec + 1)
   6.574 +         | TupleDifference (ts1, ts2) =>
   6.575 +           sub ts1 prec ^ " - " ^ sub ts1 (prec + 1)
   6.576 +         | TupleIntersect (ts1, ts2) => sub ts1 prec ^ " & " ^ sub ts1 prec
   6.577 +         | TupleProduct (ts1, ts2) => sub ts1 prec ^ "->" ^ sub ts2 prec
   6.578 +         | TupleProject (ts, c) => sub ts prec ^ "[" ^ Int.toString c ^ "]"
   6.579 +         | TupleSet ts => "{" ^ commas (map string_for_tuple ts) ^ "}"
   6.580 +         | TupleRange (t1, t2) =>
   6.581 +           "{" ^ string_for_tuple t1 ^
   6.582 +           (if t1 = t2 then "" else " .. " ^ string_for_tuple t2) ^ "}"
   6.583 +         | TupleArea (t1, t2) =>
   6.584 +           "{" ^ string_for_tuple t1 ^ " # " ^ string_for_tuple t2 ^ "}"
   6.585 +         | TupleAtomSeq x => atom_seq_name x
   6.586 +         | TupleSetReg x => tuple_set_reg_name x) ^
   6.587 +        (if need_parens then ")" else "")
   6.588 +      end
   6.589 +  in sub tuple_set 0 end
   6.590 +
   6.591 +(* tuple_assign -> string *)
   6.592 +fun string_for_tuple_assign (AssignTuple (x, t)) =
   6.593 +    tuple_reg_name x ^ " := " ^ string_for_tuple t ^ "\n"
   6.594 +  | string_for_tuple_assign (AssignTupleSet (x, ts)) =
   6.595 +    tuple_set_reg_name x ^ " := " ^ string_for_tuple_set ts ^ "\n"
   6.596 +
   6.597 +(* bound -> string *)
   6.598 +fun string_for_bound (zs, tss) =
   6.599 +  "bounds " ^ commas (map commented_rel_name zs) ^ ": " ^
   6.600 +  (if length tss = 1 then "" else "[") ^ commas (map string_for_tuple_set tss) ^
   6.601 +  (if length tss = 1 then "" else "]") ^ "\n"
   6.602 +
   6.603 +(* int_bound -> string *)
   6.604 +fun int_string_for_bound (opt_n, tss) =
   6.605 +  (case opt_n of
   6.606 +     SOME n => Int.toString n ^ ": "
   6.607 +   | NONE => "") ^ "[" ^ commas (map string_for_tuple_set tss) ^ "]"
   6.608 +
   6.609 +val prec_All = 1
   6.610 +val prec_Or = 2
   6.611 +val prec_Iff = 3
   6.612 +val prec_Implies = 4
   6.613 +val prec_And = 5
   6.614 +val prec_Not = 6
   6.615 +val prec_Eq = 7
   6.616 +val prec_Some = 8
   6.617 +val prec_SHL = 9
   6.618 +val prec_Add = 10
   6.619 +val prec_Mult = 11
   6.620 +val prec_Override = 12
   6.621 +val prec_Intersect = 13
   6.622 +val prec_Product = 14
   6.623 +val prec_IfNo = 15
   6.624 +val prec_Project = 17
   6.625 +val prec_Join = 18
   6.626 +val prec_BitNot = 19
   6.627 +
   6.628 +(* formula -> int *)
   6.629 +fun precedence_f (All _) = prec_All
   6.630 +  | precedence_f (Exist _) = prec_All
   6.631 +  | precedence_f (FormulaLet _) = prec_All
   6.632 +  | precedence_f (FormulaIf _) = prec_All
   6.633 +  | precedence_f (Or _) = prec_Or
   6.634 +  | precedence_f (Iff _) = prec_Iff
   6.635 +  | precedence_f (Implies _) = prec_Implies
   6.636 +  | precedence_f (And _) = prec_And
   6.637 +  | precedence_f (Not _) = prec_Not
   6.638 +  | precedence_f (Acyclic _) = no_prec
   6.639 +  | precedence_f (Function _) = no_prec
   6.640 +  | precedence_f (Functional _) = no_prec
   6.641 +  | precedence_f (TotalOrdering _) = no_prec
   6.642 +  | precedence_f (Subset _) = prec_Eq
   6.643 +  | precedence_f (RelEq _) = prec_Eq
   6.644 +  | precedence_f (IntEq _) = prec_Eq
   6.645 +  | precedence_f (LT _) = prec_Eq
   6.646 +  | precedence_f (LE _) = prec_Eq
   6.647 +  | precedence_f (No _) = prec_Some
   6.648 +  | precedence_f (Lone _) = prec_Some
   6.649 +  | precedence_f (One _) = prec_Some
   6.650 +  | precedence_f (Some _) = prec_Some
   6.651 +  | precedence_f False = no_prec
   6.652 +  | precedence_f True = no_prec
   6.653 +  | precedence_f (FormulaReg _) = no_prec
   6.654 +(* rel_expr -> int *)
   6.655 +and precedence_r (RelLet _) = prec_All
   6.656 +  | precedence_r (RelIf _) = prec_All
   6.657 +  | precedence_r (Union _) = prec_Add
   6.658 +  | precedence_r (Difference _) = prec_Add
   6.659 +  | precedence_r (Override _) = prec_Override
   6.660 +  | precedence_r (Intersect _) = prec_Intersect
   6.661 +  | precedence_r (Product _) = prec_Product
   6.662 +  | precedence_r (IfNo _) = prec_IfNo
   6.663 +  | precedence_r (Project _) = prec_Project
   6.664 +  | precedence_r (Join _) = prec_Join
   6.665 +  | precedence_r (Closure _) = prec_BitNot
   6.666 +  | precedence_r (ReflexiveClosure _) = prec_BitNot
   6.667 +  | precedence_r (Transpose _) = prec_BitNot
   6.668 +  | precedence_r (Comprehension _) = no_prec
   6.669 +  | precedence_r (Bits _) = no_prec
   6.670 +  | precedence_r (Int _) = no_prec
   6.671 +  | precedence_r Iden = no_prec
   6.672 +  | precedence_r Ints = no_prec
   6.673 +  | precedence_r None = no_prec
   6.674 +  | precedence_r Univ = no_prec
   6.675 +  | precedence_r (Atom _) = no_prec
   6.676 +  | precedence_r (AtomSeq _) = no_prec
   6.677 +  | precedence_r (Rel _) = no_prec
   6.678 +  | precedence_r (Var _) = no_prec
   6.679 +  | precedence_r (RelReg _) = no_prec
   6.680 +(* int_expr -> int *)
   6.681 +and precedence_i (Sum _) = prec_All
   6.682 +  | precedence_i (IntLet _) = prec_All
   6.683 +  | precedence_i (IntIf _) = prec_All
   6.684 +  | precedence_i (SHL _) = prec_SHL
   6.685 +  | precedence_i (SHA _) = prec_SHL
   6.686 +  | precedence_i (SHR _) = prec_SHL
   6.687 +  | precedence_i (Add _) = prec_Add
   6.688 +  | precedence_i (Sub _) = prec_Add
   6.689 +  | precedence_i (Mult _) = prec_Mult
   6.690 +  | precedence_i (Div _) = prec_Mult
   6.691 +  | precedence_i (Mod _) = prec_Mult
   6.692 +  | precedence_i (Cardinality _) = no_prec
   6.693 +  | precedence_i (SetSum _) = no_prec
   6.694 +  | precedence_i (BitOr _) = prec_Intersect
   6.695 +  | precedence_i (BitXor _) = prec_Intersect
   6.696 +  | precedence_i (BitAnd _) = prec_Intersect
   6.697 +  | precedence_i (BitNot _) = prec_BitNot
   6.698 +  | precedence_i (Neg _) = prec_BitNot
   6.699 +  | precedence_i (Absolute _) = prec_BitNot
   6.700 +  | precedence_i (Signum _) = prec_BitNot
   6.701 +  | precedence_i (Num _) = no_prec
   6.702 +  | precedence_i (IntReg _) = no_prec
   6.703 +
   6.704 +(* (string -> unit) -> problem list -> unit *)
   6.705 +fun write_problem_file out problems =
   6.706 +  let
   6.707 +    (* formula -> unit *)
   6.708 +    fun out_outmost_f (And (f1, f2)) =
   6.709 +        (out_outmost_f f1; out "\n   && "; out_outmost_f f2)
   6.710 +      | out_outmost_f f = out_f f prec_And
   6.711 +    (* formula -> int -> unit *)
   6.712 +    and out_f formula outer_prec =
   6.713 +      let
   6.714 +        val prec = precedence_f formula
   6.715 +        val need_parens = (prec < outer_prec)
   6.716 +      in
   6.717 +        (if need_parens then out "(" else ());
   6.718 +        (case formula of
   6.719 +           All (ds, f) => (out "all ["; out_decls ds; out "] | "; out_f f prec)
   6.720 +         | Exist (ds, f) =>
   6.721 +           (out "some ["; out_decls ds; out "] | "; out_f f prec)
   6.722 +         | FormulaLet (bs, f) =>
   6.723 +           (out "let ["; out_assigns bs; out "] | "; out_f f prec)
   6.724 +         | FormulaIf (f, f1, f2) =>
   6.725 +           (out "if "; out_f f prec; out " then "; out_f f1 prec; out " else ";
   6.726 +            out_f f2 prec)
   6.727 +         | Or (f1, f2) => (out_f f1 prec; out " || "; out_f f2 prec)
   6.728 +         | Iff (f1, f2) => (out_f f1 prec; out " <=> "; out_f f2 prec)
   6.729 +         | Implies (f1, f2) => (out_f f1 (prec + 1); out " => "; out_f f2 prec)
   6.730 +         | And (f1, f2) => (out_f f1 prec; out " && "; out_f f2 prec)
   6.731 +         | Not f => (out "! "; out_f f prec)
   6.732 +         | Acyclic x => out ("ACYCLIC(" ^ rel_name x ^ ")")
   6.733 +         | Function (x, r1, r2) =>
   6.734 +           (out ("FUNCTION(" ^ rel_name x ^ ", "); out_r r1 0; out " -> one ";
   6.735 +            out_r r2 0; out ")")
   6.736 +         | Functional (x, r1, r2) =>
   6.737 +           (out ("FUNCTION(" ^ rel_name x ^ ", "); out_r r1 0; out " -> lone ";
   6.738 +            out_r r2 0; out ")")
   6.739 +         | TotalOrdering (x1, x2, x3, x4) =>
   6.740 +           out ("TOTAL_ORDERING(" ^ rel_name x1 ^ ", " ^ rel_name x2 ^ ", "
   6.741 +                ^ rel_name x3 ^ ", " ^ rel_name x4 ^ ")")
   6.742 +         | Subset (r1, r2) => (out_r r1 prec; out " in "; out_r r2 prec)
   6.743 +         | RelEq (r1, r2) => (out_r r1 prec; out " = "; out_r r2 prec)
   6.744 +         | IntEq (i1, i2) => (out_i i1 prec; out " = "; out_i i2 prec)
   6.745 +         | LT (i1, i2) => (out_i i1 prec; out " < "; out_i i2 prec)
   6.746 +         | LE (i1, i2) => (out_i i1 prec; out " <= "; out_i i2 prec)
   6.747 +         | No r => (out "no "; out_r r prec)
   6.748 +         | Lone r => (out "lone "; out_r r prec)
   6.749 +         | One r => (out "one "; out_r r prec)
   6.750 +         | Some r => (out "some "; out_r r prec)
   6.751 +         | False => out "false"
   6.752 +         | True => out "true"
   6.753 +         | FormulaReg j => out (formula_reg_name j));
   6.754 +        (if need_parens then out ")" else ())
   6.755 +      end
   6.756 +    (* rel_expr -> int -> unit *)
   6.757 +    and out_r rel_expr outer_prec =
   6.758 +      let
   6.759 +        val prec = precedence_r rel_expr
   6.760 +        val need_parens = (prec < outer_prec)
   6.761 +      in
   6.762 +        (if need_parens then out "(" else ());
   6.763 +        (case rel_expr of
   6.764 +           RelLet (bs, r) =>
   6.765 +           (out "let ["; out_assigns bs; out "] | "; out_r r prec)
   6.766 +         | RelIf (f, r1, r2) =>
   6.767 +           (out "if "; out_f f prec; out " then "; out_r r1 prec;
   6.768 +            out " else "; out_r r2 prec)
   6.769 +         | Union (r1, r2) => (out_r r1 prec; out " + "; out_r r2 (prec + 1))
   6.770 +         | Difference (r1, r2) =>
   6.771 +           (out_r r1 prec; out " - "; out_r r2 (prec + 1))
   6.772 +         | Override (r1, r2) => (out_r r1 prec; out " ++ "; out_r r2 prec)
   6.773 +         | Intersect (r1, r2) => (out_r r1 prec; out " & "; out_r r2 prec)
   6.774 +         | Product (r1, r2) => (out_r r1 prec; out "->"; out_r r2 prec)
   6.775 +         | IfNo (r1, r2) => (out_r r1 prec; out "\\"; out_r r2 prec)
   6.776 +         | Project (r1, is) => (out_r r1 prec; out "["; out_columns is; out "]")
   6.777 +         | Join (r1, r2) => (out_r r1 prec; out "."; out_r r2 (prec + 1))
   6.778 +         | Closure r => (out "^"; out_r r prec)
   6.779 +         | ReflexiveClosure r => (out "*"; out_r r prec)
   6.780 +         | Transpose r => (out "~"; out_r r prec)
   6.781 +         | Comprehension (ds, f) =>
   6.782 +           (out "{["; out_decls ds; out "] | "; out_f f 0; out "}")
   6.783 +         | Bits i => (out "Bits["; out_i i 0; out "]")
   6.784 +         | Int i => (out "Int["; out_i i 0; out "]")
   6.785 +         | Iden => out "iden"
   6.786 +         | Ints => out "ints"
   6.787 +         | None => out "none"
   6.788 +         | Univ => out "univ"
   6.789 +         | Atom j => out (atom_name j)
   6.790 +         | AtomSeq x => out (atom_seq_name x)
   6.791 +         | Rel x => out (rel_name x)
   6.792 +         | Var x => out (var_name x)
   6.793 +         | RelReg (_, j) => out (rel_reg_name j));
   6.794 +        (if need_parens then out ")" else ())
   6.795 +      end
   6.796 +    (* int_expr -> int -> unit *)
   6.797 +    and out_i int_expr outer_prec =
   6.798 +      let
   6.799 +        val prec = precedence_i int_expr
   6.800 +        val need_parens = (prec < outer_prec)
   6.801 +      in
   6.802 +        (if need_parens then out "(" else ());
   6.803 +        (case int_expr of
   6.804 +           Sum (ds, i) => (out "sum ["; out_decls ds; out "] | "; out_i i prec)
   6.805 +         | IntLet (bs, i) =>
   6.806 +           (out "let ["; out_assigns bs; out "] | "; out_i i prec)
   6.807 +         | IntIf (f, i1, i2) =>
   6.808 +           (out "if "; out_f f prec; out " then "; out_i i1 prec;
   6.809 +            out " else "; out_i i2 prec)
   6.810 +         | SHL (i1, i2) => (out_i i1 prec; out " << "; out_i i2 (prec + 1))
   6.811 +         | SHA (i1, i2) => (out_i i1 prec; out " >> "; out_i i2 (prec + 1))
   6.812 +         | SHR (i1, i2) => (out_i i1 prec; out " >>> "; out_i i2 (prec + 1))
   6.813 +         | Add (i1, i2) => (out_i i1 prec; out " + "; out_i i2 (prec + 1))
   6.814 +         | Sub (i1, i2) => (out_i i1 prec; out " - "; out_i i2 (prec + 1))
   6.815 +         | Mult (i1, i2) => (out_i i1 prec; out " * "; out_i i2 (prec + 1))
   6.816 +         | Div (i1, i2) => (out_i i1 prec; out " / "; out_i i2 (prec + 1))
   6.817 +         | Mod (i1, i2) => (out_i i1 prec; out " % "; out_i i2 (prec + 1))
   6.818 +         | Cardinality r => (out "#("; out_r r 0; out ")")
   6.819 +         | SetSum r => (out "sum("; out_r r 0; out ")")
   6.820 +         | BitOr (i1, i2) => (out_i i1 prec; out " | "; out_i i2 prec)
   6.821 +         | BitXor (i1, i2) => (out_i i1 prec; out " ^ "; out_i i2 prec)
   6.822 +         | BitAnd (i1, i2) => (out_i i1 prec; out " & "; out_i i2 prec)
   6.823 +         | BitNot i => (out "~"; out_i i prec)
   6.824 +         | Neg i => (out "-"; out_i i prec)
   6.825 +         | Absolute i => (out "abs "; out_i i prec)
   6.826 +         | Signum i => (out "sgn "; out_i i prec)
   6.827 +         | Num k => out (Int.toString k)
   6.828 +         | IntReg j => out (int_reg_name j));
   6.829 +        (if need_parens then out ")" else ())
   6.830 +      end
   6.831 +    (* decl list -> unit *)
   6.832 +    and out_decls [] = ()
   6.833 +      | out_decls [d] = out_decl d
   6.834 +      | out_decls (d :: ds) = (out_decl d; out ", "; out_decls ds)
   6.835 +    (* decl -> unit *)
   6.836 +    and out_decl (DeclNo (x, r)) =
   6.837 +        (out (var_name x); out " : no "; out_r r 0)
   6.838 +      | out_decl (DeclLone (x, r)) =
   6.839 +        (out (var_name x); out " : lone "; out_r r 0)
   6.840 +      | out_decl (DeclOne (x, r)) =
   6.841 +        (out (var_name x); out " : one "; out_r r 0)
   6.842 +      | out_decl (DeclSome (x, r)) =
   6.843 +        (out (var_name x); out " : some "; out_r r 0)
   6.844 +      | out_decl (DeclSet (x, r)) =
   6.845 +        (out (var_name x); out " : set "; out_r r 0)
   6.846 +    (* assign_expr list -> unit *)
   6.847 +    and out_assigns [] = ()
   6.848 +      | out_assigns [b] = out_assign b
   6.849 +      | out_assigns (b :: bs) = (out_assign b; out ", "; out_assigns bs)
   6.850 +    (* assign_expr -> unit *)
   6.851 +    and out_assign (AssignFormulaReg (j, f)) =
   6.852 +        (out (formula_reg_name j); out " := "; out_f f 0)
   6.853 +      | out_assign (AssignRelReg ((_, j), r)) =
   6.854 +        (out (rel_reg_name j); out " := "; out_r r 0)
   6.855 +      | out_assign (AssignIntReg (j, i)) =
   6.856 +        (out (int_reg_name j); out " := "; out_i i 0)
   6.857 +    (* int_expr list -> unit *)
   6.858 +    and out_columns [] = ()
   6.859 +      | out_columns [i] = out_i i 0
   6.860 +      | out_columns (i :: is) = (out_i i 0; out ", "; out_columns is)
   6.861 +    (* problem -> unit *)
   6.862 +    and out_problem {comment, settings, univ_card, tuple_assigns, bounds,
   6.863 +                     int_bounds, expr_assigns, formula} =
   6.864 +        (out ("\n" ^ block_comment comment ^
   6.865 +              implode (map (fn (key, value) => key ^ ": " ^ value ^ "\n")
   6.866 +                            settings) ^
   6.867 +              "univ: " ^ atom_seq_name (univ_card, 0) ^ "\n" ^
   6.868 +              implode (map string_for_tuple_assign tuple_assigns) ^
   6.869 +              implode (map string_for_bound bounds) ^
   6.870 +              (if int_bounds = [] then
   6.871 +                 ""
   6.872 +               else
   6.873 +                 "int_bounds: " ^
   6.874 +                 commas (map int_string_for_bound int_bounds) ^ "\n"));
   6.875 +         map (fn b => (out_assign b; out ";")) expr_assigns;
   6.876 +         out "solve "; out_outmost_f formula; out ";\n")
   6.877 +  in
   6.878 +    out ("// This file was generated by Isabelle (probably Nitpick)\n" ^
   6.879 +         "// " ^ Date.fmt "%Y-%m-%d %H:%M:%S"
   6.880 +                          (Date.fromTimeLocal (Time.now ())) ^ "\n");
   6.881 +    map out_problem problems
   6.882 +  end
   6.883 +
   6.884 +(* string -> bool *)
   6.885 +fun is_ident_char s =
   6.886 +  Symbol.is_ascii_letter s orelse Symbol.is_ascii_digit s
   6.887 +  orelse s = "_" orelse s = "'" orelse s = "$"
   6.888 +
   6.889 +(* string list -> string list *)
   6.890 +fun strip_blanks [] = []
   6.891 +  | strip_blanks (" " :: ss) = strip_blanks ss
   6.892 +  | strip_blanks [s1, " "] = [s1]
   6.893 +  | strip_blanks (s1 :: " " :: s2 :: ss) =
   6.894 +    if is_ident_char s1 andalso is_ident_char s2 then
   6.895 +      s1 :: " " :: strip_blanks (s2 :: ss)
   6.896 +    else
   6.897 +      strip_blanks (s1 :: s2 :: ss)
   6.898 +  | strip_blanks (s :: ss) = s :: strip_blanks ss
   6.899 +
   6.900 +(* (string list -> 'a * string list) -> string list -> 'a list * string list *)
   6.901 +fun scan_non_empty_list scan = scan ::: Scan.repeat ($$ "," |-- scan)
   6.902 +fun scan_list scan = scan_non_empty_list scan || Scan.succeed []
   6.903 +(* string list -> int * string list *)
   6.904 +val scan_nat = Scan.repeat1 (Scan.one Symbol.is_ascii_digit)
   6.905 +               >> (the o Int.fromString o space_implode "")
   6.906 +(*  string list -> (int * int) * string list *)
   6.907 +val scan_rel_name = $$ "s" |-- scan_nat >> pair 1
   6.908 +                    || $$ "r" |-- scan_nat >> pair 2
   6.909 +                    || ($$ "m" |-- scan_nat --| $$ "_") -- scan_nat
   6.910 +(* string list -> int * string list *)
   6.911 +val scan_atom = $$ "A" |-- scan_nat
   6.912 +(* string list -> int list * string list *)
   6.913 +val scan_tuple = $$ "[" |-- scan_list scan_atom --| $$ "]"
   6.914 +(* string list -> int list list * string list *)
   6.915 +val scan_tuple_set = $$ "[" |-- scan_list scan_tuple --| $$ "]"
   6.916 +(* string list -> ((int * int) * int list list) * string list *)
   6.917 +val scan_assignment = (scan_rel_name --| $$ "=") -- scan_tuple_set
   6.918 +(* string list -> ((int * int) * int list list) list * string list *)
   6.919 +val scan_instance = Scan.this_string "relations:" |--
   6.920 +                    $$ "{" |-- scan_list scan_assignment --| $$ "}"
   6.921 +
   6.922 +(* string -> raw_bound list *)
   6.923 +fun parse_instance inst =
   6.924 +  Scan.finite Symbol.stopper
   6.925 +      (Scan.error (!! (fn _ => raise SYNTAX ("Kodkod.parse_instance",
   6.926 +                                             "ill-formed Kodkodi output"))
   6.927 +                      scan_instance))
   6.928 +      (strip_blanks (explode inst))
   6.929 +  |> fst
   6.930 +
   6.931 +val problem_marker = "*** PROBLEM "
   6.932 +val outcome_marker = "---OUTCOME---\n"
   6.933 +val instance_marker = "---INSTANCE---\n"
   6.934 +
   6.935 +(* string -> substring -> string *)
   6.936 +fun read_section_body marker =
   6.937 +  Substring.string o fst o Substring.position "\n\n"
   6.938 +  o Substring.triml (size marker)
   6.939 +
   6.940 +(* substring -> raw_bound list *)
   6.941 +fun read_next_instance s =
   6.942 +  let val s = Substring.position instance_marker s |> snd in
   6.943 +    if Substring.isEmpty s then
   6.944 +      raise SYNTAX ("Kodkod.read_next_instance", "expected \"INSTANCE\" marker")
   6.945 +    else
   6.946 +      read_section_body instance_marker s |> parse_instance
   6.947 +  end
   6.948 +
   6.949 +(* int -> substring * (int * raw_bound list) list * int list
   6.950 +   -> substring * (int * raw_bound list) list * int list *)
   6.951 +fun read_next_outcomes j (s, ps, js) =
   6.952 +  let val (s1, s2) = Substring.position outcome_marker s in
   6.953 +    if Substring.isEmpty s2
   6.954 +       orelse not (Substring.isEmpty (Substring.position problem_marker s1
   6.955 +                                      |> snd)) then
   6.956 +      (s, ps, js)
   6.957 +    else
   6.958 +      let
   6.959 +        val outcome = read_section_body outcome_marker s2
   6.960 +        val s = Substring.triml (size outcome_marker) s2
   6.961 +      in
   6.962 +        if String.isSuffix "UNSATISFIABLE" outcome then
   6.963 +          read_next_outcomes j (s, ps, j :: js)
   6.964 +        else if String.isSuffix "SATISFIABLE" outcome then
   6.965 +          read_next_outcomes j (s, (j, read_next_instance s2) :: ps, js)
   6.966 +        else
   6.967 +          raise SYNTAX ("Kodkod.read_next_outcomes",
   6.968 +                        "unknown outcome " ^ quote outcome)
   6.969 +      end
   6.970 +  end
   6.971 +
   6.972 +(* substring * (int * raw_bound list) list * int list
   6.973 +   -> (int * raw_bound list) list * int list *)
   6.974 +fun read_next_problems (s, ps, js) =
   6.975 +  let val s = Substring.position problem_marker s |> snd in
   6.976 +    if Substring.isEmpty s then
   6.977 +      (ps, js)
   6.978 +    else
   6.979 +      let
   6.980 +        val s = Substring.triml (size problem_marker) s
   6.981 +        val j_plus_1 = s |> Substring.takel (not_equal #" ") |> Substring.string
   6.982 +                         |> Int.fromString |> the
   6.983 +        val j = j_plus_1 - 1
   6.984 +      in read_next_problems (read_next_outcomes j (s, ps, js)) end
   6.985 +  end
   6.986 +  handle Option.Option => raise SYNTAX ("Kodkod.read_next_problems",
   6.987 +                                        "expected number after \"PROBLEM\"")
   6.988 +
   6.989 +(* Path.T -> (int * raw_bound list) list * int list *)
   6.990 +fun read_output_file path =
   6.991 +  read_next_problems (Substring.full (File.read path), [], []) |>> rev ||> rev
   6.992 +
   6.993 +(* The fudge term below is to account for Kodkodi's slow start-up time, which
   6.994 +   is partly due to the JVM and partly due to the ML "system" function. *)
   6.995 +val fudge_ms = 250
   6.996 +
   6.997 +(* bool -> Time.time option -> int -> int -> problem list -> outcome *)
   6.998 +fun solve_any_problem overlord deadline max_threads max_solutions problems =
   6.999 +  let
  6.1000 +    val j = find_index (equal True o #formula) problems
  6.1001 +    val indexed_problems = if j >= 0 then
  6.1002 +                             [(j, nth problems j)]
  6.1003 +                           else
  6.1004 +                             filter (not_equal False o #formula o snd)
  6.1005 +                                    (0 upto length problems - 1 ~~ problems)
  6.1006 +    val triv_js = filter_out (AList.defined (op =) indexed_problems)
  6.1007 +                             (0 upto length problems - 1)
  6.1008 +    (* int -> int *)
  6.1009 +    val reindex = fst o nth indexed_problems
  6.1010 +  in
  6.1011 +    if null indexed_problems then
  6.1012 +      Normal ([], triv_js)
  6.1013 +    else
  6.1014 +      let
  6.1015 +        val (serial_str, tmp_path) =
  6.1016 +          if overlord then
  6.1017 +            ("", Path.append (Path.variable "ISABELLE_HOME_USER") o Path.base)
  6.1018 +          else
  6.1019 +            (serial_string (), File.tmp_path)
  6.1020 +        (* string -> string -> Path.T *)
  6.1021 +        fun path_for base suf =
  6.1022 +          tmp_path (Path.explode (base ^ serial_str ^ "." ^ suf))
  6.1023 +        val in_path = path_for "isabelle" "kki"
  6.1024 +        val in_buf = Unsynchronized.ref Buffer.empty
  6.1025 +        (* string -> unit *)
  6.1026 +        fun out s = Unsynchronized.change in_buf (Buffer.add s)
  6.1027 +        val out_path = path_for "kodkodi" "out"
  6.1028 +        val err_path = path_for "kodkodi" "err"
  6.1029 +        val _ = write_problem_file out (map snd indexed_problems)
  6.1030 +        val _ = File.write_buffer in_path (!in_buf)
  6.1031 +        (* (int list -> outcome) -> outcome *)
  6.1032 +        fun stopped constr =
  6.1033 +          let val nontriv_js = map reindex (snd (read_output_file out_path)) in
  6.1034 +            constr (triv_js @ nontriv_js)
  6.1035 +            handle Exn.Interrupt => Interrupted NONE
  6.1036 +          end
  6.1037 +      in
  6.1038 +        let
  6.1039 +          val ms =
  6.1040 +            case deadline of
  6.1041 +              NONE => ~1
  6.1042 +            | SOME time =>
  6.1043 +              Int.max (0, Time.toMilliseconds (Time.- (time, Time.now ()))
  6.1044 +                          - fudge_ms)
  6.1045 +          val outcome =
  6.1046 +            let
  6.1047 +              val code =
  6.1048 +                system ("env CLASSPATH=\"$KODKODI_CLASSPATH:$CLASSPATH\" \
  6.1049 +                        \\"$ISABELLE_TOOL\" java \
  6.1050 +                        \de.tum.in.isabelle.Kodkodi.Kodkodi" ^
  6.1051 +                        (if ms >= 0 then " -max-msecs " ^ Int.toString ms
  6.1052 +                         else "") ^
  6.1053 +                        (if max_solutions > 1 then " -solve-all" else "") ^
  6.1054 +                        " -max-solutions " ^ Int.toString max_solutions ^
  6.1055 +                        (if max_threads > 0 then
  6.1056 +                           " -max-threads " ^ Int.toString max_threads
  6.1057 +                         else
  6.1058 +                           "") ^
  6.1059 +                        " < " ^ Path.implode in_path ^
  6.1060 +                        " > " ^ Path.implode out_path ^
  6.1061 +                        " 2> " ^ Path.implode err_path)
  6.1062 +              val (ps, nontriv_js) = read_output_file out_path
  6.1063 +                                     |>> map (apfst reindex) ||> map reindex
  6.1064 +              val js = triv_js @ nontriv_js
  6.1065 +              val first_error =
  6.1066 +                File.fold_lines (fn line => fn "" => line | s => s) err_path ""
  6.1067 +            in
  6.1068 +              if null ps then
  6.1069 +                if code = 2 then
  6.1070 +                  TimedOut js
  6.1071 +                else if first_error <> "" then
  6.1072 +                  Error (first_error |> perhaps (try (unsuffix "."))
  6.1073 +                                     |> perhaps (try (unprefix "Error: ")), js)
  6.1074 +                else if code <> 0 then
  6.1075 +                  Error ("Unknown error", js)
  6.1076 +                else
  6.1077 +                  Normal ([], js)
  6.1078 +              else
  6.1079 +                Normal (ps, js)
  6.1080 +            end
  6.1081 +        in
  6.1082 +          if overlord then ()
  6.1083 +          else List.app File.rm [in_path, out_path, err_path];
  6.1084 +          outcome
  6.1085 +        end
  6.1086 +        handle Exn.Interrupt => stopped (Interrupted o SOME)
  6.1087 +      end
  6.1088 +  end
  6.1089 +
  6.1090 +end;
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/Tools/Nitpick/kodkod_sat.ML	Thu Oct 22 14:51:47 2009 +0200
     7.3 @@ -0,0 +1,109 @@
     7.4 +(*  Title:      HOL/Nitpick/Tools/kodkod_sat.ML
     7.5 +    Author:     Jasmin Blanchette, TU Muenchen
     7.6 +    Copyright   2009
     7.7 +
     7.8 +Kodkod SAT solver integration.
     7.9 +*)
    7.10 +
    7.11 +signature KODKOD_SAT =
    7.12 +sig
    7.13 +  val configured_sat_solvers : bool -> string list
    7.14 +  val smart_sat_solver_name : bool -> string
    7.15 +  val sat_solver_spec : string -> string * string list
    7.16 +end;
    7.17 +
    7.18 +structure KodkodSAT : KODKOD_SAT =
    7.19 +struct
    7.20 +
    7.21 +datatype sink = ToStdout | ToFile
    7.22 +
    7.23 +datatype sat_solver_info =
    7.24 +  Internal of bool * string list |
    7.25 +  External of sink * string * string * string list |
    7.26 +  ExternalV2 of sink * string * string * string list * string * string * string
    7.27 +
    7.28 +val berkmin_exec = getenv "BERKMIN_EXE"
    7.29 +
    7.30 +(* (string * sat_solver_info) list *)
    7.31 +val static_list =
    7.32 +  [("MiniSat", ExternalV2 (ToFile, "MINISAT_HOME", "minisat", [], "SAT", "",
    7.33 +                           "UNSAT")),
    7.34 +   ("PicoSAT", External (ToStdout, "PICOSAT_HOME", "picosat", [])),
    7.35 +   ("zChaff", ExternalV2 (ToStdout, "ZCHAFF_HOME", "zchaff", [],
    7.36 +                          "Instance Satisfiable", "",
    7.37 +                          "Instance Unsatisfiable")),
    7.38 +   ("RSat", ExternalV2 (ToStdout, "RSAT_HOME", "rsat", ["-s"],
    7.39 +                        "s SATISFIABLE", "v ", "s UNSATISFIABLE")),
    7.40 +   ("BerkMin", ExternalV2 (ToStdout, "BERKMIN_HOME",
    7.41 +                           if berkmin_exec = "" then "BerkMin561"
    7.42 +                           else berkmin_exec, [], "Satisfiable          !!",
    7.43 +                           "solution =", "UNSATISFIABLE          !!")),
    7.44 +   ("BerkMinAlloy", External (ToStdout, "BERKMINALLOY_HOME", "berkmin", [])),
    7.45 +   ("Jerusat", External (ToStdout, "JERUSAT_HOME", "Jerusat1.3", [])),
    7.46 +   ("SAT4J", Internal (true, ["DefaultSAT4J"])),
    7.47 +   ("MiniSatJNI", Internal (true, ["MiniSat"])),
    7.48 +   ("zChaffJNI", Internal (false, ["zChaff"])),
    7.49 +   ("SAT4JLight", Internal (true, ["LightSAT4J"])),
    7.50 +   ("HaifaSat", ExternalV2 (ToStdout, "HAIFASAT_HOME", "HaifaSat", ["-p", "1"],
    7.51 +                            "s SATISFIABLE", "v ", "s UNSATISFIABLE"))]
    7.52 +
    7.53 +val created_temp_dir = Unsynchronized.ref false
    7.54 +
    7.55 +(* string -> sink -> string -> string -> string list -> string list
    7.56 +   -> (string * (unit -> string list)) option *)
    7.57 +fun dynamic_entry_for_external name dev home exec args markers =
    7.58 +  case getenv home of
    7.59 +    "" => NONE
    7.60 +  | dir => SOME (name, fn () =>
    7.61 +                          let
    7.62 +                            val temp_dir = getenv "ISABELLE_TMP"
    7.63 +                            val _ = if !created_temp_dir then
    7.64 +                                      ()
    7.65 +                                    else
    7.66 +                                      (created_temp_dir := true;
    7.67 +                                       File.mkdir (Path.explode temp_dir))
    7.68 +                            val temp = temp_dir ^ "/" ^ name ^ serial_string ()
    7.69 +                            val out_file = temp ^ ".out"
    7.70 +                          in
    7.71 +                            [if null markers then "External" else "ExternalV2",
    7.72 +                             dir ^ "/" ^ exec, temp ^ ".cnf",
    7.73 +                             if dev = ToFile then out_file else ""] @ markers @
    7.74 +                            (if dev = ToFile then [out_file] else []) @ args
    7.75 +                          end)
    7.76 +(* bool -> string * sat_solver_info
    7.77 +   -> (string * (unit -> string list)) option *)
    7.78 +fun dynamic_entry_for_info false (name, Internal (_, ss)) = SOME (name, K ss)
    7.79 +  | dynamic_entry_for_info false (name, External (dev, home, exec, args)) =
    7.80 +    dynamic_entry_for_external name dev home exec args []
    7.81 +  | dynamic_entry_for_info false (name, ExternalV2 (dev, home, exec, args,
    7.82 +                                                    m1, m2, m3)) =
    7.83 +    dynamic_entry_for_external name dev home exec args [m1, m2, m3]
    7.84 +  | dynamic_entry_for_info true (name, Internal (true, ss)) = SOME (name, K ss)
    7.85 +  | dynamic_entry_for_info true _ = NONE
    7.86 +(* bool -> (string * (unit -> string list)) list *)
    7.87 +fun dynamic_list incremental =
    7.88 +  map_filter (dynamic_entry_for_info incremental) static_list
    7.89 +
    7.90 +(* bool -> string list *)
    7.91 +val configured_sat_solvers = map fst o dynamic_list
    7.92 +
    7.93 +(* bool -> string *)
    7.94 +val smart_sat_solver_name = dynamic_list #> hd #> fst
    7.95 +
    7.96 +(* (string * 'a) list -> string *)
    7.97 +fun enum_solvers xs = commas (map (quote o fst) xs |> distinct (op =))
    7.98 +(* string -> string * string list *)
    7.99 +fun sat_solver_spec name =
   7.100 +  let val dynamic_list = dynamic_list false in
   7.101 +    (name, the (AList.lookup (op =) dynamic_list name) ())
   7.102 +    handle Option.Option =>
   7.103 +           error (if AList.defined (op =) static_list name then
   7.104 +                    "The SAT solver " ^ quote name ^ " is not configured. The \
   7.105 +                    \following solvers are configured:\n" ^
   7.106 +                    enum_solvers dynamic_list ^ "."
   7.107 +                  else
   7.108 +                    "Unknown SAT solver " ^ quote name ^ ". The following \
   7.109 +                    \solvers are supported:\n" ^ enum_solvers static_list ^ ".")
   7.110 +  end
   7.111 +
   7.112 +end;
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOL/Tools/Nitpick/minipick.ML	Thu Oct 22 14:51:47 2009 +0200
     8.3 @@ -0,0 +1,322 @@
     8.4 +(*  Title:      HOL/Nitpick/Tools/minipick.ML
     8.5 +    Author:     Jasmin Blanchette, TU Muenchen
     8.6 +    Copyright   2009
     8.7 +
     8.8 +Finite model generation for HOL formulas using Kodkod, minimalistic version.
     8.9 +*)
    8.10 +
    8.11 +signature MINIPICK =
    8.12 +sig
    8.13 +  val pick_nits_in_term : Proof.context -> (typ -> int) -> term -> string
    8.14 +end;
    8.15 +
    8.16 +structure Minipick : MINIPICK =
    8.17 +struct
    8.18 +
    8.19 +open Kodkod
    8.20 +open NitpickUtil
    8.21 +open NitpickHOL
    8.22 +open NitpickPeephole
    8.23 +open NitpickKodkod
    8.24 +
    8.25 +(* theory -> typ -> unit *)
    8.26 +fun check_type ctxt (Type ("fun", Ts)) = List.app (check_type ctxt) Ts
    8.27 +  | check_type ctxt (Type ("*", Ts)) = List.app (check_type ctxt) Ts
    8.28 +  | check_type _ @{typ bool} = ()
    8.29 +  | check_type _ (TFree (_, @{sort "{}"})) = ()
    8.30 +  | check_type _ (TFree (_, @{sort HOL.type})) = ()
    8.31 +  | check_type ctxt T =
    8.32 +    raise NOT_SUPPORTED ("type " ^ quote (Syntax.string_of_typ ctxt T))
    8.33 +
    8.34 +(* (typ -> int) -> typ -> int *)
    8.35 +fun atom_schema_of_one scope (Type ("fun", [T1, T2])) =
    8.36 +    replicate_list (scope T1) (atom_schema_of_one scope T2)
    8.37 +  | atom_schema_of_one scope (Type ("*", [T1, T2])) =
    8.38 +    atom_schema_of_one scope T1 @ atom_schema_of_one scope T2
    8.39 +  | atom_schema_of_one scope T = [scope T]
    8.40 +fun atom_schema_of_set scope (Type ("fun", [T1, @{typ bool}])) =
    8.41 +    atom_schema_of_one scope T1
    8.42 +  | atom_schema_of_set scope (Type ("fun", [T1, T2])) =
    8.43 +    atom_schema_of_one scope T1 @ atom_schema_of_set scope T2
    8.44 +  | atom_schema_of_set scope T = atom_schema_of_one scope T
    8.45 +val arity_of_one = length oo atom_schema_of_one
    8.46 +val arity_of_set = length oo atom_schema_of_set
    8.47 +
    8.48 +(* (typ -> int) -> typ list -> int -> int *)
    8.49 +fun index_for_bound_var _ [_] 0 = 0
    8.50 +  | index_for_bound_var scope (_ :: Ts) 0 =
    8.51 +    index_for_bound_var scope Ts 0 + arity_of_one scope (hd Ts)
    8.52 +  | index_for_bound_var scope Ts n = index_for_bound_var scope (tl Ts) (n - 1)
    8.53 +(* (typ -> int) -> typ list -> int -> rel_expr list *)
    8.54 +fun one_vars_for_bound_var scope Ts j =
    8.55 +  map (curry Var 1) (index_seq (index_for_bound_var scope Ts j)
    8.56 +                               (arity_of_one scope (nth Ts j)))
    8.57 +fun set_vars_for_bound_var scope Ts j =
    8.58 +  map (curry Var 1) (index_seq (index_for_bound_var scope Ts j)
    8.59 +                               (arity_of_set scope (nth Ts j)))
    8.60 +(* (typ -> int) -> typ list -> typ -> decl list *)
    8.61 +fun decls_for_one scope Ts T =
    8.62 +  map2 (curry DeclOne o pair 1)
    8.63 +       (index_seq (index_for_bound_var scope (T :: Ts) 0)
    8.64 +                  (arity_of_one scope (nth (T :: Ts) 0)))
    8.65 +       (map (AtomSeq o rpair 0) (atom_schema_of_one scope T))
    8.66 +fun decls_for_set scope Ts T =
    8.67 +  map2 (curry DeclOne o pair 1)
    8.68 +       (index_seq (index_for_bound_var scope (T :: Ts) 0)
    8.69 +                  (arity_of_set scope (nth (T :: Ts) 0)))
    8.70 +       (map (AtomSeq o rpair 0) (atom_schema_of_set scope T))
    8.71 +
    8.72 +(* int list -> rel_expr *)
    8.73 +val atom_product = foldl1 Product o map Atom
    8.74 +
    8.75 +val false_atom = Atom 0
    8.76 +val true_atom = Atom 1
    8.77 +
    8.78 +(* rel_expr -> formula *)
    8.79 +fun formula_from_atom r = RelEq (r, true_atom)
    8.80 +(* formula -> rel_expr *)
    8.81 +fun atom_from_formula f = RelIf (f, true_atom, false_atom)
    8.82 +
    8.83 +(* Proof.context -> (typ -> int) -> styp list -> term -> formula *)
    8.84 +fun kodkod_formula_for_term ctxt scope frees =
    8.85 +  let
    8.86 +    (* typ list -> int -> rel_expr *)
    8.87 +    val one_from_bound_var = foldl1 Product oo one_vars_for_bound_var scope
    8.88 +    val set_from_bound_var = foldl1 Product oo set_vars_for_bound_var scope
    8.89 +    (* typ -> rel_expr -> rel_expr *)
    8.90 +    fun set_from_one (T as Type ("fun", [T1, @{typ bool}])) r =
    8.91 +        let
    8.92 +          val jss = atom_schema_of_one scope T1 |> map (rpair 0)
    8.93 +                    |> all_combinations
    8.94 +        in
    8.95 +          map2 (fn i => fn js =>
    8.96 +                   RelIf (RelEq (Project (r, [Num i]), true_atom),
    8.97 +                          atom_product js, empty_n_ary_rel (length js)))
    8.98 +               (index_seq 0 (length jss)) jss
    8.99 +          |> foldl1 Union
   8.100 +        end
   8.101 +      | set_from_one (Type ("fun", [T1, T2])) r =
   8.102 +        let
   8.103 +          val jss = atom_schema_of_one scope T1 |> map (rpair 0)
   8.104 +                    |> all_combinations
   8.105 +          val arity2 = arity_of_one scope T2
   8.106 +        in
   8.107 +          map2 (fn i => fn js =>
   8.108 +                   Product (atom_product js,
   8.109 +                            Project (r, num_seq (i * arity2) arity2)
   8.110 +                            |> set_from_one T2))
   8.111 +               (index_seq 0 (length jss)) jss
   8.112 +          |> foldl1 Union
   8.113 +        end
   8.114 +      | set_from_one _ r = r
   8.115 +    (* typ list -> typ -> rel_expr -> rel_expr *)
   8.116 +    fun one_from_set Ts (T as Type ("fun", _)) r =
   8.117 +        Comprehension (decls_for_one scope Ts T,
   8.118 +                       RelEq (set_from_one T (one_from_bound_var (T :: Ts) 0),
   8.119 +                              r))
   8.120 +      | one_from_set _ _ r = r
   8.121 +    (* typ list -> term -> formula *)
   8.122 +    fun to_f Ts t =
   8.123 +      (case t of
   8.124 +         @{const Not} $ t1 => Not (to_f Ts t1)
   8.125 +       | @{const False} => False
   8.126 +       | @{const True} => True
   8.127 +       | Const (@{const_name All}, _) $ Abs (s, T, t') =>
   8.128 +         All (decls_for_one scope Ts T, to_f (T :: Ts) t')
   8.129 +       | (t0 as Const (@{const_name All}, _)) $ t1 =>
   8.130 +         to_f Ts (t0 $ eta_expand Ts t1 1)
   8.131 +       | Const (@{const_name Ex}, _) $ Abs (s, T, t') =>
   8.132 +         Exist (decls_for_one scope Ts T, to_f (T :: Ts) t')
   8.133 +       | (t0 as Const (@{const_name Ex}, _)) $ t1 =>
   8.134 +         to_f Ts (t0 $ eta_expand Ts t1 1)
   8.135 +       | Const (@{const_name "op ="}, _) $ t1 $ t2 =>
   8.136 +         RelEq (to_set Ts t1, to_set Ts t2)
   8.137 +       | Const (@{const_name ord_class.less_eq},
   8.138 +                Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ t1 $ t2 =>
   8.139 +         Subset (to_set Ts t1, to_set Ts t2)
   8.140 +       | @{const "op &"} $ t1 $ t2 => And (to_f Ts t1, to_f Ts t2)
   8.141 +       | @{const "op |"} $ t1 $ t2 => Or (to_f Ts t1, to_f Ts t2)
   8.142 +       | @{const "op -->"} $ t1 $ t2 => Implies (to_f Ts t1, to_f Ts t2)
   8.143 +       | t1 $ t2 => Subset (to_one Ts t2, to_set Ts t1)
   8.144 +       | Free _ => raise SAME ()
   8.145 +       | Term.Var _ => raise SAME ()
   8.146 +       | Bound _ => raise SAME ()
   8.147 +       | Const (s, _) => raise NOT_SUPPORTED ("constant " ^ quote s)
   8.148 +       | _ => raise TERM ("to_f", [t]))
   8.149 +      handle SAME () => formula_from_atom (to_set Ts t)
   8.150 +    (* typ list -> term -> rel_expr *)
   8.151 +    and to_one Ts t =
   8.152 +        case t of
   8.153 +          Const (@{const_name Pair}, _) $ t1 $ t2 =>
   8.154 +          Product (to_one Ts t1, to_one Ts t2)
   8.155 +        | Const (@{const_name Pair}, _) $ _ => to_one Ts (eta_expand Ts t 1)
   8.156 +        | Const (@{const_name Pair}, _) => to_one Ts (eta_expand Ts t 2)
   8.157 +        | Const (@{const_name fst}, _) $ t1 =>
   8.158 +          let val fst_arity = arity_of_one scope (fastype_of1 (Ts, t)) in
   8.159 +            Project (to_one Ts t1, num_seq 0 fst_arity)
   8.160 +          end
   8.161 +        | Const (@{const_name fst}, _) => to_one Ts (eta_expand Ts t 1)
   8.162 +        | Const (@{const_name snd}, _) $ t1 =>
   8.163 +          let
   8.164 +            val pair_arity = arity_of_one scope (fastype_of1 (Ts, t1))
   8.165 +            val snd_arity = arity_of_one scope (fastype_of1 (Ts, t))
   8.166 +            val fst_arity = pair_arity - snd_arity
   8.167 +          in Project (to_one Ts t1, num_seq fst_arity snd_arity) end
   8.168 +        | Const (@{const_name snd}, _) => to_one Ts (eta_expand Ts t 1)
   8.169 +        | Bound j => one_from_bound_var Ts j
   8.170 +        | _ => one_from_set Ts (fastype_of1 (Ts, t)) (to_set Ts t)
   8.171 +    (* term -> rel_expr *)
   8.172 +    and to_set Ts t =
   8.173 +      (case t of
   8.174 +         @{const Not} => to_set Ts (eta_expand Ts t 1)
   8.175 +       | Const (@{const_name All}, _) => to_set Ts (eta_expand Ts t 1)
   8.176 +       | Const (@{const_name Ex}, _) => to_set Ts (eta_expand Ts t 1)
   8.177 +       | Const (@{const_name "op ="}, _) $ _ => to_set Ts (eta_expand Ts t 1)
   8.178 +       | Const (@{const_name "op ="}, _) => to_set Ts (eta_expand Ts t 2)
   8.179 +       | Const (@{const_name ord_class.less_eq},
   8.180 +                Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ _ =>
   8.181 +         to_set Ts (eta_expand Ts t 1)
   8.182 +       | Const (@{const_name ord_class.less_eq}, _) =>
   8.183 +         to_set Ts (eta_expand Ts t 2)
   8.184 +       | @{const "op &"} $ _ => to_set Ts (eta_expand Ts t 1)
   8.185 +       | @{const "op &"} => to_set Ts (eta_expand Ts t 2)
   8.186 +       | @{const "op |"} $ _ => to_set Ts (eta_expand Ts t 1)
   8.187 +       | @{const "op |"} => to_set Ts (eta_expand Ts t 2)
   8.188 +       | @{const "op -->"} $ _ => to_set Ts (eta_expand Ts t 1)
   8.189 +       | @{const "op -->"} => to_set Ts (eta_expand Ts t 2)
   8.190 +       | Const (@{const_name bot_class.bot},
   8.191 +                T as Type ("fun", [_, @{typ bool}])) =>
   8.192 +         empty_n_ary_rel (arity_of_set scope T)
   8.193 +       | Const (@{const_name insert}, _) $ t1 $ t2 =>
   8.194 +         Union (to_one Ts t1, to_set Ts t2)
   8.195 +       | Const (@{const_name insert}, _) $ _ => to_set Ts (eta_expand Ts t 1)
   8.196 +       | Const (@{const_name insert}, _) => to_set Ts (eta_expand Ts t 2)
   8.197 +       | Const (@{const_name trancl}, _) $ t1 =>
   8.198 +         if arity_of_set scope (fastype_of1 (Ts, t1)) = 2 then
   8.199 +           Closure (to_set Ts t1)
   8.200 +         else
   8.201 +           raise NOT_SUPPORTED "transitive closure for function or pair type"
   8.202 +       | Const (@{const_name trancl}, _) => to_set Ts (eta_expand Ts t 1)
   8.203 +       | Const (@{const_name lower_semilattice_class.inf},
   8.204 +                Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ t1 $ t2 =>
   8.205 +         Intersect (to_set Ts t1, to_set Ts t2)
   8.206 +       | Const (@{const_name lower_semilattice_class.inf}, _) $ _ =>
   8.207 +         to_set Ts (eta_expand Ts t 1)
   8.208 +       | Const (@{const_name lower_semilattice_class.inf}, _) =>
   8.209 +         to_set Ts (eta_expand Ts t 2)
   8.210 +       | Const (@{const_name upper_semilattice_class.sup},
   8.211 +                Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ t1 $ t2 =>
   8.212 +         Union (to_set Ts t1, to_set Ts t2)
   8.213 +       | Const (@{const_name upper_semilattice_class.sup}, _) $ _ =>
   8.214 +         to_set Ts (eta_expand Ts t 1)
   8.215 +       | Const (@{const_name upper_semilattice_class.sup}, _) =>
   8.216 +         to_set Ts (eta_expand Ts t 2)
   8.217 +       | Const (@{const_name minus_class.minus},
   8.218 +                Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ t1 $ t2 =>
   8.219 +         Difference (to_set Ts t1, to_set Ts t2)
   8.220 +       | Const (@{const_name minus_class.minus},
   8.221 +                Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) $ _ =>
   8.222 +         to_set Ts (eta_expand Ts t 1)
   8.223 +       | Const (@{const_name minus_class.minus},
   8.224 +                Type ("fun", [Type ("fun", [_, @{typ bool}]), _])) =>
   8.225 +         to_set Ts (eta_expand Ts t 2)
   8.226 +       | Const (@{const_name Pair}, _) $ _ $ _ => raise SAME ()
   8.227 +       | Const (@{const_name Pair}, _) $ _ => raise SAME ()
   8.228 +       | Const (@{const_name Pair}, _) => raise SAME ()
   8.229 +       | Const (@{const_name fst}, _) $ _ => raise SAME ()
   8.230 +       | Const (@{const_name fst}, _) => raise SAME ()
   8.231 +       | Const (@{const_name snd}, _) $ _ => raise SAME ()
   8.232 +       | Const (@{const_name snd}, _) => raise SAME ()
   8.233 +       | Const (_, @{typ bool}) => atom_from_formula (to_f Ts t)
   8.234 +       | Free (x as (_, T)) =>
   8.235 +         Rel (arity_of_set scope T, find_index (equal x) frees)
   8.236 +       | Term.Var _ => raise NOT_SUPPORTED "schematic variables"
   8.237 +       | Bound j => raise SAME ()
   8.238 +       | Abs (_, T, t') =>
   8.239 +         (case fastype_of1 (T :: Ts, t') of
   8.240 +            @{typ bool} => Comprehension (decls_for_one scope Ts T,
   8.241 +                                          to_f (T :: Ts) t')
   8.242 +          | T' => Comprehension (decls_for_one scope Ts T @
   8.243 +                                 decls_for_set scope (T :: Ts) T',
   8.244 +                                 Subset (set_from_bound_var (T' :: T :: Ts) 0,
   8.245 +                                         to_set (T :: Ts) t')))
   8.246 +       | t1 $ t2 =>
   8.247 +         (case fastype_of1 (Ts, t) of
   8.248 +            @{typ bool} => atom_from_formula (to_f Ts t)
   8.249 +          | T =>
   8.250 +            let val T2 = fastype_of1 (Ts, t2) in
   8.251 +              case arity_of_one scope T2 of
   8.252 +                1 => Join (to_one Ts t2, to_set Ts t1)
   8.253 +              | n =>
   8.254 +                let
   8.255 +                  val arity2 = arity_of_one scope T2
   8.256 +                  val res_arity = arity_of_set scope T
   8.257 +                in
   8.258 +                  Project (Intersect
   8.259 +                      (Product (to_one Ts t2,
   8.260 +                                atom_schema_of_set scope T
   8.261 +                                |> map (AtomSeq o rpair 0) |> foldl1 Product),
   8.262 +                       to_set Ts t1),
   8.263 +                      num_seq arity2 res_arity)
   8.264 +                end
   8.265 +            end)
   8.266 +       | _ => raise NOT_SUPPORTED ("term " ^
   8.267 +                                   quote (Syntax.string_of_term ctxt t)))
   8.268 +      handle SAME () => set_from_one (fastype_of1 (Ts, t)) (to_one Ts t)
   8.269 +  in to_f [] end
   8.270 +
   8.271 +(* (typ -> int) -> int -> styp -> bound *)
   8.272 +fun bound_for_free scope i (s, T) =
   8.273 +  let val js = atom_schema_of_set scope T in
   8.274 +    ([((length js, i), s)],
   8.275 +     [TupleSet [], atom_schema_of_set scope T |> map (rpair 0)
   8.276 +                   |> tuple_set_from_atom_schema])
   8.277 +  end
   8.278 +
   8.279 +(* (typ -> int) -> typ list -> typ -> rel_expr -> formula *)
   8.280 +fun declarative_axiom_for_rel_expr scope Ts (Type ("fun", [T1, T2])) r =
   8.281 +    if body_type T2 = bool_T then
   8.282 +      True
   8.283 +    else
   8.284 +      All (decls_for_one scope Ts T1,
   8.285 +           declarative_axiom_for_rel_expr scope (T1 :: Ts) T2
   8.286 +               (List.foldl Join r (one_vars_for_bound_var scope (T1 :: Ts) 0)))
   8.287 +  | declarative_axiom_for_rel_expr _ _ _ r = One r
   8.288 +
   8.289 +(* (typ -> int) -> int -> styp -> formula *)
   8.290 +fun declarative_axiom_for_free scope i (_, T) =
   8.291 +  declarative_axiom_for_rel_expr scope [] T (Rel (arity_of_set scope T, i))
   8.292 +
   8.293 +(* Proof.context -> (typ -> int) -> term -> string *)
   8.294 +fun pick_nits_in_term ctxt raw_scope t =
   8.295 +  let
   8.296 +    val thy = ProofContext.theory_of ctxt
   8.297 +    (* typ -> int *)
   8.298 +    fun scope (Type ("fun", [T1, T2])) = reasonable_power (scope T2) (scope T1)
   8.299 +      | scope (Type ("*", [T1, T2])) = scope T1 * scope T2
   8.300 +      | scope @{typ bool} = 2
   8.301 +      | scope T = Int.max (1, raw_scope T)
   8.302 +    val neg_t = @{const Not} $ ObjectLogic.atomize_term thy t
   8.303 +    val _ = fold_types (K o check_type ctxt) neg_t ()
   8.304 +    val frees = Term.add_frees neg_t []
   8.305 +    val bounds = map2 (bound_for_free scope) (index_seq 0 (length frees)) frees
   8.306 +    val declarative_axioms =
   8.307 +      map2 (declarative_axiom_for_free scope) (index_seq 0 (length frees))
   8.308 +           frees
   8.309 +    val formula = kodkod_formula_for_term ctxt scope frees neg_t
   8.310 +                  |> fold_rev (curry And) declarative_axioms
   8.311 +    val univ_card = univ_card 0 0 0 bounds formula
   8.312 +    val problem =
   8.313 +      {comment = "", settings = [], univ_card = univ_card, tuple_assigns = [],
   8.314 +       bounds = bounds, int_bounds = [], expr_assigns = [], formula = formula}
   8.315 +  in
   8.316 +    case solve_any_problem true NONE 0 1 [problem] of
   8.317 +      Normal ([], _) => "none"
   8.318 +    | Normal _ => "genuine"
   8.319 +    | TimedOut _ => "unknown"
   8.320 +    | Interrupted _ => "unknown"
   8.321 +    | Error (s, _) => error ("Kodkod error: " ^ s)
   8.322 +  end
   8.323 +  handle NOT_SUPPORTED details =>
   8.324 +         (warning ("Unsupported case: " ^ details ^ "."); "unknown")
   8.325 +end;
     9.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.2 +++ b/src/HOL/Tools/Nitpick/nitpick.ML	Thu Oct 22 14:51:47 2009 +0200
     9.3 @@ -0,0 +1,857 @@
     9.4 +(*  Title:      HOL/Nitpick/Tools/nitpick.ML
     9.5 +    Author:     Jasmin Blanchette, TU Muenchen
     9.6 +    Copyright   2008, 2009
     9.7 +
     9.8 +Finite model generation for HOL formulas using Kodkod.
     9.9 +*)
    9.10 +
    9.11 +signature NITPICK =
    9.12 +sig
    9.13 +  type params = {
    9.14 +    cards_assigns: (typ option * int list) list,
    9.15 +    maxes_assigns: (styp option * int list) list,
    9.16 +    iters_assigns: (styp option * int list) list,
    9.17 +    bisim_depths: int list,
    9.18 +    boxes: (typ option * bool option) list,
    9.19 +    monos: (typ option * bool option) list,
    9.20 +    wfs: (styp option * bool option) list,
    9.21 +    sat_solver: string,
    9.22 +    blocking: bool,
    9.23 +    falsify: bool,
    9.24 +    debug: bool,
    9.25 +    verbose: bool,
    9.26 +    overlord: bool,
    9.27 +    user_axioms: bool option,
    9.28 +    assms: bool,
    9.29 +    coalesce_type_vars: bool,
    9.30 +    destroy_constrs: bool,
    9.31 +    specialize: bool,
    9.32 +    skolemize: bool,
    9.33 +    star_linear_preds: bool,
    9.34 +    uncurry: bool,
    9.35 +    fast_descrs: bool,
    9.36 +    peephole_optim: bool,
    9.37 +    timeout: Time.time option,
    9.38 +    tac_timeout: Time.time option,
    9.39 +    sym_break: int,
    9.40 +    sharing_depth: int,
    9.41 +    flatten_props: bool,
    9.42 +    max_threads: int,
    9.43 +    show_skolems: bool,
    9.44 +    show_datatypes: bool,
    9.45 +    show_consts: bool,
    9.46 +    evals: term list,
    9.47 +    formats: (term option * int list) list,
    9.48 +    max_potential: int,
    9.49 +    max_genuine: int,
    9.50 +    check_potential: bool,
    9.51 +    check_genuine: bool,
    9.52 +    batch_size: int,
    9.53 +    expect: string}
    9.54 +
    9.55 +  val register_frac_type : string -> (string * string) list -> theory -> theory
    9.56 +  val unregister_frac_type : string -> theory -> theory
    9.57 +  val register_codatatype : typ -> string -> styp list -> theory -> theory
    9.58 +  val unregister_codatatype : typ -> theory -> theory
    9.59 +  val pick_nits_in_term :
    9.60 +    Proof.state -> params -> bool -> term list -> term -> string * Proof.state
    9.61 +  val pick_nits_in_subgoal :
    9.62 +    Proof.state -> params -> bool -> int -> string * Proof.state
    9.63 +end;
    9.64 +
    9.65 +structure Nitpick : NITPICK =
    9.66 +struct
    9.67 +
    9.68 +open NitpickUtil
    9.69 +open NitpickHOL
    9.70 +open NitpickMono
    9.71 +open NitpickScope
    9.72 +open NitpickPeephole
    9.73 +open NitpickRep
    9.74 +open NitpickNut
    9.75 +open NitpickKodkod
    9.76 +open NitpickModel
    9.77 +
    9.78 +type params = {
    9.79 +  cards_assigns: (typ option * int list) list,
    9.80 +  maxes_assigns: (styp option * int list) list,
    9.81 +  iters_assigns: (styp option * int list) list,
    9.82 +  bisim_depths: int list,
    9.83 +  boxes: (typ option * bool option) list,
    9.84 +  monos: (typ option * bool option) list,
    9.85 +  wfs: (styp option * bool option) list,
    9.86 +  sat_solver: string,
    9.87 +  blocking: bool,
    9.88 +  falsify: bool,
    9.89 +  debug: bool,
    9.90 +  verbose: bool,
    9.91 +  overlord: bool,
    9.92 +  user_axioms: bool option,
    9.93 +  assms: bool,
    9.94 +  coalesce_type_vars: bool,
    9.95 +  destroy_constrs: bool,
    9.96 +  specialize: bool,
    9.97 +  skolemize: bool,
    9.98 +  star_linear_preds: bool,
    9.99 +  uncurry: bool,
   9.100 +  fast_descrs: bool,
   9.101 +  peephole_optim: bool,
   9.102 +  timeout: Time.time option,
   9.103 +  tac_timeout: Time.time option,
   9.104 +  sym_break: int,
   9.105 +  sharing_depth: int,
   9.106 +  flatten_props: bool,
   9.107 +  max_threads: int,
   9.108 +  show_skolems: bool,
   9.109 +  show_datatypes: bool,
   9.110 +  show_consts: bool,
   9.111 +  evals: term list,
   9.112 +  formats: (term option * int list) list,
   9.113 +  max_potential: int,
   9.114 +  max_genuine: int,
   9.115 +  check_potential: bool,
   9.116 +  check_genuine: bool,
   9.117 +  batch_size: int,
   9.118 +  expect: string}
   9.119 +
   9.120 +type problem_extension = {
   9.121 +  free_names: nut list,
   9.122 +  sel_names: nut list,
   9.123 +  nonsel_names: nut list,
   9.124 +  rel_table: nut NameTable.table,
   9.125 +  liberal: bool,
   9.126 +  scope: scope,
   9.127 +  core: Kodkod.formula,
   9.128 +  defs: Kodkod.formula list}
   9.129 +
   9.130 +type rich_problem = Kodkod.problem * problem_extension
   9.131 +
   9.132 +(* Proof.context -> string -> term list -> Pretty.T list *)
   9.133 +fun pretties_for_formulas _ _ [] = []
   9.134 +  | pretties_for_formulas ctxt s ts =
   9.135 +    [Pretty.str (s ^ plural_s_for_list ts ^ ":"),
   9.136 +     Pretty.indent indent_size (Pretty.chunks
   9.137 +         (map2 (fn j => fn t =>
   9.138 +                   Pretty.block [t |> shorten_const_names_in_term
   9.139 +                                   |> Syntax.pretty_term ctxt,
   9.140 +                                 Pretty.str (if j = 1 then "." else ";")])
   9.141 +               (length ts downto 1) ts))]
   9.142 +
   9.143 +val max_liberal_delay_ms = 200
   9.144 +val max_liberal_delay_percent = 2
   9.145 +
   9.146 +(* Time.time option -> int *)
   9.147 +fun liberal_delay_for_timeout NONE = max_liberal_delay_ms
   9.148 +  | liberal_delay_for_timeout (SOME timeout) =
   9.149 +    Int.max (0, Int.min (max_liberal_delay_ms,
   9.150 +                         Time.toMilliseconds timeout
   9.151 +                         * max_liberal_delay_percent div 100))
   9.152 +
   9.153 +(* Time.time option -> bool *)
   9.154 +fun passed_deadline NONE = false
   9.155 +  | passed_deadline (SOME time) = Time.compare (Time.now (), time) <> LESS
   9.156 +
   9.157 +(* ('a * bool option) list -> bool *)
   9.158 +fun none_true asgns = forall (not_equal (SOME true) o snd) asgns
   9.159 +
   9.160 +val weaselly_sorts =
   9.161 +  [@{sort default}, @{sort zero}, @{sort one}, @{sort plus}, @{sort minus},
   9.162 +   @{sort uminus}, @{sort times}, @{sort inverse}, @{sort abs}, @{sort sgn},
   9.163 +   @{sort ord}, @{sort eq}, @{sort number}]
   9.164 +(* theory -> typ -> bool *)
   9.165 +fun is_tfree_with_weaselly_sort thy (TFree (_, S)) =
   9.166 +    exists (curry (Sign.subsort thy) S) weaselly_sorts
   9.167 +  | is_tfree_with_weaselly_sort _ _ = false
   9.168 +(* theory term -> bool *)
   9.169 +val has_weaselly_sorts =
   9.170 +  exists_type o exists_subtype o is_tfree_with_weaselly_sort
   9.171 +
   9.172 +(* Time.time -> Proof.state -> params -> bool -> term -> string * Proof.state *)
   9.173 +fun pick_them_nits_in_term deadline state (params : params) auto orig_assm_ts
   9.174 +                           orig_t =
   9.175 +  let
   9.176 +    val timer = Timer.startRealTimer ()
   9.177 +    val thy = Proof.theory_of state
   9.178 +    val ctxt = Proof.context_of state
   9.179 +    val {cards_assigns, maxes_assigns, iters_assigns, bisim_depths, boxes,
   9.180 +         monos, wfs, sat_solver, blocking, falsify, debug, verbose, overlord,
   9.181 +         user_axioms, assms, coalesce_type_vars, destroy_constrs, specialize,
   9.182 +         skolemize, star_linear_preds, uncurry, fast_descrs, peephole_optim,
   9.183 +         tac_timeout, sym_break, sharing_depth, flatten_props, max_threads,
   9.184 +         show_skolems, show_datatypes, show_consts, evals, formats,
   9.185 +         max_potential, max_genuine, check_potential, check_genuine, batch_size,
   9.186 +         ...} =
   9.187 +      params
   9.188 +    val state_ref = Unsynchronized.ref state
   9.189 +    (* Pretty.T -> unit *)
   9.190 +    val pprint =
   9.191 +      if auto then
   9.192 +        Unsynchronized.change state_ref o Proof.goal_message o K
   9.193 +        o curry Pretty.blk 0 o cons (Pretty.str "") o single
   9.194 +        o Pretty.mark Markup.hilite
   9.195 +      else
   9.196 +        priority o Pretty.string_of
   9.197 +    (* (unit -> Pretty.T) -> unit *)
   9.198 +    fun pprint_m f = () |> not auto ? pprint o f
   9.199 +    fun pprint_v f = () |> verbose ? pprint o f
   9.200 +    fun pprint_d f = () |> debug ? pprint o f
   9.201 +    (* string -> unit *)
   9.202 +    val print = pprint o curry Pretty.blk 0 o pstrs
   9.203 +    (* (unit -> string) -> unit *)
   9.204 +    fun print_m f = pprint_m (curry Pretty.blk 0 o pstrs o f)
   9.205 +    fun print_v f = pprint_v (curry Pretty.blk 0 o pstrs o f)
   9.206 +    fun print_d f = pprint_d (curry Pretty.blk 0 o pstrs o f)
   9.207 +
   9.208 +    (* unit -> unit *)
   9.209 +    fun check_deadline () =
   9.210 +      if debug andalso passed_deadline deadline then raise TimeLimit.TimeOut
   9.211 +      else ()
   9.212 +    (* unit -> 'a *)
   9.213 +    fun do_interrupted () =
   9.214 +      if passed_deadline deadline then raise TimeLimit.TimeOut
   9.215 +      else raise Interrupt
   9.216 +
   9.217 +    val _ = print_m (K "Nitpicking...")
   9.218 +    val neg_t = if falsify then Logic.mk_implies (orig_t, @{prop False})
   9.219 +                else orig_t
   9.220 +    val assms_t = if assms orelse auto then
   9.221 +                    Logic.mk_conjunction_list (neg_t :: orig_assm_ts)
   9.222 +                  else
   9.223 +                    neg_t
   9.224 +    val (assms_t, evals) =
   9.225 +      assms_t :: evals
   9.226 +      |> coalesce_type_vars ? coalesce_type_vars_in_terms
   9.227 +      |> hd pairf tl
   9.228 +    val original_max_potential = max_potential
   9.229 +    val original_max_genuine = max_genuine
   9.230 +(*
   9.231 +    val _ = priority ("*** " ^ Syntax.string_of_term ctxt orig_t)
   9.232 +    val _ = List.app (fn t => priority ("*** " ^ Syntax.string_of_term ctxt t))
   9.233 +                     orig_assm_ts
   9.234 +*)
   9.235 +    val max_bisim_depth = fold Integer.max bisim_depths ~1
   9.236 +    val case_names = case_const_names thy
   9.237 +    val (defs, built_in_nondefs, user_nondefs) = all_axioms_of thy
   9.238 +    val def_table = const_def_table ctxt defs
   9.239 +    val nondef_table = const_nondef_table (built_in_nondefs @ user_nondefs)
   9.240 +    val simp_table = Unsynchronized.ref (const_simp_table ctxt)
   9.241 +    val psimp_table = const_psimp_table ctxt
   9.242 +    val intro_table = inductive_intro_table ctxt def_table
   9.243 +    val ground_thm_table = ground_theorem_table thy
   9.244 +    val ersatz_table = ersatz_table thy
   9.245 +    val (ext_ctxt as {skolems, special_funs, wf_cache, ...}) =
   9.246 +      {thy = thy, ctxt = ctxt, max_bisim_depth = max_bisim_depth, boxes = boxes,
   9.247 +       user_axioms = user_axioms, debug = debug, wfs = wfs,
   9.248 +       destroy_constrs = destroy_constrs, specialize = specialize,
   9.249 +       skolemize = skolemize, star_linear_preds = star_linear_preds,
   9.250 +       uncurry = uncurry, fast_descrs = fast_descrs, tac_timeout = tac_timeout,
   9.251 +       evals = evals, case_names = case_names, def_table = def_table,
   9.252 +       nondef_table = nondef_table, user_nondefs = user_nondefs,
   9.253 +       simp_table = simp_table, psimp_table = psimp_table,
   9.254 +       intro_table = intro_table, ground_thm_table = ground_thm_table,
   9.255 +       ersatz_table = ersatz_table, skolems = Unsynchronized.ref [],
   9.256 +       special_funs = Unsynchronized.ref [],
   9.257 +       unrolled_preds = Unsynchronized.ref [], wf_cache = Unsynchronized.ref []}
   9.258 +    val frees = Term.add_frees assms_t []
   9.259 +    val _ = null (Term.add_tvars assms_t [])
   9.260 +            orelse raise NOT_SUPPORTED "schematic type variables"
   9.261 +    val (((def_ts, nondef_ts), (got_all_mono_user_axioms, no_poly_user_axioms)),
   9.262 +         core_t) = preprocess_term ext_ctxt assms_t
   9.263 +    val got_all_user_axioms =
   9.264 +      got_all_mono_user_axioms andalso no_poly_user_axioms
   9.265 +
   9.266 +    (* styp * (bool * bool) -> unit *)
   9.267 +    fun print_wf (x, (gfp, wf)) =
   9.268 +      pprint (Pretty.blk (0,
   9.269 +          pstrs ("The " ^ (if gfp then "co" else "") ^ "inductive predicate \"")
   9.270 +          @ Syntax.pretty_term ctxt (Const x) ::
   9.271 +          pstrs (if wf then
   9.272 +                   "\" was proved well-founded. Nitpick can compute it \
   9.273 +                   \efficiently."
   9.274 +                 else
   9.275 +                   "\" could not be proved well-founded. Nitpick might need to \
   9.276 +                   \unroll it.")))
   9.277 +    val _ = if verbose then List.app print_wf (!wf_cache) else ()
   9.278 +    val _ =
   9.279 +      pprint_d (fn () =>
   9.280 +          Pretty.chunks
   9.281 +              (pretties_for_formulas ctxt "Preprocessed formula" [core_t] @
   9.282 +               pretties_for_formulas ctxt "Relevant definitional axiom" def_ts @
   9.283 +               pretties_for_formulas ctxt "Relevant nondefinitional axiom"
   9.284 +                                     nondef_ts))
   9.285 +    val _ = List.app (ignore o Term.type_of) (core_t :: def_ts @ nondef_ts)
   9.286 +            handle TYPE (_, Ts, ts) =>
   9.287 +                   raise TYPE ("Nitpick.pick_them_nits_in_term", Ts, ts)
   9.288 +
   9.289 +    val unique_scope = forall (equal 1 o length o snd) cards_assigns
   9.290 +    (* typ -> bool *)
   9.291 +    fun is_free_type_monotonic T =
   9.292 +      unique_scope orelse
   9.293 +      case triple_lookup (type_match thy) monos T of
   9.294 +        SOME (SOME b) => b
   9.295 +      | _ => formulas_monotonic ext_ctxt T def_ts nondef_ts core_t
   9.296 +    fun is_datatype_monotonic T =
   9.297 +      unique_scope orelse
   9.298 +      case triple_lookup (type_match thy) monos T of
   9.299 +        SOME (SOME b) => b
   9.300 +      | _ =>
   9.301 +        not (is_pure_typedef thy T) orelse is_univ_typedef thy T
   9.302 +        orelse is_number_type thy T
   9.303 +        orelse formulas_monotonic ext_ctxt T def_ts nondef_ts core_t
   9.304 +    val Ts = ground_types_in_terms ext_ctxt (core_t :: def_ts @ nondef_ts)
   9.305 +             |> sort TermOrd.typ_ord
   9.306 +    val (all_dataTs, all_free_Ts) =
   9.307 +      List.partition (is_integer_type orf is_datatype thy) Ts
   9.308 +    val (mono_dataTs, nonmono_dataTs) =
   9.309 +      List.partition is_datatype_monotonic all_dataTs
   9.310 +    val (mono_free_Ts, nonmono_free_Ts) =
   9.311 +      List.partition is_free_type_monotonic all_free_Ts
   9.312 +
   9.313 +    val _ =
   9.314 +      if not unique_scope andalso not (null mono_free_Ts) then
   9.315 +        print_v (fn () =>
   9.316 +                    let
   9.317 +                      val ss = map (quote o string_for_type ctxt) mono_free_Ts
   9.318 +                    in
   9.319 +                      "The type" ^ plural_s_for_list ss ^ " " ^
   9.320 +                      space_implode " " (serial_commas "and" ss) ^ " " ^
   9.321 +                      (if none_true monos then
   9.322 +                         "passed the monotonicity test"
   9.323 +                       else
   9.324 +                         (if length ss = 1 then "is" else "are") ^
   9.325 +                         " considered monotonic") ^
   9.326 +                      ". Nitpick might be able to skip some scopes."
   9.327 +                    end)
   9.328 +      else
   9.329 +        ()
   9.330 +    val mono_Ts = mono_dataTs @ mono_free_Ts
   9.331 +    val nonmono_Ts = nonmono_dataTs @ nonmono_free_Ts
   9.332 +
   9.333 +(*
   9.334 +    val _ = priority "Monotonic datatypes:"
   9.335 +    val _ = List.app (priority o string_for_type ctxt) mono_dataTs
   9.336 +    val _ = priority "Nonmonotonic datatypes:"
   9.337 +    val _ = List.app (priority o string_for_type ctxt) nonmono_dataTs
   9.338 +    val _ = priority "Monotonic free types:"
   9.339 +    val _ = List.app (priority o string_for_type ctxt) mono_free_Ts
   9.340 +    val _ = priority "Nonmonotonic free types:"
   9.341 +    val _ = List.app (priority o string_for_type ctxt) nonmono_free_Ts
   9.342 +*)
   9.343 +
   9.344 +    val core_u = nut_from_term thy fast_descrs (!special_funs) Eq core_t
   9.345 +    val def_us = map (nut_from_term thy fast_descrs (!special_funs) DefEq)
   9.346 +                     def_ts
   9.347 +    val nondef_us = map (nut_from_term thy fast_descrs (!special_funs) Eq)
   9.348 +                        nondef_ts
   9.349 +    val (free_names, const_names) =
   9.350 +      fold add_free_and_const_names (core_u :: def_us @ nondef_us) ([], [])
   9.351 +    val nonsel_names = filter_out (is_sel o nickname_of) const_names
   9.352 +    val would_be_genuine = got_all_user_axioms andalso none_true wfs
   9.353 +(*
   9.354 +    val _ = List.app (priority o string_for_nut ctxt)
   9.355 +                     (core_u :: def_us @ nondef_us)
   9.356 +*)
   9.357 +    val need_incremental = Int.max (max_potential, max_genuine) >= 2
   9.358 +    val effective_sat_solver =
   9.359 +      if sat_solver <> "smart" then
   9.360 +        if need_incremental andalso
   9.361 +           not (sat_solver mem KodkodSAT.configured_sat_solvers true) then
   9.362 +          (print_m (K ("An incremental SAT solver is required: \"SAT4J\" will \
   9.363 +                       \be used instead of " ^ quote sat_solver ^ "."));
   9.364 +           "SAT4J")
   9.365 +        else
   9.366 +          sat_solver
   9.367 +      else
   9.368 +        KodkodSAT.smart_sat_solver_name need_incremental
   9.369 +    val _ =
   9.370 +      if sat_solver = "smart" then
   9.371 +        print_v (fn () => "Using SAT solver " ^ quote effective_sat_solver ^
   9.372 +                          ". The following" ^
   9.373 +                          (if need_incremental then " incremental " else " ") ^
   9.374 +                          "solvers are configured: " ^
   9.375 +                          commas (map quote (KodkodSAT.configured_sat_solvers
   9.376 +                                                       need_incremental)) ^ ".")
   9.377 +      else
   9.378 +        ()
   9.379 +
   9.380 +    val too_big_scopes = Unsynchronized.ref []
   9.381 +
   9.382 +    (* bool -> scope -> rich_problem option *)
   9.383 +    fun problem_for_scope liberal
   9.384 +            (scope as {card_assigns, bisim_depth, datatypes, ofs, ...}) =
   9.385 +      let
   9.386 +        val _ = not (exists (fn other => scope_less_eq other scope)
   9.387 +                            (!too_big_scopes))
   9.388 +                orelse raise LIMIT ("Nitpick.pick_them_nits_in_term.\
   9.389 +                                    \problem_for_scope", "too big scope")
   9.390 +(*
   9.391 +        val _ = priority "Offsets:"
   9.392 +        val _ = List.app (fn (T, j0) =>
   9.393 +                             priority (string_for_type ctxt T ^ " = " ^
   9.394 +                                       string_of_int j0))
   9.395 +                         (Typtab.dest ofs)
   9.396 +*)
   9.397 +        val all_precise = forall (is_precise_type datatypes) Ts
   9.398 +        (* nut list -> rep NameTable.table -> nut list * rep NameTable.table *)
   9.399 +        val repify_consts = choose_reps_for_consts scope all_precise
   9.400 +        val main_j0 = offset_of_type ofs bool_T
   9.401 +        val (nat_card, nat_j0) = spec_of_type scope nat_T
   9.402 +        val (int_card, int_j0) = spec_of_type scope int_T
   9.403 +        val _ = forall (equal main_j0) [nat_j0, int_j0]
   9.404 +                orelse raise BAD ("Nitpick.pick_them_nits_in_term.\
   9.405 +                                  \problem_for_scope", "bad offsets")
   9.406 +        val kk = kodkod_constrs peephole_optim nat_card int_card main_j0
   9.407 +        val (free_names, rep_table) =
   9.408 +          choose_reps_for_free_vars scope free_names NameTable.empty
   9.409 +        val (sel_names, rep_table) = choose_reps_for_all_sels scope rep_table
   9.410 +        val (nonsel_names, rep_table) = repify_consts nonsel_names rep_table
   9.411 +        val min_highest_arity =
   9.412 +          NameTable.fold (curry Int.max o arity_of_rep o snd) rep_table 1
   9.413 +        val min_univ_card =
   9.414 +          NameTable.fold (curry Int.max o min_univ_card_of_rep o snd) rep_table
   9.415 +                         (univ_card nat_card int_card main_j0 [] Kodkod.True)
   9.416 +        val _ = check_arity min_univ_card min_highest_arity
   9.417 +
   9.418 +        val core_u = choose_reps_in_nut scope liberal rep_table false core_u
   9.419 +        val def_us = map (choose_reps_in_nut scope liberal rep_table true)
   9.420 +                         def_us
   9.421 +        val nondef_us = map (choose_reps_in_nut scope liberal rep_table false)
   9.422 +                            nondef_us
   9.423 +(*
   9.424 +        val _ = List.app (priority o string_for_nut ctxt)
   9.425 +                         (free_names @ sel_names @ nonsel_names @
   9.426 +                          core_u :: def_us @ nondef_us)
   9.427 +*)
   9.428 +        val (free_rels, pool, rel_table) =
   9.429 +          rename_free_vars free_names initial_pool NameTable.empty
   9.430 +        val (sel_rels, pool, rel_table) =
   9.431 +          rename_free_vars sel_names pool rel_table
   9.432 +        val (other_rels, pool, rel_table) =
   9.433 +          rename_free_vars nonsel_names pool rel_table
   9.434 +        val core_u = rename_vars_in_nut pool rel_table core_u
   9.435 +        val def_us = map (rename_vars_in_nut pool rel_table) def_us
   9.436 +        val nondef_us = map (rename_vars_in_nut pool rel_table) nondef_us
   9.437 +        (* nut -> Kodkod.formula *)
   9.438 +        val to_f = kodkod_formula_from_nut ofs liberal kk
   9.439 +        val core_f = to_f core_u
   9.440 +        val def_fs = map to_f def_us
   9.441 +        val nondef_fs = map to_f nondef_us
   9.442 +        val formula = fold (fold s_and) [def_fs, nondef_fs] core_f
   9.443 +        val comment = (if liberal then "liberal" else "conservative") ^ "\n" ^
   9.444 +                      PrintMode.setmp [] multiline_string_for_scope scope
   9.445 +        val kodkod_sat_solver = KodkodSAT.sat_solver_spec effective_sat_solver
   9.446 +                                |> snd
   9.447 +        val delay = if liberal then
   9.448 +                      Option.map (fn time => Time.- (time, Time.now ()))
   9.449 +                                 deadline
   9.450 +                      |> liberal_delay_for_timeout
   9.451 +                    else
   9.452 +                      0
   9.453 +        val settings = [("solver", commas (map quote kodkod_sat_solver)),
   9.454 +                        ("skolem_depth", "-1"),
   9.455 +                        ("bit_width", "16"),
   9.456 +                        ("symmetry_breaking", signed_string_of_int sym_break),
   9.457 +                        ("sharing", signed_string_of_int sharing_depth),
   9.458 +                        ("flatten", Bool.toString flatten_props),
   9.459 +                        ("delay", signed_string_of_int delay)]
   9.460 +        val plain_rels = free_rels @ other_rels
   9.461 +        val plain_bounds = map (bound_for_plain_rel ctxt debug) plain_rels
   9.462 +        val plain_axioms = map (declarative_axiom_for_plain_rel kk) plain_rels
   9.463 +        val sel_bounds = map (bound_for_sel_rel ctxt debug datatypes) sel_rels
   9.464 +        val dtype_axioms = declarative_axioms_for_datatypes ext_ctxt ofs kk
   9.465 +                                                            rel_table datatypes
   9.466 +        val declarative_axioms = plain_axioms @ dtype_axioms
   9.467 +        val univ_card = univ_card nat_card int_card main_j0
   9.468 +                                  (plain_bounds @ sel_bounds) formula
   9.469 +        val built_in_bounds = bounds_for_built_in_rels_in_formula debug
   9.470 +                                  univ_card nat_card int_card main_j0 formula
   9.471 +        val bounds = built_in_bounds @ plain_bounds @ sel_bounds
   9.472 +                     |> not debug ? merge_bounds
   9.473 +        val highest_arity =
   9.474 +          fold Integer.max (map (fst o fst) (maps fst bounds)) 0
   9.475 +        val formula = fold_rev s_and declarative_axioms formula
   9.476 +        val _ = if formula = Kodkod.False then ()
   9.477 +                else check_arity univ_card highest_arity
   9.478 +      in
   9.479 +        SOME ({comment = comment, settings = settings, univ_card = univ_card,
   9.480 +               tuple_assigns = [], bounds = bounds,
   9.481 +               int_bounds = sequential_int_bounds univ_card,
   9.482 +               expr_assigns = [], formula = formula},
   9.483 +              {free_names = free_names, sel_names = sel_names,
   9.484 +               nonsel_names = nonsel_names, rel_table = rel_table,
   9.485 +               liberal = liberal, scope = scope, core = core_f,
   9.486 +               defs = nondef_fs @ def_fs @ declarative_axioms})
   9.487 +      end
   9.488 +      handle LIMIT (loc, msg) =>
   9.489 +             if loc = "NitpickKodkod.check_arity"
   9.490 +                andalso not (Typtab.is_empty ofs) then
   9.491 +               problem_for_scope liberal
   9.492 +                   {ext_ctxt = ext_ctxt, card_assigns = card_assigns,
   9.493 +                    bisim_depth = bisim_depth, datatypes = datatypes,
   9.494 +                    ofs = Typtab.empty}
   9.495 +             else if loc = "Nitpick.pick_them_nits_in_term.\
   9.496 +                           \problem_for_scope" then
   9.497 +               NONE
   9.498 +             else
   9.499 +               (Unsynchronized.change too_big_scopes (cons scope);
   9.500 +                print_v (fn () => ("Limit reached: " ^ msg ^
   9.501 +                                   ". Dropping " ^ (if liberal then "potential"
   9.502 +                                                    else "genuine") ^
   9.503 +                                   " component of scope."));
   9.504 +                NONE)
   9.505 +
   9.506 +    (* int -> (''a * int list list) list -> ''a -> Kodkod.tuple_set *)
   9.507 +    fun tuple_set_for_rel univ_card =
   9.508 +      Kodkod.TupleSet o map (kk_tuple debug univ_card) o the
   9.509 +      oo AList.lookup (op =)
   9.510 +
   9.511 +    val word_model = if falsify then "counterexample" else "model"
   9.512 +
   9.513 +    val scopes = Unsynchronized.ref []
   9.514 +    val generated_scopes = Unsynchronized.ref []
   9.515 +    val generated_problems = Unsynchronized.ref []
   9.516 +    val checked_problems = Unsynchronized.ref (SOME [])
   9.517 +    val met_potential = Unsynchronized.ref 0
   9.518 +
   9.519 +    (* rich_problem list -> int list -> unit *)
   9.520 +    fun update_checked_problems problems =
   9.521 +      List.app (Unsynchronized.change checked_problems o Option.map o cons
   9.522 +                o nth problems)
   9.523 +
   9.524 +    (* bool -> Kodkod.raw_bound list -> problem_extension -> bool option *)
   9.525 +    fun print_and_check_model genuine bounds
   9.526 +            ({free_names, sel_names, nonsel_names, rel_table, scope, ...}
   9.527 +             : problem_extension) =
   9.528 +      let
   9.529 +        val (reconstructed_model, codatatypes_ok) =
   9.530 +          reconstruct_hol_model {show_skolems = show_skolems,
   9.531 +                                 show_datatypes = show_datatypes,
   9.532 +                                 show_consts = show_consts}
   9.533 +              scope formats frees free_names sel_names nonsel_names rel_table
   9.534 +              bounds
   9.535 +        val would_be_genuine = would_be_genuine andalso codatatypes_ok
   9.536 +      in
   9.537 +        pprint (Pretty.chunks
   9.538 +            [Pretty.blk (0,
   9.539 +                 (pstrs ("Nitpick found a" ^
   9.540 +                         (if not genuine then " potential "
   9.541 +                          else if would_be_genuine then " "
   9.542 +                          else " likely genuine ") ^ word_model) @
   9.543 +                  (case pretties_for_scope scope verbose of
   9.544 +                     [] => []
   9.545 +                   | pretties => pstrs " for " @ pretties) @
   9.546 +                  [Pretty.str ":\n"])),
   9.547 +             Pretty.indent indent_size reconstructed_model]);
   9.548 +        if genuine then
   9.549 +          (if check_genuine then
   9.550 +             (case prove_hol_model scope tac_timeout free_names sel_names
   9.551 +                                   rel_table bounds assms_t of
   9.552 +                SOME true => print ("Confirmation by \"auto\": The above " ^
   9.553 +                                    word_model ^ " is really genuine.")
   9.554 +              | SOME false =>
   9.555 +                if would_be_genuine then
   9.556 +                  error ("A supposedly genuine " ^ word_model ^ " was shown to\
   9.557 +                         \be spurious by \"auto\".\nThis should never happen.\n\
   9.558 +                         \Please send a bug report to blanchet\
   9.559 +                         \te@in.tum.de.")
   9.560 +                else
   9.561 +                  print ("Refutation by \"auto\": The above " ^ word_model ^
   9.562 +                         " is spurious.")
   9.563 +              | NONE => print "No confirmation by \"auto\".")
   9.564 +           else
   9.565 +             ();
   9.566 +           if has_weaselly_sorts thy orig_t then
   9.567 +             print "Hint: Maybe you forgot a type constraint?"
   9.568 +           else
   9.569 +             ();
   9.570 +           if not would_be_genuine then
   9.571 +             if no_poly_user_axioms then
   9.572 +               let
   9.573 +                 val options =
   9.574 +                   [] |> not got_all_mono_user_axioms
   9.575 +                         ? cons ("user_axioms", "\"true\"")
   9.576 +                      |> not (none_true wfs)
   9.577 +                         ? cons ("wf", "\"smart\" or \"false\"")
   9.578 +                      |> not codatatypes_ok
   9.579 +                         ? cons ("bisim_depth", "a nonnegative value")
   9.580 +                 val ss =
   9.581 +                   map (fn (name, value) => quote name ^ " set to " ^ value)
   9.582 +                       options
   9.583 +               in
   9.584 +                 print ("Try again with " ^
   9.585 +                        space_implode " " (serial_commas "and" ss) ^
   9.586 +                        " to confirm that the " ^ word_model ^ " is genuine.")
   9.587 +               end
   9.588 +             else
   9.589 +               print ("Nitpick is unable to guarantee the authenticity of \
   9.590 +                      \the " ^ word_model ^ " in the presence of polymorphic \
   9.591 +                      \axioms.")
   9.592 +           else
   9.593 +             ();
   9.594 +           NONE)
   9.595 +        else
   9.596 +          if not genuine then
   9.597 +            (Unsynchronized.inc met_potential;
   9.598 +             if check_potential then
   9.599 +               let
   9.600 +                 val status = prove_hol_model scope tac_timeout free_names
   9.601 +                                              sel_names rel_table bounds assms_t
   9.602 +               in
   9.603 +                 (case status of
   9.604 +                    SOME true => print ("Confirmation by \"auto\": The above " ^
   9.605 +                                        word_model ^ " is genuine.")
   9.606 +                  | SOME false => print ("Refutation by \"auto\": The above " ^
   9.607 +                                         word_model ^ " is spurious.")
   9.608 +                  | NONE => print "No confirmation by \"auto\".");
   9.609 +                 status
   9.610 +               end
   9.611 +             else
   9.612 +               NONE)
   9.613 +          else
   9.614 +            NONE
   9.615 +      end
   9.616 +    (* int -> int -> int -> bool -> rich_problem list -> int * int * int *)
   9.617 +    fun solve_any_problem max_potential max_genuine donno first_time problems =
   9.618 +      let
   9.619 +        val max_potential = Int.max (0, max_potential)
   9.620 +        val max_genuine = Int.max (0, max_genuine)
   9.621 +        (* bool -> int * Kodkod.raw_bound list -> bool option *)
   9.622 +        fun print_and_check genuine (j, bounds) =
   9.623 +          print_and_check_model genuine bounds (snd (nth problems j))
   9.624 +        val max_solutions = max_potential + max_genuine
   9.625 +                            |> not need_incremental ? curry Int.min 1
   9.626 +      in
   9.627 +        if max_solutions <= 0 then
   9.628 +          (0, 0, donno)
   9.629 +        else
   9.630 +          case Kodkod.solve_any_problem overlord deadline max_threads
   9.631 +                                        max_solutions (map fst problems) of
   9.632 +            Kodkod.Normal ([], unsat_js) =>
   9.633 +            (update_checked_problems problems unsat_js;
   9.634 +             (max_potential, max_genuine, donno))
   9.635 +          | Kodkod.Normal (sat_ps, unsat_js) =>
   9.636 +            let
   9.637 +              val (lib_ps, con_ps) =
   9.638 +                List.partition (#liberal o snd o nth problems o fst) sat_ps
   9.639 +            in
   9.640 +              update_checked_problems problems (unsat_js @ map fst lib_ps);
   9.641 +              if null con_ps then
   9.642 +                let
   9.643 +                  val num_genuine = Library.take (max_potential, lib_ps)
   9.644 +                                    |> map (print_and_check false)
   9.645 +                                    |> filter (equal (SOME true)) |> length
   9.646 +                  val max_genuine = max_genuine - num_genuine
   9.647 +                  val max_potential = max_potential
   9.648 +                                      - (length lib_ps - num_genuine)
   9.649 +                in
   9.650 +                  if max_genuine <= 0 then
   9.651 +                    (0, 0, donno)
   9.652 +                  else
   9.653 +                    let
   9.654 +                      (* "co_js" is the list of conservative problems whose
   9.655 +                         liberal pendants couldn't be satisfied and hence that
   9.656 +                         most probably can't be satisfied themselves. *)
   9.657 +                      val co_js =
   9.658 +                        map (fn j => j - 1) unsat_js
   9.659 +                        |> filter (fn j =>
   9.660 +                                      j >= 0 andalso
   9.661 +                                      scopes_equivalent
   9.662 +                                          (#scope (snd (nth problems j)))
   9.663 +                                          (#scope (snd (nth problems (j + 1)))))
   9.664 +                      val bye_js = sort_distinct int_ord (map fst sat_ps @
   9.665 +                                                          unsat_js @ co_js)
   9.666 +                      val problems =
   9.667 +                        problems |> filter_out_indices bye_js
   9.668 +                                 |> max_potential <= 0
   9.669 +                                    ? filter_out (#liberal o snd)
   9.670 +                    in
   9.671 +                      solve_any_problem max_potential max_genuine donno false
   9.672 +                                        problems
   9.673 +                    end
   9.674 +                end
   9.675 +              else
   9.676 +                let
   9.677 +                  val _ = Library.take (max_genuine, con_ps)
   9.678 +                          |> List.app (ignore o print_and_check true)
   9.679 +                  val max_genuine = max_genuine - length con_ps
   9.680 +                in
   9.681 +                  if max_genuine <= 0 orelse not first_time then
   9.682 +                    (0, max_genuine, donno)
   9.683 +                  else
   9.684 +                    let
   9.685 +                      val bye_js = sort_distinct int_ord
   9.686 +                                                 (map fst sat_ps @ unsat_js)
   9.687 +                      val problems =
   9.688 +                        problems |> filter_out_indices bye_js
   9.689 +                                 |> filter_out (#liberal o snd)
   9.690 +                    in solve_any_problem 0 max_genuine donno false problems end
   9.691 +                end
   9.692 +            end
   9.693 +          | Kodkod.TimedOut unsat_js =>
   9.694 +            (update_checked_problems problems unsat_js; raise TimeLimit.TimeOut)
   9.695 +          | Kodkod.Interrupted NONE =>
   9.696 +            (checked_problems := NONE; do_interrupted ())
   9.697 +          | Kodkod.Interrupted (SOME unsat_js) =>
   9.698 +            (update_checked_problems problems unsat_js; do_interrupted ())
   9.699 +          | Kodkod.Error (s, unsat_js) =>
   9.700 +            (update_checked_problems problems unsat_js;
   9.701 +             print_v (K ("Kodkod error: " ^ s ^ "."));
   9.702 +             (max_potential, max_genuine, donno + 1))
   9.703 +      end
   9.704 +
   9.705 +    (* int -> int -> scope list -> int * int * int -> int * int * int *)
   9.706 +    fun run_batch j n scopes (max_potential, max_genuine, donno) =
   9.707 +      let
   9.708 +        val _ =
   9.709 +          if null scopes then
   9.710 +            print_m (K "The scope specification is inconsistent.")
   9.711 +          else if verbose then
   9.712 +            pprint (Pretty.chunks
   9.713 +                [Pretty.blk (0,
   9.714 +                     pstrs ((if n > 1 then
   9.715 +                               "Batch " ^ string_of_int (j + 1) ^ " of " ^
   9.716 +                               signed_string_of_int n ^ ": "
   9.717 +                             else
   9.718 +                               "") ^
   9.719 +                            "Trying " ^ string_of_int (length scopes) ^
   9.720 +                            " scope" ^ plural_s_for_list scopes ^ ":")),
   9.721 +                 Pretty.indent indent_size
   9.722 +                     (Pretty.chunks (map2
   9.723 +                          (fn j => fn scope =>
   9.724 +                              Pretty.block (
   9.725 +                                  (case pretties_for_scope scope true of
   9.726 +                                     [] => [Pretty.str "Empty"]
   9.727 +                                   | pretties => pretties) @
   9.728 +                                  [Pretty.str (if j = 1 then "." else ";")]))
   9.729 +                          (length scopes downto 1) scopes))])
   9.730 +          else
   9.731 +            ()
   9.732 +        (* scope * bool -> rich_problem list * bool
   9.733 +           -> rich_problem list * bool *)
   9.734 +        fun add_problem_for_scope (scope as {datatypes, ...}, liberal)
   9.735 +                                  (problems, donno) =
   9.736 +          (check_deadline ();
   9.737 +           case problem_for_scope liberal scope of
   9.738 +             SOME problem =>
   9.739 +             (problems
   9.740 +              |> (null problems orelse
   9.741 +                  not (Kodkod.problems_equivalent (fst problem)
   9.742 +                                                  (fst (hd problems))))
   9.743 +                  ? cons problem, donno)
   9.744 +           | NONE => (problems, donno + 1))
   9.745 +        val (problems, donno) =
   9.746 +          fold add_problem_for_scope
   9.747 +               (map_product pair scopes
   9.748 +                    ((if max_genuine > 0 then [false] else []) @
   9.749 +                     (if max_potential > 0 then [true] else [])))
   9.750 +               ([], donno)
   9.751 +        val _ = Unsynchronized.change generated_problems (append problems)
   9.752 +        val _ = Unsynchronized.change generated_scopes (append scopes)
   9.753 +      in
   9.754 +        solve_any_problem max_potential max_genuine donno true (rev problems)
   9.755 +      end
   9.756 +
   9.757 +    (* rich_problem list -> scope -> int *)
   9.758 +    fun scope_count (problems : rich_problem list) scope =
   9.759 +      length (filter (scopes_equivalent scope o #scope o snd) problems)
   9.760 +    (* string -> string *)
   9.761 +    fun excipit did_so_and_so =
   9.762 +      let
   9.763 +        (* rich_problem list -> rich_problem list *)
   9.764 +        val do_filter =
   9.765 +          if !met_potential = max_potential then filter_out (#liberal o snd)
   9.766 +          else I
   9.767 +        val total = length (!scopes)
   9.768 +        val unsat =
   9.769 +          fold (fn scope =>
   9.770 +                   case scope_count (do_filter (!generated_problems)) scope of
   9.771 +                     0 => I
   9.772 +                   | n =>
   9.773 +                     if scope_count (do_filter (these (!checked_problems)))
   9.774 +                                    scope = n then
   9.775 +                       Integer.add 1
   9.776 +                     else
   9.777 +                       I) (!generated_scopes) 0
   9.778 +      in
   9.779 +        "Nitpick " ^ did_so_and_so ^
   9.780 +        (if is_some (!checked_problems) andalso total > 0 then
   9.781 +           " after checking " ^
   9.782 +           string_of_int (Int.min (total - 1, unsat)) ^ " of " ^
   9.783 +           string_of_int total ^ " scope" ^ plural_s total
   9.784 +         else
   9.785 +           "") ^ "."
   9.786 +      end
   9.787 +
   9.788 +    (* int -> int -> scope list -> int * int * int -> Kodkod.outcome *)
   9.789 +    fun run_batches _ _ [] (max_potential, max_genuine, donno) =
   9.790 +        if donno > 0 andalso max_genuine > 0 then
   9.791 +          (print_m (fn () => excipit "ran out of resources"); "unknown")
   9.792 +        else if max_genuine = original_max_genuine then
   9.793 +          if max_potential = original_max_potential then
   9.794 +            (print_m (K ("Nitpick found no " ^ word_model ^ ".")); "none")
   9.795 +          else
   9.796 +            (print_m (K ("Nitpick could not find " ^
   9.797 +                         (if max_genuine = 1 then "a better " ^ word_model ^ "."
   9.798 +                          else "any better " ^ word_model ^ "s.")));
   9.799 +             "potential")
   9.800 +        else
   9.801 +          if would_be_genuine then "genuine" else "likely_genuine"
   9.802 +      | run_batches j n (batch :: batches) z =
   9.803 +        let val (z as (_, max_genuine, _)) = run_batch j n batch z in
   9.804 +          run_batches (j + 1) n (if max_genuine > 0 then batches else []) z
   9.805 +        end
   9.806 +
   9.807 +    val _ = scopes := all_scopes ext_ctxt sym_break cards_assigns maxes_assigns
   9.808 +                                 iters_assigns bisim_depths mono_Ts nonmono_Ts
   9.809 +    val batches = batch_list batch_size (!scopes)
   9.810 +    val outcome_code =
   9.811 +      (run_batches 0 (length batches) batches (max_potential, max_genuine, 0)
   9.812 +       handle Exn.Interrupt => do_interrupted ())
   9.813 +      handle TimeLimit.TimeOut =>
   9.814 +             (print_m (fn () => excipit "ran out of time");
   9.815 +              if !met_potential > 0 then "potential" else "unknown")
   9.816 +           | Exn.Interrupt => if auto orelse debug then raise Interrupt
   9.817 +                              else error (excipit "was interrupted")
   9.818 +    val _ = print_v (fn () => "Total time: " ^
   9.819 +                              signed_string_of_int (Time.toMilliseconds
   9.820 +                                    (Timer.checkRealTimer timer)) ^ " ms.")
   9.821 +  in (outcome_code, !state_ref) end
   9.822 +  handle Exn.Interrupt =>
   9.823 +         if auto orelse #debug params then
   9.824 +           raise Interrupt
   9.825 +         else
   9.826 +           if passed_deadline deadline then
   9.827 +             (priority "Nitpick ran out of time."; ("unknown", state))
   9.828 +           else
   9.829 +             error "Nitpick was interrupted."
   9.830 +
   9.831 +(* Proof.state -> params -> bool -> term -> string * Proof.state *)
   9.832 +fun pick_nits_in_term state (params as {debug, timeout, expect, ...})
   9.833 +                      auto orig_assm_ts orig_t =
   9.834 +  let
   9.835 +    val deadline = Option.map (curry Time.+ (Time.now ())) timeout
   9.836 +    val outcome as (outcome_code, _) =
   9.837 +      time_limit (if debug then NONE else timeout)
   9.838 +          (pick_them_nits_in_term deadline state params auto orig_assm_ts)
   9.839 +          orig_t
   9.840 +  in
   9.841 +    if expect = "" orelse outcome_code = expect then outcome
   9.842 +    else error ("Unexpected outcome: " ^ quote outcome_code ^ ".")
   9.843 +  end
   9.844 +
   9.845 +(* Proof.state -> params -> thm -> int -> string * Proof.state *)
   9.846 +fun pick_nits_in_subgoal state params auto subgoal =
   9.847 +  let
   9.848 +    val ctxt = Proof.context_of state
   9.849 +    val t = state |> Proof.get_goal |> snd |> snd |> prop_of
   9.850 +  in
   9.851 +    if Logic.count_prems t = 0 then
   9.852 +      (priority "No subgoal!"; ("none", state))
   9.853 +    else
   9.854 +      let
   9.855 +        val assms = map term_of (Assumption.all_assms_of ctxt)
   9.856 +        val (t, frees) = Logic.goal_params t subgoal
   9.857 +      in pick_nits_in_term state params auto assms (subst_bounds (frees, t)) end
   9.858 +  end
   9.859 +
   9.860 +end;
    10.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.2 +++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML	Thu Oct 22 14:51:47 2009 +0200
    10.3 @@ -0,0 +1,3330 @@
    10.4 +(*  Title:      HOL/Nitpick/Tools/nitpick_hol.ML
    10.5 +    Author:     Jasmin Blanchette, TU Muenchen
    10.6 +    Copyright   2008, 2009
    10.7 +
    10.8 +Auxiliary HOL-related functions used by Nitpick.
    10.9 +*)
   10.10 +
   10.11 +signature NITPICK_HOL =
   10.12 +sig
   10.13 +  type const_table = term list Symtab.table
   10.14 +  type special_fun = (styp * int list * term list) * styp
   10.15 +  type unrolled = styp * styp
   10.16 +  type wf_cache = (styp * (bool * bool)) list
   10.17 +
   10.18 +  type extended_context = {
   10.19 +    thy: theory,
   10.20 +    ctxt: Proof.context,
   10.21 +    max_bisim_depth: int,
   10.22 +    boxes: (typ option * bool option) list,
   10.23 +    wfs: (styp option * bool option) list,
   10.24 +    user_axioms: bool option,
   10.25 +    debug: bool,
   10.26 +    destroy_constrs: bool,
   10.27 +    specialize: bool,
   10.28 +    skolemize: bool,
   10.29 +    star_linear_preds: bool,
   10.30 +    uncurry: bool,
   10.31 +    fast_descrs: bool,
   10.32 +    tac_timeout: Time.time option,
   10.33 +    evals: term list,
   10.34 +    case_names: (string * int) list,
   10.35 +    def_table: const_table,
   10.36 +    nondef_table: const_table,
   10.37 +    user_nondefs: term list,
   10.38 +    simp_table: const_table Unsynchronized.ref,
   10.39 +    psimp_table: const_table,
   10.40 +    intro_table: const_table,
   10.41 +    ground_thm_table: term list Inttab.table,
   10.42 +    ersatz_table: (string * string) list,
   10.43 +    skolems: (string * string list) list Unsynchronized.ref,
   10.44 +    special_funs: special_fun list Unsynchronized.ref,
   10.45 +    unrolled_preds: unrolled list Unsynchronized.ref,
   10.46 +    wf_cache: wf_cache Unsynchronized.ref}
   10.47 +
   10.48 +  val name_sep : string
   10.49 +  val numeral_prefix : string
   10.50 +  val skolem_prefix : string
   10.51 +  val eval_prefix : string
   10.52 +  val original_name : string -> string
   10.53 +  val unbox_type : typ -> typ
   10.54 +  val string_for_type : Proof.context -> typ -> string
   10.55 +  val prefix_name : string -> string -> string
   10.56 +  val short_name : string -> string
   10.57 +  val short_const_name : string -> string
   10.58 +  val shorten_const_names_in_term : term -> term
   10.59 +  val type_match : theory -> typ * typ -> bool
   10.60 +  val const_match : theory -> styp * styp -> bool
   10.61 +  val term_match : theory -> term * term -> bool
   10.62 +  val is_TFree : typ -> bool
   10.63 +  val is_higher_order_type : typ -> bool
   10.64 +  val is_fun_type : typ -> bool
   10.65 +  val is_set_type : typ -> bool
   10.66 +  val is_pair_type : typ -> bool
   10.67 +  val is_lfp_iterator_type : typ -> bool
   10.68 +  val is_gfp_iterator_type : typ -> bool
   10.69 +  val is_fp_iterator_type : typ -> bool
   10.70 +  val is_boolean_type : typ -> bool
   10.71 +  val is_integer_type : typ -> bool
   10.72 +  val is_record_type : typ -> bool
   10.73 +  val is_number_type : theory -> typ -> bool
   10.74 +  val const_for_iterator_type : typ -> styp
   10.75 +  val nth_range_type : int -> typ -> typ
   10.76 +  val num_factors_in_type : typ -> int
   10.77 +  val num_binder_types : typ -> int
   10.78 +  val curried_binder_types : typ -> typ list
   10.79 +  val mk_flat_tuple : typ -> term list -> term
   10.80 +  val dest_n_tuple : int -> term -> term list
   10.81 +  val instantiate_type : theory -> typ -> typ -> typ -> typ
   10.82 +  val is_codatatype : theory -> typ -> bool
   10.83 +  val is_pure_typedef : theory -> typ -> bool
   10.84 +  val is_univ_typedef : theory -> typ -> bool
   10.85 +  val is_datatype : theory -> typ -> bool
   10.86 +  val is_record_constr : styp -> bool
   10.87 +  val is_record_get : theory -> styp -> bool
   10.88 +  val is_record_update : theory -> styp -> bool
   10.89 +  val is_abs_fun : theory -> styp -> bool
   10.90 +  val is_rep_fun : theory -> styp -> bool
   10.91 +  val is_constr : theory -> styp -> bool
   10.92 +  val is_sel : string -> bool
   10.93 +  val discr_for_constr : styp -> styp
   10.94 +  val num_sels_for_constr_type : typ -> int
   10.95 +  val nth_sel_name_for_constr_name : string -> int -> string
   10.96 +  val nth_sel_for_constr : styp -> int -> styp
   10.97 +  val boxed_nth_sel_for_constr : extended_context -> styp -> int -> styp
   10.98 +  val sel_no_from_name : string -> int
   10.99 +  val eta_expand : typ list -> term -> int -> term
  10.100 +  val extensionalize : term -> term
  10.101 +  val distinctness_formula : typ -> term list -> term
  10.102 +  val register_frac_type : string -> (string * string) list -> theory -> theory
  10.103 +  val unregister_frac_type : string -> theory -> theory
  10.104 +  val register_codatatype : typ -> string -> styp list -> theory -> theory
  10.105 +  val unregister_codatatype : typ -> theory -> theory
  10.106 +  val datatype_constrs : theory -> typ -> styp list
  10.107 +  val boxed_datatype_constrs : extended_context -> typ -> styp list
  10.108 +  val num_datatype_constrs : theory -> typ -> int
  10.109 +  val constr_name_for_sel_like : string -> string
  10.110 +  val boxed_constr_for_sel : extended_context -> styp -> styp
  10.111 +  val card_of_type : (typ * int) list -> typ -> int
  10.112 +  val bounded_card_of_type : int -> int -> (typ * int) list -> typ -> int
  10.113 +  val bounded_precise_card_of_type :
  10.114 +    theory -> int -> int -> (typ * int) list -> typ -> int
  10.115 +  val is_finite_type : theory -> typ -> bool
  10.116 +  val all_axioms_of : theory -> term list * term list * term list
  10.117 +  val arity_of_built_in_const : bool -> styp -> int option
  10.118 +  val is_built_in_const : bool -> styp -> bool
  10.119 +  val case_const_names : theory -> (string * int) list
  10.120 +  val const_def_table : Proof.context -> term list -> const_table
  10.121 +  val const_nondef_table : term list -> const_table
  10.122 +  val const_simp_table : Proof.context -> const_table
  10.123 +  val const_psimp_table : Proof.context -> const_table
  10.124 +  val inductive_intro_table : Proof.context -> const_table -> const_table
  10.125 +  val ground_theorem_table : theory -> term list Inttab.table
  10.126 +  val ersatz_table : theory -> (string * string) list
  10.127 +  val def_of_const : theory -> const_table -> styp -> term option
  10.128 +  val is_inductive_pred : extended_context -> styp -> bool
  10.129 +  val is_constr_pattern_lhs : theory -> term -> bool
  10.130 +  val is_constr_pattern_formula : theory -> term -> bool
  10.131 +  val coalesce_type_vars_in_terms : term list -> term list
  10.132 +  val ground_types_in_type : extended_context -> typ -> typ list
  10.133 +  val ground_types_in_terms : extended_context -> term list -> typ list
  10.134 +  val format_type : int list -> int list -> typ -> typ
  10.135 +  val format_term_type :
  10.136 +    theory -> const_table -> (term option * int list) list -> term -> typ
  10.137 +  val user_friendly_const :
  10.138 +   extended_context -> string * string -> (term option * int list) list
  10.139 +   -> styp -> term * typ
  10.140 +  val assign_operator_for_const : styp -> string
  10.141 +  val preprocess_term :
  10.142 +    extended_context -> term -> ((term list * term list) * (bool * bool)) * term
  10.143 +end;
  10.144 +
  10.145 +structure NitpickHOL : NITPICK_HOL =
  10.146 +struct
  10.147 +
  10.148 +open NitpickUtil
  10.149 +
  10.150 +type const_table = term list Symtab.table
  10.151 +type special_fun = (styp * int list * term list) * styp
  10.152 +type unrolled = styp * styp
  10.153 +type wf_cache = (styp * (bool * bool)) list
  10.154 +
  10.155 +type extended_context = {
  10.156 +  thy: theory,
  10.157 +  ctxt: Proof.context,
  10.158 +  max_bisim_depth: int,
  10.159 +  boxes: (typ option * bool option) list,
  10.160 +  wfs: (styp option * bool option) list,
  10.161 +  user_axioms: bool option,
  10.162 +  debug: bool,
  10.163 +  destroy_constrs: bool,
  10.164 +  specialize: bool,
  10.165 +  skolemize: bool,
  10.166 +  star_linear_preds: bool,
  10.167 +  uncurry: bool,
  10.168 +  fast_descrs: bool,
  10.169 +  tac_timeout: Time.time option,
  10.170 +  evals: term list,
  10.171 +  case_names: (string * int) list,
  10.172 +  def_table: const_table,
  10.173 +  nondef_table: const_table,
  10.174 +  user_nondefs: term list,
  10.175 +  simp_table: const_table Unsynchronized.ref,
  10.176 +  psimp_table: const_table,
  10.177 +  intro_table: const_table,
  10.178 +  ground_thm_table: term list Inttab.table,
  10.179 +  ersatz_table: (string * string) list,
  10.180 +  skolems: (string * string list) list Unsynchronized.ref,
  10.181 +  special_funs: special_fun list Unsynchronized.ref,
  10.182 +  unrolled_preds: unrolled list Unsynchronized.ref,
  10.183 +  wf_cache: wf_cache Unsynchronized.ref}
  10.184 +
  10.185 +structure TheoryData = TheoryDataFun(
  10.186 +  type T = {frac_types: (string * (string * string) list) list,
  10.187 +            codatatypes: (string * (string * styp list)) list}
  10.188 +  val empty = {frac_types = [], codatatypes = []}
  10.189 +  val copy = I
  10.190 +  val extend = I
  10.191 +  fun merge _ ({frac_types = fs1, codatatypes = cs1},
  10.192 +               {frac_types = fs2, codatatypes = cs2}) =
  10.193 +    {frac_types = AList.merge (op =) (op =) (fs1, fs2),
  10.194 +     codatatypes = AList.merge (op =) (op =) (cs1, cs2)})
  10.195 +
  10.196 +(* term * term -> term *)
  10.197 +fun s_conj (t1, @{const True}) = t1
  10.198 +  | s_conj (@{const True}, t2) = t2
  10.199 +  | s_conj (t1, t2) = if @{const False} mem [t1, t2] then @{const False}
  10.200 +                      else HOLogic.mk_conj (t1, t2)
  10.201 +fun s_disj (t1, @{const False}) = t1
  10.202 +  | s_disj (@{const False}, t2) = t2
  10.203 +  | s_disj (t1, t2) = if @{const True} mem [t1, t2] then @{const True}
  10.204 +                      else HOLogic.mk_disj (t1, t2)
  10.205 +(* term -> term -> term *)
  10.206 +fun mk_exists v t =
  10.207 +  HOLogic.exists_const (fastype_of v) $ lambda v (incr_boundvars 1 t)
  10.208 +
  10.209 +(* term -> term -> term list *)
  10.210 +fun strip_connective conn_t (t as (t0 $ t1 $ t2)) =
  10.211 +    if t0 = conn_t then strip_connective t0 t2 @ strip_connective t0 t1 else [t]
  10.212 +  | strip_connective _ t = [t]
  10.213 +(* term -> term list * term *)
  10.214 +fun strip_any_connective (t as (t0 $ t1 $ t2)) =
  10.215 +    if t0 mem [@{const "op &"}, @{const "op |"}] then
  10.216 +      (strip_connective t0 t, t0)
  10.217 +    else
  10.218 +      ([t], @{const Not})
  10.219 +  | strip_any_connective t = ([t], @{const Not})
  10.220 +(* term -> term list *)
  10.221 +val conjuncts = strip_connective @{const "op &"}
  10.222 +val disjuncts = strip_connective @{const "op |"}
  10.223 +
  10.224 +val name_sep = "$"
  10.225 +val numeral_prefix = nitpick_prefix ^ "num" ^ name_sep
  10.226 +val sel_prefix = nitpick_prefix ^ "sel"
  10.227 +val discr_prefix = nitpick_prefix ^ "is" ^ name_sep
  10.228 +val set_prefix = nitpick_prefix ^ "set" ^ name_sep
  10.229 +val lfp_iterator_prefix = nitpick_prefix ^ "lfpit" ^ name_sep
  10.230 +val gfp_iterator_prefix = nitpick_prefix ^ "gfpit" ^ name_sep
  10.231 +val nwf_prefix = nitpick_prefix ^ "nwf" ^ name_sep
  10.232 +val unrolled_prefix = nitpick_prefix ^ "unroll" ^ name_sep
  10.233 +val base_prefix = nitpick_prefix ^ "base" ^ name_sep
  10.234 +val step_prefix = nitpick_prefix ^ "step" ^ name_sep
  10.235 +val ubfp_prefix = nitpick_prefix ^ "ubfp" ^ name_sep
  10.236 +val lbfp_prefix = nitpick_prefix ^ "lbfp" ^ name_sep
  10.237 +val skolem_prefix = nitpick_prefix ^ "sk"
  10.238 +val special_prefix = nitpick_prefix ^ "sp"
  10.239 +val uncurry_prefix = nitpick_prefix ^ "unc"
  10.240 +val eval_prefix = nitpick_prefix ^ "eval"
  10.241 +val bound_var_prefix = "b"
  10.242 +val cong_var_prefix = "c"
  10.243 +val iter_var_prefix = "i"
  10.244 +val val_var_prefix = nitpick_prefix ^ "v"
  10.245 +val arg_var_prefix = "x"
  10.246 +
  10.247 +(* int -> string *)
  10.248 +fun sel_prefix_for j = sel_prefix ^ string_of_int j ^ name_sep
  10.249 +fun special_prefix_for j = special_prefix ^ string_of_int j ^ name_sep
  10.250 +(* int -> int -> string *)
  10.251 +fun skolem_prefix_for k j =
  10.252 +  skolem_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
  10.253 +fun uncurry_prefix_for k j =
  10.254 +  uncurry_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
  10.255 +
  10.256 +(* string -> string * string *)
  10.257 +val strip_first_name_sep =
  10.258 +  Substring.full #> Substring.position name_sep ##> Substring.triml 1
  10.259 +  #> pairself Substring.string
  10.260 +(* string -> string *)
  10.261 +fun original_name s =
  10.262 +  if String.isPrefix nitpick_prefix s then
  10.263 +    case strip_first_name_sep s of (s1, "") => s1 | (_, s2) => original_name s2
  10.264 +  else
  10.265 +    s
  10.266 +val after_name_sep = snd o strip_first_name_sep
  10.267 +
  10.268 +(* When you add constants to these lists, make sure to handle them in
  10.269 +   "NitpickNut.nut_from_term", and perhaps in "NitpickMono.consider_term" as
  10.270 +   well. *)
  10.271 +val built_in_consts =
  10.272 +  [(@{const_name all}, 1),
  10.273 +   (@{const_name "=="}, 2),
  10.274 +   (@{const_name "==>"}, 2),
  10.275 +   (@{const_name Pure.conjunction}, 2),
  10.276 +   (@{const_name Trueprop}, 1),
  10.277 +   (@{const_name Not}, 1),
  10.278 +   (@{const_name False}, 0),
  10.279 +   (@{const_name True}, 0),
  10.280 +   (@{const_name All}, 1),
  10.281 +   (@{const_name Ex}, 1),
  10.282 +   (@{const_name "op ="}, 2),
  10.283 +   (@{const_name "op &"}, 2),
  10.284 +   (@{const_name "op |"}, 2),
  10.285 +   (@{const_name "op -->"}, 2),
  10.286 +   (@{const_name If}, 3),
  10.287 +   (@{const_name Let}, 2),
  10.288 +   (@{const_name Unity}, 0),
  10.289 +   (@{const_name Pair}, 2),
  10.290 +   (@{const_name fst}, 1),
  10.291 +   (@{const_name snd}, 1),
  10.292 +   (@{const_name Id}, 0),
  10.293 +   (@{const_name insert}, 2),
  10.294 +   (@{const_name converse}, 1),
  10.295 +   (@{const_name trancl}, 1),
  10.296 +   (@{const_name rel_comp}, 2),
  10.297 +   (@{const_name image}, 2),
  10.298 +   (@{const_name Suc}, 0),
  10.299 +   (@{const_name finite}, 1),
  10.300 +   (@{const_name nat}, 0),
  10.301 +   (@{const_name zero_nat_inst.zero_nat}, 0),
  10.302 +   (@{const_name one_nat_inst.one_nat}, 0),
  10.303 +   (@{const_name plus_nat_inst.plus_nat}, 0),
  10.304 +   (@{const_name minus_nat_inst.minus_nat}, 0),
  10.305 +   (@{const_name times_nat_inst.times_nat}, 0),
  10.306 +   (@{const_name div_nat_inst.div_nat}, 0),
  10.307 +   (@{const_name div_nat_inst.mod_nat}, 0),
  10.308 +   (@{const_name ord_nat_inst.less_nat}, 2),
  10.309 +   (@{const_name ord_nat_inst.less_eq_nat}, 2),
  10.310 +   (@{const_name nat_gcd}, 0),
  10.311 +   (@{const_name nat_lcm}, 0),
  10.312 +   (@{const_name zero_int_inst.zero_int}, 0),
  10.313 +   (@{const_name one_int_inst.one_int}, 0),
  10.314 +   (@{const_name plus_int_inst.plus_int}, 0),
  10.315 +   (@{const_name minus_int_inst.minus_int}, 0),
  10.316 +   (@{const_name times_int_inst.times_int}, 0),
  10.317 +   (@{const_name div_int_inst.div_int}, 0),
  10.318 +   (@{const_name div_int_inst.mod_int}, 0),
  10.319 +   (@{const_name uminus_int_inst.uminus_int}, 0), (* FIXME: needed? *)
  10.320 +   (@{const_name ord_int_inst.less_int}, 2),
  10.321 +   (@{const_name ord_int_inst.less_eq_int}, 2),
  10.322 +   (@{const_name Tha}, 1),
  10.323 +   (@{const_name Frac}, 0),
  10.324 +   (@{const_name norm_frac}, 0)]
  10.325 +val built_in_descr_consts =
  10.326 +  [(@{const_name The}, 1),
  10.327 +   (@{const_name Eps}, 1)]
  10.328 +val built_in_typed_consts =
  10.329 +  [((@{const_name of_nat}, nat_T --> int_T), 0)]
  10.330 +val built_in_set_consts =
  10.331 +  [(@{const_name lower_semilattice_fun_inst.inf_fun}, 2),
  10.332 +   (@{const_name upper_semilattice_fun_inst.sup_fun}, 2),
  10.333 +   (@{const_name minus_fun_inst.minus_fun}, 2),
  10.334 +   (@{const_name ord_fun_inst.less_eq_fun}, 2)]
  10.335 +
  10.336 +(* typ -> typ *)
  10.337 +fun unbox_type (Type (@{type_name fun_box}, Ts)) =
  10.338 +    Type ("fun", map unbox_type Ts)
  10.339 +  | unbox_type (Type (@{type_name pair_box}, Ts)) =
  10.340 +    Type ("*", map unbox_type Ts)
  10.341 +  | unbox_type (Type (s, Ts)) = Type (s, map unbox_type Ts)
  10.342 +  | unbox_type T = T
  10.343 +(* Proof.context -> typ -> string *)
  10.344 +fun string_for_type ctxt = Syntax.string_of_typ ctxt o unbox_type
  10.345 +
  10.346 +(* string -> string -> string *)
  10.347 +val prefix_name = Long_Name.qualify o Long_Name.base_name
  10.348 +(* string -> string *)
  10.349 +fun short_name s = List.last (space_explode "." s) handle List.Empty => ""
  10.350 +(* string -> term -> term *)
  10.351 +val prefix_abs_vars = Term.map_abs_vars o prefix_name
  10.352 +(* term -> term *)
  10.353 +val shorten_abs_vars = Term.map_abs_vars short_name
  10.354 +(* string -> string *)
  10.355 +fun short_const_name s =
  10.356 +  case space_explode name_sep s of
  10.357 +    [_] => s |> String.isPrefix nitpick_prefix s ? unprefix nitpick_prefix
  10.358 +  | ss => map short_name ss |> space_implode "_"
  10.359 +(* term -> term *)
  10.360 +val shorten_const_names_in_term =
  10.361 +  map_aterms (fn Const (s, T) => Const (short_const_name s, T) | t => t)
  10.362 +
  10.363 +(* theory -> typ * typ -> bool *)
  10.364 +fun type_match thy (T1, T2) =
  10.365 +  (Sign.typ_match thy (T2, T1) Vartab.empty; true)
  10.366 +  handle Type.TYPE_MATCH => false
  10.367 +(* theory -> styp * styp -> bool *)
  10.368 +fun const_match thy ((s1, T1), (s2, T2)) =
  10.369 +  s1 = s2 andalso type_match thy (T1, T2)
  10.370 +(* theory -> term * term -> bool *)
  10.371 +fun term_match thy (Const x1, Const x2) = const_match thy (x1, x2)
  10.372 +  | term_match thy (Free (s1, T1), Free (s2, T2)) =
  10.373 +    const_match thy ((short_name s1, T1), (short_name s2, T2))
  10.374 +  | term_match thy (t1, t2) = t1 aconv t2
  10.375 +
  10.376 +(* typ -> bool *)
  10.377 +fun is_TFree (TFree _) = true
  10.378 +  | is_TFree _ = false
  10.379 +fun is_higher_order_type (Type ("fun", _)) = true
  10.380 +  | is_higher_order_type (Type (_, Ts)) = exists is_higher_order_type Ts
  10.381 +  | is_higher_order_type _ = false
  10.382 +fun is_fun_type (Type ("fun", _)) = true
  10.383 +  | is_fun_type _ = false
  10.384 +fun is_set_type (Type ("fun", [_, @{typ bool}])) = true
  10.385 +  | is_set_type _ = false
  10.386 +fun is_pair_type (Type ("*", _)) = true
  10.387 +  | is_pair_type _ = false
  10.388 +fun is_lfp_iterator_type (Type (s, _)) = String.isPrefix lfp_iterator_prefix s
  10.389 +  | is_lfp_iterator_type _ = false
  10.390 +fun is_gfp_iterator_type (Type (s, _)) = String.isPrefix gfp_iterator_prefix s
  10.391 +  | is_gfp_iterator_type _ = false
  10.392 +val is_fp_iterator_type = is_lfp_iterator_type orf is_gfp_iterator_type
  10.393 +val is_boolean_type = equal prop_T orf equal bool_T
  10.394 +val is_integer_type =
  10.395 +  member (op =) [nat_T, int_T, @{typ bisim_iterator}] orf is_fp_iterator_type
  10.396 +val is_record_type = not o null o Record.dest_recTs
  10.397 +(* theory -> typ -> bool *)
  10.398 +fun is_frac_type thy (Type (s, [])) =
  10.399 +    not (null (these (AList.lookup (op =) (#frac_types (TheoryData.get thy))
  10.400 +                                          s)))
  10.401 +  | is_frac_type _ _ = false
  10.402 +fun is_number_type thy = is_integer_type orf is_frac_type thy
  10.403 +
  10.404 +(* bool -> styp -> typ *)
  10.405 +fun iterator_type_for_const gfp (s, T) =
  10.406 +  Type ((if gfp then gfp_iterator_prefix else lfp_iterator_prefix) ^ s,
  10.407 +        binder_types T)
  10.408 +(* typ -> styp *)
  10.409 +fun const_for_iterator_type (Type (s, Ts)) = (after_name_sep s, Ts ---> bool_T)
  10.410 +  | const_for_iterator_type T =
  10.411 +    raise TYPE ("NitpickHOL.const_for_iterator_type", [T], [])
  10.412 +
  10.413 +(* int -> typ -> typ * typ *)
  10.414 +fun strip_n_binders 0 T = ([], T)
  10.415 +  | strip_n_binders n (Type ("fun", [T1, T2])) =
  10.416 +    strip_n_binders (n - 1) T2 |>> cons T1
  10.417 +  | strip_n_binders n (Type (@{type_name fun_box}, Ts)) =
  10.418 +    strip_n_binders n (Type ("fun", Ts))
  10.419 +  | strip_n_binders _ T = raise TYPE ("NitpickHOL.strip_n_binders", [T], [])
  10.420 +(* typ -> typ *)
  10.421 +val nth_range_type = snd oo strip_n_binders
  10.422 +
  10.423 +(* typ -> int *)
  10.424 +fun num_factors_in_type (Type ("*", [T1, T2])) =
  10.425 +    fold (Integer.add o num_factors_in_type) [T1, T2] 0
  10.426 +  | num_factors_in_type _ = 1
  10.427 +fun num_binder_types (Type ("fun", [_, T2])) = 1 + num_binder_types T2
  10.428 +  | num_binder_types _ = 0
  10.429 +(* typ -> typ list *)
  10.430 +val curried_binder_types = maps HOLogic.flatten_tupleT o binder_types
  10.431 +fun maybe_curried_binder_types T =
  10.432 +  (if is_pair_type (body_type T) then binder_types else curried_binder_types) T
  10.433 +
  10.434 +(* typ -> term list -> term *)
  10.435 +fun mk_flat_tuple _ [t] = t
  10.436 +  | mk_flat_tuple (Type ("*", [T1, T2])) (t :: ts) =
  10.437 +    HOLogic.pair_const T1 T2 $ t $ (mk_flat_tuple T2 ts)
  10.438 +  | mk_flat_tuple T ts = raise TYPE ("NitpickHOL.mk_flat_tuple", [T], ts)
  10.439 +(* int -> term -> term list *)
  10.440 +fun dest_n_tuple 1 t = [t]
  10.441 +  | dest_n_tuple n t = HOLogic.dest_prod t ||> dest_n_tuple (n - 1) |> op ::
  10.442 +
  10.443 +(* int -> typ -> typ list *)
  10.444 +fun dest_n_tuple_type 1 T = [T]
  10.445 +  | dest_n_tuple_type n (Type (_, [T1, T2])) =
  10.446 +    T1 :: dest_n_tuple_type (n - 1) T2
  10.447 +  | dest_n_tuple_type _ T = raise TYPE ("NitpickHOL.dest_n_tuple_type", [T], [])
  10.448 +
  10.449 +(* (typ * typ) list -> typ -> typ *)
  10.450 +fun typ_subst [] T = T
  10.451 +  | typ_subst ps T =
  10.452 +    let
  10.453 +      (* typ -> typ *)
  10.454 +      fun subst T =
  10.455 +        case AList.lookup (op =) ps T of
  10.456 +          SOME T' => T'
  10.457 +        | NONE => case T of Type (s, Ts) => Type (s, map subst Ts) | _ => T
  10.458 +    in subst T end
  10.459 +
  10.460 +(* theory -> typ -> typ -> typ -> typ *)
  10.461 +fun instantiate_type thy T1 T1' T2 =
  10.462 +  Same.commit (Envir.subst_type_same
  10.463 +                   (Sign.typ_match thy (Logic.varifyT T1, T1') Vartab.empty))
  10.464 +              (Logic.varifyT T2)
  10.465 +  handle Type.TYPE_MATCH =>
  10.466 +         raise TYPE ("NitpickHOL.instantiate_type", [T1, T1'], [])
  10.467 +
  10.468 +(* theory -> typ -> typ -> styp *)
  10.469 +fun repair_constr_type thy body_T' T =
  10.470 +  instantiate_type thy (body_type T) body_T' T
  10.471 +
  10.472 +(* string -> (string * string) list -> theory -> theory *)
  10.473 +fun register_frac_type frac_s ersaetze thy =
  10.474 +  let
  10.475 +    val {frac_types, codatatypes} = TheoryData.get thy
  10.476 +    val frac_types = AList.update (op =) (frac_s, ersaetze) frac_types
  10.477 +  in TheoryData.put {frac_types = frac_types, codatatypes = codatatypes} thy end
  10.478 +(* string -> theory -> theory *)
  10.479 +fun unregister_frac_type frac_s = register_frac_type frac_s []
  10.480 +
  10.481 +(* typ -> string -> styp list -> theory -> theory *)
  10.482 +fun register_codatatype co_T case_name constr_xs thy =
  10.483 +  let
  10.484 +    val {frac_types, codatatypes} = TheoryData.get thy
  10.485 +    val constr_xs = map (apsnd (repair_constr_type thy co_T)) constr_xs
  10.486 +    val (co_s, co_Ts) = dest_Type co_T
  10.487 +    val _ =
  10.488 +      if forall is_TFree co_Ts andalso not (has_duplicates (op =) co_Ts) then ()
  10.489 +      else raise TYPE ("NitpickHOL.register_codatatype", [co_T], [])
  10.490 +    val codatatypes = AList.update (op =) (co_s, (case_name, constr_xs))
  10.491 +                                   codatatypes
  10.492 +  in TheoryData.put {frac_types = frac_types, codatatypes = codatatypes} thy end
  10.493 +(* typ -> theory -> theory *)
  10.494 +fun unregister_codatatype co_T = register_codatatype co_T "" []
  10.495 +
  10.496 +type typedef_info =
  10.497 +  {rep_type: typ, abs_type: typ, Rep_name: string, Abs_name: string,
  10.498 +   set_def: thm option, prop_of_Rep: thm, set_name: string,
  10.499 +   Rep_inverse: thm option}
  10.500 +
  10.501 +(* theory -> string -> typedef_info *)
  10.502 +fun typedef_info thy s =
  10.503 +  if is_frac_type thy (Type (s, [])) then
  10.504 +    SOME {abs_type = Type (s, []), rep_type = @{typ "int * int"},
  10.505 +          Abs_name = @{const_name Abs_Frac}, Rep_name = @{const_name Rep_Frac},
  10.506 +          set_def = NONE, prop_of_Rep = @{prop "Rep_Frac x \<in> Frac"}
  10.507 +                          |> Logic.varify,
  10.508 +          set_name = @{const_name Frac}, Rep_inverse = NONE}
  10.509 +  else case Typedef.get_info thy s of
  10.510 +    SOME {abs_type, rep_type, Abs_name, Rep_name, set_def, Rep, Rep_inverse,
  10.511 +          ...} =>
  10.512 +    SOME {abs_type = abs_type, rep_type = rep_type, Abs_name = Abs_name,
  10.513 +          Rep_name = Rep_name, set_def = set_def, prop_of_Rep = prop_of Rep,
  10.514 +          set_name = set_prefix ^ s, Rep_inverse = SOME Rep_inverse}
  10.515 +  | NONE => NONE
  10.516 +
  10.517 +(* string -> bool *)
  10.518 +fun is_basic_datatype s =
  10.519 +    s mem [@{type_name "*"}, @{type_name bool}, @{type_name unit},
  10.520 +           @{type_name nat}, @{type_name int}]
  10.521 +(* theory -> string -> bool *)
  10.522 +val is_typedef = is_some oo typedef_info
  10.523 +val is_real_datatype = is_some oo Datatype.get_info
  10.524 +(* theory -> typ -> bool *)
  10.525 +fun is_codatatype thy (T as Type (s, _)) =
  10.526 +    not (null (AList.lookup (op =) (#codatatypes (TheoryData.get thy)) s
  10.527 +               |> Option.map snd |> these))
  10.528 +  | is_codatatype _ _ = false
  10.529 +fun is_pure_typedef thy (T as Type (s, _)) =
  10.530 +    is_typedef thy s andalso
  10.531 +    not (is_real_datatype thy s orelse is_codatatype thy T
  10.532 +         orelse is_record_type T orelse is_integer_type T)
  10.533 +  | is_pure_typedef _ _ = false
  10.534 +fun is_univ_typedef thy (Type (s, _)) =
  10.535 +    (case typedef_info thy s of
  10.536 +       SOME {set_def, prop_of_Rep, ...} =>
  10.537 +       (case set_def of
  10.538 +          SOME thm =>
  10.539 +          try (fst o dest_Const o snd o Logic.dest_equals o prop_of) thm
  10.540 +        | NONE =>
  10.541 +          try (fst o dest_Const o snd o HOLogic.dest_mem
  10.542 +               o HOLogic.dest_Trueprop) prop_of_Rep) = SOME @{const_name UNIV}
  10.543 +     | NONE => false)
  10.544 +  | is_univ_typedef _ _ = false
  10.545 +fun is_datatype thy (T as Type (s, _)) =
  10.546 +    (is_typedef thy s orelse is_codatatype thy T orelse T = @{typ ind})
  10.547 +    andalso not (is_basic_datatype s)
  10.548 +  | is_datatype _ _ = false
  10.549 +
  10.550 +(* theory -> typ -> (string * typ) list * (string * typ) *)
  10.551 +fun all_record_fields thy T =
  10.552 +  let val (recs, more) = Record.get_extT_fields thy T in
  10.553 +    recs @ more :: all_record_fields thy (snd more)
  10.554 +  end
  10.555 +  handle TYPE _ => []
  10.556 +(* styp -> bool *)
  10.557 +fun is_record_constr (x as (s, T)) =
  10.558 +  String.isSuffix Record.extN s andalso
  10.559 +  let val dataT = body_type T in
  10.560 +    is_record_type dataT andalso
  10.561 +    s = unsuffix Record.ext_typeN (fst (dest_Type dataT)) ^ Record.extN
  10.562 +  end
  10.563 +(* theory -> typ -> int *)
  10.564 +val num_record_fields = Integer.add 1 o length o fst oo Record.get_extT_fields
  10.565 +(* theory -> string -> typ -> int *)
  10.566 +fun no_of_record_field thy s T1 =
  10.567 +  find_index (equal s o fst) (Record.get_extT_fields thy T1 ||> single |> op @)
  10.568 +(* theory -> styp -> bool *)
  10.569 +fun is_record_get thy (s, Type ("fun", [T1, _])) =
  10.570 +    exists (equal s o fst) (all_record_fields thy T1)
  10.571 +  | is_record_get _ _ = false
  10.572 +fun is_record_update thy (s, T) =
  10.573 +  String.isSuffix Record.updateN s andalso
  10.574 +  exists (equal (unsuffix Record.updateN s) o fst)
  10.575 +         (all_record_fields thy (body_type T))
  10.576 +  handle TYPE _ => false
  10.577 +fun is_abs_fun thy (s, Type ("fun", [_, Type (s', _)])) =
  10.578 +    (case typedef_info thy s' of
  10.579 +       SOME {Abs_name, ...} => s = Abs_name
  10.580 +     | NONE => false)
  10.581 +  | is_abs_fun _ _ = false
  10.582 +fun is_rep_fun thy (s, Type ("fun", [Type (s', _), _])) =
  10.583 +    (case typedef_info thy s' of
  10.584 +       SOME {Rep_name, ...} => s = Rep_name
  10.585 +     | NONE => false)
  10.586 +  | is_rep_fun _ _ = false
  10.587 +
  10.588 +(* theory -> styp -> styp *)
  10.589 +fun mate_of_rep_fun thy (x as (_, Type ("fun", [T1 as Type (s', _), T2]))) =
  10.590 +    (case typedef_info thy s' of
  10.591 +       SOME {Abs_name, ...} => (Abs_name, Type ("fun", [T2, T1]))
  10.592 +     | NONE => raise TERM ("NitpickHOL.mate_of_rep_fun", [Const x]))
  10.593 +  | mate_of_rep_fun _ x = raise TERM ("NitpickHOL.mate_of_rep_fun", [Const x])
  10.594 +
  10.595 +(* theory -> styp -> bool *)
  10.596 +fun is_coconstr thy (s, T) =
  10.597 +  let
  10.598 +    val {codatatypes, ...} = TheoryData.get thy
  10.599 +    val co_T = body_type T
  10.600 +    val co_s = dest_Type co_T |> fst
  10.601 +  in
  10.602 +    exists (fn (s', T') => s = s' andalso repair_constr_type thy co_T T' = T)
  10.603 +           (AList.lookup (op =) codatatypes co_s |> Option.map snd |> these)
  10.604 +  end
  10.605 +  handle TYPE ("dest_Type", _, _) => false
  10.606 +fun is_constr_like thy (s, T) =
  10.607 +  s mem [@{const_name FunBox}, @{const_name PairBox}] orelse
  10.608 +  let val (x as (s, T)) = (s, unbox_type T) in
  10.609 +    Refute.is_IDT_constructor thy x orelse is_record_constr x
  10.610 +    orelse (is_abs_fun thy x andalso is_pure_typedef thy (range_type T))
  10.611 +    orelse s mem [@{const_name Zero_Rep}, @{const_name Suc_Rep}]
  10.612 +    orelse x = (@{const_name zero_nat_inst.zero_nat}, nat_T)
  10.613 +    orelse is_coconstr thy x
  10.614 +  end
  10.615 +fun is_constr thy (x as (_, T)) =
  10.616 +  is_constr_like thy x
  10.617 +  andalso not (is_basic_datatype (fst (dest_Type (body_type T))))
  10.618 +(* string -> bool *)
  10.619 +val is_sel = String.isPrefix discr_prefix orf String.isPrefix sel_prefix
  10.620 +val is_sel_like_and_no_discr =
  10.621 +  String.isPrefix sel_prefix
  10.622 +  orf (member (op =) [@{const_name fst}, @{const_name snd}])
  10.623 +
  10.624 +datatype boxability =
  10.625 +  InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2
  10.626 +
  10.627 +(* boxability -> boxability *)
  10.628 +fun in_fun_lhs_for InConstr = InSel
  10.629 +  | in_fun_lhs_for _ = InFunLHS
  10.630 +fun in_fun_rhs_for InConstr = InConstr
  10.631 +  | in_fun_rhs_for InSel = InSel
  10.632 +  | in_fun_rhs_for InFunRHS1 = InFunRHS2
  10.633 +  | in_fun_rhs_for _ = InFunRHS1
  10.634 +
  10.635 +(* extended_context -> boxability -> typ -> bool *)
  10.636 +fun is_boxing_worth_it (ext_ctxt : extended_context) boxy T =
  10.637 +  case T of
  10.638 +    Type ("fun", _) =>
  10.639 +    boxy mem [InPair, InFunLHS] andalso not (is_boolean_type (body_type T))
  10.640 +  | Type ("*", Ts) =>
  10.641 +    boxy mem [InPair, InFunRHS1, InFunRHS2]
  10.642 +    orelse (boxy mem [InExpr, InFunLHS]
  10.643 +            andalso exists (is_boxing_worth_it ext_ctxt InPair)
  10.644 +                           (map (box_type ext_ctxt InPair) Ts))
  10.645 +  | _ => false
  10.646 +(* extended_context -> boxability -> string * typ list -> string *)
  10.647 +and should_box_type (ext_ctxt as {thy, boxes, ...}) boxy (z as (s, Ts)) =
  10.648 +  case triple_lookup (type_match thy) boxes (Type z) of
  10.649 +    SOME (SOME box_me) => box_me
  10.650 +  | _ => is_boxing_worth_it ext_ctxt boxy (Type z)
  10.651 +(* extended_context -> boxability -> typ -> typ *)
  10.652 +and box_type ext_ctxt boxy T =
  10.653 +  case T of
  10.654 +    Type (z as ("fun", [T1, T2])) =>
  10.655 +    if not (boxy mem [InConstr, InSel])
  10.656 +       andalso should_box_type ext_ctxt boxy z then
  10.657 +      Type (@{type_name fun_box},
  10.658 +            [box_type ext_ctxt InFunLHS T1, box_type ext_ctxt InFunRHS1 T2])
  10.659 +    else
  10.660 +      box_type ext_ctxt (in_fun_lhs_for boxy) T1
  10.661 +      --> box_type ext_ctxt (in_fun_rhs_for boxy) T2
  10.662 +  | Type (z as ("*", Ts)) =>
  10.663 +    if should_box_type ext_ctxt boxy z then
  10.664 +      Type (@{type_name pair_box}, map (box_type ext_ctxt InSel) Ts)
  10.665 +    else
  10.666 +      Type ("*", map (box_type ext_ctxt
  10.667 +                               (if boxy mem [InConstr, InSel] then boxy
  10.668 +                                else InPair)) Ts)
  10.669 +  | _ => T
  10.670 +
  10.671 +(* styp -> styp *)
  10.672 +fun discr_for_constr (s, T) = (discr_prefix ^ s, body_type T --> bool_T)
  10.673 +
  10.674 +(* typ -> int *)
  10.675 +fun num_sels_for_constr_type T = length (maybe_curried_binder_types T)
  10.676 +(* string -> int -> string *)
  10.677 +fun nth_sel_name_for_constr_name s n =
  10.678 +  if s = @{const_name Pair} then
  10.679 +    if n = 0 then @{const_name fst} else @{const_name snd}
  10.680 +  else
  10.681 +    sel_prefix_for n ^ s
  10.682 +(* styp -> int -> styp *)
  10.683 +fun nth_sel_for_constr x ~1 = discr_for_constr x
  10.684 +  | nth_sel_for_constr (s, T) n =
  10.685 +    (nth_sel_name_for_constr_name s n,
  10.686 +     body_type T --> nth (maybe_curried_binder_types T) n)
  10.687 +(* extended_context -> styp -> int -> styp *)
  10.688 +fun boxed_nth_sel_for_constr ext_ctxt =
  10.689 +  apsnd (box_type ext_ctxt InSel) oo nth_sel_for_constr
  10.690 +
  10.691 +(* string -> int *)
  10.692 +fun sel_no_from_name s =
  10.693 +  if String.isPrefix discr_prefix s then
  10.694 +    ~1
  10.695 +  else if String.isPrefix sel_prefix s then
  10.696 +    s |> unprefix sel_prefix |> Int.fromString |> the
  10.697 +  else if s = @{const_name snd} then
  10.698 +    1
  10.699 +  else
  10.700 +    0
  10.701 +
  10.702 +(* typ list -> term -> int -> term *)
  10.703 +fun eta_expand _ t 0 = t
  10.704 +  | eta_expand Ts (Abs (s, T, t')) n =
  10.705 +    Abs (s, T, eta_expand (T :: Ts) t' (n - 1))
  10.706 +  | eta_expand Ts t n =
  10.707 +    fold_rev (curry3 Abs ("x\<^isub>\<eta>" ^ nat_subscript n))
  10.708 +             (List.take (binder_types (fastype_of1 (Ts, t)), n))
  10.709 +             (list_comb (incr_boundvars n t, map Bound (n - 1 downto 0)))
  10.710 +
  10.711 +(* term -> term *)
  10.712 +fun extensionalize t =
  10.713 +  case t of
  10.714 +    (t0 as @{const Trueprop}) $ t1 => t0 $ extensionalize t1
  10.715 +  | Const (@{const_name "op ="}, _) $ t1 $ Abs (s, T, t2) =>
  10.716 +    let val v = Var ((s, maxidx_of_term t + 1), T) in
  10.717 +      extensionalize (HOLogic.mk_eq (t1 $ v, subst_bound (v, t2)))
  10.718 +    end
  10.719 +  | _ => t
  10.720 +
  10.721 +(* typ -> term list -> term *)
  10.722 +fun distinctness_formula T =
  10.723 +  all_distinct_unordered_pairs_of
  10.724 +  #> map (fn (t1, t2) => @{const Not} $ (HOLogic.eq_const T $ t1 $ t2))
  10.725 +  #> List.foldr (s_conj o swap) @{const True}
  10.726 +
  10.727 +(* typ -> term *)
  10.728 +fun zero_const T = Const (@{const_name zero_nat_inst.zero_nat}, T)
  10.729 +fun suc_const T = Const (@{const_name Suc}, T --> T)
  10.730 +
  10.731 +(* theory -> typ -> styp list *)
  10.732 +fun datatype_constrs thy (T as Type (s, Ts)) =
  10.733 +    if is_datatype thy T then
  10.734 +      case Datatype.get_info thy s of
  10.735 +        SOME {index, descr, ...} =>
  10.736 +        let val (_, dtyps, constrs) = AList.lookup (op =) descr index |> the in
  10.737 +          map (fn (s', Us) =>
  10.738 +                  (s', map (Refute.typ_of_dtyp descr (dtyps ~~ Ts)) Us ---> T))
  10.739 +              constrs
  10.740 +         end
  10.741 +      | NONE =>
  10.742 +        case AList.lookup (op =) (#codatatypes (TheoryData.get thy)) s of
  10.743 +          SOME (_, xs' as (_ :: _)) =>
  10.744 +          map (apsnd (repair_constr_type thy T)) xs'
  10.745 +        | _ =>
  10.746 +          if is_record_type T then
  10.747 +            let
  10.748 +              val s' = unsuffix Record.ext_typeN s ^ Record.extN
  10.749 +              val T' = (Record.get_extT_fields thy T
  10.750 +                       |> apsnd single |> uncurry append |> map snd) ---> T
  10.751 +            in [(s', T')] end
  10.752 +          else case typedef_info thy s of
  10.753 +            SOME {abs_type, rep_type, Abs_name, ...} =>
  10.754 +            [(Abs_name, instantiate_type thy abs_type T rep_type --> T)]
  10.755 +          | NONE =>
  10.756 +            if T = @{typ ind} then
  10.757 +              [dest_Const @{const Zero_Rep}, dest_Const @{const Suc_Rep}]
  10.758 +            else
  10.759 +              []
  10.760 +    else
  10.761 +      []
  10.762 +  | datatype_constrs _ _ = []
  10.763 +(* extended_context -> typ -> styp list *)
  10.764 +fun boxed_datatype_constrs (ext_ctxt as {thy, ...}) =
  10.765 +  map (apsnd (box_type ext_ctxt InConstr)) o datatype_constrs thy
  10.766 +(* theory -> typ -> int *)
  10.767 +val num_datatype_constrs = length oo datatype_constrs
  10.768 +
  10.769 +(* string -> string *)
  10.770 +fun constr_name_for_sel_like @{const_name fst} = @{const_name Pair}
  10.771 +  | constr_name_for_sel_like @{const_name snd} = @{const_name Pair}
  10.772 +  | constr_name_for_sel_like s' = original_name s'
  10.773 +(* extended_context -> styp -> styp *)
  10.774 +fun boxed_constr_for_sel ext_ctxt (s', T') =
  10.775 +  let val s = constr_name_for_sel_like s' in
  10.776 +    AList.lookup (op =) (boxed_datatype_constrs ext_ctxt (domain_type T')) s
  10.777 +    |> the |> pair s
  10.778 +  end
  10.779 +(* theory -> styp -> term *)
  10.780 +fun discr_term_for_constr thy (x as (s, T)) =
  10.781 +  let val dataT = body_type T in
  10.782 +    if s = @{const_name Suc} then
  10.783 +      Abs (Name.uu, dataT,
  10.784 +           @{const Not} $ HOLogic.mk_eq (zero_const dataT, Bound 0))
  10.785 +    else if num_datatype_constrs thy dataT >= 2 then
  10.786 +      Const (discr_for_constr x)
  10.787 +    else
  10.788 +      Abs (Name.uu, dataT, @{const True})
  10.789 +  end
  10.790 +
  10.791 +(* theory -> styp -> term -> term *)
  10.792 +fun discriminate_value thy (x as (_, T)) t =
  10.793 +  case strip_comb t of
  10.794 +    (Const x', args) =>
  10.795 +    if x = x' then @{const True}
  10.796 +    else if is_constr_like thy x' then @{const False}
  10.797 +    else betapply (discr_term_for_constr thy x, t)
  10.798 +  | _ => betapply (discr_term_for_constr thy x, t)
  10.799 +
  10.800 +(* styp -> term -> term *)
  10.801 +fun nth_arg_sel_term_for_constr (x as (s, T)) n =
  10.802 +  let val (arg_Ts, dataT) = strip_type T in
  10.803 +    if dataT = nat_T then
  10.804 +      @{term "%n::nat. minus_nat_inst.minus_nat n one_nat_inst.one_nat"}
  10.805 +    else if is_pair_type dataT then
  10.806 +      Const (nth_sel_for_constr x n)
  10.807 +    else
  10.808 +      let
  10.809 +        (* int -> typ -> int * term *)
  10.810 +        fun aux m (Type ("*", [T1, T2])) =
  10.811 +            let
  10.812 +              val (m, t1) = aux m T1
  10.813 +              val (m, t2) = aux m T2
  10.814 +            in (m, HOLogic.mk_prod (t1, t2)) end
  10.815 +          | aux m T =
  10.816 +            (m + 1, Const (nth_sel_name_for_constr_name s m, dataT --> T)
  10.817 +                    $ Bound 0)
  10.818 +        val m = fold (Integer.add o num_factors_in_type)
  10.819 +                     (List.take (arg_Ts, n)) 0
  10.820 +      in Abs ("x", dataT, aux m (nth arg_Ts n) |> snd) end
  10.821 +  end
  10.822 +(* theory -> styp -> term -> int -> typ -> term *)
  10.823 +fun select_nth_constr_arg thy x t n res_T =
  10.824 +  case strip_comb t of
  10.825 +    (Const x', args) =>
  10.826 +    if x = x' then nth args n
  10.827 +    else if is_constr_like thy x' then Const (@{const_name unknown}, res_T)
  10.828 +    else betapply (nth_arg_sel_term_for_constr x n, t)
  10.829 +  | _ => betapply (nth_arg_sel_term_for_constr x n, t)
  10.830 +
  10.831 +(* theory -> styp -> term list -> term *)
  10.832 +fun construct_value _ x [] = Const x
  10.833 +  | construct_value thy (x as (s, _)) args =
  10.834 +    let val args = map Envir.eta_contract args in
  10.835 +      case hd args of
  10.836 +        Const (x' as (s', _)) $ t =>
  10.837 +        if is_sel_like_and_no_discr s' andalso constr_name_for_sel_like s' = s
  10.838 +           andalso forall (fn (n, t') =>
  10.839 +                              select_nth_constr_arg thy x t n dummyT = t')
  10.840 +                          (index_seq 0 (length args) ~~ args) then
  10.841 +          t
  10.842 +        else
  10.843 +          list_comb (Const x, args)
  10.844 +      | _ => list_comb (Const x, args)
  10.845 +    end
  10.846 +
  10.847 +(* theory -> typ -> term -> term *)
  10.848 +fun constr_expand thy T t =
  10.849 +  (case head_of t of
  10.850 +     Const x => if is_constr_like thy x then t else raise SAME ()
  10.851 +   | _ => raise SAME ())
  10.852 +  handle SAME () =>
  10.853 +         let
  10.854 +           val x' as (_, T') =
  10.855 +             if is_pair_type T then
  10.856 +               let val (T1, T2) = HOLogic.dest_prodT T in
  10.857 +                 (@{const_name Pair}, [T1, T2] ---> T)
  10.858 +               end
  10.859 +             else
  10.860 +               datatype_constrs thy T |> the_single
  10.861 +           val arg_Ts = binder_types T'
  10.862 +         in
  10.863 +           list_comb (Const x', map2 (select_nth_constr_arg thy x' t)
  10.864 +                                     (index_seq 0 (length arg_Ts)) arg_Ts)
  10.865 +         end
  10.866 +
  10.867 +(* (typ * int) list -> typ -> int *)
  10.868 +fun card_of_type asgns (Type ("fun", [T1, T2])) =
  10.869 +    reasonable_power (card_of_type asgns T2) (card_of_type asgns T1)
  10.870 +  | card_of_type asgns (Type ("*", [T1, T2])) =
  10.871 +    card_of_type asgns T1 * card_of_type asgns T2
  10.872 +  | card_of_type _ (Type (@{type_name itself}, _)) = 1
  10.873 +  | card_of_type _ @{typ prop} = 2
  10.874 +  | card_of_type _ @{typ bool} = 2
  10.875 +  | card_of_type _ @{typ unit} = 1
  10.876 +  | card_of_type asgns T =
  10.877 +    case AList.lookup (op =) asgns T of
  10.878 +      SOME k => k
  10.879 +    | NONE => if T = @{typ bisim_iterator} then 0
  10.880 +              else raise TYPE ("NitpickHOL.card_of_type", [T], [])
  10.881 +(* int -> (typ * int) list -> typ -> int *)
  10.882 +fun bounded_card_of_type max default_card asgns (Type ("fun", [T1, T2])) =
  10.883 +    let
  10.884 +      val k1 = bounded_card_of_type max default_card asgns T1
  10.885 +      val k2 = bounded_card_of_type max default_card asgns T2
  10.886 +    in
  10.887 +      if k1 = max orelse k2 = max then max
  10.888 +      else Int.min (max, reasonable_power k2 k1)
  10.889 +    end
  10.890 +  | bounded_card_of_type max default_card asgns (Type ("*", [T1, T2])) =
  10.891 +    let
  10.892 +      val k1 = bounded_card_of_type max default_card asgns T1
  10.893 +      val k2 = bounded_card_of_type max default_card asgns T2
  10.894 +    in if k1 = max orelse k2 = max then max else Int.min (max, k1 * k2) end
  10.895 +  | bounded_card_of_type max default_card asgns T =
  10.896 +    Int.min (max, if default_card = ~1 then
  10.897 +                    card_of_type asgns T
  10.898 +                  else
  10.899 +                    card_of_type asgns T
  10.900 +                    handle TYPE ("NitpickHOL.card_of_type", _, _) =>
  10.901 +                           default_card)
  10.902 +(* theory -> int -> (typ * int) list -> typ -> int *)
  10.903 +fun bounded_precise_card_of_type thy max default_card asgns T =
  10.904 +  let
  10.905 +    (* typ list -> typ -> int *)
  10.906 +    fun aux avoid T =
  10.907 +      (if T mem avoid then
  10.908 +         0
  10.909 +       else case T of
  10.910 +         Type ("fun", [T1, T2]) =>
  10.911 +         let
  10.912 +           val k1 = aux avoid T1
  10.913 +           val k2 = aux avoid T2
  10.914 +         in
  10.915 +           if k1 = 0 orelse k2 = 0 then 0
  10.916 +           else if k1 >= max orelse k2 >= max then max
  10.917 +           else Int.min (max, reasonable_power k2 k1)
  10.918 +         end
  10.919 +       | Type ("*", [T1, T2]) =>
  10.920 +         let
  10.921 +           val k1 = aux avoid T1
  10.922 +           val k2 = aux avoid T2
  10.923 +         in
  10.924 +           if k1 = 0 orelse k2 = 0 then 0
  10.925 +           else if k1 >= max orelse k2 >= max then max
  10.926 +           else Int.min (max, k1 * k2)
  10.927 +         end
  10.928 +       | Type (@{type_name itself}, _) => 1
  10.929 +       | @{typ prop} => 2
  10.930 +       | @{typ bool} => 2
  10.931 +       | @{typ unit} => 1
  10.932 +       | Type _ =>
  10.933 +         (case datatype_constrs thy T of
  10.934 +            [] => if is_integer_type T then 0 else raise SAME ()
  10.935 +          | constrs =>
  10.936 +            let
  10.937 +              val constr_cards =
  10.938 +                datatype_constrs thy T
  10.939 +                |> map (Integer.prod o map (aux (T :: avoid)) o binder_types
  10.940 +                        o snd)
  10.941 +            in
  10.942 +              if exists (equal 0) constr_cards then 0
  10.943 +              else Integer.sum constr_cards
  10.944 +            end)
  10.945 +       | _ => raise SAME ())
  10.946 +      handle SAME () => AList.lookup (op =) asgns T |> the_default default_card
  10.947 +  in Int.min (max, aux [] T) end
  10.948 +
  10.949 +(* theory -> typ -> bool *)
  10.950 +fun is_finite_type thy = not_equal 0 o bounded_precise_card_of_type thy 1 2 []
  10.951 +
  10.952 +(* term -> bool *)
  10.953 +fun is_ground_term (t1 $ t2) = is_ground_term t1 andalso is_ground_term t2
  10.954 +  | is_ground_term (Const _) = true
  10.955 +  | is_ground_term _ = false
  10.956 +
  10.957 +(* term -> word -> word *)
  10.958 +fun hashw_term (t1 $ t2) = Polyhash.hashw (hashw_term t1, hashw_term t2)
  10.959 +  | hashw_term (Const (s, _)) = Polyhash.hashw_string (s, 0w0)
  10.960 +  | hashw_term _ = 0w0
  10.961 +(* term -> int *)
  10.962 +val hash_term = Word.toInt o hashw_term
  10.963 +
  10.964 +(* term list -> (indexname * typ) list *)
  10.965 +fun special_bounds ts =
  10.966 +  fold Term.add_vars ts [] |> sort (TermOrd.fast_indexname_ord o pairself fst)
  10.967 +
  10.968 +(* indexname * typ -> term -> term *)
  10.969 +fun abs_var ((s, j), T) body = Abs (s, T, abstract_over (Var ((s, j), T), body))
  10.970 +
  10.971 +(* term -> bool *)
  10.972 +fun is_arity_type_axiom (Const (@{const_name HOL.type_class}, _)
  10.973 +                         $ Const (@{const_name TYPE}, _)) = true
  10.974 +  | is_arity_type_axiom _ = false
  10.975 +(* theory -> bool -> term -> bool *)
  10.976 +fun is_typedef_axiom thy only_boring (@{const "==>"} $ _ $ t2) =
  10.977 +    is_typedef_axiom thy only_boring t2
  10.978 +  | is_typedef_axiom thy only_boring
  10.979 +        (@{const Trueprop} $ (Const (@{const_name Typedef.type_definition}, _)
  10.980 +         $ Const (_, Type ("fun", [T as Type (s, _), _])) $ Const _ $ _)) =
  10.981 +    is_typedef thy s
  10.982 +    andalso not (only_boring andalso
  10.983 +                 (s mem [@{type_name unit}, @{type_name "*"}, @{type_name "+"}]
  10.984 +                  orelse is_frac_type thy T))
  10.985 +  | is_typedef_axiom _ _ _ = false
  10.986 +
  10.987 +(* Distinguishes between (1) constant definition axioms, (2) type arity and
  10.988 +   typedef axioms, and (3) other axioms, and returns the pair ((1), (3)).
  10.989 +   Typedef axioms are uninteresting to Nitpick, because it can retrieve them
  10.990 +   using "typedef_info". *)
  10.991 +(* theory -> (string * term) list -> string list -> term list * term list *)
  10.992 +fun partition_axioms_by_definitionality thy axioms def_names =
  10.993 +  let
  10.994 +    val axioms = sort (fast_string_ord o pairself fst) axioms
  10.995 +    val defs = OrdList.inter (fast_string_ord o apsnd fst) def_names axioms
  10.996 +    val nondefs =
  10.997 +      OrdList.subtract (fast_string_ord o apsnd fst) def_names axioms
  10.998 +      |> filter_out ((is_arity_type_axiom orf is_typedef_axiom thy true) o snd)
  10.999 +  in pairself (map snd) (defs, nondefs) end
 10.1000 +
 10.1001 +(* Ideally we would check against "Complex_Main", not "Quickcheck", but any
 10.1002 +   theory will do as long as it contains all the "axioms" and "axiomatization"
 10.1003 +   commands. *)
 10.1004 +(* theory -> bool *)
 10.1005 +fun is_built_in_theory thy = Theory.subthy (thy, @{theory Refute})
 10.1006 +
 10.1007 +(* term -> bool *)
 10.1008 +val is_plain_definition =
 10.1009 +  let
 10.1010 +    (* term -> bool *)
 10.1011 +    fun do_lhs t1 =
 10.1012 +      case strip_comb t1 of
 10.1013 +        (Const _, args) => forall is_Var args
 10.1014 +                           andalso not (has_duplicates (op =) args)
 10.1015 +      | _ => false
 10.1016 +    fun do_eq (Const (@{const_name "=="}, _) $ t1 $ _) = do_lhs t1
 10.1017 +      | do_eq (@{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t1 $ _)) =
 10.1018 +        do_lhs t1
 10.1019 +      | do_eq _ = false
 10.1020 +  in do_eq end
 10.1021 +
 10.1022 +(* This table is not pretty. A better approach would be to avoid expanding the
 10.1023 +   operators to their low-level definitions, but this would require dealing with
 10.1024 +   overloading. *)
 10.1025 +val built_in_built_in_defs =
 10.1026 +  [@{thm div_int_inst.div_int}, @{thm div_int_inst.mod_int},
 10.1027 +   @{thm div_nat_inst.div_nat}, @{thm div_nat_inst.mod_nat},
 10.1028 +   @{thm lower_semilattice_fun_inst.inf_fun}, @{thm minus_fun_inst.minus_fun},
 10.1029 +   @{thm minus_int_inst.minus_int}, @{thm minus_nat_inst.minus_nat},
 10.1030 +   @{thm one_int_inst.one_int}, @{thm one_nat_inst.one_nat},
 10.1031 +   @{thm ord_fun_inst.less_eq_fun}, @{thm ord_int_inst.less_eq_int},
 10.1032 +   @{thm ord_int_inst.less_int}, @{thm ord_nat_inst.less_eq_nat},
 10.1033 +   @{thm ord_nat_inst.less_nat}, @{thm plus_int_inst.plus_int},
 10.1034 +   @{thm plus_nat_inst.plus_nat}, @{thm times_int_inst.times_int},
 10.1035 +   @{thm times_nat_inst.times_nat}, @{thm uminus_int_inst.uminus_int},
 10.1036 +   @{thm upper_semilattice_fun_inst.sup_fun}, @{thm zero_int_inst.zero_int},
 10.1037 +   @{thm zero_nat_inst.zero_nat}]
 10.1038 +  |> map prop_of
 10.1039 +
 10.1040 +(* theory -> term list * term list * term list *)
 10.1041 +fun all_axioms_of thy =
 10.1042 +  let
 10.1043 +    (* theory list -> term list *)
 10.1044 +    val axioms_of_thys = maps Thm.axioms_of #> map (apsnd prop_of)
 10.1045 +    val specs = Defs.all_specifications_of (Theory.defs_of thy)
 10.1046 +    val def_names =
 10.1047 +      specs |> maps snd
 10.1048 +      |> filter #is_def |> map #name |> OrdList.make fast_string_ord
 10.1049 +    val thys = thy :: Theory.ancestors_of thy
 10.1050 +    val (built_in_thys, user_thys) = List.partition is_built_in_theory thys
 10.1051 +    val built_in_axioms = axioms_of_thys built_in_thys
 10.1052 +    val user_axioms = axioms_of_thys user_thys
 10.1053 +    val (built_in_defs, built_in_nondefs) =
 10.1054 +      partition_axioms_by_definitionality thy built_in_axioms def_names
 10.1055 +      |> apsnd (filter (is_typedef_axiom thy false))
 10.1056 +    val (user_defs, user_nondefs) =
 10.1057 +      partition_axioms_by_definitionality thy user_axioms def_names
 10.1058 +    val defs = built_in_built_in_defs @
 10.1059 +               (thy |> PureThy.all_thms_of
 10.1060 +                    |> filter (equal Thm.definitionK o Thm.get_kind o snd)
 10.1061 +                    |> map (prop_of o snd) |> filter is_plain_definition) @
 10.1062 +               user_defs @ built_in_defs
 10.1063 +  in (defs, built_in_nondefs, user_nondefs) end
 10.1064 +
 10.1065 +(* bool -> styp -> int option *)
 10.1066 +fun arity_of_built_in_const fast_descrs (s, T) =
 10.1067 +  if s = @{const_name If} then
 10.1068 +    if nth_range_type 3 T = @{typ bool} then NONE else SOME 3
 10.1069 +  else case AList.lookup (op =)
 10.1070 +                (built_in_consts
 10.1071 +                 |> fast_descrs ? append built_in_descr_consts) s of
 10.1072 +    SOME n => SOME n
 10.1073 +  | NONE =>
 10.1074 +    case AList.lookup (op =) built_in_typed_consts (s, T) of
 10.1075 +      SOME n => SOME n
 10.1076 +    | NONE =>
 10.1077 +      if is_fun_type T andalso is_set_type (domain_type T) then
 10.1078 +        AList.lookup (op =) built_in_set_consts s
 10.1079 +      else
 10.1080 +        NONE
 10.1081 +(* bool -> styp -> bool *)
 10.1082 +val is_built_in_const = is_some oo arity_of_built_in_const
 10.1083 +
 10.1084 +(* This function is designed to work for both real definition axioms and
 10.1085 +   simplification rules (equational specifications). *)
 10.1086 +(* term -> term *)
 10.1087 +fun term_under_def t =
 10.1088 +  case t of
 10.1089 +    @{const "==>"} $ _ $ t2 => term_under_def t2
 10.1090 +  | Const (@{const_name "=="}, _) $ t1 $ _ => term_under_def t1
 10.1091 +  | @{const Trueprop} $ t1 => term_under_def t1
 10.1092 +  | Const (@{const_name "op ="}, _) $ t1 $ _ => term_under_def t1
 10.1093 +  | Abs (_, _, t') => term_under_def t'
 10.1094 +  | t1 $ _ => term_under_def t1
 10.1095 +  | _ => t
 10.1096 +
 10.1097 +(* Here we crucially rely on "Refute.specialize_type" performing a preorder
 10.1098 +   traversal of the term, without which the wrong occurrence of a constant could
 10.1099 +   be matched in the face of overloading. *)
 10.1100 +(* theory -> bool -> const_table -> styp -> term list *)
 10.1101 +fun def_props_for_const thy fast_descrs table (x as (s, _)) =
 10.1102 +  if is_built_in_const fast_descrs x then
 10.1103 +    []
 10.1104 +  else
 10.1105 +    these (Symtab.lookup table s)
 10.1106 +    |> map_filter (try (Refute.specialize_type thy x))
 10.1107 +    |> filter (equal (Const x) o term_under_def)
 10.1108 +
 10.1109 +(* term -> term *)
 10.1110 +fun normalized_rhs_of thy t =
 10.1111 +  let
 10.1112 +    (* term -> term *)
 10.1113 +    fun aux (v as Var _) t = lambda v t
 10.1114 +      | aux (c as Const (@{const_name TYPE}, T)) t = lambda c t
 10.1115 +      | aux _ _ = raise TERM ("NitpickHOL.normalized_rhs_of", [t])
 10.1116 +    val (lhs, rhs) =
 10.1117 +      case t of
 10.1118 +        Const (@{const_name "=="}, _) $ t1 $ t2 => (t1, t2)
 10.1119 +      | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t1 $ t2) =>
 10.1120 +        (t1, t2)
 10.1121 +      | _ => raise TERM ("NitpickHOL.normalized_rhs_of", [t])
 10.1122 +    val args = strip_comb lhs |> snd
 10.1123 +  in fold_rev aux args rhs end
 10.1124 +
 10.1125 +(* theory -> const_table -> styp -> term option *)
 10.1126 +fun def_of_const thy table (x as (s, _)) =
 10.1127 +  if is_built_in_const false x orelse original_name s <> s then
 10.1128 +    NONE
 10.1129 +  else
 10.1130 +    x |> def_props_for_const thy false table |> List.last
 10.1131 +      |> normalized_rhs_of thy |> prefix_abs_vars s |> SOME
 10.1132 +    handle List.Empty => NONE
 10.1133 +
 10.1134 +datatype fixpoint_kind = Lfp | Gfp | NoFp
 10.1135 +
 10.1136 +(* term -> fixpoint_kind *)
 10.1137 +fun fixpoint_kind_of_rhs (Abs (_, _, t)) = fixpoint_kind_of_rhs t
 10.1138 +  | fixpoint_kind_of_rhs (Const (@{const_name lfp}, _) $ Abs _) = Lfp
 10.1139 +  | fixpoint_kind_of_rhs (Const (@{const_name gfp}, _) $ Abs _) = Gfp
 10.1140 +  | fixpoint_kind_of_rhs _ = NoFp
 10.1141 +
 10.1142 +(* theory -> const_table -> term -> bool *)
 10.1143 +fun is_mutually_inductive_pred_def thy table t =
 10.1144 +  let
 10.1145 +    (* term -> bool *)
 10.1146 +    fun is_good_arg (Bound _) = true
 10.1147 +      | is_good_arg (Const (s, _)) =
 10.1148 +        s mem [@{const_name True}, @{const_name False}, @{const_name undefined}]
 10.1149 +      | is_good_arg _ = false
 10.1150 +  in
 10.1151 +    case t |> strip_abs_body |> strip_comb of
 10.1152 +      (Const x, ts as (_ :: _)) =>
 10.1153 +      (case def_of_const thy table x of
 10.1154 +         SOME t' => fixpoint_kind_of_rhs t' <> NoFp andalso forall is_good_arg ts
 10.1155 +       | NONE => false)
 10.1156 +    | _ => false
 10.1157 +  end
 10.1158 +(* theory -> const_table -> term -> term *)
 10.1159 +fun unfold_mutually_inductive_preds thy table =
 10.1160 +  map_aterms (fn t as Const x =>
 10.1161 +                 (case def_of_const thy table x of
 10.1162 +                    SOME t' =>
 10.1163 +                    let val t' = Envir.eta_contract t' in
 10.1164 +                      if is_mutually_inductive_pred_def thy table t' then t'
 10.1165 +                      else t
 10.1166 +                    end
 10.1167 +                 | NONE => t)
 10.1168 +               | t => t)
 10.1169 +
 10.1170 +(* term -> string * term *)
 10.1171 +fun pair_for_prop t =
 10.1172 +  case term_under_def t of
 10.1173 +    Const (s, _) => (s, t)
 10.1174 +  | Free _ => raise NOT_SUPPORTED "local definitions"
 10.1175 +  | t' => raise TERM ("NitpickHOL.pair_for_prop", [t, t'])
 10.1176 +
 10.1177 +(* (Proof.context -> term list) -> Proof.context -> const_table *)
 10.1178 +fun table_for get ctxt =
 10.1179 +  get ctxt |> map pair_for_prop |> AList.group (op =) |> Symtab.make
 10.1180 +
 10.1181 +(* theory -> (string * int) list *)
 10.1182 +fun case_const_names thy =
 10.1183 +  Symtab.fold (fn (dtype_s, {index, descr, case_name, ...}) =>
 10.1184 +                  if is_basic_datatype dtype_s then
 10.1185 +                    I
 10.1186 +                  else
 10.1187 +                    cons (case_name, AList.lookup (op =) descr index
 10.1188 +                                     |> the |> #3 |> length))
 10.1189 +              (Datatype.get_all thy) [] @
 10.1190 +  map (apsnd length o snd) (#codatatypes (TheoryData.get thy))
 10.1191 +
 10.1192 +(* Proof.context -> term list -> const_table *)
 10.1193 +fun const_def_table ctxt ts =
 10.1194 +  table_for (map prop_of o Nitpick_Defs.get) ctxt
 10.1195 +  |> fold (fn (s, t) => Symtab.map_default (s, []) (cons t))
 10.1196 +          (map pair_for_prop ts)
 10.1197 +(* term list -> const_table *)
 10.1198 +fun const_nondef_table ts =
 10.1199 +  fold (fn t => append (map (fn s => (s, t)) (Term.add_const_names t []))) ts []
 10.1200 +  |> AList.group (op =) |> Symtab.make
 10.1201 +(* Proof.context -> const_table *)
 10.1202 +val const_simp_table = table_for (map prop_of o Nitpick_Simps.get)
 10.1203 +val const_psimp_table = table_for (map prop_of o Nitpick_Psimps.get)
 10.1204 +(* Proof.context -> const_table -> const_table *)
 10.1205 +fun inductive_intro_table ctxt def_table =
 10.1206 +  table_for (map (unfold_mutually_inductive_preds (ProofContext.theory_of ctxt)
 10.1207 +                                                  def_table o prop_of)
 10.1208 +             o Nitpick_Intros.get) ctxt
 10.1209 +(* theory -> term list Inttab.table *)
 10.1210 +fun ground_theorem_table thy =
 10.1211 +  fold ((fn @{const Trueprop} $ t1 =>
 10.1212 +            is_ground_term t1 ? Inttab.map_default (hash_term t1, []) (cons t1)
 10.1213 +          | _ => I) o prop_of o snd) (PureThy.all_thms_of thy) Inttab.empty
 10.1214 +
 10.1215 +val basic_ersatz_table =
 10.1216 +  [(@{const_name prod_case}, @{const_name split}),
 10.1217 +   (@{const_name card}, @{const_name card'}),
 10.1218 +   (@{const_name setsum}, @{const_name setsum'}),
 10.1219 +   (@{const_name fold_graph}, @{const_name fold_graph'}),
 10.1220 +   (@{const_name wf}, @{const_name wf'}),
 10.1221 +   (@{const_name wf_wfrec}, @{const_name wf_wfrec'}),
 10.1222 +   (@{const_name wfrec}, @{const_name wfrec'})]
 10.1223 +
 10.1224 +(* theory -> (string * string) list *)
 10.1225 +fun ersatz_table thy =
 10.1226 +  fold (append o snd) (#frac_types (TheoryData.get thy)) basic_ersatz_table
 10.1227 +
 10.1228 +(* const_table Unsynchronized.ref -> string -> term list -> unit *)
 10.1229 +fun add_simps simp_table s eqs =
 10.1230 +  Unsynchronized.change simp_table
 10.1231 +      (Symtab.update (s, eqs @ these (Symtab.lookup (!simp_table) s)))
 10.1232 +
 10.1233 +(* Similar to "Refute.specialize_type" but returns all matches rather than only
 10.1234 +   the first (preorder) match. *)
 10.1235 +(* theory -> styp -> term -> term list *)
 10.1236 +fun multi_specialize_type thy (x as (s, T)) t =
 10.1237 +  let
 10.1238 +    (* term -> (typ * term) list -> (typ * term) list *)
 10.1239 +    fun aux (Const (s', T')) ys =
 10.1240 +        if s = s' then
 10.1241 +          (if AList.defined (op =) ys T' then
 10.1242 +             I
 10.1243 +           else if T = T' then
 10.1244 +             cons (T, t)
 10.1245 +           else
 10.1246 +             cons (T', Refute.monomorphic_term
 10.1247 +                           (Sign.typ_match thy (T', T) Vartab.empty) t)
 10.1248 +             handle Type.TYPE_MATCH => I) ys
 10.1249 +        else
 10.1250 +          ys
 10.1251 +      | aux _ ys = ys
 10.1252 +  in map snd (fold_aterms aux t []) end
 10.1253 +
 10.1254 +(* theory -> const_table -> styp -> term list *)
 10.1255 +fun nondef_props_for_const thy table (x as (s, _)) =
 10.1256 +  these (Symtab.lookup table s) |> maps (multi_specialize_type thy x)
 10.1257 +  handle Refute.REFUTE _ =>
 10.1258 +         raise NOT_SUPPORTED ("too much polymorphism in axiom involving " ^
 10.1259 +                              quote s)
 10.1260 +
 10.1261 +(* theory -> styp list -> term list *)
 10.1262 +fun optimized_typedef_axioms thy (abs_s, abs_Ts) =
 10.1263 +  let val abs_T = Type (abs_s, abs_Ts) in
 10.1264 +    if is_univ_typedef thy abs_T then
 10.1265 +      []
 10.1266 +    else case typedef_info thy abs_s of
 10.1267 +      SOME {abs_type, rep_type, Abs_name, Rep_name, prop_of_Rep, set_name,
 10.1268 +            ...} =>
 10.1269 +      let
 10.1270 +        val rep_T = instantiate_type thy abs_type abs_T rep_type
 10.1271 +        val rep_t = Const (Rep_name, abs_T --> rep_T)
 10.1272 +        val set_t = Const (set_name, rep_T --> bool_T)
 10.1273 +        val set_t' =
 10.1274 +          prop_of_Rep |> HOLogic.dest_Trueprop
 10.1275 +                      |> Refute.specialize_type thy (dest_Const rep_t)
 10.1276 +                      |> HOLogic.dest_mem |> snd
 10.1277 +      in
 10.1278 +        [HOLogic.all_const abs_T
 10.1279 +         $ Abs (Name.uu, abs_T, set_t $ (rep_t $ Bound 0))]
 10.1280 +        |> set_t <> set_t' ? cons (HOLogic.mk_eq (set_t, set_t'))
 10.1281 +        |> map HOLogic.mk_Trueprop
 10.1282 +      end
 10.1283 +    | NONE => []
 10.1284 +  end
 10.1285 +(* theory -> styp -> term *)
 10.1286 +fun inverse_axiom_for_rep_fun thy (x as (_, T)) =
 10.1287 +  typedef_info thy (fst (dest_Type (domain_type T)))
 10.1288 +  |> the |> #Rep_inverse |> the |> prop_of |> Refute.specialize_type thy x
 10.1289 +
 10.1290 +(* theory -> int * styp -> term *)
 10.1291 +fun constr_case_body thy (j, (x as (_, T))) =
 10.1292 +  let val arg_Ts = binder_types T in
 10.1293 +    list_comb (Bound j, map2 (select_nth_constr_arg thy x (Bound 0))
 10.1294 +                             (index_seq 0 (length arg_Ts)) arg_Ts)
 10.1295 +  end
 10.1296 +(* theory -> typ -> int * styp -> term -> term *)
 10.1297 +fun add_constr_case thy res_T (j, x) res_t =
 10.1298 +  Const (@{const_name If}, [bool_T, res_T, res_T] ---> res_T)
 10.1299 +  $ discriminate_value thy x (Bound 0) $ constr_case_body thy (j, x) $ res_t
 10.1300 +(* theory -> typ -> typ -> term *)
 10.1301 +fun optimized_case_def thy dataT res_T =
 10.1302 +  let
 10.1303 +    val xs = datatype_constrs thy dataT
 10.1304 +    val func_Ts = map ((fn T => binder_types T ---> res_T) o snd) xs
 10.1305 +    val (xs', x) = split_last xs
 10.1306 +  in
 10.1307 +    constr_case_body thy (1, x)
 10.1308 +    |> fold_rev (add_constr_case thy res_T) (length xs downto 2 ~~ xs')
 10.1309 +    |> fold_rev (curry absdummy) (func_Ts @ [dataT])
 10.1310 +  end
 10.1311 +
 10.1312 +val redefined_in_NitpickDefs_thy =
 10.1313 +  [@{const_name option_case}, @{const_name nat_case}, @{const_name list_case},
 10.1314 +   @{const_name list_size}]
 10.1315 +
 10.1316 +(* theory -> string -> typ -> typ -> term -> term *)
 10.1317 +fun optimized_record_get thy s rec_T res_T t =
 10.1318 +  let val constr_x = the_single (datatype_constrs thy rec_T) in
 10.1319 +    case no_of_record_field thy s rec_T of
 10.1320 +      ~1 => (case rec_T of
 10.1321 +               Type (_, Ts as _ :: _) =>
 10.1322 +               let
 10.1323 +                 val rec_T' = List.last Ts
 10.1324 +                 val j = num_record_fields thy rec_T - 1
 10.1325 +               in
 10.1326 +                 select_nth_constr_arg thy constr_x t j res_T
 10.1327 +                 |> optimized_record_get thy s rec_T' res_T
 10.1328 +               end
 10.1329 +             | _ => raise TYPE ("NitpickHOL.optimized_record_get", [rec_T], []))
 10.1330 +    | j => select_nth_constr_arg thy constr_x t j res_T
 10.1331 +  end
 10.1332 +(* theory -> string -> typ -> term -> term -> term *)
 10.1333 +fun optimized_record_update thy s rec_T fun_t rec_t =
 10.1334 +  let
 10.1335 +    val constr_x as (_, constr_T) = the_single (datatype_constrs thy rec_T)
 10.1336 +    val Ts = binder_types constr_T
 10.1337 +    val n = length Ts
 10.1338 +    val special_j = no_of_record_field thy s rec_T
 10.1339 +    val ts = map2 (fn j => fn T =>
 10.1340 +                      let
 10.1341 +                        val t = select_nth_constr_arg thy constr_x rec_t j T
 10.1342 +                      in
 10.1343 +                        if j = special_j then
 10.1344 +                          betapply (fun_t, t)
 10.1345 +                        else if j = n - 1 andalso special_j = ~1 then
 10.1346 +                          optimized_record_update thy s
 10.1347 +                              (rec_T |> dest_Type |> snd |> List.last) fun_t t
 10.1348 +                        else
 10.1349 +                          t
 10.1350 +                      end) (index_seq 0 n) Ts
 10.1351 +  in list_comb (Const constr_x, ts) end
 10.1352 +
 10.1353 +(* Constants "c" whose definition is of the form "c == c'", where "c'" is also a
 10.1354 +   constant, are said to be trivial. For those, we ignore the simplification
 10.1355 +   rules and use the definition instead, to ensure that built-in symbols like
 10.1356 +   "ord_nat_inst.less_eq_nat" are picked up correctly. *)
 10.1357 +(* theory -> const_table -> styp -> bool *)
 10.1358 +fun has_trivial_definition thy table x =
 10.1359 +  case def_of_const thy table x of SOME (Const _) => true | _ => false
 10.1360 +
 10.1361 +(* theory -> const_table -> string * typ -> fixpoint_kind *)
 10.1362 +fun fixpoint_kind_of_const thy table x =
 10.1363 +  if is_built_in_const false x then
 10.1364 +    NoFp
 10.1365 +  else
 10.1366 +    fixpoint_kind_of_rhs (the (def_of_const thy table x))
 10.1367 +    handle Option.Option => NoFp
 10.1368 +
 10.1369 +(* extended_context -> styp -> bool *)
 10.1370 +fun is_real_inductive_pred ({thy, fast_descrs, def_table, intro_table, ...}
 10.1371 +                            : extended_context) x =
 10.1372 +  not (null (def_props_for_const thy fast_descrs intro_table x))
 10.1373 +  andalso fixpoint_kind_of_const thy def_table x <> NoFp
 10.1374 +fun is_real_equational_fun ({thy, fast_descrs, simp_table, psimp_table, ...}
 10.1375 +                            : extended_context) x =
 10.1376 +  exists (fn table => not (null (def_props_for_const thy fast_descrs table x)))
 10.1377 +         [!simp_table, psimp_table]
 10.1378 +fun is_inductive_pred ext_ctxt =
 10.1379 +  is_real_inductive_pred ext_ctxt andf (not o is_real_equational_fun ext_ctxt)
 10.1380 +fun is_equational_fun (ext_ctxt as {thy, def_table, ...}) =
 10.1381 +  (is_real_equational_fun ext_ctxt orf is_real_inductive_pred ext_ctxt
 10.1382 +   orf (String.isPrefix ubfp_prefix orf String.isPrefix lbfp_prefix) o fst)
 10.1383 +  andf (not o has_trivial_definition thy def_table)
 10.1384 +  andf (not o member (op =) redefined_in_NitpickDefs_thy o fst)
 10.1385 +
 10.1386 +(* term * term -> term *)
 10.1387 +fun s_betapply (Const (@{const_name If}, _) $ @{const True} $ t, _) = t
 10.1388 +  | s_betapply (Const (@{const_name If}, _) $ @{const False} $ _, t) = t
 10.1389 +  | s_betapply p = betapply p
 10.1390 +(* term * term list -> term *)
 10.1391 +val s_betapplys = Library.foldl s_betapply
 10.1392 +
 10.1393 +(* term -> term *)
 10.1394 +fun lhs_of_equation t =
 10.1395 +  case t of
 10.1396 +    Const (@{const_name all}, _) $ Abs (_, _, t1) => lhs_of_equation t1
 10.1397 +  | Const (@{const_name "=="}, _) $ t1 $ _ => SOME t1
 10.1398 +  | @{const "==>"} $ _ $ t2 => lhs_of_equation t2
 10.1399 +  | @{const Trueprop} $ t1 => lhs_of_equation t1
 10.1400 +  | Const (@{const_name All}, _) $ Abs (_, _, t1) => lhs_of_equation t1
 10.1401 +  | Const (@{const_name "op ="}, _) $ t1 $ _ => SOME t1
 10.1402 +  | @{const "op -->"} $ _ $ t2 => lhs_of_equation t2
 10.1403 +  | _ => NONE
 10.1404 +(* theory -> term -> bool *)
 10.1405 +fun is_constr_pattern _ (Bound _) = true
 10.1406 +  | is_constr_pattern thy t =
 10.1407 +    case strip_comb t of
 10.1408 +      (Const (x as (s, _)), args) =>
 10.1409 +      is_constr_like thy x andalso forall (is_constr_pattern thy) args
 10.1410 +    | _ => false
 10.1411 +fun is_constr_pattern_lhs thy t =
 10.1412 +  forall (is_constr_pattern thy) (snd (strip_comb t))
 10.1413 +fun is_constr_pattern_formula thy t =
 10.1414 +  case lhs_of_equation t of
 10.1415 +    SOME t' => is_constr_pattern_lhs thy t'
 10.1416 +  | NONE => false
 10.1417 +
 10.1418 +val unfold_max_depth = 63
 10.1419 +val axioms_max_depth = 63
 10.1420 +
 10.1421 +(* extended_context -> term -> term *)
 10.1422 +fun unfold_defs_in_term (ext_ctxt as {thy, destroy_constrs, fast_descrs,
 10.1423 +                                      case_names, def_table, ground_thm_table,
 10.1424 +                                      ersatz_table, ...}) =
 10.1425 +  let
 10.1426 +    (* int -> typ list -> term -> term *)
 10.1427 +    fun do_term depth Ts t =
 10.1428 +      case t of
 10.1429 +        (t0 as Const (@{const_name Int.number_class.number_of},
 10.1430 +                      Type ("fun", [_, ran_T]))) $ t1 =>
 10.1431 +        ((if is_number_type thy ran_T then
 10.1432 +            let
 10.1433 +              val j = t1 |> HOLogic.dest_numeral
 10.1434 +                         |> ran_T <> int_T ? curry Int.max 0
 10.1435 +              val s = numeral_prefix ^ signed_string_of_int j
 10.1436 +            in
 10.1437 +              if is_integer_type ran_T then
 10.1438 +                Const (s, ran_T)
 10.1439 +              else
 10.1440 +                do_term depth Ts (Const (@{const_name of_int}, int_T --> ran_T)
 10.1441 +                                  $ Const (s, int_T))
 10.1442 +            end
 10.1443 +            handle TERM _ => raise SAME ()
 10.1444 +          else
 10.1445 +            raise SAME ())
 10.1446 +         handle SAME () => betapply (do_term depth Ts t0, do_term depth Ts t1))
 10.1447 +      | Const (@{const_name refl_on}, T) $ Const (@{const_name UNIV}, _) $ t2 =>
 10.1448 +        do_const depth Ts t (@{const_name refl'}, range_type T) [t2]
 10.1449 +      | (t0 as Const (x as (@{const_name Sigma}, T))) $ t1
 10.1450 +        $ (t2 as Abs (_, _, t2')) =>
 10.1451 +        betapplys (t0 |> loose_bvar1 (t2', 0) ? do_term depth Ts,
 10.1452 +                   map (do_term depth Ts) [t1, t2])
 10.1453 +      | Const (x as (@{const_name distinct},
 10.1454 +               Type ("fun", [Type (@{type_name list}, [T']), _])))
 10.1455 +        $ (t1 as _ $ _) =>
 10.1456 +        (t1 |> HOLogic.dest_list |> distinctness_formula T'
 10.1457 +         handle TERM _ => do_const depth Ts t x [t1])
 10.1458 +      | (t0 as Const (x as (@{const_name If}, _))) $ t1 $ t2 $ t3 =>
 10.1459 +        if is_ground_term t1
 10.1460 +           andalso exists (Pattern.matches thy o rpair t1)
 10.1461 +                          (Inttab.lookup_list ground_thm_table
 10.1462 +                                              (hash_term t1)) then
 10.1463 +          do_term depth Ts t2
 10.1464 +        else
 10.1465 +          do_const depth Ts t x [t1, t2, t3]
 10.1466 +      | Const x $ t1 $ t2 $ t3 => do_const depth Ts t x [t1, t2, t3]
 10.1467 +      | Const x $ t1 $ t2 => do_const depth Ts t x [t1, t2]
 10.1468 +      | Const x $ t1 => do_const depth Ts t x [t1]
 10.1469 +      | Const x => do_const depth Ts t x []
 10.1470 +      | t1 $ t2 => betapply (do_term depth Ts t1, do_term depth Ts t2)
 10.1471 +      | Free _ => t
 10.1472 +      | Var _ => t
 10.1473 +      | Bound _ => t
 10.1474 +      | Abs (s, T, body) => Abs (s, T, do_term depth (T :: Ts) body)
 10.1475 +    (* int -> typ list -> styp -> term list -> int -> typ -> term * term list *)
 10.1476 +    and select_nth_constr_arg_with_args _ _ (x as (_, T)) [] n res_T =
 10.1477 +        (Abs (Name.uu, body_type T,
 10.1478 +              select_nth_constr_arg thy x (Bound 0) n res_T), [])
 10.1479 +      | select_nth_constr_arg_with_args depth Ts x (t :: ts) n res_T =
 10.1480 +        (select_nth_constr_arg thy x (do_term depth Ts t) n res_T, ts)
 10.1481 +    (* int -> typ list -> term -> styp -> term list -> term *)
 10.1482 +    and do_const depth Ts t (x as (s, T)) ts =
 10.1483 +      case AList.lookup (op =) ersatz_table s of
 10.1484 +        SOME s' =>
 10.1485 +        do_const (depth + 1) Ts (list_comb (Const (s', T), ts)) (s', T) ts
 10.1486 +      | NONE =>
 10.1487 +        let
 10.1488 +          val (const, ts) =
 10.1489 +            if is_built_in_const fast_descrs x then
 10.1490 +              if s = @{const_name finite} then
 10.1491 +                if is_finite_type thy (domain_type T) then
 10.1492 +                  (Abs ("A", domain_type T, @{const True}), ts)
 10.1493 +                else case ts of
 10.1494 +                  [Const (@{const_name UNIV}, _)] => (@{const False}, [])
 10.1495 +                | _ => (Const x, ts)
 10.1496 +              else
 10.1497 +                (Const x, ts)
 10.1498 +            else case AList.lookup (op =) case_names s of
 10.1499 +              SOME n =>
 10.1500 +              let
 10.1501 +                val (dataT, res_T) = nth_range_type n T
 10.1502 +                                     |> domain_type pairf range_type
 10.1503 +              in
 10.1504 +                (optimized_case_def thy dataT res_T
 10.1505 +                 |> do_term (depth + 1) Ts, ts)
 10.1506 +              end
 10.1507 +            | _ =>
 10.1508 +              if is_constr thy x then
 10.1509 +                (Const x, ts)
 10.1510 +              else if is_record_get thy x then
 10.1511 +                case length ts of
 10.1512 +                  0 => (do_term depth Ts (eta_expand Ts t 1), [])
 10.1513 +                | _ => (optimized_record_get thy s (domain_type T)
 10.1514 +                                             (range_type T) (hd ts), tl ts)
 10.1515 +              else if is_record_update thy x then
 10.1516 +                case length ts of
 10.1517 +                  2 => (optimized_record_update thy (unsuffix Record.updateN s)
 10.1518 +                                                (nth_range_type 2 T)
 10.1519 +                                                (do_term depth Ts (hd ts))
 10.1520 +                                                (do_term depth Ts (nth ts 1)),
 10.1521 +                        [])
 10.1522 +                | n => (do_term depth Ts (eta_expand Ts t (2 - n)), [])
 10.1523 +              else if is_rep_fun thy x then
 10.1524 +                let val x' = mate_of_rep_fun thy x in
 10.1525 +                  if is_constr thy x' then
 10.1526 +                    select_nth_constr_arg_with_args depth Ts x' ts 0
 10.1527 +                                                    (range_type T)
 10.1528 +                  else
 10.1529 +                    (Const x, ts)
 10.1530 +                end
 10.1531 +              else if is_equational_fun ext_ctxt x then
 10.1532 +                (Const x, ts)
 10.1533 +              else case def_of_const thy def_table x of
 10.1534 +                SOME def =>
 10.1535 +                if depth > unfold_max_depth then
 10.1536 +                  raise LIMIT ("NitpickHOL.unfold_defs_in_term",
 10.1537 +                               "too many nested definitions (" ^
 10.1538 +                               string_of_int depth ^ ") while expanding " ^
 10.1539 +                               quote s)
 10.1540 +                else if s = @{const_name wfrec'} then
 10.1541 +                  (do_term (depth + 1) Ts (betapplys (def, ts)), [])
 10.1542 +                else
 10.1543 +                  (do_term (depth + 1) Ts def, ts)
 10.1544 +              | NONE => (Const x, ts)
 10.1545 +        in s_betapplys (const, map (do_term depth Ts) ts) |> Envir.beta_norm end
 10.1546 +  in do_term 0 [] end
 10.1547 +
 10.1548 +(* theory -> typ -> term list *)
 10.1549 +fun codatatype_bisim_axioms thy T =
 10.1550 +  let
 10.1551 +    val xs = datatype_constrs thy T
 10.1552 +    val set_T = T --> bool_T
 10.1553 +    val iter_T = @{typ bisim_iterator}
 10.1554 +    val bisim_const = Const (@{const_name bisim}, [iter_T, T, T] ---> bool_T)
 10.1555 +    val bisim_max = @{const bisim_iterator_max}
 10.1556 +    val n_var = Var (("n", 0), iter_T)
 10.1557 +    val n_var_minus_1 =
 10.1558 +      Const (@{const_name Tha}, (iter_T --> bool_T) --> iter_T)
 10.1559 +      $ Abs ("m", iter_T, HOLogic.eq_const iter_T
 10.1560 +                          $ (suc_const iter_T $ Bound 0) $ n_var)
 10.1561 +    val x_var = Var (("x", 0), T)
 10.1562 +    val y_var = Var (("y", 0), T)
 10.1563 +    (* styp -> int -> typ -> term *)
 10.1564 +    fun nth_sub_bisim x n nth_T =
 10.1565 +      (if is_codatatype thy nth_T then bisim_const $ n_var_minus_1
 10.1566 +       else HOLogic.eq_const nth_T)
 10.1567 +      $ select_nth_constr_arg thy x x_var n nth_T
 10.1568 +      $ select_nth_constr_arg thy x y_var n nth_T
 10.1569 +    (* styp -> term *)
 10.1570 +    fun case_func (x as (_, T)) =
 10.1571 +      let
 10.1572 +        val arg_Ts = binder_types T
 10.1573 +        val core_t =
 10.1574 +          discriminate_value thy x y_var ::
 10.1575 +          map2 (nth_sub_bisim x) (index_seq 0 (length arg_Ts)) arg_Ts
 10.1576 +          |> foldr1 s_conj
 10.1577 +      in List.foldr absdummy core_t arg_Ts end
 10.1578 +  in
 10.1579 +    [HOLogic.eq_const bool_T $ (bisim_const $ n_var $ x_var $ y_var)
 10.1580 +     $ (@{term "op |"} $ (HOLogic.eq_const iter_T $ n_var $ zero_const iter_T)
 10.1581 +        $ (betapplys (optimized_case_def thy T bool_T,
 10.1582 +                      map case_func xs @ [x_var]))),
 10.1583 +     HOLogic.eq_const set_T $ (bisim_const $ bisim_max $ x_var)
 10.1584 +     $ (Const (@{const_name insert}, [T, set_T] ---> set_T)
 10.1585 +        $ x_var $ Const (@{const_name bot_fun_inst.bot_fun}, set_T))]
 10.1586 +    |> map HOLogic.mk_Trueprop
 10.1587 +  end
 10.1588 +
 10.1589 +exception NO_TRIPLE of unit
 10.1590 +
 10.1591 +(* theory -> styp -> term -> term list * term list * term *)
 10.1592 +fun triple_for_intro_rule thy x t =
 10.1593 +  let
 10.1594 +    val prems = Logic.strip_imp_prems t |> map (ObjectLogic.atomize_term thy)
 10.1595 +    val concl = Logic.strip_imp_concl t |> ObjectLogic.atomize_term thy
 10.1596 +    val (main, side) = List.partition (exists_Const (equal x)) prems
 10.1597 +    (* term -> bool *)
 10.1598 +     val is_good_head = equal (Const x) o head_of
 10.1599 +  in
 10.1600 +    if forall is_good_head main then (side, main, concl) else raise NO_TRIPLE ()
 10.1601 +  end
 10.1602 +
 10.1603 +(* term -> term *)
 10.1604 +val tuple_for_args = HOLogic.mk_tuple o snd o strip_comb
 10.1605 +
 10.1606 +(* indexname * typ -> term list -> term -> term -> term *)
 10.1607 +fun wf_constraint_for rel side concl main =
 10.1608 +  let
 10.1609 +    val core = HOLogic.mk_mem (HOLogic.mk_prod (tuple_for_args main,
 10.1610 +                                                tuple_for_args concl), Var rel)
 10.1611 +    val t = List.foldl HOLogic.mk_imp core side
 10.1612 +    val vars = filter (not_equal rel) (Term.add_vars t [])
 10.1613 +  in
 10.1614 +    Library.foldl (fn (t', ((x, j), T)) =>
 10.1615 +                      HOLogic.all_const T
 10.1616 +                      $ Abs (x, T, abstract_over (Var ((x, j), T), t')))
 10.1617 +                  (t, vars)
 10.1618 +  end
 10.1619 +
 10.1620 +(* indexname * typ -> term list * term list * term -> term *)
 10.1621 +fun wf_constraint_for_triple rel (side, main, concl) =
 10.1622 +  map (wf_constraint_for rel side concl) main |> foldr1 s_conj
 10.1623 +
 10.1624 +(* Proof.context -> Time.time option -> thm
 10.1625 +   -> (Proof.context -> tactic -> tactic) -> bool *)
 10.1626 +fun terminates_by ctxt timeout goal tac =
 10.1627 +  can (SINGLE (Classical.safe_tac (claset_of ctxt)) #> the
 10.1628 +       #> SINGLE (DETERM_TIMEOUT timeout
 10.1629 +                                 (tac ctxt (auto_tac (clasimpset_of ctxt))))
 10.1630 +       #> the #> Goal.finish ctxt) goal
 10.1631 +
 10.1632 +val cached_timeout = Unsynchronized.ref (SOME Time.zeroTime)
 10.1633 +val cached_wf_props : (term * bool) list Unsynchronized.ref =
 10.1634 +  Unsynchronized.ref []
 10.1635 +
 10.1636 +val termination_tacs = [LexicographicOrder.lex_order_tac,
 10.1637 +                        ScnpReconstruct.sizechange_tac]
 10.1638 +
 10.1639 +(* extended_context -> const_table -> styp -> bool *)
 10.1640 +fun is_is_well_founded_inductive_pred
 10.1641 +        ({thy, ctxt, debug, fast_descrs, tac_timeout, intro_table, ...}
 10.1642 +         : extended_context) (x as (_, T)) =
 10.1643 +  case def_props_for_const thy fast_descrs intro_table x of
 10.1644 +    [] => raise TERM ("NitpickHOL.is_is_well_founded_inductive_pred", [Const x])
 10.1645 +  | intro_ts =>
 10.1646 +    (case map (triple_for_intro_rule thy x) intro_ts
 10.1647 +          |> filter_out (null o #2) of
 10.1648 +       [] => true
 10.1649 +     | triples =>
 10.1650 +       let
 10.1651 +         val binders_T = HOLogic.mk_tupleT (binder_types T)
 10.1652 +         val rel_T = HOLogic.mk_prodT (binders_T, binders_T) --> bool_T
 10.1653 +         val j = List.foldl Int.max 0 (map maxidx_of_term intro_ts) + 1
 10.1654 +         val rel = (("R", j), rel_T)
 10.1655 +         val prop = Const (@{const_name wf}, rel_T --> bool_T) $ Var rel ::
 10.1656 +                    map (wf_constraint_for_triple rel) triples
 10.1657 +                    |> foldr1 s_conj |> HOLogic.mk_Trueprop
 10.1658 +         val _ = if debug then
 10.1659 +                   priority ("Wellfoundedness goal: " ^
 10.1660 +                             Syntax.string_of_term ctxt prop ^ ".")
 10.1661 +                 else
 10.1662 +                   ()
 10.1663 +       in
 10.1664 +         if tac_timeout = (!cached_timeout) then ()
 10.1665 +         else (cached_wf_props := []; cached_timeout := tac_timeout);
 10.1666 +         case AList.lookup (op =) (!cached_wf_props) prop of
 10.1667 +           SOME wf => wf
 10.1668 +         | NONE =>
 10.1669 +           let
 10.1670 +             val goal = prop |> cterm_of thy |> Goal.init
 10.1671 +             val wf = silence (exists (terminates_by ctxt tac_timeout goal))
 10.1672 +                              termination_tacs
 10.1673 +           in Unsynchronized.change cached_wf_props (cons (prop, wf)); wf end
 10.1674 +       end)
 10.1675 +    handle List.Empty => false
 10.1676 +         | NO_TRIPLE () => false
 10.1677 +
 10.1678 +(* The type constraint below is a workaround for a Poly/ML bug. *)
 10.1679 +
 10.1680 +(* extended_context -> styp -> bool *)
 10.1681 +fun is_well_founded_inductive_pred
 10.1682 +        (ext_ctxt as {thy, wfs, def_table, wf_cache, ...} : extended_context)
 10.1683 +        (x as (s, _)) =
 10.1684 +  case triple_lookup (const_match thy) wfs x of
 10.1685 +    SOME (SOME b) => b
 10.1686 +  | _ => s = @{const_name fold_graph'}
 10.1687 +         orelse case AList.lookup (op =) (!wf_cache) x of
 10.1688 +                  SOME (_, wf) => wf
 10.1689 +                | NONE =>
 10.1690 +                  let
 10.1691 +                    val gfp = (fixpoint_kind_of_const thy def_table x = Gfp)
 10.1692 +                    val wf = is_is_well_founded_inductive_pred ext_ctxt x
 10.1693 +                  in
 10.1694 +                    Unsynchronized.change wf_cache (cons (x, (gfp, wf))); wf
 10.1695 +                  end
 10.1696 +
 10.1697 +(* typ list -> typ -> typ -> term -> term *)
 10.1698 +fun ap_curry [_] _ _ t = t
 10.1699 +  | ap_curry arg_Ts tuple_T body_T t =
 10.1700 +    let val n = length arg_Ts in
 10.1701 +      list_abs (map (pair "c") arg_Ts,
 10.1702 +                incr_boundvars n t
 10.1703 +                $ mk_flat_tuple tuple_T (map Bound (n - 1 downto 0)))
 10.1704 +    end
 10.1705 +
 10.1706 +(* int -> term -> int *)
 10.1707 +fun num_occs_of_bound_in_term j (t1 $ t2) =
 10.1708 +    op + (pairself (num_occs_of_bound_in_term j) (t1, t2))
 10.1709 +  | num_occs_of_bound_in_term j (Abs (s, T, t')) =
 10.1710 +    num_occs_of_bound_in_term (j + 1) t'
 10.1711 +  | num_occs_of_bound_in_term j (Bound j') = if j' = j then 1 else 0
 10.1712 +  | num_occs_of_bound_in_term _ _ = 0
 10.1713 +
 10.1714 +(* term -> bool *)
 10.1715 +val is_linear_inductive_pred_def =
 10.1716 +  let
 10.1717 +    (* int -> term -> bool *)
 10.1718 +    fun do_disjunct j (Const (@{const_name Ex}, _) $ Abs (_, _, t2)) =
 10.1719 +        do_disjunct (j + 1) t2
 10.1720 +      | do_disjunct j t =
 10.1721 +        case num_occs_of_bound_in_term j t of
 10.1722 +          0 => true
 10.1723 +        | 1 => exists (equal (Bound j) o head_of) (conjuncts t)
 10.1724 +        | _ => false
 10.1725 +    (* term -> bool *)
 10.1726 +    fun do_lfp_def (Const (@{const_name lfp}, _) $ t2) =
 10.1727 +        let val (xs, body) = strip_abs t2 in
 10.1728 +          case length xs of
 10.1729 +            1 => false
 10.1730 +          | n => forall (do_disjunct (n - 1)) (disjuncts body)
 10.1731 +        end
 10.1732 +      | do_lfp_def _ = false
 10.1733 +  in do_lfp_def o strip_abs_body end
 10.1734 +
 10.1735 +(* typ -> typ -> term -> term *)
 10.1736 +fun ap_split tuple_T =
 10.1737 +  HOLogic.mk_psplits (HOLogic.flat_tupleT_paths tuple_T) tuple_T
 10.1738 +
 10.1739 +(* term -> term * term *)
 10.1740 +val linear_pred_base_and_step_rhss =
 10.1741 +  let
 10.1742 +    (* term -> term *)
 10.1743 +    fun aux (Const (@{const_name lfp}, _) $ t2) =
 10.1744 +        let
 10.1745 +          val (xs, body) = strip_abs t2
 10.1746 +          val arg_Ts = map snd (tl xs)
 10.1747 +          val tuple_T = HOLogic.mk_tupleT arg_Ts
 10.1748 +          val j = length arg_Ts
 10.1749 +          (* int -> term -> term *)
 10.1750 +          fun repair_rec j (Const (@{const_name Ex}, T1) $ Abs (s2, T2, t2')) =
 10.1751 +              Const (@{const_name Ex}, T1)
 10.1752 +              $ Abs (s2, T2, repair_rec (j + 1) t2')
 10.1753 +            | repair_rec j (@{const "op &"} $ t1 $ t2) =
 10.1754 +              @{const "op &"} $ repair_rec j t1 $ repair_rec j t2
 10.1755 +            | repair_rec j t =
 10.1756 +              let val (head, args) = strip_comb t in
 10.1757 +                if head = Bound j then
 10.1758 +                  HOLogic.eq_const tuple_T $ Bound j
 10.1759 +                  $ mk_flat_tuple tuple_T args
 10.1760 +                else
 10.1761 +                  t
 10.1762 +              end
 10.1763 +          val (nonrecs, recs) =
 10.1764 +            List.partition (equal 0 o num_occs_of_bound_in_term j)
 10.1765 +                           (disjuncts body)
 10.1766 +          val base_body = nonrecs |> List.foldl s_disj @{const False}
 10.1767 +          val step_body = recs |> map (repair_rec j)
 10.1768 +                               |> List.foldl s_disj @{const False} 
 10.1769 +        in
 10.1770 +          (list_abs (tl xs, incr_bv (~1, j, base_body))
 10.1771 +           |> ap_split tuple_T bool_T,
 10.1772 +           Abs ("y", tuple_T, list_abs (tl xs, step_body)
 10.1773 +                              |> ap_split tuple_T bool_T))
 10.1774 +        end
 10.1775 +      | aux t =
 10.1776 +        raise TERM ("NitpickHOL.linear_pred_base_and_step_rhss.aux", [t])
 10.1777 +  in aux end
 10.1778 +
 10.1779 +(* extended_context -> styp -> term -> term *)
 10.1780 +fun closed_linear_pred_const (ext_ctxt as {simp_table, ...}) (x as (s, T)) def =
 10.1781 +  let
 10.1782 +    val j = maxidx_of_term def + 1
 10.1783 +    val (outer, fp_app) = strip_abs def
 10.1784 +    val outer_bounds = map Bound (length outer - 1 downto 0)
 10.1785 +    val outer_vars = map (fn (s, T) => Var ((s, j), T)) outer
 10.1786 +    val fp_app = subst_bounds (rev outer_vars, fp_app)
 10.1787 +    val (outer_Ts, rest_T) = strip_n_binders (length outer) T
 10.1788 +    val tuple_arg_Ts = strip_type rest_T |> fst
 10.1789 +    val tuple_T = HOLogic.mk_tupleT tuple_arg_Ts
 10.1790 +    val set_T = tuple_T --> bool_T
 10.1791 +    val curried_T = tuple_T --> set_T
 10.1792 +    val uncurried_T = Type ("*", [tuple_T, tuple_T]) --> bool_T
 10.1793 +    val (base_rhs, step_rhs) = linear_pred_base_and_step_rhss fp_app
 10.1794 +    val base_x as (base_s, _) = (base_prefix ^ s, outer_Ts ---> set_T)
 10.1795 +    val base_eq = HOLogic.mk_eq (list_comb (Const base_x, outer_vars), base_rhs)
 10.1796 +                  |> HOLogic.mk_Trueprop
 10.1797 +    val _ = add_simps simp_table base_s [base_eq]
 10.1798 +    val step_x as (step_s, _) = (step_prefix ^ s, outer_Ts ---> curried_T)
 10.1799 +    val step_eq = HOLogic.mk_eq (list_comb (Const step_x, outer_vars), step_rhs)
 10.1800 +                  |> HOLogic.mk_Trueprop
 10.1801 +    val _ = add_simps simp_table step_s [step_eq]
 10.1802 +  in
 10.1803 +    list_abs (outer,
 10.1804 +              Const (@{const_name Image}, uncurried_T --> set_T --> set_T)
 10.1805 +              $ (Const (@{const_name rtrancl}, uncurried_T --> uncurried_T)
 10.1806 +                 $ (Const (@{const_name split}, curried_T --> uncurried_T)
 10.1807 +                    $ list_comb (Const step_x, outer_bounds)))
 10.1808 +              $ list_comb (Const base_x, outer_bounds)
 10.1809 +              |> ap_curry tuple_arg_Ts tuple_T bool_T)
 10.1810 +    |> unfold_defs_in_term ext_ctxt
 10.1811 +  end
 10.1812 +
 10.1813 +(* extended_context -> bool -> styp -> term *)
 10.1814 +fun unrolled_inductive_pred_const (ext_ctxt as {thy, star_linear_preds,
 10.1815 +                                                def_table, simp_table, ...})
 10.1816 +                                  gfp (x as (s, T)) =
 10.1817 +  let
 10.1818 +    val iter_T = iterator_type_for_const gfp x
 10.1819 +    val x' as (s', _) = (unrolled_prefix ^ s, iter_T --> T)
 10.1820 +    val unrolled_const = Const x' $ zero_const iter_T
 10.1821 +    val def = the (def_of_const thy def_table x)
 10.1822 +  in
 10.1823 +    if is_equational_fun ext_ctxt x' then
 10.1824 +      unrolled_const (* already done *)
 10.1825 +    else if not gfp andalso is_linear_inductive_pred_def def
 10.1826 +         andalso star_linear_preds then
 10.1827 +      closed_linear_pred_const ext_ctxt x def
 10.1828 +    else
 10.1829 +      let
 10.1830 +        val j = maxidx_of_term def + 1
 10.1831 +        val (outer, fp_app) = strip_abs def
 10.1832 +        val outer_bounds = map Bound (length outer - 1 downto 0)
 10.1833 +        val cur = Var ((iter_var_prefix, j + 1), iter_T)
 10.1834 +        val next = suc_const iter_T $ cur
 10.1835 +        val rhs = case fp_app of
 10.1836 +                    Const _ $ t =>
 10.1837 +                    betapply (t, list_comb (Const x', next :: outer_bounds))
 10.1838 +                  | _ => raise TERM ("NitpickHOL.unrolled_inductive_pred_const",
 10.1839 +                                     [fp_app])
 10.1840 +        val (inner, naked_rhs) = strip_abs rhs
 10.1841 +        val all = outer @ inner
 10.1842 +        val bounds = map Bound (length all - 1 downto 0)
 10.1843 +        val vars = map (fn (s, T) => Var ((s, j), T)) all
 10.1844 +        val eq = HOLogic.mk_eq (list_comb (Const x', cur :: bounds), naked_rhs)
 10.1845 +                 |> HOLogic.mk_Trueprop |> curry subst_bounds (rev vars)
 10.1846 +        val _ = add_simps simp_table s' [eq]
 10.1847 +      in unrolled_const end
 10.1848 +  end
 10.1849 +
 10.1850 +(* extended_context -> styp -> term *)
 10.1851 +fun raw_inductive_pred_axiom ({thy, def_table, ...} : extended_context) x =
 10.1852 +  let
 10.1853 +    val def = the (def_of_const thy def_table x)
 10.1854 +    val (outer, fp_app) = strip_abs def
 10.1855 +    val outer_bounds = map Bound (length outer - 1 downto 0)
 10.1856 +    val rhs = case fp_app of
 10.1857 +                Const _ $ t => betapply (t, list_comb (Const x, outer_bounds))
 10.1858 +              | _ => raise TERM ("NitpickHOL.raw_inductive_pred_axiom",
 10.1859 +                                 [fp_app])
 10.1860 +    val (inner, naked_rhs) = strip_abs rhs
 10.1861 +    val all = outer @ inner
 10.1862 +    val bounds = map Bound (length all - 1 downto 0)
 10.1863 +    val j = maxidx_of_term def + 1
 10.1864 +    val vars = map (fn (s, T) => Var ((s, j), T)) all
 10.1865 +  in
 10.1866 +    HOLogic.mk_eq (list_comb (Const x, bounds), naked_rhs)
 10.1867 +    |> HOLogic.mk_Trueprop |> curry subst_bounds (rev vars)
 10.1868 +  end
 10.1869 +fun inductive_pred_axiom ext_ctxt (x as (s, T)) =
 10.1870 +  if String.isPrefix ubfp_prefix s orelse String.isPrefix lbfp_prefix s then
 10.1871 +    let val x' = (after_name_sep s, T) in
 10.1872 +      raw_inductive_pred_axiom ext_ctxt x' |> subst_atomic [(Const x', Const x)]
 10.1873 +    end
 10.1874 +  else
 10.1875 +    raw_inductive_pred_axiom ext_ctxt x
 10.1876 +
 10.1877 +(* extended_context -> styp -> term list *)
 10.1878 +fun raw_equational_fun_axioms (ext_ctxt as {thy, fast_descrs, simp_table,
 10.1879 +                                            psimp_table, ...}) (x as (s, _)) =
 10.1880 +  if s mem redefined_in_NitpickDefs_thy then
 10.1881 +    []
 10.1882 +  else case def_props_for_const thy fast_descrs (!simp_table) x of
 10.1883 +    [] => (case def_props_for_const thy fast_descrs psimp_table x of
 10.1884 +             [] => [inductive_pred_axiom ext_ctxt x]
 10.1885 +           | psimps => psimps)
 10.1886 +  | simps => simps
 10.1887 +
 10.1888 +val equational_fun_axioms = map extensionalize oo raw_equational_fun_axioms
 10.1889 +
 10.1890 +(* term list -> term list *)
 10.1891 +fun coalesce_type_vars_in_terms ts =
 10.1892 +  let
 10.1893 +    (* typ -> (sort * string) list -> (sort * string) list *)
 10.1894 +    fun add_type (TFree (s, S)) table =
 10.1895 +        (case AList.lookup (op =) table S of
 10.1896 +           SOME s' =>
 10.1897 +           if string_ord (s', s) = LESS then AList.update (op =) (S, s') table
 10.1898 +           else table
 10.1899 +         | NONE => (S, s) :: table)
 10.1900 +      | add_type _ table = table
 10.1901 +    val table = fold (fold_types (fold_atyps add_type)) ts []
 10.1902 +    (* typ -> typ *)
 10.1903 +    fun coalesce (TFree (s, S)) = TFree (AList.lookup (op =) table S |> the, S)
 10.1904 +      | coalesce T = T
 10.1905 +  in map (map_types (map_atyps coalesce)) ts end
 10.1906 +
 10.1907 +(* extended_context -> typ -> typ list -> typ list *)
 10.1908 +fun add_ground_types ext_ctxt T accum =
 10.1909 +  case T of
 10.1910 +    Type ("fun", Ts) => fold (add_ground_types ext_ctxt) Ts accum
 10.1911 +  | Type ("*", Ts) => fold (add_ground_types ext_ctxt) Ts accum
 10.1912 +  | Type (@{type_name itself}, [T1]) => add_ground_types ext_ctxt T1 accum
 10.1913 +  | Type (_, Ts) =>
 10.1914 +    if T mem @{typ prop} :: @{typ bool} :: @{typ unit} :: accum then
 10.1915 +      accum
 10.1916 +    else
 10.1917 +      T :: accum
 10.1918 +      |> fold (add_ground_types ext_ctxt)
 10.1919 +              (case boxed_datatype_constrs ext_ctxt T of
 10.1920 +                 [] => Ts
 10.1921 +               | xs => map snd xs)
 10.1922 +  | _ => insert (op =) T accum
 10.1923 +(* extended_context -> typ -> typ list *)
 10.1924 +fun ground_types_in_type ext_ctxt T = add_ground_types ext_ctxt T []
 10.1925 +(* extended_context -> term list -> typ list *)
 10.1926 +fun ground_types_in_terms ext_ctxt ts =
 10.1927 +  fold (fold_types (add_ground_types ext_ctxt)) ts []
 10.1928 +
 10.1929 +(* typ list -> int -> term -> bool *)
 10.1930 +fun has_heavy_bounds_or_vars Ts level t =
 10.1931 +  let
 10.1932 +    (* typ list -> bool *)
 10.1933 +    fun aux [] = false
 10.1934 +      | aux [T] = is_fun_type T orelse is_pair_type T
 10.1935 +      | aux _ = true
 10.1936 +  in aux (map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t)) end
 10.1937 +
 10.1938 +(* typ list -> int -> int -> int -> term -> term *)
 10.1939 +fun fresh_value_var Ts k n j t =
 10.1940 +  Var ((val_var_prefix ^ nat_subscript (n - j), k), fastype_of1 (Ts, t))
 10.1941 +
 10.1942 +(* theory -> typ list -> bool -> int -> int -> term -> term list -> term list
 10.1943 +   -> term * term list *)
 10.1944 +fun pull_out_constr_comb thy Ts relax k level t args seen =
 10.1945 +  let val t_comb = list_comb (t, args) in
 10.1946 +    case t of
 10.1947 +      Const x =>
 10.1948 +      if not relax andalso is_constr thy x
 10.1949 +         andalso not (is_fun_type (fastype_of1 (Ts, t_comb)))
 10.1950 +         andalso has_heavy_bounds_or_vars Ts level t_comb
 10.1951 +         andalso not (loose_bvar (t_comb, level)) then
 10.1952 +        let
 10.1953 +          val (j, seen) = case find_index (equal t_comb) seen of
 10.1954 +                            ~1 => (0, t_comb :: seen)
 10.1955 +                          | j => (j, seen)
 10.1956 +        in (fresh_value_var Ts k (length seen) j t_comb, seen) end
 10.1957 +      else
 10.1958 +        (t_comb, seen)
 10.1959 +    | _ => (t_comb, seen)
 10.1960 +  end
 10.1961 +
 10.1962 +(* (term -> term) -> typ list -> int -> term list -> term list *)
 10.1963 +fun equations_for_pulled_out_constrs mk_eq Ts k seen =
 10.1964 +  let val n = length seen in
 10.1965 +    map2 (fn j => fn t => mk_eq (fresh_value_var Ts k n j t, t))
 10.1966 +         (index_seq 0 n) seen
 10.1967 +  end
 10.1968 +
 10.1969 +(* theory -> bool -> term -> term *)
 10.1970 +fun pull_out_universal_constrs thy def t =
 10.1971 +  let
 10.1972 +    val k = maxidx_of_term t + 1
 10.1973 +    (* typ list -> bool -> term -> term list -> term list -> term * term list *)
 10.1974 +    fun do_term Ts def t args seen =
 10.1975 +      case t of
 10.1976 +        (t0 as Const (@{const_name "=="}, _)) $ t1 $ t2 =>
 10.1977 +        do_eq_or_imp Ts def t0 t1 t2 seen
 10.1978 +      | (t0 as @{const "==>"}) $ t1 $ t2 => do_eq_or_imp Ts def t0 t1 t2 seen
 10.1979 +      | (t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2 =>
 10.1980 +        do_eq_or_imp Ts def t0 t1 t2 seen
 10.1981 +      | (t0 as @{const "op -->"}) $ t1 $ t2 => do_eq_or_imp Ts def t0 t1 t2 seen
 10.1982 +      | Abs (s, T, t') =>
 10.1983 +        let val (t', seen) = do_term (T :: Ts) def t' [] seen in
 10.1984 +          (list_comb (Abs (s, T, t'), args), seen)
 10.1985 +        end
 10.1986 +      | t1 $ t2 =>
 10.1987 +        let val (t2, seen) = do_term Ts def t2 [] seen in
 10.1988 +          do_term Ts def t1 (t2 :: args) seen
 10.1989 +        end
 10.1990 +      | _ => pull_out_constr_comb thy Ts def k 0 t args seen
 10.1991 +    (* typ list -> bool -> term -> term -> term -> term list
 10.1992 +       -> term * term list *)
 10.1993 +    and do_eq_or_imp Ts def t0 t1 t2 seen =
 10.1994 +      let
 10.1995 +        val (t2, seen) = do_term Ts def t2 [] seen
 10.1996 +        val (t1, seen) = do_term Ts false t1 [] seen
 10.1997 +      in (t0 $ t1 $ t2, seen) end
 10.1998 +    val (concl, seen) = do_term [] def t [] []
 10.1999 +  in
 10.2000 +    Logic.list_implies (equations_for_pulled_out_constrs Logic.mk_equals [] k
 10.2001 +                                                         seen, concl)
 10.2002 +  end
 10.2003 +
 10.2004 +(* theory -> bool -> term -> term *)
 10.2005 +fun destroy_pulled_out_constrs thy axiom t =
 10.2006 +  let
 10.2007 +    (* styp -> int *)
 10.2008 +    val num_occs_of_var =
 10.2009 +      fold_aterms (fn Var z => (fn f => fn z' => f z' |> z = z' ? Integer.add 1)
 10.2010 +                    | _ => I) t (K 0)
 10.2011 +    (* bool -> term -> term *)
 10.2012 +    fun aux careful ((t0 as Const (@{const_name "=="}, _)) $ t1 $ t2) =
 10.2013 +        aux_eq careful true t0 t1 t2
 10.2014 +      | aux careful ((t0 as @{const "==>"}) $ t1 $ t2) =
 10.2015 +        t0 $ aux false t1 $ aux careful t2
 10.2016 +      | aux careful ((t0 as Const (@{const_name "op ="}, _)) $ t1 $ t2) =
 10.2017 +        aux_eq careful true t0 t1 t2
 10.2018 +      | aux careful ((t0 as @{const "op -->"}) $ t1 $ t2) =
 10.2019 +        t0 $ aux false t1 $ aux careful t2
 10.2020 +      | aux careful (Abs (s, T, t')) = Abs (s, T, aux careful t')
 10.2021 +      | aux careful (t1 $ t2) = aux careful t1 $ aux careful t2
 10.2022 +      | aux _ t = t
 10.2023 +    (* bool -> bool -> term -> term -> term -> term *)
 10.2024 +    and aux_eq careful pass1 t0 t1 t2 =
 10.2025 +      (if careful then
 10.2026 +         raise SAME ()
 10.2027 +       else if axiom andalso is_Var t2
 10.2028 +               andalso num_occs_of_var (dest_Var t2) = 1 then
 10.2029 +         @{const True}
 10.2030 +       else case strip_comb t2 of
 10.2031 +         (Const (x as (s, T)), args) =>
 10.2032 +         let val arg_Ts = binder_types T in
 10.2033 +           if length arg_Ts = length args
 10.2034 +              andalso (is_constr thy x orelse s mem [@{const_name Pair}]
 10.2035 +                       orelse x = dest_Const @{const Suc})
 10.2036 +              andalso (not careful orelse not (is_Var t1)
 10.2037 +                       orelse String.isPrefix val_var_prefix
 10.2038 +                                              (fst (fst (dest_Var t1)))) then
 10.2039 +             discriminate_value thy x t1 ::
 10.2040 +             map3 (sel_eq x t1) (index_seq 0 (length args)) arg_Ts args
 10.2041 +             |> foldr1 s_conj
 10.2042 +             |> body_type (type_of t0) = prop_T ? HOLogic.mk_Trueprop
 10.2043 +           else
 10.2044 +             raise SAME ()
 10.2045 +         end
 10.2046 +       | _ => raise SAME ())
 10.2047 +      handle SAME () => if pass1 then aux_eq careful false t0 t2 t1
 10.2048 +                        else t0 $ aux false t2 $ aux false t1
 10.2049 +    (* styp -> term -> int -> typ -> term -> term *)
 10.2050 +    and sel_eq x t n nth_T nth_t =
 10.2051 +      HOLogic.eq_const nth_T $ nth_t $ select_nth_constr_arg thy x t n nth_T
 10.2052 +      |> aux false
 10.2053 +  in aux axiom t end
 10.2054 +
 10.2055 +(* theory -> term -> term *)
 10.2056 +fun simplify_constrs_and_sels thy t =
 10.2057 +  let
 10.2058 +    (* term -> int -> term *)
 10.2059 +    fun is_nth_sel_on t' n (Const (s, _) $ t) =
 10.2060 +        (t = t' andalso is_sel_like_and_no_discr s
 10.2061 +         andalso sel_no_from_name s = n)
 10.2062 +      | is_nth_sel_on _ _ _ = false
 10.2063 +    (* term -> term list -> term *)
 10.2064 +    fun do_term (Const (@{const_name Rep_Frac}, _)
 10.2065 +                 $ (Const (@{const_name Abs_Frac}, _) $ t1)) [] = do_term t1 []
 10.2066 +      | do_term (Const (@{const_name Abs_Frac}, _)
 10.2067 +                 $ (Const (@{const_name Rep_Frac}, _) $ t1)) [] = do_term t1 []
 10.2068 +      | do_term (t1 $ t2) args = do_term t1 (do_term t2 [] :: args)
 10.2069 +      | do_term (t as Const (x as (s, T))) (args as _ :: _) =
 10.2070 +        ((if is_constr_like thy x then
 10.2071 +            if length args = num_binder_types T then
 10.2072 +              case hd args of
 10.2073 +                Const (x' as (_, T')) $ t' =>
 10.2074 +                if domain_type T' = body_type T
 10.2075 +                   andalso forall (uncurry (is_nth_sel_on t'))
 10.2076 +                                  (index_seq 0 (length args) ~~ args) then
 10.2077 +                  t'
 10.2078 +                else
 10.2079 +                  raise SAME ()
 10.2080 +              | _ => raise SAME ()
 10.2081 +            else
 10.2082 +              raise SAME ()
 10.2083 +          else if is_sel_like_and_no_discr s then
 10.2084 +            case strip_comb (hd args) of
 10.2085 +              (Const (x' as (s', T')), ts') =>
 10.2086 +              if is_constr_like thy x'
 10.2087 +                 andalso constr_name_for_sel_like s = s'
 10.2088 +                 andalso not (exists is_pair_type (binder_types T')) then
 10.2089 +                list_comb (nth ts' (sel_no_from_name s), tl args)
 10.2090 +              else
 10.2091 +                raise SAME ()
 10.2092 +            | _ => raise SAME ()
 10.2093 +          else
 10.2094 +            raise SAME ())
 10.2095 +         handle SAME () => betapplys (t, args))
 10.2096 +      | do_term (Abs (s, T, t')) args =
 10.2097 +        betapplys (Abs (s, T, do_term t' []), args)
 10.2098 +      | do_term t args = betapplys (t, args)
 10.2099 +  in do_term t [] end
 10.2100 +
 10.2101 +(* term -> term *)
 10.2102 +fun curry_assms (@{const "==>"} $ (@{const Trueprop}
 10.2103 +                                   $ (@{const "op &"} $ t1 $ t2)) $ t3) =
 10.2104 +    curry_assms (Logic.list_implies ([t1, t2] |> map HOLogic.mk_Trueprop, t3))
 10.2105 +  | curry_assms (@{const "==>"} $ t1 $ t2) =
 10.2106 +    @{const "==>"} $ curry_assms t1 $ curry_assms t2
 10.2107 +  | curry_assms t = t
 10.2108 +
 10.2109 +(* term -> term *)
 10.2110 +val destroy_universal_equalities =
 10.2111 +  let
 10.2112 +    (* term list -> (indexname * typ) list -> term -> term *)
 10.2113 +    fun aux prems zs t =
 10.2114 +      case t of
 10.2115 +        @{const "==>"} $ t1 $ t2 => aux_implies prems zs t1 t2
 10.2116 +      | _ => Logic.list_implies (rev prems, t)
 10.2117 +    (* term list -> (indexname * typ) list -> term -> term -> term *)
 10.2118 +    and aux_implies prems zs t1 t2 =
 10.2119 +      case t1 of
 10.2120 +        Const (@{const_name "=="}, _) $ Var z $ t' => aux_eq prems zs z t' t1 t2
 10.2121 +      | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ Var z $ t') =>
 10.2122 +        aux_eq prems zs z t' t1 t2
 10.2123 +      | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t' $ Var z) =>
 10.2124 +        aux_eq prems zs z t' t1 t2
 10.2125 +      | _ => aux (t1 :: prems) (Term.add_vars t1 zs) t2
 10.2126 +    (* term list -> (indexname * typ) list -> indexname * typ -> term -> term
 10.2127 +       -> term -> term *)
 10.2128 +    and aux_eq prems zs z t' t1 t2 =
 10.2129 +      if not (z mem zs) andalso not (exists_subterm (equal (Var z)) t') then
 10.2130 +        aux prems zs (subst_free [(Var z, t')] t2)
 10.2131 +      else
 10.2132 +        aux (t1 :: prems) (Term.add_vars t1 zs) t2
 10.2133 +  in aux [] [] end
 10.2134 +
 10.2135 +(* theory -> term -> term *)
 10.2136 +fun pull_out_existential_constrs thy t =
 10.2137 +  let
 10.2138 +    val k = maxidx_of_term t + 1
 10.2139 +    (* typ list -> int -> term -> term list -> term list -> term * term list *)
 10.2140 +    fun aux Ts num_exists t args seen =
 10.2141 +      case t of
 10.2142 +        (t0 as Const (@{const_name Ex}, _)) $ Abs (s1, T1, t1) =>
 10.2143 +        let
 10.2144 +          val (t1, seen') = aux (T1 :: Ts) (num_exists + 1) t1 [] []
 10.2145 +          val n = length seen'
 10.2146 +          (* unit -> term list *)
 10.2147 +          fun vars () = map2 (fresh_value_var Ts k n) (index_seq 0 n) seen'
 10.2148 +        in
 10.2149 +          (equations_for_pulled_out_constrs HOLogic.mk_eq Ts k seen'
 10.2150 +           |> List.foldl s_conj t1 |> fold mk_exists (vars ())
 10.2151 +           |> curry3 Abs s1 T1 |> curry (op $) t0, seen)
 10.2152 +        end
 10.2153 +      | t1 $ t2 =>
 10.2154 +        let val (t2, seen) = aux Ts num_exists t2 [] seen in
 10.2155 +          aux Ts num_exists t1 (t2 :: args) seen
 10.2156 +        end
 10.2157 +      | Abs (s, T, t') =>
 10.2158 +        let
 10.2159 +          val (t', seen) = aux (T :: Ts) 0 t' [] (map (incr_boundvars 1) seen)
 10.2160 +        in (list_comb (Abs (s, T, t'), args), map (incr_boundvars ~1) seen) end
 10.2161 +      | _ =>
 10.2162 +        if num_exists > 0 then
 10.2163 +          pull_out_constr_comb thy Ts false k num_exists t args seen
 10.2164 +        else
 10.2165 +          (list_comb (t, args), seen)
 10.2166 +  in aux [] 0 t [] [] |> fst end
 10.2167 +
 10.2168 +(* theory -> int -> term list -> term list -> (term * term list) option *)
 10.2169 +fun find_bound_assign _ _ _ [] = NONE
 10.2170 +  | find_bound_assign thy j seen (t :: ts) =
 10.2171 +    let
 10.2172 +      (* bool -> term -> term -> (term * term list) option *)
 10.2173 +      fun aux pass1 t1 t2 =
 10.2174 +        (if loose_bvar1 (t2, j) then
 10.2175 +           if pass1 then aux false t2 t1 else raise SAME ()
 10.2176 +         else case t1 of
 10.2177 +           Bound j' => if j' = j then SOME (t2, ts @ seen) else raise SAME ()
 10.2178 +         | Const (s, Type ("fun", [T1, T2])) $ Bound j' =>
 10.2179 +           if j' = j andalso s = sel_prefix_for 0 ^ @{const_name FunBox} then
 10.2180 +             SOME (construct_value thy (@{const_name FunBox}, T2 --> T1) [t2],
 10.2181 +                   ts @ seen)
 10.2182 +           else
 10.2183 +             raise SAME ()
 10.2184 +         | _ => raise SAME ())
 10.2185 +        handle SAME () => find_bound_assign thy j (t :: seen) ts
 10.2186 +    in
 10.2187 +      case t of
 10.2188 +        Const (@{const_name "op ="}, _) $ t1 $ t2 => aux true t1 t2
 10.2189 +      | _ => find_bound_assign thy j (t :: seen) ts
 10.2190 +    end
 10.2191 +
 10.2192 +(* int -> term -> term -> term *)
 10.2193 +fun subst_one_bound j arg t =
 10.2194 +  let
 10.2195 +    fun aux (Bound i, lev) =
 10.2196 +        if i < lev then raise SAME ()
 10.2197 +        else if i = lev then incr_boundvars (lev - j) arg
 10.2198 +        else Bound (i - 1)
 10.2199 +      | aux (Abs (a, T, body), lev) = Abs (a, T, aux (body, lev + 1))
 10.2200 +      | aux (f $ t, lev) =
 10.2201 +        (aux (f, lev) $ (aux (t, lev) handle SAME () => t)
 10.2202 +         handle SAME () => f $ aux (t, lev))
 10.2203 +      | aux _ = raise SAME ()
 10.2204 +  in aux (t, j) handle SAME () => t end
 10.2205 +
 10.2206 +(* theory -> term -> term *)
 10.2207 +fun destroy_existential_equalities thy =
 10.2208 +  let
 10.2209 +    (* string list -> typ list -> term list -> term *)
 10.2210 +    fun kill [] [] ts = foldr1 s_conj ts
 10.2211 +      | kill (s :: ss) (T :: Ts) ts =
 10.2212 +        (case find_bound_assign thy (length ss) [] ts of
 10.2213 +           SOME (_, []) => @{const True}
 10.2214 +         | SOME (arg_t, ts) =>
 10.2215 +           kill ss Ts (map (subst_one_bound (length ss)
 10.2216 +                                (incr_bv (~1, length ss + 1, arg_t))) ts)
 10.2217 +         | NONE =>
 10.2218 +           Const (@{const_name Ex}, (T --> bool_T) --> bool_T)
 10.2219 +           $ Abs (s, T, kill ss Ts ts))
 10.2220 +      | kill _ _ _ = raise UnequalLengths
 10.2221 +    (* string list -> typ list -> term -> term *)
 10.2222 +    fun gather ss Ts ((t0 as Const (@{const_name Ex}, _)) $ Abs (s1, T1, t1)) =
 10.2223 +        gather (ss @ [s1]) (Ts @ [T1]) t1
 10.2224 +      | gather [] [] (Abs (s, T, t1)) = Abs (s, T, gather [] [] t1)
 10.2225 +      | gather [] [] (t1 $ t2) = gather [] [] t1 $ gather [] [] t2
 10.2226 +      | gather [] [] t = t
 10.2227 +      | gather ss Ts t = kill ss Ts (conjuncts (gather [] [] t))
 10.2228 +  in gather [] [] end
 10.2229 +
 10.2230 +(* term -> term *)
 10.2231 +fun distribute_quantifiers t =
 10.2232 +  case t of
 10.2233 +    (t0 as Const (@{const_name All}, T0)) $ Abs (s, T1, t1) =>
 10.2234 +    (case t1 of
 10.2235 +       (t10 as @{const "op &"}) $ t11 $ t12 =>
 10.2236 +       t10 $ distribute_quantifiers (t0 $ Abs (s, T1, t11))
 10.2237 +           $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
 10.2238 +     | (t10 as @{const Not}) $ t11 =>
 10.2239 +       t10 $ distribute_quantifiers (Const (@{const_name Ex}, T0)
 10.2240 +                                     $ Abs (s, T1, t11))
 10.2241 +     | t1 =>
 10.2242 +       if not (loose_bvar1 (t1, 0)) then
 10.2243 +         distribute_quantifiers (incr_boundvars ~1 t1)
 10.2244 +       else
 10.2245 +         t0 $ Abs (s, T1, distribute_quantifiers t1))
 10.2246 +  | (t0 as Const (@{const_name Ex}, T0)) $ Abs (s, T1, t1) =>
 10.2247 +    (case distribute_quantifiers t1 of
 10.2248 +       (t10 as @{const "op |"}) $ t11 $ t12 =>
 10.2249 +       t10 $ distribute_quantifiers (t0 $ Abs (s, T1, t11))
 10.2250 +           $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
 10.2251 +     | (t10 as @{const "op -->"}) $ t11 $ t12 =>
 10.2252 +       t10 $ distribute_quantifiers (Const (@{const_name All}, T0)
 10.2253 +                                     $ Abs (s, T1, t11))
 10.2254 +           $ distribute_quantifiers (t0 $ Abs (s, T1, t12))
 10.2255 +     | (t10 as @{const Not}) $ t11 =>
 10.2256 +       t10 $ distribute_quantifiers (Const (@{const_name All}, T0)
 10.2257 +                                     $ Abs (s, T1, t11))
 10.2258 +     | t1 =>
 10.2259 +       if not (loose_bvar1 (t1, 0)) then
 10.2260 +         distribute_quantifiers (incr_boundvars ~1 t1)
 10.2261 +       else
 10.2262 +         t0 $ Abs (s, T1, distribute_quantifiers t1))
 10.2263 +  | t1 $ t2 => distribute_quantifiers t1 $ distribute_quantifiers t2
 10.2264 +  | Abs (s, T, t') => Abs (s, T, distribute_quantifiers t')
 10.2265 +  | _ => t
 10.2266 +
 10.2267 +(* int -> int -> (int -> int) -> term -> term *)
 10.2268 +fun renumber_bounds j n f t =
 10.2269 +  case t of
 10.2270 +    t1 $ t2 => renumber_bounds j n f t1 $ renumber_bounds j n f t2
 10.2271 +  | Abs (s, T, t') => Abs (s, T, renumber_bounds (j + 1) n f t')
 10.2272 +  | Bound j' =>
 10.2273 +    Bound (if j' >= j andalso j' < j + n then f (j' - j) + j else j')
 10.2274 +  | _ => t
 10.2275 +
 10.2276 +val quantifier_cluster_max_size = 8
 10.2277 +
 10.2278 +(* theory -> term -> term *)
 10.2279 +fun push_quantifiers_inward thy =
 10.2280 +  let
 10.2281 +    (* string -> string list -> typ list -> term -> term *)
 10.2282 +    fun aux quant_s ss Ts t =
 10.2283 +      (case t of
 10.2284 +         (t0 as Const (s0, _)) $ Abs (s1, T1, t1 as _ $ _) =>
 10.2285 +         if s0 = quant_s andalso length Ts < quantifier_cluster_max_size then
 10.2286 +           aux s0 (s1 :: ss) (T1 :: Ts) t1
 10.2287 +         else if quant_s = ""
 10.2288 +                 andalso s0 mem [@{const_name All}, @{const_name Ex}] then
 10.2289 +           aux s0 [s1] [T1] t1
 10.2290 +         else
 10.2291 +           raise SAME ()
 10.2292 +       | _ => raise SAME ())
 10.2293 +      handle SAME () =>
 10.2294 +             case t of
 10.2295 +               t1 $ t2 =>
 10.2296 +               if quant_s = "" then
 10.2297 +                 aux "" [] [] t1 $ aux "" [] [] t2
 10.2298 +               else
 10.2299 +                 let
 10.2300 +                   val typical_card = 4
 10.2301 +                   (* ('a -> ''b list) -> 'a list -> ''b list *)
 10.2302 +                   fun big_union proj ps =
 10.2303 +                     fold (fold (insert (op =)) o proj) ps []
 10.2304 +                   val (ts, connective) = strip_any_connective t
 10.2305 +                   val T_costs =
 10.2306 +                     map (bounded_card_of_type 65536 typical_card []) Ts
 10.2307 +                   val t_costs = map size_of_term ts
 10.2308 +                   val num_Ts = length Ts
 10.2309 +                   (* int -> int *)
 10.2310 +                   val flip = curry (op -) (num_Ts - 1)
 10.2311 +                   val t_boundss = map (map flip o loose_bnos) ts
 10.2312 +                   (* (int list * int) list -> int list -> int *)
 10.2313 +                   fun cost boundss_cum_costs [] =
 10.2314 +                       map snd boundss_cum_costs |> Integer.sum
 10.2315 +                     | cost boundss_cum_costs (j :: js) =
 10.2316 +                       let
 10.2317 +                         val (yeas, nays) =
 10.2318 +                           List.partition (fn (bounds, _) => j mem bounds)
 10.2319 +                                          boundss_cum_costs
 10.2320 +                         val yeas_bounds = big_union fst yeas
 10.2321 +                         val yeas_cost = Integer.sum (map snd yeas)
 10.2322 +                                         * nth T_costs j
 10.2323 +                       in cost ((yeas_bounds, yeas_cost) :: nays) js end
 10.2324 +                   val js = all_permutations (index_seq 0 num_Ts)
 10.2325 +                            |> map (`(cost (t_boundss ~~ t_costs)))
 10.2326 +                            |> sort (int_ord o pairself fst) |> hd |> snd
 10.2327 +                   val back_js = map (fn j => find_index (equal j) js)
 10.2328 +                                     (index_seq 0 num_Ts)
 10.2329 +                   val ts = map (renumber_bounds 0 num_Ts (nth back_js o flip))
 10.2330 +                                ts
 10.2331 +                   (* (term * int list) list -> term *)
 10.2332 +                   fun mk_connection [] =
 10.2333 +                       raise ARG ("NitpickHOL.push_quantifiers_inward.aux.\
 10.2334 +                                  \mk_connection", "")
 10.2335 +                     | mk_connection ts_cum_bounds =
 10.2336 +                       ts_cum_bounds |> map fst
 10.2337 +                       |> foldr1 (fn (t1, t2) => connective $ t1 $ t2)
 10.2338 +                   (* (term * int list) list -> int list -> term *)
 10.2339 +                   fun build ts_cum_bounds [] = ts_cum_bounds |> mk_connection
 10.2340 +                     | build ts_cum_bounds (j :: js) =
 10.2341 +                       let
 10.2342 +                         val (yeas, nays) =
 10.2343 +                           List.partition (fn (_, bounds) => j mem bounds)
 10.2344 +                                          ts_cum_bounds
 10.2345 +                           ||> map (apfst (incr_boundvars ~1))
 10.2346 +                       in
 10.2347 +                         if null yeas then
 10.2348 +                           build nays js
 10.2349 +                         else
 10.2350 +                           let val T = nth Ts (flip j) in
 10.2351 +                             build ((Const (quant_s, (T --> bool_T) --> bool_T)
 10.2352 +                                     $ Abs (nth ss (flip j), T,
 10.2353 +                                            mk_connection yeas),
 10.2354 +                                      big_union snd yeas) :: nays) js
 10.2355 +                           end
 10.2356 +                       end
 10.2357 +                 in build (ts ~~ t_boundss) js end
 10.2358 +             | Abs (s, T, t') => Abs (s, T, aux "" [] [] t')
 10.2359 +             | _ => t
 10.2360 +  in aux "" [] [] end
 10.2361 +
 10.2362 +(* polarity -> string -> bool *)
 10.2363 +fun is_positive_existential polar quant_s =
 10.2364 +  (polar = Pos andalso quant_s = @{const_name Ex})
 10.2365 +  orelse (polar = Neg andalso quant_s <> @{const_name Ex})
 10.2366 +
 10.2367 +(* extended_context -> int -> term -> term *)
 10.2368 +fun skolemize_term_and_more (ext_ctxt as {thy, def_table, skolems, ...})
 10.2369 +                            skolem_depth =
 10.2370 +  let
 10.2371 +    (* int list -> int list *)
 10.2372 +    val incrs = map (Integer.add 1)
 10.2373 +    (* string list -> typ list -> int list -> int -> polarity -> term -> term *)
 10.2374 +    fun aux ss Ts js depth polar t =
 10.2375 +      let
 10.2376 +        (* string -> typ -> string -> typ -> term -> term *)
 10.2377 +        fun do_quantifier quant_s quant_T abs_s abs_T t =
 10.2378 +          if not (loose_bvar1 (t, 0)) then
 10.2379 +            aux ss Ts js depth polar (incr_boundvars ~1 t)
 10.2380 +          else if depth <= skolem_depth
 10.2381 +                  andalso is_positive_existential polar quant_s then
 10.2382 +            let
 10.2383 +              val j = length (!skolems) + 1
 10.2384 +              val sko_s = skolem_prefix_for (length js) j ^ abs_s
 10.2385 +              val _ = Unsynchronized.change skolems (cons (sko_s, ss))
 10.2386 +              val sko_t = list_comb (Const (sko_s, rev Ts ---> abs_T),
 10.2387 +                                     map Bound (rev js))
 10.2388 +              val abs_t = Abs (abs_s, abs_T, aux ss Ts (incrs js) depth polar t)
 10.2389 +            in
 10.2390 +              if null js then betapply (abs_t, sko_t)
 10.2391 +              else Const (@{const_name Let}, abs_T --> quant_T) $ sko_t $ abs_t
 10.2392 +            end
 10.2393 +          else
 10.2394 +            Const (quant_s, quant_T)
 10.2395 +            $ Abs (abs_s, abs_T,
 10.2396 +                   if is_higher_order_type abs_T then
 10.2397 +                     t
 10.2398 +                   else
 10.2399 +                     aux (abs_s :: ss) (abs_T :: Ts) (0 :: incrs js)
 10.2400 +                         (depth + 1) polar t)
 10.2401 +      in
 10.2402 +        case t of
 10.2403 +          Const (s0 as @{const_name all}, T0) $ Abs (s1, T1, t1) =>
 10.2404 +          do_quantifier s0 T0 s1 T1 t1
 10.2405 +        | @{const "==>"} $ t1 $ t2 =>
 10.2406 +          @{const "==>"} $ aux ss Ts js depth (flip_polarity polar) t1
 10.2407 +          $ aux ss Ts js depth polar t2
 10.2408 +        | @{const Pure.conjunction} $ t1 $ t2 =>
 10.2409 +          @{const Pure.conjunction} $ aux ss Ts js depth polar t1
 10.2410 +          $ aux ss Ts js depth polar t2
 10.2411 +        | @{const Trueprop} $ t1 =>
 10.2412 +          @{const Trueprop} $ aux ss Ts js depth polar t1
 10.2413 +        | @{const Not} $ t1 =>
 10.2414 +          @{const Not} $ aux ss Ts js depth (flip_polarity polar) t1
 10.2415 +        | Const (s0 as @{const_name All}, T0) $ Abs (s1, T1, t1) =>
 10.2416 +          do_quantifier s0 T0 s1 T1 t1
 10.2417 +        | Const (s0 as @{const_name Ex}, T0) $ Abs (s1, T1, t1) =>
 10.2418 +          do_quantifier s0 T0 s1 T1 t1
 10.2419 +        | @{const "op &"} $ t1 $ t2 =>
 10.2420 +          @{const "op &"} $ aux ss Ts js depth polar t1
 10.2421 +          $ aux ss Ts js depth polar t2
 10.2422 +        | @{const "op |"} $ t1 $ t2 =>
 10.2423 +          @{const "op |"} $ aux ss Ts js depth polar t1
 10.2424 +          $ aux ss Ts js depth polar t2
 10.2425 +        | @{const "op -->"} $ t1 $ t2 =>
 10.2426 +          @{const "op -->"} $ aux ss Ts js depth (flip_polarity polar) t1
 10.2427 +          $ aux ss Ts js depth polar t2
 10.2428 +        | (t0 as Const (@{const_name Let}, T0)) $ t1 $ t2 =>
 10.2429 +          t0 $ t1 $ aux ss Ts js depth polar t2
 10.2430 +        | Const (x as (s, T)) =>
 10.2431 +          if is_inductive_pred ext_ctxt x
 10.2432 +             andalso not (is_well_founded_inductive_pred ext_ctxt x) then
 10.2433 +            let
 10.2434 +              val gfp = (fixpoint_kind_of_const thy def_table x = Gfp)
 10.2435 +              val (pref, connective, set_oper) =
 10.2436 +                if gfp then
 10.2437 +                  (lbfp_prefix,
 10.2438 +                   @{const "op |"},
 10.2439 +                   @{const_name upper_semilattice_fun_inst.sup_fun})
 10.2440 +                else
 10.2441 +                  (ubfp_prefix,
 10.2442 +                   @{const "op &"},
 10.2443 +                   @{const_name lower_semilattice_fun_inst.inf_fun})
 10.2444 +              (* unit -> term *)
 10.2445 +              fun pos () = unrolled_inductive_pred_const ext_ctxt gfp x
 10.2446 +                           |> aux ss Ts js depth polar
 10.2447 +              fun neg () = Const (pref ^ s, T)
 10.2448 +            in
 10.2449 +              (case polar |> gfp ? flip_polarity of
 10.2450 +                 Pos => pos ()
 10.2451 +               | Neg => neg ()
 10.2452 +               | Neut =>
 10.2453 +                 if is_fun_type T then
 10.2454 +                   let
 10.2455 +                     val ((trunk_arg_Ts, rump_arg_T), body_T) =
 10.2456 +                       T |> strip_type |>> split_last
 10.2457 +                     val set_T = rump_arg_T --> body_T
 10.2458 +                     (* (unit -> term) -> term *)
 10.2459 +                     fun app f =
 10.2460 +                       list_comb (f (),
 10.2461 +                                  map Bound (length trunk_arg_Ts - 1 downto 0))
 10.2462 +                   in
 10.2463 +                     List.foldl absdummy
 10.2464 +                                (Const (set_oper, [set_T, set_T] ---> set_T)
 10.2465 +                                        $ app pos $ app neg) trunk_arg_Ts
 10.2466 +                   end
 10.2467 +                 else
 10.2468 +                   connective $ pos () $ neg ())
 10.2469 +            end
 10.2470 +          else
 10.2471 +            Const x
 10.2472 +        | t1 $ t2 =>
 10.2473 +          betapply (aux ss Ts [] (skolem_depth + 1) polar t1,
 10.2474 +                    aux ss Ts [] depth Neut t2)
 10.2475 +        | Abs (s, T, t1) => Abs (s, T, aux ss Ts (incrs js) depth polar t1)
 10.2476 +        | _ => t
 10.2477 +      end
 10.2478 +  in aux [] [] [] 0 Pos end
 10.2479 +
 10.2480 +(* extended_context -> styp -> (int * term option) list *)
 10.2481 +fun static_args_in_term ({ersatz_table, ...} : extended_context) x t =
 10.2482 +  let
 10.2483 +    (* term -> term list -> term list -> term list list *)
 10.2484 +    fun fun_calls (Abs (_, _, t)) _ = fun_calls t []
 10.2485 +      | fun_calls (t1 $ t2) args = fun_calls t2 [] #> fun_calls t1 (t2 :: args)
 10.2486 +      | fun_calls t args =
 10.2487 +        (case t of
 10.2488 +           Const (x' as (s', T')) =>
 10.2489 +           x = x' orelse (case AList.lookup (op =) ersatz_table s' of
 10.2490 +                            SOME s'' => x = (s'', T')
 10.2491 +                          | NONE => false)
 10.2492 +         | _ => false) ? cons args
 10.2493 +    (* term list list -> term list list -> term list -> term list list *)
 10.2494 +    fun call_sets [] [] vs = [vs]
 10.2495 +      | call_sets [] uss vs = vs :: call_sets uss [] []
 10.2496 +      | call_sets ([] :: _) _ _ = []
 10.2497 +      | call_sets ((t :: ts) :: tss) uss vs =
 10.2498 +        OrdList.insert TermOrd.term_ord t vs |> call_sets tss (ts :: uss)
 10.2499 +    val sets = call_sets (fun_calls t [] []) [] []
 10.2500 +    val indexed_sets = sets ~~ (index_seq 0 (length sets))
 10.2501 +  in
 10.2502 +    fold_rev (fn (set, j) =>
 10.2503 +                 case set of
 10.2504 +                   [Var _] => AList.lookup (op =) indexed_sets set = SOME j
 10.2505 +                              ? cons (j, NONE)
 10.2506 +                 | [t as Const _] => cons (j, SOME t)
 10.2507 +                 | [t as Free _] => cons (j, SOME t)
 10.2508 +                 | _ => I) indexed_sets []
 10.2509 +  end
 10.2510 +(* extended_context -> styp -> term list -> (int * term option) list *)
 10.2511 +fun static_args_in_terms ext_ctxt x =
 10.2512 +  map (static_args_in_term ext_ctxt x)
 10.2513 +  #> fold1 (OrdList.inter (prod_ord int_ord (option_ord TermOrd.term_ord)))
 10.2514 +
 10.2515 +(* term -> term list *)
 10.2516 +fun params_in_equation (@{const "==>"} $ _ $ t2) = params_in_equation t2
 10.2517 +  | params_in_equation (@{const Trueprop} $ t1) = params_in_equation t1
 10.2518 +  | params_in_equation (Const (@{const_name "op ="}, _) $ t1 $ _) =
 10.2519 +    snd (strip_comb t1)
 10.2520 +  | params_in_equation _ = []
 10.2521 +
 10.2522 +(* styp -> styp -> int list -> term list -> term list -> term -> term *)
 10.2523 +fun specialize_fun_axiom x x' fixed_js fixed_args extra_args t =
 10.2524 +  let
 10.2525 +    val k = fold Integer.max (map maxidx_of_term (fixed_args @ extra_args)) 0
 10.2526 +            + 1
 10.2527 +    val t = map_aterms (fn Var ((s, i), T) => Var ((s, k + i), T) | t' => t') t
 10.2528 +    val fixed_params = filter_indices fixed_js (params_in_equation t)
 10.2529 +    (* term list -> term -> term *)
 10.2530 +    fun aux args (Abs (s, T, t)) = list_comb (Abs (s, T, aux [] t), args)
 10.2531 +      | aux args (t1 $ t2) = aux (aux [] t2 :: args) t1
 10.2532 +      | aux args t =
 10.2533 +        if t = Const x then
 10.2534 +          list_comb (Const x', extra_args @ filter_out_indices fixed_js args)
 10.2535 +        else
 10.2536 +          let val j = find_index (equal t) fixed_params in
 10.2537 +            list_comb (if j >= 0 then nth fixed_args j else t, args)
 10.2538 +          end
 10.2539 +  in aux [] t end
 10.2540 +
 10.2541 +(* typ list -> term -> bool *)
 10.2542 +fun is_eligible_arg Ts t =
 10.2543 +  let val bad_Ts = map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t) in
 10.2544 +    null bad_Ts
 10.2545 +    orelse (is_higher_order_type (fastype_of1 (Ts, t))
 10.2546 +            andalso forall (not o is_higher_order_type) bad_Ts)
 10.2547 +  end
 10.2548 +
 10.2549 +(* (int * term option) list -> (int * term) list -> int list *)
 10.2550 +fun overlapping_indices [] _ = []
 10.2551 +  | overlapping_indices _ [] = []
 10.2552 +  | overlapping_indices (ps1 as (j1, t1) :: ps1') (ps2 as (j2, t2) :: ps2') =
 10.2553 +    if j1 < j2 then overlapping_indices ps1' ps2
 10.2554 +    else if j1 > j2 then overlapping_indices ps1 ps2'
 10.2555 +    else overlapping_indices ps1' ps2' |> the_default t2 t1 = t2 ? cons j1
 10.2556 +
 10.2557 +val special_depth = 20
 10.2558 +
 10.2559 +(* extended_context -> int -> term -> term *)
 10.2560 +fun specialize_consts_in_term (ext_ctxt as {thy, specialize, simp_table,
 10.2561 +                                            special_funs, ...}) depth t =
 10.2562 +  if not specialize orelse depth > special_depth then
 10.2563 +    t
 10.2564 +  else
 10.2565 +    let
 10.2566 +      (* FIXME: strong enough in the face of user-defined axioms? *)
 10.2567 +      val blacklist = if depth = 0 then []
 10.2568 +                      else case term_under_def t of Const x => [x] | _ => []
 10.2569 +      (* term list -> typ list -> term -> term *)
 10.2570 +      fun aux args Ts (Const (x as (s, T))) =
 10.2571 +          ((if not (x mem blacklist) andalso not (null args)
 10.2572 +               andalso not (String.isPrefix special_prefix s)
 10.2573 +               andalso is_equational_fun ext_ctxt x then
 10.2574 +              let
 10.2575 +                val eligible_args = filter (is_eligible_arg Ts o snd)
 10.2576 +                                           (index_seq 0 (length args) ~~ args)
 10.2577 +                val _ = not (null eligible_args) orelse raise SAME ()
 10.2578 +                val old_axs = equational_fun_axioms ext_ctxt x
 10.2579 +                              |> map (destroy_existential_equalities thy)
 10.2580 +                val static_params = static_args_in_terms ext_ctxt x old_axs
 10.2581 +                val fixed_js = overlapping_indices static_params eligible_args
 10.2582 +                val _ = not (null fixed_js) orelse raise SAME ()
 10.2583 +                val fixed_args = filter_indices fixed_js args
 10.2584 +                val vars = fold Term.add_vars fixed_args []
 10.2585 +                           |> sort (TermOrd.fast_indexname_ord o pairself fst)
 10.2586 +                val bound_js = fold (fn t => fn js => add_loose_bnos (t, 0, js))
 10.2587 +                                    fixed_args []
 10.2588 +                               |> sort int_ord
 10.2589 +                val live_args = filter_out_indices fixed_js args
 10.2590 +                val extra_args = map Var vars @ map Bound bound_js @ live_args
 10.2591 +                val extra_Ts = map snd vars @ filter_indices bound_js Ts
 10.2592 +                val k = maxidx_of_term t + 1
 10.2593 +                (* int -> term *)
 10.2594 +                fun var_for_bound_no j =
 10.2595 +                  Var ((bound_var_prefix ^
 10.2596 +                        nat_subscript (find_index (equal j) bound_js + 1), k),
 10.2597 +                       nth Ts j)
 10.2598 +                val fixed_args_in_axiom =
 10.2599 +                  map (curry subst_bounds
 10.2600 +                             (map var_for_bound_no (index_seq 0 (length Ts))))
 10.2601 +                      fixed_args
 10.2602 +              in
 10.2603 +                case AList.lookup (op =) (!special_funs)
 10.2604 +                                  (x, fixed_js, fixed_args_in_axiom) of
 10.2605 +                  SOME x' => list_comb (Const x', extra_args)
 10.2606 +                | NONE =>
 10.2607 +                  let
 10.2608 +                    val extra_args_in_axiom =
 10.2609 +                      map Var vars @ map var_for_bound_no bound_js
 10.2610 +                    val x' as (s', _) =
 10.2611 +                      (special_prefix_for (length (!special_funs) + 1) ^ s,
 10.2612 +                       extra_Ts @ filter_out_indices fixed_js (binder_types T)
 10.2613 +                       ---> body_type T)
 10.2614 +                    val new_axs =
 10.2615 +                      map (specialize_fun_axiom x x' fixed_js
 10.2616 +                               fixed_args_in_axiom extra_args_in_axiom) old_axs
 10.2617 +                    val _ =
 10.2618 +                      Unsynchronized.change special_funs
 10.2619 +                          (cons ((x, fixed_js, fixed_args_in_axiom), x'))
 10.2620 +                    val _ = add_simps simp_table s' new_axs
 10.2621 +                  in list_comb (Const x', extra_args) end
 10.2622 +              end
 10.2623 +            else
 10.2624 +              raise SAME ())
 10.2625 +           handle SAME () => list_comb (Const x, args))
 10.2626 +        | aux args Ts (Abs (s, T, t)) =
 10.2627 +          list_comb (Abs (s, T, aux [] (T :: Ts) t), args)
 10.2628 +        | aux args Ts (t1 $ t2) = aux (aux [] Ts t2 :: args) Ts t1
 10.2629 +        | aux args _ t = list_comb (t, args)
 10.2630 +    in aux [] [] t end
 10.2631 +
 10.2632 +(* theory -> term -> int Termtab.tab -> int Termtab.tab *)
 10.2633 +fun add_to_uncurry_table thy t =
 10.2634 +  let
 10.2635 +    (* term -> term list -> int Termtab.tab -> int Termtab.tab *)
 10.2636 +    fun aux (t1 $ t2) args table =
 10.2637 +        let val table = aux t2 [] table in aux t1 (t2 :: args) table end
 10.2638 +      | aux (Abs (_, _, t')) _ table = aux t' [] table
 10.2639 +      | aux (t as Const (x as (s, _))) args table =
 10.2640 +        if is_built_in_const false x orelse is_constr_like thy x orelse is_sel s
 10.2641 +           orelse s = @{const_name Sigma} then
 10.2642 +          table
 10.2643 +        else
 10.2644 +          Termtab.map_default (t, 65536) (curry Int.min (length args)) table
 10.2645 +      | aux _ _ table = table
 10.2646 +  in aux t [] end
 10.2647 +
 10.2648 +(* int Termtab.tab term -> term *)
 10.2649 +fun uncurry_term table t =
 10.2650 +  let
 10.2651 +    (* term -> term list -> term *)
 10.2652 +    fun aux (t1 $ t2) args = aux t1 (aux t2 [] :: args)
 10.2653 +      | aux (Abs (s, T, t')) args = betapplys (Abs (s, T, aux t' []), args)
 10.2654 +      | aux (t as Const (s, T)) args =
 10.2655 +        (case Termtab.lookup table t of
 10.2656 +           SOME n =>
 10.2657 +           if n >= 2 then
 10.2658 +             let
 10.2659 +               val (arg_Ts, rest_T) = strip_n_binders n T
 10.2660 +               val j =
 10.2661 +                 if hd arg_Ts = @{typ bisim_iterator}
 10.2662 +                    orelse is_fp_iterator_type (hd arg_Ts) then
 10.2663 +                   1
 10.2664 +                 else case find_index (not_equal bool_T) arg_Ts of
 10.2665 +                   ~1 => n
 10.2666 +                 | j => j
 10.2667 +               val ((before_args, tuple_args), after_args) =
 10.2668 +                 args |> chop n |>> chop j
 10.2669 +               val ((before_arg_Ts, tuple_arg_Ts), rest_T) =
 10.2670 +                 T |> strip_n_binders n |>> chop j
 10.2671 +               val tuple_T = HOLogic.mk_tupleT tuple_arg_Ts
 10.2672 +             in
 10.2673 +               if n - j < 2 then
 10.2674 +                 betapplys (t, args)
 10.2675 +               else
 10.2676 +                 betapplys (Const (uncurry_prefix_for (n - j) j ^ s,
 10.2677 +                                   before_arg_Ts ---> tuple_T --> rest_T),
 10.2678 +                            before_args @ [mk_flat_tuple tuple_T tuple_args] @
 10.2679 +                            after_args)
 10.2680 +             end
 10.2681 +           else
 10.2682 +             betapplys (t, args)
 10.2683 +         | NONE => betapplys (t, args))
 10.2684 +      | aux t args = betapplys (t, args)
 10.2685 +  in aux t [] end
 10.2686 +
 10.2687 +(* (term -> term) -> int -> term -> term *)
 10.2688 +fun coerce_bound_no f j t =
 10.2689 +  case t of
 10.2690 +    t1 $ t2 => coerce_bound_no f j t1 $ coerce_bound_no f j t2
 10.2691 +  | Abs (s, T, t') => Abs (s, T, coerce_bound_no f (j + 1) t')
 10.2692 +  | Bound j' => if j' = j then f t else t
 10.2693 +  | _ => t
 10.2694 +
 10.2695 +(* extended_context -> bool -> term -> term *)
 10.2696 +fun box_fun_and_pair_in_term (ext_ctxt as {thy, fast_descrs, ...}) def orig_t =
 10.2697 +  let
 10.2698 +    (* typ -> typ *)
 10.2699 +    fun box_relational_operator_type (Type ("fun", Ts)) =
 10.2700 +        Type ("fun", map box_relational_operator_type Ts)
 10.2701 +      | box_relational_operator_type (Type ("*", Ts)) =
 10.2702 +        Type ("*", map (box_type ext_ctxt InPair) Ts)
 10.2703 +      | box_relational_operator_type T = T
 10.2704 +    (* typ -> typ -> term -> term *)
 10.2705 +    fun coerce_bound_0_in_term new_T old_T =
 10.2706 +      old_T <> new_T ? coerce_bound_no (coerce_term [new_T] old_T new_T) 0
 10.2707 +    (* typ list -> typ -> term -> term *)
 10.2708 +    and coerce_term Ts new_T old_T t =
 10.2709 +      if old_T = new_T then
 10.2710 +        t
 10.2711 +      else
 10.2712 +        case (new_T, old_T) of
 10.2713 +          (Type (new_s, new_Ts as [new_T1, new_T2]),
 10.2714 +           Type ("fun", [old_T1, old_T2])) =>
 10.2715 +          (case eta_expand Ts t 1 of
 10.2716 +             Abs (s, _, t') =>
 10.2717 +             Abs (s, new_T1,
 10.2718 +                  t' |> coerce_bound_0_in_term new_T1 old_T1
 10.2719 +                     |> coerce_term (new_T1 :: Ts) new_T2 old_T2)
 10.2720 +             |> Envir.eta_contract
 10.2721 +             |> new_s <> "fun"
 10.2722 +                ? construct_value thy (@{const_name FunBox},
 10.2723 +                                       Type ("fun", new_Ts) --> new_T) o single
 10.2724 +           | t' => raise TERM ("NitpickHOL.box_fun_and_pair_in_term.\
 10.2725 +                               \coerce_term", [t']))
 10.2726 +        | (Type (new_s, new_Ts as [new_T1, new_T2]),
 10.2727 +           Type (old_s, old_Ts as [old_T1, old_T2])) =>
 10.2728 +          if old_s mem [@{type_name fun_box}, @{type_name pair_box}, "*"] then
 10.2729 +            case constr_expand thy old_T t of
 10.2730 +              Const (@{const_name FunBox}, _) $ t1 =>
 10.2731 +              if new_s = "fun" then
 10.2732 +                coerce_term Ts new_T (Type ("fun", old_Ts)) t1
 10.2733 +              else
 10.2734 +                construct_value thy
 10.2735 +                    (@{const_name FunBox}, Type ("fun", new_Ts) --> new_T)
 10.2736 +                     [coerce_term Ts (Type ("fun", new_Ts))
 10.2737 +                                  (Type ("fun", old_Ts)) t1]
 10.2738 +            | Const _ $ t1 $ t2 =>
 10.2739 +              construct_value thy
 10.2740 +                  (if new_s = "*" then @{const_name Pair}
 10.2741 +                   else @{const_name PairBox}, new_Ts ---> new_T)
 10.2742 +                  [coerce_term Ts new_T1 old_T1 t1,
 10.2743 +                   coerce_term Ts new_T2 old_T2 t2]
 10.2744 +            | t' => raise TERM ("NitpickHOL.box_fun_and_pair_in_term.\
 10.2745 +                                \coerce_term", [t'])
 10.2746 +          else
 10.2747 +            raise TYPE ("coerce_term", [new_T, old_T], [t])
 10.2748 +        | _ => raise TYPE ("coerce_term", [new_T, old_T], [t])
 10.2749 +    (* indexname * typ -> typ * term -> typ option list -> typ option list *)
 10.2750 +    fun add_boxed_types_for_var (z as (_, T)) (T', t') =
 10.2751 +      case t' of
 10.2752 +        Var z' => z' = z ? insert (op =) T'
 10.2753 +      | Const (@{const_name Pair}, _) $ t1 $ t2 =>
 10.2754 +        (case T' of
 10.2755 +           Type (_, [T1, T2]) =>
 10.2756 +           fold (add_boxed_types_for_var z) [(T1, t1), (T2, t2)]
 10.2757 +         | _ => raise TYPE ("NitpickHOL.box_fun_and_pair_in_term.\
 10.2758 +                            \add_boxed_types_for_var", [T'], []))
 10.2759 +      | _ => exists_subterm (equal (Var z)) t' ? insert (op =) T
 10.2760 +    (* typ list -> typ list -> term -> indexname * typ -> typ *)
 10.2761 +    fun box_var_in_def new_Ts old_Ts t (z as (_, T)) =
 10.2762 +      case t of
 10.2763 +        @{const Trueprop} $ t1 => box_var_in_def new_Ts old_Ts t1 z
 10.2764 +      | Const (s0, _) $ t1 $ _ =>
 10.2765 +        if s0 mem [@{const_name "=="}, @{const_name "op ="}] then
 10.2766 +          let
 10.2767 +            val (t', args) = strip_comb t1
 10.2768 +            val T' = fastype_of1 (new_Ts, do_term new_Ts old_Ts Neut t')
 10.2769 +          in
 10.2770 +            case fold (add_boxed_types_for_var z)
 10.2771 +                      (fst (strip_n_binders (length args) T') ~~ args) [] of
 10.2772 +              [T''] => T''
 10.2773 +            | _ => T
 10.2774 +          end
 10.2775 +        else
 10.2776 +          T
 10.2777 +      | _ => T
 10.2778 +    (* typ list -> typ list -> polarity -> string -> typ -> string -> typ
 10.2779 +       -> term -> term *)
 10.2780 +    and do_quantifier new_Ts old_Ts polar quant_s quant_T abs_s abs_T t =
 10.2781 +      let
 10.2782 +        val abs_T' =
 10.2783 +          if polar = Neut orelse is_positive_existential polar quant_s then
 10.2784 +            box_type ext_ctxt InFunLHS abs_T
 10.2785 +          else
 10.2786 +            abs_T
 10.2787 +        val body_T = body_type quant_T
 10.2788 +      in
 10.2789 +        Const (quant_s, (abs_T' --> body_T) --> body_T)
 10.2790 +        $ Abs (abs_s, abs_T',
 10.2791 +               t |> do_term (abs_T' :: new_Ts) (abs_T :: old_Ts) polar)
 10.2792 +      end
 10.2793 +    (* typ list -> typ list -> string -> typ -> term -> term -> term *)
 10.2794 +    and do_equals new_Ts old_Ts s0 T0 t1 t2 =
 10.2795 +      let
 10.2796 +        val (t1, t2) = pairself (do_term new_Ts old_Ts Neut) (t1, t2)
 10.2797 +        val (T1, T2) = pairself (curry fastype_of1 new_Ts) (t1, t2)
 10.2798 +        val T = [T1, T2] |> sort TermOrd.typ_ord |> List.last
 10.2799 +      in
 10.2800 +        list_comb (Const (s0, [T, T] ---> body_type T0),
 10.2801 +                   map2 (coerce_term new_Ts T) [T1, T2] [t1, t2])
 10.2802 +      end
 10.2803 +    (* string -> typ -> term *)
 10.2804 +    and do_description_operator s T =
 10.2805 +      let val T1 = box_type ext_ctxt InFunLHS (range_type T) in
 10.2806 +        Const (s, (T1 --> bool_T) --> T1)
 10.2807 +      end
 10.2808 +    (* typ list -> typ list -> polarity -> term -> term *)
 10.2809 +    and do_term new_Ts old_Ts polar t =
 10.2810 +      case t of
 10.2811 +        Const (s0 as @{const_name all}, T0) $ Abs (s1, T1, t1) =>
 10.2812 +        do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
 10.2813 +      | Const (s0 as @{const_name "=="}, T0) $ t1 $ t2 =>
 10.2814 +        do_equals new_Ts old_Ts s0 T0 t1 t2
 10.2815 +      | @{const "==>"} $ t1 $ t2 =>
 10.2816 +        @{const "==>"} $ do_term new_Ts old_Ts (flip_polarity polar) t1
 10.2817 +        $ do_term new_Ts old_Ts polar t2
 10.2818 +      | @{const Pure.conjunction} $ t1 $ t2 =>
 10.2819 +        @{const Pure.conjunction} $ do_term new_Ts old_Ts polar t1
 10.2820 +        $ do_term new_Ts old_Ts polar t2
 10.2821 +      | @{const Trueprop} $ t1 =>
 10.2822 +        @{const Trueprop} $ do_term new_Ts old_Ts polar t1
 10.2823 +      | @{const Not} $ t1 =>
 10.2824 +        @{const Not} $ do_term new_Ts old_Ts (flip_polarity polar) t1
 10.2825 +      | Const (s0 as @{const_name All}, T0) $ Abs (s1, T1, t1) =>
 10.2826 +        do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
 10.2827 +      | Const (s0 as @{const_name Ex}, T0) $ Abs (s1, T1, t1) =>
 10.2828 +        do_quantifier new_Ts old_Ts polar s0 T0 s1 T1 t1
 10.2829 +      | Const (s0 as @{const_name "op ="}, T0) $ t1 $ t2 =>
 10.2830 +        do_equals new_Ts old_Ts s0 T0 t1 t2
 10.2831 +      | @{const "op &"} $ t1 $ t2 =>
 10.2832 +        @{const "op &"} $ do_term new_Ts old_Ts polar t1
 10.2833 +        $ do_term new_Ts old_Ts polar t2
 10.2834 +      | @{const "op |"} $ t1 $ t2 =>
 10.2835 +        @{const "op |"} $ do_term new_Ts old_Ts polar t1
 10.2836 +        $ do_term new_Ts old_Ts polar t2
 10.2837 +      | @{const "op -->"} $ t1 $ t2 =>
 10.2838 +        @{const "op -->"} $ do_term new_Ts old_Ts (flip_polarity polar) t1
 10.2839 +        $ do_term new_Ts old_Ts polar t2
 10.2840 +      | Const (s as @{const_name The}, T) => do_description_operator s T
 10.2841 +      | Const (s as @{const_name Eps}, T) => do_description_operator s T
 10.2842 +      | Const (s as @{const_name Tha}, T) => do_description_operator s T
 10.2843 +      | Const (x as (s, T)) =>
 10.2844 +        Const (s, if s mem [@{const_name converse}, @{const_name trancl}] then
 10.2845 +                    box_relational_operator_type T
 10.2846 +                  else if is_built_in_const fast_descrs x
 10.2847 +                          orelse s = @{const_name Sigma} then
 10.2848 +                    T
 10.2849 +                  else if is_constr_like thy x then
 10.2850 +                    box_type ext_ctxt InConstr T
 10.2851 +                  else if is_sel s orelse is_rep_fun thy x then
 10.2852 +                    box_type ext_ctxt InSel T
 10.2853 +                  else
 10.2854 +                    box_type ext_ctxt InExpr T)
 10.2855 +      | t1 $ Abs (s, T, t2') =>
 10.2856 +        let
 10.2857 +          val t1 = do_term new_Ts old_Ts Neut t1
 10.2858 +          val T1 = fastype_of1 (new_Ts, t1)
 10.2859 +          val (s1, Ts1) = dest_Type T1
 10.2860 +          val T' = hd (snd (dest_Type (hd Ts1)))
 10.2861 +          val t2 = Abs (s, T', do_term (T' :: new_Ts) (T :: old_Ts) Neut t2')
 10.2862 +          val T2 = fastype_of1 (new_Ts, t2)
 10.2863 +          val t2 = coerce_term new_Ts (hd Ts1) T2 t2
 10.2864 +        in
 10.2865 +          betapply (if s1 = "fun" then
 10.2866 +                      t1
 10.2867 +                    else
 10.2868 +                      select_nth_constr_arg thy
 10.2869 +                          (@{const_name FunBox}, Type ("fun", Ts1) --> T1) t1 0
 10.2870 +                          (Type ("fun", Ts1)), t2)
 10.2871 +        end
 10.2872 +      | t1 $ t2 =>
 10.2873 +        let
 10.2874 +          val t1 = do_term new_Ts old_Ts Neut t1
 10.2875 +          val T1 = fastype_of1 (new_Ts, t1)
 10.2876 +          val (s1, Ts1) = dest_Type T1
 10.2877 +          val t2 = do_term new_Ts old_Ts Neut t2
 10.2878 +          val T2 = fastype_of1 (new_Ts, t2)
 10.2879 +          val t2 = coerce_term new_Ts (hd Ts1) T2 t2
 10.2880 +        in
 10.2881 +          betapply (if s1 = "fun" then
 10.2882 +                      t1
 10.2883 +                    else
 10.2884 +                      select_nth_constr_arg thy
 10.2885 +                          (@{const_name FunBox}, Type ("fun", Ts1) --> T1) t1 0
 10.2886 +                          (Type ("fun", Ts1)), t2)
 10.2887 +        end
 10.2888 +      | Free (s, T) => Free (s, box_type ext_ctxt InExpr T)
 10.2889 +      | Var (z as (x, T)) =>
 10.2890 +        Var (x, if def then box_var_in_def new_Ts old_Ts orig_t z
 10.2891 +                else box_type ext_ctxt InExpr T)
 10.2892 +      | Bound _ => t
 10.2893 +      | Abs (s, T, t') =>
 10.2894 +        Abs (s, T, do_term (T :: new_Ts) (T :: old_Ts) Neut t')
 10.2895 +  in do_term [] [] Pos orig_t end
 10.2896 +
 10.2897 +(* int -> term -> term *)
 10.2898 +fun eval_axiom_for_term j t =
 10.2899 +  Logic.mk_equals (Const (eval_prefix ^ string_of_int j, fastype_of t), t)
 10.2900 +
 10.2901 +(* extended_context -> styp -> bool *)
 10.2902 +fun is_equational_fun_surely_complete ext_ctxt x =
 10.2903 +  case raw_equational_fun_axioms ext_ctxt x of
 10.2904 +    [@{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t1 $ _)] =>
 10.2905 +    strip_comb t1 |> snd |> forall is_Var
 10.2906 +  | _ => false
 10.2907 +
 10.2908 +type special = int list * term list * styp
 10.2909 +
 10.2910 +(* styp -> special -> special -> term *)
 10.2911 +fun special_congruence_axiom (s, T) (js1, ts1, x1) (js2, ts2, x2) =
 10.2912 +  let
 10.2913 +    val (bounds1, bounds2) = pairself (map Var o special_bounds) (ts1, ts2)
 10.2914 +    val Ts = binder_types T
 10.2915 +    val max_j = fold (fold (curry Int.max)) [js1, js2] ~1
 10.2916 +    val (eqs, (args1, args2)) =
 10.2917 +      fold (fn j => case pairself (fn ps => AList.lookup (op =) ps j)
 10.2918 +                                  (js1 ~~ ts1, js2 ~~ ts2) of
 10.2919 +                      (SOME t1, SOME t2) => apfst (cons (t1, t2))
 10.2920 +                    | (SOME t1, NONE) => apsnd (apsnd (cons t1))
 10.2921 +                    | (NONE, SOME t2) => apsnd (apfst (cons t2))
 10.2922 +                    | (NONE, NONE) =>
 10.2923 +                      let val v = Var ((cong_var_prefix ^ nat_subscript j, 0),
 10.2924 +                                       nth Ts j) in
 10.2925 +                        apsnd (pairself (cons v))
 10.2926 +                      end) (max_j downto 0) ([], ([], []))
 10.2927 +  in
 10.2928 +    Logic.list_implies (eqs |> filter_out (op =) |> distinct (op =)
 10.2929 +                            |> map Logic.mk_equals,
 10.2930 +                        Logic.mk_equals (list_comb (Const x1, bounds1 @ args1),
 10.2931 +                                         list_comb (Const x2, bounds2 @ args2)))
 10.2932 +    |> Refute.close_form
 10.2933 +  end
 10.2934 +
 10.2935 +(* extended_context -> styp list -> term list *)
 10.2936 +fun special_congruence_axioms (ext_ctxt as {special_funs, ...}) xs =
 10.2937 +  let
 10.2938 +    val groups =
 10.2939 +      !special_funs
 10.2940 +      |> map (fn ((x, js, ts), x') => (x, (js, ts, x')))
 10.2941 +      |> AList.group (op =)
 10.2942 +      |> filter_out (is_equational_fun_surely_complete ext_ctxt o fst)
 10.2943 +      |> map (fn (x, zs) => (x, zs |> (x mem xs) ? cons ([], [], x)))
 10.2944 +    (* special -> int *)
 10.2945 +    fun generality (js, _, _) = ~(length js)
 10.2946 +    (* special -> special -> bool *)
 10.2947 +    fun is_more_specific (j1, t1, x1) (j2, t2, x2) =
 10.2948 +      x1 <> x2 andalso OrdList.subset (prod_ord int_ord TermOrd.term_ord)
 10.2949 +                                      (j2 ~~ t2, j1 ~~ t1)
 10.2950 +    (* styp -> special list -> special list -> special list -> term list
 10.2951 +       -> term list *)
 10.2952 +    fun do_pass_1 _ [] [_] [_] = I
 10.2953 +      | do_pass_1 x skipped _ [] = do_pass_2 x skipped
 10.2954 +      | do_pass_1 x skipped all (z :: zs) =
 10.2955 +        case filter (is_more_specific z) all
 10.2956 +             |> sort (int_ord o pairself generality) of
 10.2957 +          [] => do_pass_1 x (z :: skipped) all zs
 10.2958 +        | (z' :: _) => cons (special_congruence_axiom x z z')
 10.2959 +                       #> do_pass_1 x skipped all zs
 10.2960 +    (* styp -> special list -> term list -> term list *)
 10.2961 +    and do_pass_2 _ [] = I
 10.2962 +      | do_pass_2 x (z :: zs) =
 10.2963 +        fold (cons o special_congruence_axiom x z) zs #> do_pass_2 x zs
 10.2964 +  in fold (fn (x, zs) => do_pass_1 x [] zs zs) groups [] end
 10.2965 +
 10.2966 +(* term -> bool *)
 10.2967 +val is_trivial_equation = the_default false o try (op aconv o Logic.dest_equals)
 10.2968 +
 10.2969 +(* 'a Symtab.table -> 'a list *)
 10.2970 +fun all_table_entries table = Symtab.fold (append o snd) table []
 10.2971 +(* const_table -> string -> const_table *)
 10.2972 +fun extra_table table s = Symtab.make [(s, all_table_entries table)]
 10.2973 +
 10.2974 +(* extended_context -> term -> (term list * term list) * (bool * bool) *)
 10.2975 +fun axioms_for_term
 10.2976 +        (ext_ctxt as {thy, max_bisim_depth, user_axioms, fast_descrs, evals,
 10.2977 +                      def_table, nondef_table, user_nondefs, ...}) t =
 10.2978 +  let
 10.2979 +    type accumulator = styp list * (term list * term list)
 10.2980 +    (* (term list * term list -> term list)
 10.2981 +       -> ((term list -> term list) -> term list * term list
 10.2982 +           -> term list * term list)
 10.2983 +       -> int -> term -> accumulator -> accumulator *)
 10.2984 +    fun add_axiom get app depth t (accum as (xs, axs)) =
 10.2985 +      let
 10.2986 +        val t = t |> unfold_defs_in_term ext_ctxt
 10.2987 +                  |> skolemize_term_and_more ext_ctxt ~1
 10.2988 +      in
 10.2989 +        if is_trivial_equation t then
 10.2990 +          accum
 10.2991 +        else
 10.2992 +          let val t' = t |> specialize_consts_in_term ext_ctxt depth in
 10.2993 +            if exists (member (op aconv) (get axs)) [t, t'] then accum
 10.2994 +            else add_axioms_for_term (depth + 1) t' (xs, app (cons t') axs)
 10.2995 +          end
 10.2996 +      end
 10.2997 +    (* int -> term -> accumulator -> accumulator *)
 10.2998 +    and add_nondef_axiom depth = add_axiom snd apsnd depth
 10.2999 +    and add_def_axiom depth t =
 10.3000 +      (if head_of t = @{const "==>"} then add_nondef_axiom
 10.3001 +       else add_axiom fst apfst) depth t
 10.3002 +    (* int -> term -> accumulator -> accumulator *)
 10.3003 +    and add_axioms_for_term depth t (accum as (xs, axs)) =
 10.3004 +      case t of
 10.3005 +        t1 $ t2 => accum |> fold (add_axioms_for_term depth) [t1, t2]
 10.3006 +      | Const (x as (s, T)) =>
 10.3007 +        (if x mem xs orelse is_built_in_const fast_descrs x then
 10.3008 +           accum
 10.3009 +         else
 10.3010 +           let val accum as (xs, _) = (x :: xs, axs) in
 10.3011 +             if depth > axioms_max_depth then
 10.3012 +               raise LIMIT ("NitpickHOL.axioms_for_term.add_axioms_for_term",
 10.3013 +                            "too many nested axioms (" ^ string_of_int depth ^
 10.3014 +                            ")")
 10.3015 +             else if Refute.is_const_of_class thy x then
 10.3016 +               let
 10.3017 +                 val class = Logic.class_of_const s
 10.3018 +                 val of_class = Logic.mk_of_class (TVar (("'a", 0), [class]),
 10.3019 +                                                   class)
 10.3020 +                 val ax1 = try (Refute.specialize_type thy x) of_class
 10.3021 +                 val ax2 = Option.map (Refute.specialize_type thy x o snd)
 10.3022 +                                      (Refute.get_classdef thy class)
 10.3023 +               in fold (add_def_axiom depth) (map_filter I [ax1, ax2]) accum end
 10.3024 +             else if is_constr thy x then
 10.3025 +               accum
 10.3026 +             else if is_equational_fun ext_ctxt x then
 10.3027 +               fold (add_def_axiom depth) (equational_fun_axioms ext_ctxt x)
 10.3028 +                    accum
 10.3029 +             else if is_abs_fun thy x then
 10.3030 +               accum |> fold (add_nondef_axiom depth)
 10.3031 +                             (nondef_props_for_const thy nondef_table x)
 10.3032 +                     |> fold (add_def_axiom depth)
 10.3033 +                             (nondef_props_for_const thy
 10.3034 +                                                    (extra_table def_table s) x)
 10.3035 +             else if is_rep_fun thy x then
 10.3036 +               accum |> fold (add_nondef_axiom depth)
 10.3037 +                             (nondef_props_for_const thy nondef_table x)
 10.3038 +                     |> fold (add_def_axiom depth)
 10.3039 +                             (nondef_props_for_const thy
 10.3040 +                                                    (extra_table def_table s) x)
 10.3041 +                     |> add_axioms_for_term depth
 10.3042 +                                            (Const (mate_of_rep_fun thy x))
 10.3043 +                     |> add_def_axiom depth (inverse_axiom_for_rep_fun thy x)
 10.3044 +             else
 10.3045 +               accum |> user_axioms <> SOME false
 10.3046 +                        ? fold (add_nondef_axiom depth)
 10.3047 +                               (nondef_props_for_const thy nondef_table x)
 10.3048 +           end)
 10.3049 +        |> add_axioms_for_type depth T
 10.3050 +      | Free (_, T) => add_axioms_for_type depth T accum
 10.3051 +      | Var (_, T) => add_axioms_for_type depth T accum
 10.3052 +      | Bound _ => accum
 10.3053 +      | Abs (_, T, t) => accum |> add_axioms_for_term depth t
 10.3054 +                               |> add_axioms_for_type depth T
 10.3055 +    (* int -> typ -> accumulator -> accumulator *)
 10.3056 +    and add_axioms_for_type depth T =
 10.3057 +      case T of
 10.3058 +        Type ("fun", Ts) => fold (add_axioms_for_type depth) Ts
 10.3059 +      | Type ("*", Ts) => fold (add_axioms_for_type depth) Ts
 10.3060 +      | @{typ prop} => I
 10.3061 +      | @{typ bool} => I
 10.3062 +      | @{typ unit} => I
 10.3063 +      | Type (@{type_name Datatype.node}, _) =>
 10.3064 +        raise NOT_SUPPORTED "internal datatype node type"
 10.3065 +      | Type (@{type_name tuple_isomorphism}, _) =>
 10.3066 +        raise NOT_SUPPORTED "internal record tuple type"
 10.3067 +      | TFree (_, S) => add_axioms_for_sort depth T S
 10.3068 +      | TVar (_, S) => add_axioms_for_sort depth T S
 10.3069 +      | Type (z as (_, Ts)) =>
 10.3070 +        fold (add_axioms_for_type depth) Ts
 10.3071 +        #> (if is_pure_typedef thy T then
 10.3072 +              fold (add_def_axiom depth) (optimized_typedef_axioms thy z)
 10.3073 +            else if max_bisim_depth >= 0 andalso is_codatatype thy T then
 10.3074 +              fold (add_def_axiom depth) (codatatype_bisim_axioms thy T)
 10.3075 +            else
 10.3076 +              I)
 10.3077 +    (* int -> typ -> sort -> accumulator -> accumulator *)
 10.3078 +    and add_axioms_for_sort depth T S =
 10.3079 +      let
 10.3080 +        val supers = Sign.complete_sort thy S
 10.3081 +        val class_axioms =
 10.3082 +          maps (fn class => map prop_of (AxClass.get_info thy class |> #axioms
 10.3083 +                                         handle ERROR _ => [])) supers
 10.3084 +        val monomorphic_class_axioms =
 10.3085 +          map (fn t => case Term.add_tvars t [] of
 10.3086 +                         [] => t
 10.3087 +                       | [(x, S)] =>
 10.3088 +                         Refute.monomorphic_term (Vartab.make [(x, (S, T))]) t
 10.3089 +                       | _ => raise TERM ("NitpickHOL.axioms_for_term.\
 10.3090 +                                          \add_axioms_for_sort", [t]))
 10.3091 +              class_axioms
 10.3092 +      in fold (add_nondef_axiom depth) monomorphic_class_axioms end
 10.3093 +    val (mono_user_nondefs, poly_user_nondefs) =
 10.3094 +      List.partition (null o Term.hidden_polymorphism) user_nondefs
 10.3095 +    val eval_axioms = map2 eval_axiom_for_term (index_seq 0 (length evals))
 10.3096 +                           evals
 10.3097 +    val (xs, (defs, nondefs)) =
 10.3098 +      ([], ([], [])) |> add_axioms_for_term 1 t 
 10.3099 +                     |> fold_rev (add_def_axiom 1) eval_axioms
 10.3100 +                     |> user_axioms = SOME true
 10.3101 +                        ? fold (add_nondef_axiom 1) mono_user_nondefs
 10.3102 +    val defs = defs @ special_congruence_axioms ext_ctxt xs
 10.3103 +  in
 10.3104 +    ((defs, nondefs), (user_axioms = SOME true orelse null mono_user_nondefs,
 10.3105 +                       null poly_user_nondefs))
 10.3106 +  end
 10.3107 +
 10.3108 +(* theory -> const_table -> styp -> int list *)
 10.3109 +fun const_format thy def_table (x as (s, T)) =
 10.3110 +  if String.isPrefix unrolled_prefix s then
 10.3111 +    const_format thy def_table (original_name s, range_type T)
 10.3112 +  else if String.isPrefix skolem_prefix s then
 10.3113 +    let
 10.3114 +      val k = unprefix skolem_prefix s
 10.3115 +              |> strip_first_name_sep |> fst |> space_explode "@"
 10.3116 +              |> hd |> Int.fromString |> the
 10.3117 +    in [k, num_binder_types T - k] end
 10.3118 +  else if original_name s <> s then
 10.3119 +    [num_binder_types T]
 10.3120 +  else case def_of_const thy def_table x of
 10.3121 +    SOME t' => if fixpoint_kind_of_rhs t' <> NoFp then
 10.3122 +                 let val k = length (strip_abs_vars t') in
 10.3123 +                   [k, num_binder_types T - k]
 10.3124 +                 end
 10.3125 +               else
 10.3126 +                 [num_binder_types T]
 10.3127 +  | NONE => [num_binder_types T]
 10.3128 +(* int list -> int list -> int list *)
 10.3129 +fun intersect_formats _ [] = []
 10.3130 +  | intersect_formats [] _ = []
 10.3131 +  | intersect_formats ks1 ks2 =
 10.3132 +    let val ((ks1', k1), (ks2', k2)) = pairself split_last (ks1, ks2) in
 10.3133 +      intersect_formats (ks1' @ (if k1 > k2 then [k1 - k2] else []))
 10.3134 +                        (ks2' @ (if k2 > k1 then [k2 - k1] else [])) @
 10.3135 +      [Int.min (k1, k2)]
 10.3136 +    end
 10.3137 +
 10.3138 +(* theory -> const_table -> (term option * int list) list -> term -> int list *)
 10.3139 +fun lookup_format thy def_table formats t =
 10.3140 +  case AList.lookup (fn (SOME x, SOME y) =>
 10.3141 +                        (term_match thy) (x, y) | _ => false)
 10.3142 +                    formats (SOME t) of
 10.3143 +    SOME format => format
 10.3144 +  | NONE => let val format = the (AList.lookup (op =) formats NONE) in
 10.3145 +              case t of
 10.3146 +                Const x => intersect_formats format
 10.3147 +                                             (const_format thy def_table x)
 10.3148 +              | _ => format
 10.3149 +            end
 10.3150 +
 10.3151 +(* int list -> int list -> typ -> typ *)
 10.3152 +fun format_type default_format format T =
 10.3153 +  let
 10.3154 +    val T = unbox_type T
 10.3155 +    val format = format |> filter (curry (op <) 0)
 10.3156 +  in
 10.3157 +    if forall (equal 1) format then
 10.3158 +      T
 10.3159 +    else
 10.3160 +      let
 10.3161 +        val (binder_Ts, body_T) = strip_type T
 10.3162 +        val batched =
 10.3163 +          binder_Ts
 10.3164 +          |> map (format_type default_format default_format)
 10.3165 +          |> rev |> chunk_list_unevenly (rev format)
 10.3166 +          |> map (HOLogic.mk_tupleT o rev)
 10.3167 +      in List.foldl (op -->) body_T batched end
 10.3168 +  end
 10.3169 +(* theory -> const_table -> (term option * int list) list -> term -> typ *)
 10.3170 +fun format_term_type thy def_table formats t =
 10.3171 +  format_type (the (AList.lookup (op =) formats NONE))
 10.3172 +              (lookup_format thy def_table formats t) (fastype_of t)
 10.3173 +
 10.3174 +(* int list -> int -> int list -> int list *)
 10.3175 +fun repair_special_format js m format =
 10.3176 +  m - 1 downto 0 |> chunk_list_unevenly (rev format)
 10.3177 +                 |> map (rev o filter_out (member (op =) js))
 10.3178 +                 |> filter_out null |> map length |> rev
 10.3179 +
 10.3180 +(* extended_context -> string * string -> (term option * int list) list
 10.3181 +   -> styp -> term * typ *)
 10.3182 +fun user_friendly_const ({thy, evals, def_table, skolems, special_funs, ...}
 10.3183 +                         : extended_context) (base_name, step_name) formats =
 10.3184 +  let
 10.3185 +    val default_format = the (AList.lookup (op =) formats NONE)
 10.3186 +    (* styp -> term * typ *)
 10.3187 +    fun do_const (x as (s, T)) =
 10.3188 +      (if String.isPrefix special_prefix s then
 10.3189 +         let
 10.3190 +           (* term -> term *)
 10.3191 +           val do_term = map_aterms (fn Const x => fst (do_const x) | t' => t')
 10.3192 +           val (x' as (_, T'), js, ts) =
 10.3193 +             AList.find (op =) (!special_funs) (s, unbox_type T) |> the_single
 10.3194 +           val max_j = List.last js
 10.3195 +           val Ts = List.take (binder_types T', max_j + 1)
 10.3196 +           val missing_js = filter_out (member (op =) js) (0 upto max_j)
 10.3197 +           val missing_Ts = filter_indices missing_js Ts
 10.3198 +           (* int -> indexname *)
 10.3199 +           fun nth_missing_var n =
 10.3200 +             ((arg_var_prefix ^ nat_subscript (n + 1), 0), nth missing_Ts n)
 10.3201 +           val missing_vars = map nth_missing_var (0 upto length missing_js - 1)
 10.3202 +           val vars = special_bounds ts @ missing_vars
 10.3203 +           val ts' = map2 (fn T => fn j =>
 10.3204 +                              case AList.lookup (op =) (js ~~ ts) j of
 10.3205 +                                SOME t => do_term t
 10.3206 +                              | NONE =>
 10.3207 +                                Var (nth missing_vars
 10.3208 +                                         (find_index (equal j) missing_js)))
 10.3209 +                          Ts (0 upto max_j)
 10.3210 +           val t = do_const x' |> fst
 10.3211 +           val format =
 10.3212 +             case AList.lookup (fn (SOME t1, SOME t2) => term_match thy (t1, t2)
 10.3213 +                                 | _ => false) formats (SOME t) of
 10.3214 +               SOME format =>
 10.3215 +               repair_special_format js (num_binder_types T') format
 10.3216 +             | NONE =>
 10.3217 +               const_format thy def_table x'
 10.3218 +               |> repair_special_format js (num_binder_types T')
 10.3219 +               |> intersect_formats default_format
 10.3220 +         in
 10.3221 +           (list_comb (t, ts') |> fold_rev abs_var vars,
 10.3222 +            format_type default_format format T)
 10.3223 +         end
 10.3224 +       else if String.isPrefix uncurry_prefix s then
 10.3225 +         let
 10.3226 +           val (ss, s') = unprefix uncurry_prefix s
 10.3227 +                          |> strip_first_name_sep |>> space_explode "@"
 10.3228 +         in
 10.3229 +           if String.isPrefix step_prefix s' then
 10.3230 +             do_const (s', T)
 10.3231 +           else
 10.3232 +             let
 10.3233 +               val k = the (Int.fromString (hd ss))
 10.3234 +               val j = the (Int.fromString (List.last ss))
 10.3235 +               val (before_Ts, (tuple_T, rest_T)) =
 10.3236 +                 strip_n_binders j T ||> (strip_n_binders 1 #>> hd)
 10.3237 +               val T' = before_Ts ---> dest_n_tuple_type k tuple_T ---> rest_T
 10.3238 +             in do_const (s', T') end
 10.3239 +         end
 10.3240 +       else if String.isPrefix unrolled_prefix s then
 10.3241 +         let val t = Const (original_name s, range_type T) in
 10.3242 +           (lambda (Free (iter_var_prefix, nat_T)) t,
 10.3243 +            format_type default_format
 10.3244 +                        (lookup_format thy def_table formats t) T)
 10.3245 +         end
 10.3246 +       else if String.isPrefix base_prefix s then
 10.3247 +         (Const (base_name, T --> T) $ Const (unprefix base_prefix s, T),
 10.3248 +          format_type default_format default_format T)
 10.3249 +       else if String.isPrefix step_prefix s then
 10.3250 +         (Const (step_name, T --> T) $ Const (unprefix step_prefix s, T),
 10.3251 +          format_type default_format default_format T)
 10.3252 +       else if String.isPrefix skolem_prefix s then
 10.3253 +         let
 10.3254 +           val ss = the (AList.lookup (op =) (!skolems) s)
 10.3255 +           val (Ts, Ts') = chop (length ss) (binder_types T)
 10.3256 +           val frees = map Free (ss ~~ Ts)
 10.3257 +           val s' = original_name s
 10.3258 +         in
 10.3259 +           (fold lambda frees (Const (s', Ts' ---> T)),
 10.3260 +            format_type default_format
 10.3261 +                        (lookup_format thy def_table formats (Const x)) T)
 10.3262 +         end
 10.3263 +       else if String.isPrefix eval_prefix s then
 10.3264 +         let
 10.3265 +           val t = nth evals (the (Int.fromString (unprefix eval_prefix s)))
 10.3266 +         in (t, format_term_type thy def_table formats t) end
 10.3267 +       else if s = @{const_name undefined_fast_The} then
 10.3268 +         (Const (nitpick_prefix ^ "The fallback", T),
 10.3269 +          format_type default_format
 10.3270 +                      (lookup_format thy def_table formats
 10.3271 +                           (Const (@{const_name The}, (T --> bool_T) --> T))) T)
 10.3272 +       else if s = @{const_name undefined_fast_Eps} then
 10.3273 +         (Const (nitpick_prefix ^ "Eps fallback", T),
 10.3274 +          format_type default_format
 10.3275 +                      (lookup_format thy def_table formats
 10.3276 +                           (Const (@{const_name Eps}, (T --> bool_T) --> T))) T)
 10.3277 +       else
 10.3278 +         let val t = Const (original_name s, T) in
 10.3279 +           (t, format_term_type thy def_table formats t)
 10.3280 +         end)
 10.3281 +      |>> map_types (typ_subst [(@{typ bisim_iterator}, nat_T)] o unbox_type)
 10.3282 +      |>> shorten_const_names_in_term |>> shorten_abs_vars
 10.3283 +  in do_const end
 10.3284 +
 10.3285 +(* styp -> string *)
 10.3286 +fun assign_operator_for_const (s, T) =
 10.3287 +  if String.isPrefix ubfp_prefix s then
 10.3288 +    if is_fun_type T then "\<subseteq>" else "\<le>"
 10.3289 +  else if String.isPrefix lbfp_prefix s then
 10.3290 +    if is_fun_type T then "\<supseteq>" else "\<ge>"
 10.3291 +  else if original_name s <> s then
 10.3292 +    assign_operator_for_const (after_name_sep s, T)
 10.3293 +  else
 10.3294 +    "="
 10.3295 +
 10.3296 +(* extended_context -> term
 10.3297 +   -> ((term list * term list) * (bool * bool)) * term *)
 10.3298 +fun preprocess_term (ext_ctxt as {thy, destroy_constrs, boxes, skolemize,
 10.3299 +                                  uncurry, ...}) t =
 10.3300 +  let
 10.3301 +    val skolem_depth = if skolemize then 4 else ~1
 10.3302 +    val (((def_ts, nondef_ts), (got_all_mono_user_axioms, no_poly_user_axioms)),
 10.3303 +         core_t) = t |> unfold_defs_in_term ext_ctxt
 10.3304 +                     |> Refute.close_form
 10.3305 +                     |> skolemize_term_and_more ext_ctxt skolem_depth
 10.3306 +                     |> specialize_consts_in_term ext_ctxt 0
 10.3307 +                     |> `(axioms_for_term ext_ctxt)
 10.3308 +    val maybe_box = exists (not_equal (SOME false) o snd) boxes
 10.3309 +    val table =
 10.3310 +      Termtab.empty |> uncurry
 10.3311 +        ? fold (add_to_uncurry_table thy) (core_t :: def_ts @ nondef_ts)
 10.3312 +    (* bool -> bool -> term -> term *)
 10.3313 +    fun do_rest def core =
 10.3314 +      uncurry ? uncurry_term table
 10.3315 +      #> maybe_box ? box_fun_and_pair_in_term ext_ctxt def
 10.3316 +      #> destroy_constrs ? (pull_out_universal_constrs thy def
 10.3317 +                            #> pull_out_existential_constrs thy
 10.3318 +                            #> destroy_pulled_out_constrs thy def)
 10.3319 +      #> curry_assms
 10.3320 +      #> destroy_universal_equalities
 10.3321 +      #> destroy_existential_equalities thy
 10.3322 +      #> simplify_constrs_and_sels thy
 10.3323 +      #> distribute_quantifiers
 10.3324 +      #> push_quantifiers_inward thy
 10.3325 +      #> not core ? Refute.close_form
 10.3326 +      #> shorten_abs_vars
 10.3327 +  in
 10.3328 +    (((map (do_rest true false) def_ts, map (do_rest false false) nondef_ts),
 10.3329 +      (got_all_mono_user_axioms, no_poly_user_axioms)),
 10.3330 +     do_rest false true core_t)
 10.3331 +  end
 10.3332 +
 10.3333 +end;
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/HOL/Tools/Nitpick/nitpick_isar.ML	Thu Oct 22 14:51:47 2009 +0200
    11.3 @@ -0,0 +1,500 @@
    11.4 +(*  Title:      HOL/Nitpick/Tools/nitpick_isar.ML
    11.5 +    Author:     Jasmin Blanchette, TU Muenchen
    11.6 +    Copyright   2008, 2009
    11.7 +
    11.8 +Adds the "nitpick" and "nitpick_params" commands to Isabelle/Isar's outer
    11.9 +syntax.
   11.10 +*)
   11.11 +
   11.12 +signature NITPICK_ISAR =
   11.13 +sig
   11.14 +  type params = Nitpick.params
   11.15 +
   11.16 +  val default_params : theory -> (string * string) list -> params
   11.17 +end
   11.18 +
   11.19 +structure NitpickIsar : NITPICK_ISAR =
   11.20 +struct
   11.21 +
   11.22 +open NitpickUtil
   11.23 +open NitpickHOL
   11.24 +open NitpickRep
   11.25 +open NitpickNut
   11.26 +open Nitpick
   11.27 +
   11.28 +type raw_param = string * string list
   11.29 +
   11.30 +val default_default_params =
   11.31 +  [("card", ["1\<midarrow>8"]),
   11.32 +   ("iter", ["0,1,2,4,8,12,16,24"]),
   11.33 +   ("bisim_depth", ["7"]),
   11.34 +   ("box", ["smart"]),
   11.35 +   ("mono", ["smart"]),
   11.36 +   ("wf", ["smart"]),
   11.37 +   ("sat_solver", ["smart"]),
   11.38 +   ("batch_size", ["smart"]),
   11.39 +   ("auto", ["false"]),
   11.40 +   ("blocking", ["true"]),
   11.41 +   ("falsify", ["true"]),
   11.42 +   ("user_axioms", ["smart"]),
   11.43 +   ("assms", ["true"]),
   11.44 +   ("coalesce_type_vars", ["false"]),
   11.45 +   ("destroy_constrs", ["true"]),
   11.46 +   ("specialize", ["true"]),
   11.47 +   ("skolemize", ["true"]),
   11.48 +   ("star_linear_preds", ["true"]),
   11.49 +   ("uncurry", ["true"]),
   11.50 +   ("fast_descrs", ["true"]),
   11.51 +   ("peephole_optim", ["true"]),
   11.52 +   ("timeout", ["30 s"]),
   11.53 +   ("auto_timeout", ["5 s"]),
   11.54 +   ("tac_timeout", ["500 ms"]),
   11.55 +   ("sym_break", ["20"]),
   11.56 +   ("sharing_depth", ["3"]),
   11.57 +   ("flatten_props", ["false"]),
   11.58 +   ("max_threads", ["0"]),
   11.59 +   ("verbose", ["false"]),
   11.60 +   ("debug", ["false"]),
   11.61 +   ("overlord", [if exists (fn s => String.isSuffix s (getenv "HOME"))
   11.62 +                           ["blanchet", "blanchette"] then
   11.63 +                   "true"
   11.64 +                 else
   11.65 +                   "false"]),
   11.66 +   ("show_all", ["false"]),
   11.67 +   ("show_skolems", ["true"]),
   11.68 +   ("show_datatypes", ["false"]),
   11.69 +   ("show_consts", ["false"]),
   11.70 +   ("format", ["1"]),
   11.71 +   ("max_potential", ["1"]),
   11.72 +   ("max_genuine", ["1"]),
   11.73 +   ("check_potential", ["false"]),
   11.74 +   ("check_genuine", ["false"])]
   11.75 +
   11.76 +val negated_params =
   11.77 +  [("dont_box", "box"),
   11.78 +   ("non_mono", "mono"),
   11.79 +   ("non_wf", "wf"),
   11.80 +   ("no_auto", "auto"),
   11.81 +   ("non_blocking", "blocking"),
   11.82 +   ("satisfy", "falsify"),
   11.83 +   ("no_user_axioms", "user_axioms"),
   11.84 +   ("no_assms", "assms"),
   11.85 +   ("dont_coalesce_type_vars", "coalesce_type_vars"),
   11.86 +   ("dont_destroy_constrs", "destroy_constrs"),
   11.87 +   ("dont_specialize", "specialize"),
   11.88 +   ("dont_skolemize", "skolemize"),
   11.89 +   ("dont_star_linear_preds", "star_linear_preds"),
   11.90 +   ("dont_uncurry", "uncurry"),
   11.91 +   ("full_descrs", "fast_descrs"),
   11.92 +   ("no_peephole_optim", "peephole_optim"),
   11.93 +   ("dont_flatten_props", "flatten_props"),
   11.94 +   ("quiet", "verbose"),
   11.95 +   ("no_debug", "debug"),
   11.96 +   ("no_overlord", "overlord"),
   11.97 +   ("dont_show_all", "show_all"),
   11.98 +   ("hide_skolems", "show_skolems"),
   11.99 +   ("hide_datatypes", "show_datatypes"),
  11.100 +   ("hide_consts", "show_consts"),
  11.101 +   ("trust_potential", "check_potential"),
  11.102 +   ("trust_genuine", "check_genuine")]
  11.103 +
  11.104 +(* string -> bool *)
  11.105 +fun is_known_raw_param s =
  11.106 +  AList.defined (op =) default_default_params s
  11.107 +  orelse AList.defined (op =) negated_params s
  11.108 +  orelse s mem ["max", "eval", "expect"]
  11.109 +  orelse exists (fn p => String.isPrefix (p ^ " ") s)
  11.110 +                ["card", "max", "iter", "box", "dont_box", "mono", "non_mono",
  11.111 +                 "wf", "non_wf", "format"]
  11.112 +
  11.113 +(* string * 'a -> unit *)
  11.114 +fun check_raw_param (s, _) =
  11.115 +  if is_known_raw_param s then ()
  11.116 +  else error ("Unknown parameter " ^ quote s ^ ".")  
  11.117 +
  11.118 +(* string -> string option *)
  11.119 +fun unnegate_param_name name =
  11.120 +  case AList.lookup (op =) negated_params name of
  11.121 +    NONE => if String.isPrefix "dont_" name then SOME (unprefix "dont_" name)
  11.122 +            else if String.isPrefix "non_" name then SOME (unprefix "non_" name)
  11.123 +            else NONE
  11.124 +  | some_name => some_name
  11.125 +(* raw_param -> raw_param *)
  11.126 +fun unnegate_raw_param (name, value) =
  11.127 +  case unnegate_param_name name of
  11.128 +    SOME name' => (name', case value of
  11.129 +                            ["false"] => ["true"]
  11.130 +                          | ["true"] => ["false"]
  11.131 +                          | [] => ["false"]
  11.132 +                          | _ => value)
  11.133 +  | NONE => (name, value)
  11.134 +
  11.135 +structure TheoryData = TheoryDataFun(
  11.136 +  type T = {params: raw_param list, registered_auto: bool}
  11.137 +  val empty = {params = rev default_default_params, registered_auto = false}
  11.138 +  val copy = I
  11.139 +  val extend = I
  11.140 +  fun merge _ ({params = ps1, registered_auto = a1},
  11.141 +               {params = ps2, registered_auto = a2}) =
  11.142 +    {params = AList.merge (op =) (op =) (ps1, ps2),
  11.143 +     registered_auto = a1 orelse a2})
  11.144 +
  11.145 +(* raw_param -> theory -> theory *)
  11.146 +fun set_default_raw_param param thy =
  11.147 +  let val {params, registered_auto} = TheoryData.get thy in
  11.148 +    TheoryData.put
  11.149 +      {params = AList.update (op =) (unnegate_raw_param param) params,
  11.150 +       registered_auto = registered_auto} thy
  11.151 +  end
  11.152 +(* theory -> raw_param list *)
  11.153 +val default_raw_params = #params o TheoryData.get
  11.154 +
  11.155 +(* theory -> theory *)
  11.156 +fun set_registered_auto thy =
  11.157 +  TheoryData.put {params = default_raw_params thy, registered_auto = true} thy
  11.158 +(* theory -> bool *)
  11.159 +val is_registered_auto = #registered_auto o TheoryData.get
  11.160 +
  11.161 +(* string -> bool *)
  11.162 +fun is_punctuation s = (s = "," orelse s = "-" orelse s = "\<midarrow>")
  11.163 +
  11.164 +(* string list -> string *)
  11.165 +fun stringify_raw_param_value [] = ""
  11.166 +  | stringify_raw_param_value [s] = s
  11.167 +  | stringify_raw_param_value (s1 :: s2 :: ss) =
  11.168 +    s1 ^ (if is_punctuation s1 orelse is_punctuation s2 then "" else " ") ^
  11.169 +    stringify_raw_param_value (s2 :: ss)
  11.170 +
  11.171 +(* bool -> string -> string -> bool option *)
  11.172 +fun bool_option_from_string option name s =
  11.173 +  (case s of
  11.174 +     "smart" => if option then NONE else raise Option
  11.175 +   | "false" => SOME false
  11.176 +   | "true" => SOME true
  11.177 +   | "" => SOME true
  11.178 +   | s => raise Option)
  11.179 +  handle Option.Option =>
  11.180 +         let val ss = map quote ((option ? cons "smart") ["true", "false"]) in
  11.181 +           error ("Parameter " ^ quote name ^ " must be assigned " ^
  11.182 +                  space_implode " " (serial_commas "or" ss) ^ ".")
  11.183 +         end
  11.184 +(* bool -> raw_param list -> bool option -> string -> bool option *)
  11.185 +fun general_lookup_bool option raw_params default_value name =
  11.186 +  case AList.lookup (op =) raw_params name of
  11.187 +    SOME s => s |> stringify_raw_param_value
  11.188 +                |> bool_option_from_string option name
  11.189 +  | NONE => default_value
  11.190 +
  11.191 +(* int -> string -> int *)
  11.192 +fun maxed_int_from_string min_int s = Int.max (min_int, the (Int.fromString s))
  11.193 +
  11.194 +(* Proof.context -> bool -> raw_param list -> raw_param list -> params *)
  11.195 +fun extract_params ctxt auto default_params override_params =
  11.196 +  let
  11.197 +    val override_params = map unnegate_raw_param override_params
  11.198 +    val raw_params = rev override_params @ rev default_params
  11.199 +    val lookup =
  11.200 +      Option.map stringify_raw_param_value o AList.lookup (op =) raw_params
  11.201 +    (* string -> string *)
  11.202 +    fun lookup_string name = the_default "" (lookup name)
  11.203 +    (* string -> bool *)
  11.204 +    val lookup_bool = the o general_lookup_bool false raw_params (SOME false)
  11.205 +    (* string -> bool option *)
  11.206 +    val lookup_bool_option = general_lookup_bool true raw_params NONE
  11.207 +    (* string -> string option -> int *)
  11.208 +    fun do_int name value =
  11.209 +      case value of
  11.210 +        SOME s => (case Int.fromString s of
  11.211 +                     SOME i => i
  11.212 +                   | NONE => error ("Parameter " ^ quote name ^
  11.213 +                                    " must be assigned an integer value."))
  11.214 +      | NONE => 0
  11.215 +    (* string -> int *)
  11.216 +    fun lookup_int name = do_int name (lookup name)
  11.217 +    (* string -> int option *)
  11.218 +    fun lookup_int_option name =
  11.219 +      case lookup name of
  11.220 +        SOME "smart" => NONE
  11.221 +      | value => SOME (do_int name value)
  11.222 +    (* string -> int -> string -> int list *)
  11.223 +    fun int_range_from_string name min_int s =
  11.224 +      let
  11.225 +        val (k1, k2) =
  11.226 +          (case space_explode "-" s of
  11.227 +             [s] => the_default (s, s) (first_field "\<midarrow>" s)
  11.228 +           | ["", s2] => ("-" ^ s2, "-" ^ s2)
  11.229 +           | [s1, s2] => (s1, s2)
  11.230 +           | _ => raise Option)
  11.231 +          |> pairself (maxed_int_from_string min_int)
  11.232 +      in if k1 <= k2 then k1 upto k2 else k1 downto k2 end
  11.233 +      handle Option.Option =>
  11.234 +             error ("Parameter " ^ quote name ^
  11.235 +                    " must be assigned a sequence of integers.")
  11.236 +    (* string -> int -> string -> int list *)
  11.237 +    fun int_seq_from_string name min_int s =
  11.238 +      maps (int_range_from_string name min_int) (space_explode "," s)
  11.239 +    (* string -> int -> int list *)
  11.240 +    fun lookup_int_seq name min_int =
  11.241 +      case lookup name of
  11.242 +        SOME s => (case int_seq_from_string name min_int s of
  11.243 +                     [] => [min_int]
  11.244 +                   | value => value)
  11.245 +      | NONE => [min_int]
  11.246 +    (* (string -> 'a) -> int -> string -> ('a option * int list) list *)
  11.247 +    fun lookup_ints_assigns read prefix min_int =
  11.248 +      (NONE, lookup_int_seq prefix min_int)
  11.249 +      :: map (fn (name, value) =>
  11.250 +                 (SOME (read (String.extract (name, size prefix + 1, NONE))),
  11.251 +                  value |> stringify_raw_param_value
  11.252 +                        |> int_seq_from_string name min_int))
  11.253 +             (filter (String.isPrefix (prefix ^ " ") o fst) raw_params)
  11.254 +    (* (string -> 'a) -> string -> ('a option * bool option) list *)
  11.255 +    fun lookup_bool_option_assigns read prefix =
  11.256 +      (NONE, lookup_bool_option prefix)
  11.257 +      :: map (fn (name, value) =>
  11.258 +                 (SOME (read (String.extract (name, size prefix + 1, NONE))),
  11.259 +                  value |> stringify_raw_param_value
  11.260 +                        |> bool_option_from_string true name))
  11.261 +             (filter (String.isPrefix (prefix ^ " ") o fst) raw_params)
  11.262 +    (* string -> Time.time option *)
  11.263 +    fun lookup_time name =
  11.264 +      case lookup name of
  11.265 +        NONE => NONE
  11.266 +      | SOME "none" => NONE
  11.267 +      | SOME s =>
  11.268 +        let
  11.269 +          val msecs =
  11.270 +            case space_explode " " s of
  11.271 +              [s1, "min"] => 60000 * the (Int.fromString s1)
  11.272 +            | [s1, "s"] => 1000 * the (Int.fromString s1)
  11.273 +            | [s1, "ms"] => the (Int.fromString s1)
  11.274 +            | _ => 0
  11.275 +        in
  11.276 +          if msecs <= 0 then
  11.277 +            error ("Parameter " ^ quote name ^ " must be assigned a positive \
  11.278 +                   \time value (e.g., \"60 s\", \"200 ms\") or \"none\".")
  11.279 +          else
  11.280 +            SOME (Time.fromMilliseconds msecs)
  11.281 +        end
  11.282 +    (* string -> term list *)
  11.283 +    val lookup_term_list =
  11.284 +      AList.lookup (op =) raw_params #> these #> Syntax.read_terms ctxt
  11.285 +    val read_type_polymorphic =
  11.286 +      Syntax.read_typ ctxt #> Logic.mk_type
  11.287 +      #> singleton (Variable.polymorphic ctxt) #> Logic.dest_type
  11.288 +    (* string -> term *)
  11.289 +    val read_term_polymorphic =
  11.290 +      Syntax.read_term ctxt #> singleton (Variable.polymorphic ctxt)
  11.291 +    (* string -> styp *)
  11.292 +    val read_const_polymorphic = read_term_polymorphic #> dest_Const
  11.293 +    val cards_assigns = lookup_ints_assigns read_type_polymorphic "card" 1
  11.294 +    val maxes_assigns = lookup_ints_assigns read_const_polymorphic "max" ~1
  11.295 +    val iters_assigns = lookup_ints_assigns read_const_polymorphic "iter" 0
  11.296 +    val bisim_depths = lookup_int_seq "bisim_depth" ~1
  11.297 +    val boxes =
  11.298 +      lookup_bool_option_assigns read_type_polymorphic "box" @
  11.299 +      map_filter (fn (SOME T, _) =>
  11.300 +                     if is_fun_type T orelse is_pair_type T then
  11.301 +                       SOME (SOME T, SOME true)
  11.302 +                     else
  11.303 +                       NONE
  11.304 +                   | (NONE, _) => NONE) cards_assigns
  11.305 +    val monos = lookup_bool_option_assigns read_type_polymorphic "mono"
  11.306 +    val wfs = lookup_bool_option_assigns read_const_polymorphic "wf"
  11.307 +    val sat_solver = lookup_string "sat_solver"
  11.308 +    val blocking = not auto andalso lookup_bool "blocking"
  11.309 +    val falsify = lookup_bool "falsify"
  11.310 +    val debug = not auto andalso lookup_bool "debug"
  11.311 +    val verbose = debug orelse (not auto andalso lookup_bool "verbose")
  11.312 +    val overlord = lookup_bool "overlord"
  11.313 +    val user_axioms = lookup_bool_option "user_axioms"
  11.314 +    val assms = lookup_bool "assms"
  11.315 +    val coalesce_type_vars = lookup_bool "coalesce_type_vars"
  11.316 +    val destroy_constrs = lookup_bool "destroy_constrs"
  11.317 +    val specialize = lookup_bool "specialize"
  11.318 +    val skolemize = lookup_bool "skolemize"
  11.319 +    val star_linear_preds = lookup_bool "star_linear_preds"
  11.320 +    val uncurry = lookup_bool "uncurry"
  11.321 +    val fast_descrs = lookup_bool "fast_descrs"
  11.322 +    val peephole_optim = lookup_bool "peephole_optim"
  11.323 +    val timeout = if auto then lookup_time "auto_timeout"
  11.324 +                  else lookup_time "timeout"
  11.325 +    val tac_timeout = lookup_time "tac_timeout"
  11.326 +    val sym_break = Int.max (0, lookup_int "sym_break")
  11.327 +    val sharing_depth = Int.max (1, lookup_int "sharing_depth")
  11.328 +    val flatten_props = lookup_bool "flatten_props"
  11.329 +    val max_threads = Int.max (0, lookup_int "max_threads")
  11.330 +    val show_all = debug orelse lookup_bool "show_all"
  11.331 +    val show_skolems = show_all orelse lookup_bool "show_skolems"
  11.332 +    val show_datatypes = show_all orelse lookup_bool "show_datatypes"
  11.333 +    val show_consts = show_all orelse lookup_bool "show_consts"
  11.334 +    val formats = lookup_ints_assigns read_term_polymorphic "format" 0
  11.335 +    val evals = lookup_term_list "eval"
  11.336 +    val max_potential = if auto then 0
  11.337 +                        else Int.max (0, lookup_int "max_potential")
  11.338 +    val max_genuine = Int.max (0, lookup_int "max_genuine")
  11.339 +    val check_potential = lookup_bool "check_potential"
  11.340 +    val check_genuine = lookup_bool "check_genuine"
  11.341 +    val batch_size = case lookup_int_option "batch_size" of
  11.342 +                       SOME n => Int.max (1, n)
  11.343 +                     | NONE => if debug then 1 else 64
  11.344 +    val expect = lookup_string "expect"
  11.345 +  in
  11.346 +    {cards_assigns = cards_assigns, maxes_assigns = maxes_assigns,
  11.347 +     iters_assigns = iters_assigns, bisim_depths = bisim_depths, boxes = boxes,
  11.348 +     monos = monos, wfs = wfs, sat_solver = sat_solver, blocking = blocking,
  11.349 +     falsify = falsify, debug = debug, verbose = verbose, overlord = overlord,
  11.350 +     user_axioms = user_axioms, assms = assms,
  11.351 +     coalesce_type_vars = coalesce_type_vars, destroy_constrs = destroy_constrs,
  11.352 +     specialize = specialize, skolemize = skolemize,
  11.353 +     star_linear_preds = star_linear_preds, uncurry = uncurry,
  11.354 +     fast_descrs = fast_descrs, peephole_optim = peephole_optim,
  11.355 +     timeout = timeout, tac_timeout = tac_timeout, sym_break = sym_break,
  11.356 +     sharing_depth = sharing_depth, flatten_props = flatten_props,
  11.357 +     max_threads = max_threads, show_skolems = show_skolems,
  11.358 +     show_datatypes = show_datatypes, show_consts = show_consts,
  11.359 +     formats = formats, evals = evals, max_potential = max_potential,
  11.360 +     max_genuine = max_genuine, check_potential = check_potential,
  11.361 +     check_genuine = check_genuine, batch_size = batch_size, expect = expect}
  11.362 +  end
  11.363 +
  11.364 +(* theory -> (string * string) list -> params *)
  11.365 +fun default_params thy =
  11.366 +  extract_params (ProofContext.init thy) false (default_raw_params thy)
  11.367 +  o map (apsnd single)
  11.368 +
  11.369 +(* OuterParse.token list -> string * OuterParse.token list *)
  11.370 +val scan_key = Scan.repeat1 OuterParse.typ_group >> space_implode " "
  11.371 +
  11.372 +(* OuterParse.token list -> string list * OuterParse.token list *)
  11.373 +val scan_value =
  11.374 +  Scan.repeat1 (OuterParse.minus >> single
  11.375 +                || Scan.repeat1 (Scan.unless OuterParse.minus OuterParse.name)
  11.376 +                || OuterParse.$$$ "," |-- OuterParse.number >> prefix ","
  11.377 +                   >> single) >> flat
  11.378 +
  11.379 +(* OuterParse.token list -> raw_param * OuterParse.token list *)
  11.380 +val scan_param =
  11.381 +  scan_key -- (Scan.option (OuterParse.$$$ "=" |-- scan_value) >> these)
  11.382 +(* OuterParse.token list -> raw_param list option * OuterParse.token list *)
  11.383 +val scan_params = Scan.option (OuterParse.$$$ "[" |-- OuterParse.list scan_param
  11.384 +                               --| OuterParse.$$$ "]")
  11.385 +
  11.386 +(* Proof.context -> ('a -> 'a) -> 'a -> 'a *)
  11.387 +fun handle_exceptions ctxt f x =
  11.388 +  f x
  11.389 +  handle ARG (loc, details) =>
  11.390 +         error ("Bad argument(s) to " ^ quote loc ^ ": " ^ details ^ ".")
  11.391 +       | BAD (loc, details) =>
  11.392 +         error ("Internal error (" ^ quote loc ^ "): " ^ details ^ ".")
  11.393 +       | LIMIT (_, details) =>
  11.394 +         (warning ("Limit reached: " ^ details ^ "."); x)
  11.395 +       | NOT_SUPPORTED details =>
  11.396 +         (warning ("Unsupported case: " ^ details ^ "."); x)
  11.397 +       | NUT (loc, us) =>
  11.398 +         error ("Invalid intermediate term" ^ plural_s_for_list us ^
  11.399 +                " (" ^ quote loc ^ "): " ^
  11.400 +                commas (map (string_for_nut ctxt) us) ^ ".")
  11.401 +       | REP (loc, Rs) =>
  11.402 +         error ("Invalid representation" ^ plural_s_for_list Rs ^
  11.403 +                " (" ^ quote loc ^ "): " ^ commas (map string_for_rep Rs) ^ ".")
  11.404 +       | TERM (loc, ts) =>
  11.405 +         error ("Invalid term" ^ plural_s_for_list ts ^
  11.406 +                " (" ^ quote loc ^ "): " ^
  11.407 +                commas (map (Syntax.string_of_term ctxt) ts) ^ ".")
  11.408 +       | TYPE (loc, Ts, ts) =>
  11.409 +         error ("Invalid type" ^ plural_s_for_list Ts ^
  11.410 +                (if null ts then
  11.411 +                   ""
  11.412 +                 else
  11.413 +                   " for term" ^ plural_s_for_list ts ^ " " ^
  11.414 +                   commas (map (quote o Syntax.string_of_term ctxt) ts)) ^
  11.415 +                " (" ^ quote loc ^ "): " ^
  11.416 +                commas (map (Syntax.string_of_typ ctxt) Ts) ^ ".")
  11.417 +       | Kodkod.SYNTAX (_, details) =>
  11.418 +         (warning ("Ill-formed Kodkodi output: " ^ details ^ "."); x)
  11.419 +       | Refute.REFUTE (loc, details) =>
  11.420 +         error ("Unhandled Refute error (" ^ quote loc ^ "): " ^ details ^ ".")
  11.421 +
  11.422 +(* raw_param list -> bool -> int -> Proof.state -> Proof.state *)
  11.423 +fun pick_nits override_params auto subgoal state =
  11.424 +  let
  11.425 +    val thy = Proof.theory_of state
  11.426 +    val ctxt = Proof.context_of state
  11.427 +    val thm = snd (snd (Proof.get_goal state))
  11.428 +    val _ = List.app check_raw_param override_params
  11.429 +    val params as {blocking, debug, ...} =
  11.430 +      extract_params ctxt auto (default_raw_params thy) override_params
  11.431 +    (* unit -> Proof.state *)
  11.432 +    fun go () =
  11.433 +      (if auto then perhaps o try
  11.434 +       else if debug then fn f => fn x => f x
  11.435 +       else handle_exceptions ctxt)
  11.436 +      (fn state => pick_nits_in_subgoal state params auto subgoal |> snd)
  11.437 +      state
  11.438 +  in
  11.439 +    if auto orelse blocking then
  11.440 +      go ()
  11.441 +    else
  11.442 +      (SimpleThread.fork true (fn () => (go (); ()) handle Exn.Interrupt => ());
  11.443 +       state)
  11.444 +  end
  11.445 +
  11.446 +(* (TableFun().key * string list) list option * int option
  11.447 +   -> Toplevel.transition -> Toplevel.transition *)
  11.448 +fun nitpick_trans (opt_params, opt_subgoal) =
  11.449 +  Toplevel.keep (K ()
  11.450 +      o pick_nits (these opt_params) false (the_default 1 opt_subgoal)
  11.451 +      o Toplevel.proof_of)
  11.452 +
  11.453 +(* raw_param -> string *)
  11.454 +fun string_for_raw_param (name, value) =
  11.455 +  name ^ " = " ^ stringify_raw_param_value value
  11.456 +
  11.457 +(* bool -> Proof.state -> Proof.state *)
  11.458 +fun pick_nits_auto interactive state =
  11.459 +  let val thy = Proof.theory_of state in
  11.460 +    ((interactive andalso not (!Toplevel.quiet)
  11.461 +      andalso the (general_lookup_bool false (default_raw_params thy)
  11.462 +                  (SOME false) "auto"))
  11.463 +     ? pick_nits [] true 0) state
  11.464 +  end
  11.465 +
  11.466 +(* theory -> theory *)
  11.467 +fun register_auto thy =
  11.468 +  (not (is_registered_auto thy)
  11.469 +   ? (set_registered_auto
  11.470 +      #> Context.theory_map (Specification.add_theorem_hook pick_nits_auto)))
  11.471 +  thy
  11.472 +
  11.473 +(* (TableFun().key * string) list option -> Toplevel.transition
  11.474 +   -> Toplevel.transition *)
  11.475 +fun nitpick_params_trans opt_params =
  11.476 +  Toplevel.theory
  11.477 +      (fn thy =>
  11.478 +          let val thy = fold set_default_raw_param (these opt_params) thy in
  11.479 +            writeln ("Default parameters for Nitpick:\n" ^
  11.480 +                     (case rev (default_raw_params thy) of
  11.481 +                        [] => "none"
  11.482 +                      | params =>
  11.483 +                        (map check_raw_param params;
  11.484 +                         params |> map string_for_raw_param |> sort_strings
  11.485 +                                |> cat_lines)));
  11.486 +            register_auto thy
  11.487 +          end)
  11.488 +
  11.489 +(* OuterParse.token list
  11.490 +   -> (Toplevel.transition -> Toplevel.transition) * OuterParse.token list *)
  11.491 +fun scan_nitpick_command tokens =
  11.492 +  (scan_params -- Scan.option OuterParse.nat) tokens |>> nitpick_trans
  11.493 +fun scan_nitpick_params_command tokens =
  11.494 +  scan_params tokens |>> nitpick_params_trans
  11.495 +
  11.496 +val _ = OuterSyntax.improper_command "nitpick"
  11.497 +            "try to find a counterexample for a given subgoal using Kodkod"
  11.498 +            OuterKeyword.diag scan_nitpick_command
  11.499 +val _ = OuterSyntax.command "nitpick_params"
  11.500 +            "set and display the default parameters for Nitpick"
  11.501 +            OuterKeyword.thy_decl scan_nitpick_params_command
  11.502 +
  11.503 +end;
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOL/Tools/Nitpick/nitpick_kodkod.ML	Thu Oct 22 14:51:47 2009 +0200
    12.3 @@ -0,0 +1,1737 @@
    12.4 +(*  Title:      HOL/Nitpick/Tools/nitpick_kodkod.ML
    12.5 +    Author:     Jasmin Blanchette, TU Muenchen
    12.6 +    Copyright   2008, 2009
    12.7 +
    12.8 +Kodkod problem generator part of Kodkod.
    12.9 +*)
   12.10 +
   12.11 +signature NITPICK_KODKOD =
   12.12 +sig
   12.13 +  type extended_context = NitpickHOL.extended_context
   12.14 +  type dtype_spec = NitpickScope.dtype_spec
   12.15 +  type kodkod_constrs = NitpickPeephole.kodkod_constrs
   12.16 +  type nut = NitpickNut.nut
   12.17 +  type nfa_transition = Kodkod.rel_expr * typ
   12.18 +  type nfa_entry = typ * nfa_transition list
   12.19 +  type nfa_table = nfa_entry list
   12.20 +
   12.21 +  structure NameTable : TABLE
   12.22 +
   12.23 +  val univ_card :
   12.24 +    int -> int -> int -> Kodkod.bound list -> Kodkod.formula -> int
   12.25 +  val check_arity : int -> int -> unit
   12.26 +  val kk_tuple : bool -> int -> int list -> Kodkod.tuple
   12.27 +  val tuple_set_from_atom_schema : (int * int) list -> Kodkod.tuple_set
   12.28 +  val sequential_int_bounds : int -> Kodkod.int_bound list
   12.29 +  val bounds_for_built_in_rels_in_formula :
   12.30 +    bool -> int -> int -> int -> int -> Kodkod.formula -> Kodkod.bound list
   12.31 +  val bound_for_plain_rel : Proof.context -> bool -> nut -> Kodkod.bound
   12.32 +  val bound_for_sel_rel :
   12.33 +    Proof.context -> bool -> dtype_spec list -> nut -> Kodkod.bound
   12.34 +  val merge_bounds : Kodkod.bound list -> Kodkod.bound list
   12.35 +  val declarative_axiom_for_plain_rel : kodkod_constrs -> nut -> Kodkod.formula
   12.36 +  val declarative_axioms_for_datatypes :
   12.37 +    extended_context -> int Typtab.table -> kodkod_constrs
   12.38 +    -> nut NameTable.table -> dtype_spec list -> Kodkod.formula list
   12.39 +  val kodkod_formula_from_nut :
   12.40 +    int Typtab.table -> bool -> kodkod_constrs -> nut -> Kodkod.formula
   12.41 +end;
   12.42 +
   12.43 +structure NitpickKodkod : NITPICK_KODKOD =
   12.44 +struct
   12.45 +
   12.46 +open NitpickUtil
   12.47 +open NitpickHOL
   12.48 +open NitpickScope
   12.49 +open NitpickPeephole
   12.50 +open NitpickRep
   12.51 +open NitpickNut
   12.52 +
   12.53 +type nfa_transition = Kodkod.rel_expr * typ
   12.54 +type nfa_entry = typ * nfa_transition list
   12.55 +type nfa_table = nfa_entry list
   12.56 +
   12.57 +structure NfaGraph = Graph(type key = typ val ord = TermOrd.typ_ord)
   12.58 +
   12.59 +(* int -> Kodkod.int_expr list *)
   12.60 +fun flip_nums n = index_seq 1 n @ [0] |> map Kodkod.Num
   12.61 +
   12.62 +(* int -> int -> int -> Kodkod.bound list -> Kodkod.formula -> int *)
   12.63 +fun univ_card nat_card int_card main_j0 bounds formula =
   12.64 +  let
   12.65 +    (* Kodkod.rel_expr -> int -> int *)
   12.66 +    fun rel_expr_func r k =
   12.67 +      Int.max (k, case r of
   12.68 +                    Kodkod.Atom j => j + 1
   12.69 +                  | Kodkod.AtomSeq (k', j0) => j0 + k'
   12.70 +                  | _ => 0)
   12.71 +    (* Kodkod.tuple -> int -> int *)
   12.72 +    fun tuple_func t k =
   12.73 +      case t of
   12.74 +        Kodkod.Tuple js => fold Integer.max (map (Integer.add 1) js) k
   12.75 +      | _ => k
   12.76 +    (* Kodkod.tuple_set -> int -> int *)
   12.77 +    fun tuple_set_func ts k =
   12.78 +      Int.max (k, case ts of Kodkod.TupleAtomSeq (k', j0) => j0 + k' | _ => 0)
   12.79 +    val expr_F = {formula_func = K I, rel_expr_func = rel_expr_func,
   12.80 +                  int_expr_func = K I}
   12.81 +    val tuple_F = {tuple_func = tuple_func, tuple_set_func = tuple_set_func}
   12.82 +    val card = fold (Kodkod.fold_bound expr_F tuple_F) bounds 1
   12.83 +               |> Kodkod.fold_formula expr_F formula
   12.84 +  in Int.max (main_j0 + fold Integer.max [2, nat_card, int_card] 0, card) end
   12.85 +
   12.86 +(* Proof.context -> bool -> string -> typ -> rep -> string *)
   12.87 +fun bound_comment ctxt debug nick T R =
   12.88 +  short_const_name nick ^
   12.89 +  (if debug then " :: " ^ plain_string_from_yxml (Syntax.string_of_typ ctxt T)
   12.90 +   else "") ^ " : " ^ string_for_rep R
   12.91 +
   12.92 +(* int -> int -> unit *)
   12.93 +fun check_arity univ_card n =
   12.94 +  if n > Kodkod.max_arity univ_card then
   12.95 +    raise LIMIT ("NitpickKodkod.check_arity",
   12.96 +                 "arity " ^ string_of_int n ^ " too large for universe of \
   12.97 +                 \cardinality " ^ string_of_int univ_card)
   12.98 +  else
   12.99 +    ()
  12.100 +
  12.101 +(* bool -> int -> int list -> Kodkod.tuple *)
  12.102 +fun kk_tuple debug univ_card js =
  12.103 +  if debug then
  12.104 +    Kodkod.Tuple js
  12.105 +  else
  12.106 +    Kodkod.TupleIndex (length js,
  12.107 +                       fold (fn j => fn accum => accum * univ_card + j) js 0)
  12.108 +
  12.109 +(* (int * int) list -> Kodkod.tuple_set *)
  12.110 +val tuple_set_from_atom_schema =
  12.111 +  foldl1 Kodkod.TupleProduct o map Kodkod.TupleAtomSeq
  12.112 +(* rep -> Kodkod.tuple_set *)
  12.113 +val upper_bound_for_rep = tuple_set_from_atom_schema o atom_schema_of_rep
  12.114 +
  12.115 +(* int -> Kodkod.int_bound list *)
  12.116 +fun sequential_int_bounds n =
  12.117 +  [(NONE, map (Kodkod.TupleSet o single o Kodkod.Tuple o single)
  12.118 +              (index_seq 0 n))]
  12.119 +
  12.120 +(* Kodkod.formula -> Kodkod.n_ary_index list *)
  12.121 +fun built_in_rels_in_formula formula =
  12.122 +  let
  12.123 +    (* Kodkod.rel_expr -> Kodkod.n_ary_index list -> Kodkod.n_ary_index list *)
  12.124 +    fun rel_expr_func (Kodkod.Rel (n, j)) rels =
  12.125 +        (case AList.lookup (op =) (#rels initial_pool) n of
  12.126 +           SOME k => (j < k ? insert (op =) (n, j)) rels
  12.127 +         | NONE => rels)
  12.128 +      | rel_expr_func _ rels = rels
  12.129 +    val expr_F = {formula_func = K I, rel_expr_func = rel_expr_func,
  12.130 +                  int_expr_func = K I}
  12.131 +  in Kodkod.fold_formula expr_F formula [] end
  12.132 +
  12.133 +val max_table_size = 65536
  12.134 +
  12.135 +(* int -> unit *)
  12.136 +fun check_table_size k =
  12.137 +  if k > max_table_size then
  12.138 +    raise LIMIT ("NitpickKodkod.check_table_size",
  12.139 +                 "precomputed table too large (" ^ string_of_int k ^ ")")
  12.140 +  else
  12.141 +    ()
  12.142 +
  12.143 +(* bool -> int -> int * int -> (int -> int) -> Kodkod.tuple list *)
  12.144 +fun tabulate_func1 debug univ_card (k, j0) f =
  12.145 +  (check_table_size k;
  12.146 +   map_filter (fn j1 => let val j2 = f j1 in
  12.147 +                          if j2 >= 0 then
  12.148 +                            SOME (kk_tuple debug univ_card [j1 + j0, j2 + j0])
  12.149 +                          else
  12.150 +                            NONE
  12.151 +                        end) (index_seq 0 k))
  12.152 +(* bool -> int -> int * int -> int -> (int * int -> int) -> Kodkod.tuple list *)
  12.153 +fun tabulate_op2 debug univ_card (k, j0) res_j0 f =
  12.154 +  (check_table_size (k * k);
  12.155 +   map_filter (fn j => let
  12.156 +                         val j1 = j div k
  12.157 +                         val j2 = j - j1 * k
  12.158 +                         val j3 = f (j1, j2)
  12.159 +                       in
  12.160 +                         if j3 >= 0 then
  12.161 +                           SOME (kk_tuple debug univ_card
  12.162 +                                          [j1 + j0, j2 + j0, j3 + res_j0])
  12.163 +                         else
  12.164 +                           NONE
  12.165 +                       end) (index_seq 0 (k * k)))
  12.166 +(* bool -> int -> int * int -> int -> (int * int -> int * int)
  12.167 +   -> Kodkod.tuple list *)
  12.168 +fun tabulate_op2_2 debug univ_card (k, j0) res_j0 f =
  12.169 +  (check_table_size (k * k);
  12.170 +   map_filter (fn j => let
  12.171 +                         val j1 = j div k
  12.172 +                         val j2 = j - j1 * k
  12.173 +                         val (j3, j4) = f (j1, j2)
  12.174 +                       in
  12.175 +                         if j3 >= 0 andalso j4 >= 0 then
  12.176 +                           SOME (kk_tuple debug univ_card
  12.177 +                                          [j1 + j0, j2 + j0, j3 + res_j0,
  12.178 +                                           j4 + res_j0])
  12.179 +                         else
  12.180 +                           NONE
  12.181 +                       end) (index_seq 0 (k * k)))
  12.182 +(* bool -> int -> int * int -> (int * int -> int) -> Kodkod.tuple list *)
  12.183 +fun tabulate_nat_op2 debug univ_card (k, j0) f =
  12.184 +  tabulate_op2 debug univ_card (k, j0) j0 (atom_for_nat (k, 0) o f)
  12.185 +fun tabulate_int_op2 debug univ_card (k, j0) f =
  12.186 +  tabulate_op2 debug univ_card (k, j0) j0
  12.187 +               (atom_for_int (k, 0) o f o pairself (int_for_atom (k, 0)))
  12.188 +(* bool -> int -> int * int -> (int * int -> int * int) -> Kodkod.tuple list *)
  12.189 +fun tabulate_int_op2_2 debug univ_card (k, j0) f =
  12.190 +  tabulate_op2_2 debug univ_card (k, j0) j0
  12.191 +                 (pairself (atom_for_int (k, 0)) o f
  12.192 +                  o pairself (int_for_atom (k, 0)))
  12.193 +
  12.194 +(* int * int -> int *)
  12.195 +fun isa_div (m, n) = m div n handle General.Div => 0
  12.196 +fun isa_mod (m, n) = m mod n handle General.Div => m
  12.197 +fun isa_gcd (m, 0) = m
  12.198 +  | isa_gcd (m, n) = isa_gcd (n, isa_mod (m, n))
  12.199 +fun isa_lcm (m, n) = isa_div (m * n, isa_gcd (m, n))
  12.200 +val isa_zgcd = isa_gcd o pairself abs
  12.201 +(* int * int -> int * int *)
  12.202 +fun isa_norm_frac (m, n) =
  12.203 +  if n < 0 then isa_norm_frac (~m, ~n)
  12.204 +  else if m = 0 orelse n = 0 then (0, 1)
  12.205 +  else let val p = isa_zgcd (m, n) in (isa_div (m, p), isa_div (n, p)) end
  12.206 +
  12.207 +(* bool -> int -> int -> int -> int -> int * int
  12.208 +   -> string * bool * Kodkod.tuple list *)
  12.209 +fun tabulate_built_in_rel debug univ_card nat_card int_card j0 (x as (n, _)) =
  12.210 +  (check_arity univ_card n;
  12.211 +   if Kodkod.Rel x = not3_rel then
  12.212 +     ("not3", tabulate_func1 debug univ_card (2, j0) (curry (op -) 1))
  12.213 +   else if Kodkod.Rel x = suc_rel then
  12.214 +     ("suc", tabulate_func1 debug univ_card (univ_card - j0 - 1, j0)
  12.215 +                            (Integer.add 1))
  12.216 +   else if Kodkod.Rel x = nat_add_rel then
  12.217 +     ("nat_add", tabulate_nat_op2 debug univ_card (nat_card, j0) (op +))
  12.218 +   else if Kodkod.Rel x = int_add_rel then
  12.219 +     ("int_add", tabulate_int_op2 debug univ_card (int_card, j0) (op +))
  12.220 +   else if Kodkod.Rel x = nat_subtract_rel then
  12.221 +     ("nat_subtract",
  12.222 +      tabulate_op2 debug univ_card (nat_card, j0) j0 (op nat_minus))
  12.223 +   else if Kodkod.Rel x = int_subtract_rel then
  12.224 +     ("int_subtract", tabulate_int_op2 debug univ_card (int_card, j0) (op -))
  12.225 +   else if Kodkod.Rel x = nat_multiply_rel then
  12.226 +     ("nat_multiply", tabulate_nat_op2 debug univ_card (nat_card, j0) (op * ))
  12.227 +   else if Kodkod.Rel x = int_multiply_rel then
  12.228 +     ("int_multiply", tabulate_int_op2 debug univ_card (int_card, j0) (op * ))
  12.229 +   else if Kodkod.Rel x = nat_divide_rel then
  12.230 +     ("nat_divide", tabulate_nat_op2 debug univ_card (nat_card, j0) isa_div)
  12.231 +   else if Kodkod.Rel x = int_divide_rel then
  12.232 +     ("int_divide", tabulate_int_op2 debug univ_card (int_card, j0) isa_div)
  12.233 +   else if Kodkod.Rel x = nat_modulo_rel then
  12.234 +     ("nat_modulo", tabulate_nat_op2 debug univ_card (nat_card, j0) isa_mod)
  12.235 +   else if Kodkod.Rel x = int_modulo_rel then
  12.236 +     ("int_modulo", tabulate_int_op2 debug univ_card (int_card, j0) isa_mod)
  12.237 +   else if Kodkod.Rel x = nat_less_rel then
  12.238 +     ("nat_less", tabulate_nat_op2 debug univ_card (nat_card, j0)
  12.239 +                                   (int_for_bool o op <))
  12.240 +   else if Kodkod.Rel x = int_less_rel then
  12.241 +     ("int_less", tabulate_int_op2 debug univ_card (int_card, j0)
  12.242 +                                   (int_for_bool o op <))
  12.243 +   else if Kodkod.Rel x = gcd_rel then
  12.244 +     ("gcd", tabulate_nat_op2 debug univ_card (nat_card, j0) isa_gcd)
  12.245 +   else if Kodkod.Rel x = lcm_rel then
  12.246 +     ("lcm", tabulate_nat_op2 debug univ_card (nat_card, j0) isa_lcm)
  12.247 +   else if Kodkod.Rel x = norm_frac_rel then
  12.248 +     ("norm_frac", tabulate_int_op2_2 debug univ_card (int_card, j0)
  12.249 +                                      isa_norm_frac)
  12.250 +   else
  12.251 +     raise ARG ("NitpickKodkod.tabulate_built_in_rel", "unknown relation"))
  12.252 +
  12.253 +(* bool -> int -> int -> int -> int -> int * int -> Kodkod.rel_expr
  12.254 +   -> Kodkod.bound *)
  12.255 +fun bound_for_built_in_rel debug univ_card nat_card int_card j0 x =
  12.256 +  let
  12.257 +    val (nick, ts) = tabulate_built_in_rel debug univ_card nat_card int_card
  12.258 +                                           j0 x
  12.259 +  in ([(x, nick)], [Kodkod.TupleSet ts]) end
  12.260 +
  12.261 +(* bool -> int -> int -> int -> int -> Kodkod.formula -> Kodkod.bound list *)
  12.262 +fun bounds_for_built_in_rels_in_formula debug univ_card nat_card int_card j0 =
  12.263 +  map (bound_for_built_in_rel debug univ_card nat_card int_card j0)
  12.264 +  o built_in_rels_in_formula
  12.265 +
  12.266 +(* Proof.context -> bool -> nut -> Kodkod.bound *)
  12.267 +fun bound_for_plain_rel ctxt debug (u as FreeRel (x, T, R, nick)) =
  12.268 +    ([(x, bound_comment ctxt debug nick T R)],
  12.269 +     if nick = @{const_name bisim_iterator_max} then
  12.270 +       case R of
  12.271 +         Atom (k, j0) => [Kodkod.TupleSet [Kodkod.Tuple [k - 1 + j0]]]
  12.272 +       | _ => raise NUT ("NitpickKodkod.bound_for_plain_rel", [u])
  12.273 +     else
  12.274 +       [Kodkod.TupleSet [], upper_bound_for_rep R])
  12.275 +  | bound_for_plain_rel _ _ u =
  12.276 +    raise NUT ("NitpickKodkod.bound_for_plain_rel", [u])
  12.277 +
  12.278 +(* Proof.context -> bool -> dtype_spec list -> nut -> Kodkod.bound *)
  12.279 +fun bound_for_sel_rel ctxt debug dtypes
  12.280 +        (FreeRel (x, T as Type ("fun", [T1, T2]), R as Func (Atom (_, j0), R2),
  12.281 +                  nick)) =
  12.282 +    let
  12.283 +      val constr as {delta, epsilon, exclusive, explicit_max, ...} =
  12.284 +        constr_spec dtypes (original_name nick, T1)
  12.285 +    in
  12.286 +      ([(x, bound_comment ctxt debug nick T R)],
  12.287 +       if explicit_max = 0 then
  12.288 +         [Kodkod.TupleSet []]
  12.289 +       else
  12.290 +         let val ts = Kodkod.TupleAtomSeq (epsilon - delta, delta + j0) in
  12.291 +           if R2 = Formula Neut then
  12.292 +             [ts] |> not exclusive ? cons (Kodkod.TupleSet [])
  12.293 +           else
  12.294 +             [Kodkod.TupleSet [],
  12.295 +              Kodkod.TupleProduct (ts, upper_bound_for_rep R2)]
  12.296 +         end)
  12.297 +    end
  12.298 +  | bound_for_sel_rel _ _ _ u =
  12.299 +    raise NUT ("NitpickKodkod.bound_for_sel_rel", [u])
  12.300 +
  12.301 +(* Kodkod.bound list -> Kodkod.bound list *)
  12.302 +fun merge_bounds bs =
  12.303 +  let
  12.304 +    (* Kodkod.bound -> int *)
  12.305 +    fun arity (zs, _) = fst (fst (hd zs))
  12.306 +    (* Kodkod.bound list -> Kodkod.bound -> Kodkod.bound list
  12.307 +       -> Kodkod.bound list *)
  12.308 +    fun add_bound ds b [] = List.revAppend (ds, [b])
  12.309 +      | add_bound ds b (c :: cs) =
  12.310 +        if arity b = arity c andalso snd b = snd c then
  12.311 +          List.revAppend (ds, (fst c @ fst b, snd c) :: cs)
  12.312 +        else
  12.313 +          add_bound (c :: ds) b cs
  12.314 +  in fold (add_bound []) bs [] end
  12.315 +
  12.316 +(* int -> int -> Kodkod.rel_expr list *)
  12.317 +fun unary_var_seq j0 n = map (curry Kodkod.Var 1) (index_seq j0 n)
  12.318 +
  12.319 +(* int list -> Kodkod.rel_expr *)
  12.320 +val singleton_from_combination = foldl1 Kodkod.Product o map Kodkod.Atom
  12.321 +(* rep -> Kodkod.rel_expr list *)
  12.322 +fun all_singletons_for_rep R =
  12.323 +  if is_lone_rep R then
  12.324 +    all_combinations_for_rep R |> map singleton_from_combination
  12.325 +  else
  12.326 +    raise REP ("NitpickKodkod.all_singletons_for_rep", [R])
  12.327 +
  12.328 +(* Kodkod.rel_expr -> Kodkod.rel_expr list *)
  12.329 +fun unpack_products (Kodkod.Product (r1, r2)) =
  12.330 +    unpack_products r1 @ unpack_products r2
  12.331 +  | unpack_products r = [r]
  12.332 +fun unpack_joins (Kodkod.Join (r1, r2)) = unpack_joins r1 @ unpack_joins r2
  12.333 +  | unpack_joins r = [r]
  12.334 +
  12.335 +(* rep -> Kodkod.rel_expr *)
  12.336 +val empty_rel_for_rep = empty_n_ary_rel o arity_of_rep
  12.337 +fun full_rel_for_rep R =
  12.338 +  case atom_schema_of_rep R of
  12.339 +    [] => raise REP ("NitpickKodkod.full_rel_for_rep", [R])
  12.340 +  | schema => foldl1 Kodkod.Product (map Kodkod.AtomSeq schema)
  12.341 +
  12.342 +(* int -> int list -> Kodkod.decl list *)
  12.343 +fun decls_for_atom_schema j0 schema =
  12.344 +  map2 (fn j => fn x => Kodkod.DeclOne ((1, j), Kodkod.AtomSeq x))
  12.345 +       (index_seq j0 (length schema)) schema
  12.346 +
  12.347 +(* The type constraint below is a workaround for a Poly/ML bug. *)
  12.348 +
  12.349 +(* FIXME: clean up *)
  12.350 +(* kodkod_constrs -> rep -> Kodkod.rel_expr -> Kodkod.formula *)
  12.351 +fun d_n_ary_function ({kk_all, kk_join, kk_lone, kk_one, ...} : kodkod_constrs)
  12.352 +                     R r =
  12.353 +  let val body_R = body_rep R in
  12.354 +    if is_lone_rep body_R then
  12.355 +      let
  12.356 +        val binder_schema = atom_schema_of_reps (binder_reps R)
  12.357 +        val body_schema = atom_schema_of_rep body_R
  12.358 +        val one = is_one_rep body_R
  12.359 +        val opt_x = case r of Kodkod.Rel x => SOME x | _ => NONE
  12.360 +      in
  12.361 +        if opt_x <> NONE andalso length binder_schema = 1
  12.362 +           andalso length body_schema = 1 then
  12.363 +          (if one then Kodkod.Function else Kodkod.Functional)
  12.364 +              (the opt_x, Kodkod.AtomSeq (hd binder_schema),
  12.365 +               Kodkod.AtomSeq (hd body_schema))
  12.366 +        else
  12.367 +          let
  12.368 +            val decls = decls_for_atom_schema ~1 binder_schema
  12.369 +            val vars = unary_var_seq ~1 (length binder_schema)
  12.370 +            val kk_xone = if one then kk_one else kk_lone
  12.371 +          in kk_all decls (kk_xone (fold kk_join vars r)) end
  12.372 +      end
  12.373 +    else
  12.374 +      Kodkod.True
  12.375 +  end
  12.376 +fun kk_n_ary_function kk R (r as Kodkod.Rel _) =
  12.377 +    (* FIXME: weird test *)
  12.378 +    if not (is_opt_rep R) then
  12.379 +      if r = suc_rel then
  12.380 +        Kodkod.False
  12.381 +      else if r = nat_add_rel then
  12.382 +        formula_for_bool (card_of_rep (body_rep R) = 1)
  12.383 +      else if r = nat_multiply_rel then
  12.384 +        formula_for_bool (card_of_rep (body_rep R) <= 2)
  12.385 +      else
  12.386 +        d_n_ary_function kk R r
  12.387 +    else if r = nat_subtract_rel then
  12.388 +      Kodkod.True
  12.389 +    else
  12.390 +      d_n_ary_function kk R r
  12.391 +  | kk_n_ary_function kk R r = d_n_ary_function kk R r
  12.392 +
  12.393 +(* kodkod_constrs -> Kodkod.rel_expr list -> Kodkod.formula *)
  12.394 +fun kk_disjoint_sets _ [] = Kodkod.True
  12.395 +  | kk_disjoint_sets (kk as {kk_and, kk_no, kk_intersect, ...} : kodkod_constrs)
  12.396 +                     (r :: rs) =
  12.397 +    fold (kk_and o kk_no o kk_intersect r) rs (kk_disjoint_sets kk rs)
  12.398 +
  12.399 +(* int -> kodkod_constrs -> (Kodkod.rel_expr -> Kodkod.rel_expr)
  12.400 +   -> Kodkod.rel_expr -> Kodkod.rel_expr *)
  12.401 +fun basic_rel_let j ({kk_rel_let, ...} : kodkod_constrs) f r =
  12.402 +  if inline_rel_expr r then
  12.403 +    f r
  12.404 +  else
  12.405 +    let val x = (Kodkod.arity_of_rel_expr r, j) in
  12.406 +      kk_rel_let [Kodkod.AssignRelReg (x, r)] (f (Kodkod.RelReg x))
  12.407 +    end
  12.408 +
  12.409 +(* kodkod_constrs -> (Kodkod.rel_expr -> Kodkod.rel_expr) -> Kodkod.rel_expr
  12.410 +   -> Kodkod.rel_expr *)
  12.411 +val single_rel_let = basic_rel_let 0
  12.412 +(* kodkod_constrs -> (Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr)
  12.413 +   -> Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr *)
  12.414 +fun double_rel_let kk f r1 r2 =
  12.415 +  single_rel_let kk (fn r1 => basic_rel_let 1 kk (f r1) r2) r1
  12.416 +(* kodkod_constrs
  12.417 +   -> (Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr)
  12.418 +   -> Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr
  12.419 +   -> Kodkod.rel_expr *)
  12.420 +fun triple_rel_let kk f r1 r2 r3 =
  12.421 +  double_rel_let kk (fn r1 => fn r2 => basic_rel_let 2 kk (f r1 r2) r3) r1 r2
  12.422 +
  12.423 +(* kodkod_constrs -> int -> Kodkod.formula -> Kodkod.rel_expr *)
  12.424 +fun atom_from_formula ({kk_rel_if, ...} : kodkod_constrs) j0 f =
  12.425 +  kk_rel_if f (Kodkod.Atom (j0 + 1)) (Kodkod.Atom j0)
  12.426 +(* kodkod_constrs -> rep -> Kodkod.formula -> Kodkod.rel_expr *)
  12.427 +fun rel_expr_from_formula kk R f =
  12.428 +  case unopt_rep R of
  12.429 +    Atom (2, j0) => atom_from_formula kk j0 f
  12.430 +  | _ => raise REP ("NitpickKodkod.rel_expr_from_formula", [R])
  12.431 +
  12.432 +(* kodkod_cotrs -> int -> int -> Kodkod.rel_expr -> Kodkod.rel_expr list *)
  12.433 +fun unpack_vect_in_chunks ({kk_project_seq, ...} : kodkod_constrs) chunk_arity
  12.434 +                          num_chunks r =
  12.435 +  List.tabulate (num_chunks, fn j => kk_project_seq r (j * chunk_arity)
  12.436 +                                                    chunk_arity)
  12.437 +
  12.438 +(* kodkod_constrs -> bool -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr
  12.439 +   -> Kodkod.rel_expr *)
  12.440 +fun kk_n_fold_join
  12.441 +        (kk as {kk_intersect, kk_product, kk_join, kk_project_seq, ...}) one R1
  12.442 +        res_R r1 r2 =
  12.443 +  case arity_of_rep R1 of
  12.444 +    1 => kk_join r1 r2
  12.445 +  | arity1 =>
  12.446 +    let
  12.447 +      val unpacked_rs1 =
  12.448 +        if inline_rel_expr r1 then unpack_vect_in_chunks kk 1 arity1 r1
  12.449 +        else unpack_products r1
  12.450 +    in
  12.451 +      if one andalso length unpacked_rs1 = arity1 then
  12.452 +        fold kk_join unpacked_rs1 r2
  12.453 +      else
  12.454 +        kk_project_seq
  12.455 +            (kk_intersect (kk_product r1 (full_rel_for_rep res_R)) r2)
  12.456 +            arity1 (arity_of_rep res_R)
  12.457 +    end
  12.458 +
  12.459 +(* kodkod_constrs -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr list
  12.460 +   -> Kodkod.rel_expr list -> Kodkod.rel_expr *)
  12.461 +fun kk_case_switch (kk as {kk_union, kk_product, ...}) R1 R2 r rs1 rs2 =
  12.462 +  if rs1 = rs2 then r
  12.463 +  else kk_n_fold_join kk true R1 R2 r (fold1 kk_union (map2 kk_product rs1 rs2))
  12.464 +
  12.465 +val lone_rep_fallback_max_card = 4096
  12.466 +val some_j0 = 0
  12.467 +
  12.468 +(* kodkod_constrs -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
  12.469 +fun lone_rep_fallback kk new_R old_R r =
  12.470 +  if old_R = new_R then
  12.471 +    r
  12.472 +  else
  12.473 +    let val card = card_of_rep old_R in
  12.474 +      if is_lone_rep old_R andalso is_lone_rep new_R
  12.475 +         andalso card = card_of_rep new_R then
  12.476 +        if card >= lone_rep_fallback_max_card then
  12.477 +          raise LIMIT ("NitpickKodkod.lone_rep_fallback",
  12.478 +                       "too high cardinality (" ^ string_of_int card ^ ")")
  12.479 +        else
  12.480 +          kk_case_switch kk old_R new_R r (all_singletons_for_rep old_R)
  12.481 +                         (all_singletons_for_rep new_R)
  12.482 +      else
  12.483 +        raise REP ("NitpickKodkod.lone_rep_fallback", [old_R, new_R])
  12.484 +    end
  12.485 +(* kodkod_constrs -> int * int -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
  12.486 +and atom_from_rel_expr kk (x as (k, j0)) old_R r =
  12.487 +  case old_R of
  12.488 +    Func (R1, R2) =>
  12.489 +    let
  12.490 +      val dom_card = card_of_rep R1
  12.491 +      val R2' = case R2 of Atom _ => R2 | _ => Atom (card_of_rep R2, some_j0)
  12.492 +    in
  12.493 +      atom_from_rel_expr kk x (Vect (dom_card, R2'))
  12.494 +                         (vect_from_rel_expr kk dom_card R2' old_R r)
  12.495 +    end
  12.496 +  | Opt _ => raise REP ("NitpickKodkod.atom_from_rel_expr", [old_R])
  12.497 +  | _ => lone_rep_fallback kk (Atom x) old_R r
  12.498 +(* kodkod_constrs -> rep list -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
  12.499 +and struct_from_rel_expr kk Rs old_R r =
  12.500 +  case old_R of
  12.501 +    Atom _ => lone_rep_fallback kk (Struct Rs) old_R r
  12.502 +  | Struct Rs' =>
  12.503 +    let
  12.504 +      val Rs = filter (not_equal Unit) Rs
  12.505 +      val Rs' = filter (not_equal Unit) Rs'
  12.506 +    in
  12.507 +      if Rs' = Rs then
  12.508 +        r
  12.509 +      else if map card_of_rep Rs' = map card_of_rep Rs then
  12.510 +        let
  12.511 +          val old_arities = map arity_of_rep Rs'
  12.512 +          val old_offsets = offset_list old_arities
  12.513 +          val old_rs = map2 (#kk_project_seq kk r) old_offsets old_arities
  12.514 +        in
  12.515 +          fold1 (#kk_product kk)
  12.516 +                (map3 (rel_expr_from_rel_expr kk) Rs Rs' old_rs)
  12.517 +        end
  12.518 +      else
  12.519 +        lone_rep_fallback kk (Struct Rs) old_R r
  12.520 +    end
  12.521 +  | _ => raise REP ("NitpickKodkod.struct_from_rel_expr", [old_R])
  12.522 +(* kodkod_constrs -> int -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
  12.523 +and vect_from_rel_expr kk k R old_R r =
  12.524 +  case old_R of
  12.525 +    Atom _ => lone_rep_fallback kk (Vect (k, R)) old_R r
  12.526 +  | Vect (k', R') =>
  12.527 +    if k = k' andalso R = R' then r
  12.528 +    else lone_rep_fallback kk (Vect (k, R)) old_R r
  12.529 +  | Func (R1, Formula Neut) =>
  12.530 +    if k = card_of_rep R1 then
  12.531 +      fold1 (#kk_product kk)
  12.532 +            (map (fn arg_r =>
  12.533 +                     rel_expr_from_formula kk R (#kk_subset kk arg_r r))
  12.534 +                 (all_singletons_for_rep R1))
  12.535 +    else
  12.536 +      raise REP ("NitpickKodkod.vect_from_rel_expr", [old_R])
  12.537 +  | Func (Unit, R2) => rel_expr_from_rel_expr kk R R2 r
  12.538 +  | Func (R1, R2) =>
  12.539 +    fold1 (#kk_product kk)
  12.540 +          (map (fn arg_r =>
  12.541 +                   rel_expr_from_rel_expr kk R R2
  12.542 +                                         (kk_n_fold_join kk true R1 R2 arg_r r))
  12.543 +               (all_singletons_for_rep R1))
  12.544 +  | _ => raise REP ("NitpickKodkod.vect_from_rel_expr", [old_R])
  12.545 +(* kodkod_constrs -> rep -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
  12.546 +and func_from_no_opt_rel_expr kk R1 R2 (Atom x) r =
  12.547 +    let
  12.548 +      val dom_card = card_of_rep R1
  12.549 +      val R2' = case R2 of Atom _ => R2 | _ => Atom (card_of_rep R2, some_j0)
  12.550 +    in
  12.551 +      func_from_no_opt_rel_expr kk R1 R2 (Vect (dom_card, R2'))
  12.552 +                                (vect_from_rel_expr kk dom_card R2' (Atom x) r)
  12.553 +    end
  12.554 +  | func_from_no_opt_rel_expr kk Unit R2 old_R r =
  12.555 +    (case old_R of
  12.556 +       Vect (k, R') => rel_expr_from_rel_expr kk R2 R' r
  12.557 +     | Func (Unit, R2') => rel_expr_from_rel_expr kk R2 R2' r
  12.558 +     | Func (Atom (1, _), Formula Neut) =>
  12.559 +       (case unopt_rep R2 of
  12.560 +          Atom (2, j0) => atom_from_formula kk j0 (#kk_some kk r)
  12.561 +        | _ => raise REP ("NitpickKodkod.func_from_no_opt_rel_expr",
  12.562 +                          [old_R, Func (Unit, R2)]))
  12.563 +     | Func (R1', R2') =>
  12.564 +       rel_expr_from_rel_expr kk R2 R2' (#kk_project_seq kk r (arity_of_rep R1')
  12.565 +                              (arity_of_rep R2'))
  12.566 +     | _ => raise REP ("NitpickKodkod.func_from_no_opt_rel_expr",
  12.567 +                       [old_R, Func (Unit, R2)]))
  12.568 +  | func_from_no_opt_rel_expr kk R1 (Formula Neut) old_R r =
  12.569 +    (case old_R of
  12.570 +       Vect (k, Atom (2, j0)) =>
  12.571 +       let
  12.572 +         val args_rs = all_singletons_for_rep R1
  12.573 +         val vals_rs = unpack_vect_in_chunks kk 1 k r
  12.574 +         (* Kodkod.rel_expr -> Kodkod.rel_expr -> Kodkod.rel_expr *)
  12.575 +         fun empty_or_singleton_set_for arg_r val_r =
  12.576 +           #kk_join kk val_r (#kk_product kk (Kodkod.Atom (j0 + 1)) arg_r)
  12.577 +       in
  12.578 +         fold1 (#kk_union kk) (map2 empty_or_singleton_set_for args_rs vals_rs)
  12.579 +       end
  12.580 +     | Func (R1', Formula Neut) =>
  12.581 +       if R1 = R1' then
  12.582 +         r
  12.583 +       else
  12.584 +         let
  12.585 +           val schema = atom_schema_of_rep R1
  12.586 +           val r1 = fold1 (#kk_product kk) (unary_var_seq ~1 (length schema))
  12.587 +                    |> rel_expr_from_rel_expr kk R1' R1
  12.588 +         in
  12.589 +           #kk_comprehension kk (decls_for_atom_schema ~1 schema)
  12.590 +                                (#kk_subset kk r1 r)
  12.591 +         end
  12.592 +     | Func (Unit, (Atom (2, j0))) =>
  12.593 +       #kk_rel_if kk (#kk_rel_eq kk r (Kodkod.Atom (j0 + 1)))
  12.594 +                  (full_rel_for_rep R1) (empty_rel_for_rep R1)
  12.595 +     | Func (R1', Atom (2, j0)) =>
  12.596 +       func_from_no_opt_rel_expr kk R1 (Formula Neut)
  12.597 +           (Func (R1', Formula Neut)) (#kk_join kk r (Kodkod.Atom (j0 + 1)))
  12.598 +     | _ => raise REP ("NitpickKodkod.func_from_no_opt_rel_expr",
  12.599 +                       [old_R, Func (R1, Formula Neut)]))
  12.600 +  | func_from_no_opt_rel_expr kk R1 R2 old_R r =
  12.601 +    case old_R of
  12.602 +      Vect (k, R) =>
  12.603 +      let
  12.604 +        val args_rs = all_singletons_for_rep R1
  12.605 +        val vals_rs = unpack_vect_in_chunks kk (arity_of_rep R) k r
  12.606 +                      |> map (rel_expr_from_rel_expr kk R2 R)
  12.607 +      in fold1 (#kk_union kk) (map2 (#kk_product kk) args_rs vals_rs) end
  12.608 +    | Func (R1', Formula Neut) =>
  12.609 +      (case R2 of
  12.610 +         Atom (x as (2, j0)) =>
  12.611 +         let val schema = atom_schema_of_rep R1 in
  12.612 +           if length schema = 1 then
  12.613 +             #kk_override kk (#kk_product kk (Kodkod.AtomSeq (hd schema))
  12.614 +                                             (Kodkod.Atom j0))
  12.615 +                             (#kk_product kk r (Kodkod.Atom (j0 + 1)))
  12.616 +           else
  12.617 +             let
  12.618 +               val r1 = fold1 (#kk_product kk) (unary_var_seq ~1 (length schema))
  12.619 +                        |> rel_expr_from_rel_expr kk R1' R1
  12.620 +               val r2 = Kodkod.Var (1, ~(length schema) - 1)
  12.621 +               val r3 = atom_from_formula kk j0 (#kk_subset kk r1 r)
  12.622 +             in
  12.623 +               #kk_comprehension kk (decls_for_atom_schema ~1 (schema @ [x]))
  12.624 +                                 (#kk_rel_eq kk r2 r3)
  12.625 +             end
  12.626 +           end
  12.627 +         | _ => raise REP ("NitpickKodkod.func_from_no_opt_rel_expr",
  12.628 +                           [old_R, Func (R1, R2)]))
  12.629 +    | Func (Unit, R2') =>
  12.630 +      let val j0 = some_j0 in
  12.631 +        func_from_no_opt_rel_expr kk R1 R2 (Func (Atom (1, j0), R2'))
  12.632 +                                  (#kk_product kk (Kodkod.Atom j0) r)
  12.633 +      end
  12.634 +    | Func (R1', R2') =>
  12.635 +      if R1 = R1' andalso R2 = R2' then
  12.636 +        r
  12.637 +      else
  12.638 +        let
  12.639 +          val dom_schema = atom_schema_of_rep R1
  12.640 +          val ran_schema = atom_schema_of_rep R2
  12.641 +          val dom_prod = fold1 (#kk_product kk)
  12.642 +                               (unary_var_seq ~1 (length dom_schema))
  12.643 +                         |> rel_expr_from_rel_expr kk R1' R1
  12.644 +          val ran_prod = fold1 (#kk_product kk)
  12.645 +                               (unary_var_seq (~(length dom_schema) - 1)
  12.646 +                                              (length ran_schema))
  12.647 +                         |> rel_expr_from_rel_expr kk R2' R2
  12.648 +          val app = kk_n_fold_join kk true R1' R2' dom_prod r
  12.649 +        in
  12.650 +          #kk_comprehension kk (decls_for_atom_schema ~1
  12.651 +                                                      (dom_schema @ ran_schema))
  12.652 +                               (#kk_subset kk ran_prod app)
  12.653 +        end
  12.654 +    | _ => raise REP ("NitpickKodkod.func_from_no_opt_rel_expr",
  12.655 +                      [old_R, Func (R1, R2)])
  12.656 +(* kodkod_constrs -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
  12.657 +and rel_expr_from_rel_expr kk new_R old_R r =
  12.658 +  let
  12.659 +    val unopt_old_R = unopt_rep old_R
  12.660 +    val unopt_new_R = unopt_rep new_R
  12.661 +  in
  12.662 +    if unopt_old_R <> old_R andalso unopt_new_R = new_R then
  12.663 +      raise REP ("NitpickKodkod.rel_expr_from_rel_expr", [old_R, new_R])
  12.664 +    else if unopt_new_R = unopt_old_R then
  12.665 +      r
  12.666 +    else
  12.667 +      (case unopt_new_R of
  12.668 +         Atom x => atom_from_rel_expr kk x
  12.669 +       | Struct Rs => struct_from_rel_expr kk Rs
  12.670 +       | Vect (k, R') => vect_from_rel_expr kk k R'
  12.671 +       | Func (R1, R2) => func_from_no_opt_rel_expr kk R1 R2
  12.672 +       | _ => raise REP ("NitpickKodkod.rel_expr_from_rel_expr",
  12.673 +                         [old_R, new_R]))
  12.674 +          unopt_old_R r
  12.675 +  end
  12.676 +(* kodkod_constrs -> rep -> rep -> rep -> Kodkod.rel_expr -> Kodkod.rel_expr *)
  12.677 +and rel_expr_to_func kk R1 R2 = rel_expr_from_rel_expr kk (Func (R1, R2))
  12.678 +
  12.679 +(* kodkod_constrs -> nut -> Kodkod.formula *)
  12.680 +fun declarative_axiom_for_plain_rel kk (FreeRel (x, _, R as Func _, nick)) =
  12.681 +    kk_n_ary_function kk (R |> nick = @{const_name List.set} ? unopt_rep)
  12.682 +                      (Kodkod.Rel x)
  12.683 +  | declarative_axiom_for_plain_rel ({kk_lone, kk_one, ...} : kodkod_constrs)
  12.684 +                                    (FreeRel (x, _, R, _)) =
  12.685 +    if is_one_rep R then kk_one (Kodkod.Rel x)
  12.686 +    else if is_lone_rep R andalso card_of_rep R > 1 then kk_lone (Kodkod.Rel x)
  12.687 +    else Kodkod.True
  12.688 +  | declarative_axiom_for_plain_rel _ u =
  12.689 +    raise NUT ("NitpickKodkod.declarative_axiom_for_plain_rel", [u])
  12.690 +
  12.691 +(* nut NameTable.table -> styp -> Kodkod.rel_expr * rep * int *)
  12.692 +fun const_triple rel_table (x as (s, T)) =
  12.693 +  case the_name rel_table (ConstName (s, T, Any)) of
  12.694 +    FreeRel ((n, j), _, R, _) => (Kodkod.Rel (n, j), R, n)
  12.695 +  | _ => raise TERM ("NitpickKodkod.const_triple", [Const x])
  12.696 +
  12.697 +(* nut NameTable.table -> styp -> Kodkod.rel_expr *)
  12.698 +fun discr_rel_expr rel_table = #1 o const_triple rel_table o discr_for_constr
  12.699 +
  12.700 +(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
  12.701 +   -> styp -> int -> nfa_transition list *)
  12.702 +fun nfa_transitions_for_sel ext_ctxt ({kk_project, ...} : kodkod_constrs)
  12.703 +                            rel_table (dtypes : dtype_spec list) constr_x n =
  12.704 +  let
  12.705 +    val x as (_, T) = boxed_nth_sel_for_constr ext_ctxt constr_x n
  12.706 +    val (r, R, arity) = const_triple rel_table x
  12.707 +    val type_schema = type_schema_of_rep T R
  12.708 +  in
  12.709 +    map_filter (fn (j, T) =>
  12.710 +                   if forall (not_equal T o #typ) dtypes then NONE
  12.711 +                   else SOME (kk_project r (map Kodkod.Num [0, j]), T))
  12.712 +               (index_seq 1 (arity - 1) ~~ tl type_schema)
  12.713 +  end
  12.714 +(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
  12.715 +   -> styp -> nfa_transition list *)
  12.716 +fun nfa_transitions_for_constr ext_ctxt kk rel_table dtypes (x as (_, T)) =
  12.717 +  maps (nfa_transitions_for_sel ext_ctxt kk rel_table dtypes x)
  12.718 +       (index_seq 0 (num_sels_for_constr_type T))
  12.719 +(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
  12.720 +   -> dtype_spec -> nfa_entry option *)
  12.721 +fun nfa_entry_for_datatype _ _ _ _ ({co = true, ...} : dtype_spec) = NONE
  12.722 +  | nfa_entry_for_datatype ext_ctxt kk rel_table dtypes
  12.723 +                           ({typ, constrs, ...} : dtype_spec) =
  12.724 +    SOME (typ, maps (nfa_transitions_for_constr ext_ctxt kk rel_table dtypes
  12.725 +                     o #const) constrs)
  12.726 +
  12.727 +val empty_rel = Kodkod.Product (Kodkod.None, Kodkod.None)
  12.728 +
  12.729 +(* nfa_table -> typ -> typ -> Kodkod.rel_expr list *)
  12.730 +fun direct_path_rel_exprs nfa start final =
  12.731 +  case AList.lookup (op =) nfa final of
  12.732 +    SOME trans => map fst (filter (equal start o snd) trans)
  12.733 +  | NONE => []
  12.734 +(* kodkod_constrs -> nfa_table -> typ list -> typ -> typ -> Kodkod.rel_expr *)
  12.735 +and any_path_rel_expr ({kk_union, ...} : kodkod_constrs) nfa [] start final =
  12.736 +    fold kk_union (direct_path_rel_exprs nfa start final)
  12.737 +         (if start = final then Kodkod.Iden else empty_rel)
  12.738 +  | any_path_rel_expr (kk as {kk_union, ...}) nfa (q :: qs) start final =
  12.739 +    kk_union (any_path_rel_expr kk nfa qs start final)
  12.740 +             (knot_path_rel_expr kk nfa qs start q final)
  12.741 +(* kodkod_constrs -> nfa_table -> typ list -> typ -> typ -> typ
  12.742 +   -> Kodkod.rel_expr *)
  12.743 +and knot_path_rel_expr (kk as {kk_join, kk_reflexive_closure, ...}) nfa qs start
  12.744 +                       knot final =
  12.745 +  kk_join (kk_join (any_path_rel_expr kk nfa qs knot final)
  12.746 +                   (kk_reflexive_closure (loop_path_rel_expr kk nfa qs knot)))
  12.747 +          (any_path_rel_expr kk nfa qs start knot)
  12.748 +(* kodkod_constrs -> nfa_table -> typ list -> typ -> Kodkod.rel_expr *)
  12.749 +and loop_path_rel_expr ({kk_union, ...} : kodkod_constrs) nfa [] start =
  12.750 +    fold kk_union (direct_path_rel_exprs nfa start start) empty_rel
  12.751 +  | loop_path_rel_expr (kk as {kk_union, kk_closure, ...}) nfa (q :: qs) start =
  12.752 +    if start = q then
  12.753 +      kk_closure (loop_path_rel_expr kk nfa qs start)
  12.754 +    else
  12.755 +      kk_union (loop_path_rel_expr kk nfa qs start)
  12.756 +               (knot_path_rel_expr kk nfa qs start q start)
  12.757 +
  12.758 +(* nfa_table -> unit NfaGraph.T *)
  12.759 +fun graph_for_nfa nfa =
  12.760 +  let
  12.761 +    (* typ -> unit NfaGraph.T -> unit NfaGraph.T *)
  12.762 +    fun new_node q = perhaps (try (NfaGraph.new_node (q, ())))
  12.763 +    (* nfa_table -> unit NfaGraph.T -> unit NfaGraph.T *)
  12.764 +    fun add_nfa [] = I
  12.765 +      | add_nfa ((_, []) :: nfa) = add_nfa nfa
  12.766 +      | add_nfa ((q, ((_, q') :: transitions)) :: nfa) =
  12.767 +        add_nfa ((q, transitions) :: nfa) o NfaGraph.add_edge (q, q') o
  12.768 +        new_node q' o new_node q
  12.769 +  in add_nfa nfa NfaGraph.empty end
  12.770 +
  12.771 +(* nfa_table -> nfa_table list *)
  12.772 +fun strongly_connected_sub_nfas nfa =
  12.773 +  nfa |> graph_for_nfa |> NfaGraph.strong_conn
  12.774 +      |> map (fn keys => filter (member (op =) keys o fst) nfa)
  12.775 +
  12.776 +(* dtype_spec list -> kodkod_constrs -> nfa_table -> typ -> Kodkod.formula *)
  12.777 +fun acyclicity_axiom_for_datatype dtypes kk nfa start =
  12.778 +  #kk_no kk (#kk_intersect kk
  12.779 +                 (loop_path_rel_expr kk nfa (map fst nfa) start) Kodkod.Iden)
  12.780 +(* extended_context -> kodkod_constrs -> nut NameTable.table -> dtype_spec list
  12.781 +   -> Kodkod.formula list *)
  12.782 +fun acyclicity_axioms_for_datatypes ext_ctxt kk rel_table dtypes =
  12.783 +  map_filter (nfa_entry_for_datatype ext_ctxt kk rel_table dtypes) dtypes
  12.784 +  |> strongly_connected_sub_nfas
  12.785 +  |> maps (fn nfa => map (acyclicity_axiom_for_datatype dtypes kk nfa o fst)
  12.786 +                         nfa)
  12.787 +
  12.788 +(* extended_context -> int -> kodkod_constrs -> nut NameTable.table
  12.789 +   -> Kodkod.rel_expr -> constr_spec -> int -> Kodkod.formula *)