moved Refute to "HOL/Library" to speed up building "Main" even more
authorblanchet
Wed Oct 31 11:23:21 2012 +0100 (2012-10-31)
changeset 499855b4b0e4e5205
parent 49984 9f655a6bffd8
child 49986 90e7be285b49
moved Refute to "HOL/Library" to speed up building "Main" even more
src/HOL/Library/Refute.thy
src/HOL/Library/refute.ML
src/HOL/ROOT
src/HOL/Refute.thy
src/HOL/SAT.thy
src/HOL/TPTP/ATP_Problem_Import.thy
src/HOL/TPTP/atp_problem_import.ML
src/HOL/Tools/Nitpick/nitpick_hol.ML
src/HOL/Tools/Nitpick/nitpick_isar.ML
src/HOL/Tools/Nitpick/nitpick_util.ML
src/HOL/Tools/refute.ML
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/HOL/Library/Refute.thy	Wed Oct 31 11:23:21 2012 +0100
     1.3 @@ -0,0 +1,113 @@
     1.4 +(*  Title:      HOL/Refute.thy
     1.5 +    Author:     Tjark Weber
     1.6 +    Copyright   2003-2007
     1.7 +
     1.8 +Basic setup and documentation for the 'refute' (and 'refute_params') command.
     1.9 +*)
    1.10 +
    1.11 +header {* Refute *}
    1.12 +
    1.13 +theory Refute
    1.14 +imports Hilbert_Choice List Sledgehammer
    1.15 +keywords "refute" :: diag and "refute_params" :: thy_decl
    1.16 +begin
    1.17 +
    1.18 +ML_file "refute.ML"
    1.19 +setup Refute.setup
    1.20 +
    1.21 +refute_params
    1.22 + [itself = 1,
    1.23 +  minsize = 1,
    1.24 +  maxsize = 8,
    1.25 +  maxvars = 10000,
    1.26 +  maxtime = 60,
    1.27 +  satsolver = auto,
    1.28 +  no_assms = false]
    1.29 +
    1.30 +text {*
    1.31 +\small
    1.32 +\begin{verbatim}
    1.33 +(* ------------------------------------------------------------------------- *)
    1.34 +(* REFUTE                                                                    *)
    1.35 +(*                                                                           *)
    1.36 +(* We use a SAT solver to search for a (finite) model that refutes a given   *)
    1.37 +(* HOL formula.                                                              *)
    1.38 +(* ------------------------------------------------------------------------- *)
    1.39 +
    1.40 +(* ------------------------------------------------------------------------- *)
    1.41 +(* NOTE                                                                      *)
    1.42 +(*                                                                           *)
    1.43 +(* I strongly recommend that you install a stand-alone SAT solver if you     *)
    1.44 +(* want to use 'refute'.  For details see 'HOL/Tools/sat_solver.ML'.  If you *)
    1.45 +(* have installed (a supported version of) zChaff, simply set 'ZCHAFF_HOME'  *)
    1.46 +(* in 'etc/settings'.                                                        *)
    1.47 +(* ------------------------------------------------------------------------- *)
    1.48 +
    1.49 +(* ------------------------------------------------------------------------- *)
    1.50 +(* USAGE                                                                     *)
    1.51 +(*                                                                           *)
    1.52 +(* See the file 'HOL/ex/Refute_Examples.thy' for examples.  The supported    *)
    1.53 +(* parameters are explained below.                                           *)
    1.54 +(* ------------------------------------------------------------------------- *)
    1.55 +
    1.56 +(* ------------------------------------------------------------------------- *)
    1.57 +(* CURRENT LIMITATIONS                                                       *)
    1.58 +(*                                                                           *)
    1.59 +(* 'refute' currently accepts formulas of higher-order predicate logic (with *)
    1.60 +(* equality), including free/bound/schematic variables, lambda abstractions, *)
    1.61 +(* sets and set membership, "arbitrary", "The", "Eps", records and           *)
    1.62 +(* inductively defined sets.  Constants are unfolded automatically, and sort *)
    1.63 +(* axioms are added as well.  Other, user-asserted axioms however are        *)
    1.64 +(* ignored.  Inductive datatypes and recursive functions are supported, but  *)
    1.65 +(* may lead to spurious countermodels.                                       *)
    1.66 +(*                                                                           *)
    1.67 +(* The (space) complexity of the algorithm is non-elementary.                *)
    1.68 +(*                                                                           *)
    1.69 +(* Schematic type variables are not supported.                               *)
    1.70 +(* ------------------------------------------------------------------------- *)
    1.71 +
    1.72 +(* ------------------------------------------------------------------------- *)
    1.73 +(* PARAMETERS                                                                *)
    1.74 +(*                                                                           *)
    1.75 +(* The following global parameters are currently supported (and required,    *)
    1.76 +(* except for "expect"):                                                     *)
    1.77 +(*                                                                           *)
    1.78 +(* Name          Type    Description                                         *)
    1.79 +(*                                                                           *)
    1.80 +(* "minsize"     int     Only search for models with size at least           *)
    1.81 +(*                       'minsize'.                                          *)
    1.82 +(* "maxsize"     int     If >0, only search for models with size at most     *)
    1.83 +(*                       'maxsize'.                                          *)
    1.84 +(* "maxvars"     int     If >0, use at most 'maxvars' boolean variables      *)
    1.85 +(*                       when transforming the term into a propositional     *)
    1.86 +(*                       formula.                                            *)
    1.87 +(* "maxtime"     int     If >0, terminate after at most 'maxtime' seconds.   *)
    1.88 +(*                       This value is ignored under some ML compilers.      *)
    1.89 +(* "satsolver"   string  Name of the SAT solver to be used.                  *)
    1.90 +(* "no_assms"    bool    If "true", assumptions in structured proofs are     *)
    1.91 +(*                       not considered.                                     *)
    1.92 +(* "expect"      string  Expected result ("genuine", "potential", "none", or *)
    1.93 +(*                       "unknown").                                         *)
    1.94 +(*                                                                           *)
    1.95 +(* The size of particular types can be specified in the form type=size       *)
    1.96 +(* (where 'type' is a string, and 'size' is an int).  Examples:              *)
    1.97 +(* "'a"=1                                                                    *)
    1.98 +(* "List.list"=2                                                             *)
    1.99 +(* ------------------------------------------------------------------------- *)
   1.100 +
   1.101 +(* ------------------------------------------------------------------------- *)
   1.102 +(* FILES                                                                     *)
   1.103 +(*                                                                           *)
   1.104 +(* HOL/Tools/prop_logic.ML     Propositional logic                           *)
   1.105 +(* HOL/Tools/sat_solver.ML     SAT solvers                                   *)
   1.106 +(* HOL/Tools/refute.ML         Translation HOL -> propositional logic and    *)
   1.107 +(*                             Boolean assignment -> HOL model               *)
   1.108 +(* HOL/Refute.thy              This file: loads the ML files, basic setup,   *)
   1.109 +(*                             documentation                                 *)
   1.110 +(* HOL/SAT.thy                 Sets default parameters                       *)
   1.111 +(* HOL/ex/Refute_Examples.thy  Examples                                      *)
   1.112 +(* ------------------------------------------------------------------------- *)
   1.113 +\end{verbatim}
   1.114 +*}
   1.115 +
   1.116 +end
     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/HOL/Library/refute.ML	Wed Oct 31 11:23:21 2012 +0100
     2.3 @@ -0,0 +1,3229 @@
     2.4 +(*  Title:      HOL/Tools/refute.ML
     2.5 +    Author:     Tjark Weber, TU Muenchen
     2.6 +
     2.7 +Finite model generation for HOL formulas, using a SAT solver.
     2.8 +*)
     2.9 +
    2.10 +(* ------------------------------------------------------------------------- *)
    2.11 +(* Declares the 'REFUTE' signature as well as a structure 'Refute'.          *)
    2.12 +(* Documentation is available in the Isabelle/Isar theory 'HOL/Refute.thy'.  *)
    2.13 +(* ------------------------------------------------------------------------- *)
    2.14 +
    2.15 +signature REFUTE =
    2.16 +sig
    2.17 +
    2.18 +  exception REFUTE of string * string
    2.19 +
    2.20 +(* ------------------------------------------------------------------------- *)
    2.21 +(* Model/interpretation related code (translation HOL -> propositional logic *)
    2.22 +(* ------------------------------------------------------------------------- *)
    2.23 +
    2.24 +  type params
    2.25 +  type interpretation
    2.26 +  type model
    2.27 +  type arguments
    2.28 +
    2.29 +  exception MAXVARS_EXCEEDED
    2.30 +
    2.31 +  val add_interpreter : string -> (Proof.context -> model -> arguments -> term ->
    2.32 +    (interpretation * model * arguments) option) -> theory -> theory
    2.33 +  val add_printer : string -> (Proof.context -> model -> typ ->
    2.34 +    interpretation -> (int -> bool) -> term option) -> theory -> theory
    2.35 +
    2.36 +  val interpret : Proof.context -> model -> arguments -> term ->
    2.37 +    (interpretation * model * arguments)
    2.38 +
    2.39 +  val print : Proof.context -> model -> typ -> interpretation -> (int -> bool) -> term
    2.40 +  val print_model : Proof.context -> model -> (int -> bool) -> string
    2.41 +
    2.42 +(* ------------------------------------------------------------------------- *)
    2.43 +(* Interface                                                                 *)
    2.44 +(* ------------------------------------------------------------------------- *)
    2.45 +
    2.46 +  val set_default_param  : (string * string) -> theory -> theory
    2.47 +  val get_default_param  : Proof.context -> string -> string option
    2.48 +  val get_default_params : Proof.context -> (string * string) list
    2.49 +  val actual_params      : Proof.context -> (string * string) list -> params
    2.50 +
    2.51 +  val find_model :
    2.52 +    Proof.context -> params -> term list -> term -> bool -> string
    2.53 +
    2.54 +  (* tries to find a model for a formula: *)
    2.55 +  val satisfy_term :
    2.56 +    Proof.context -> (string * string) list -> term list -> term -> string
    2.57 +  (* tries to find a model that refutes a formula: *)
    2.58 +  val refute_term :
    2.59 +    Proof.context -> (string * string) list -> term list -> term -> string
    2.60 +  val refute_goal :
    2.61 +    Proof.context -> (string * string) list -> thm -> int -> string
    2.62 +
    2.63 +  val setup : theory -> theory
    2.64 +
    2.65 +(* ------------------------------------------------------------------------- *)
    2.66 +(* Additional functions used by Nitpick (to be factored out)                 *)
    2.67 +(* ------------------------------------------------------------------------- *)
    2.68 +
    2.69 +  val get_classdef : theory -> string -> (string * term) option
    2.70 +  val norm_rhs : term -> term
    2.71 +  val get_def : theory -> string * typ -> (string * term) option
    2.72 +  val get_typedef : theory -> typ -> (string * term) option
    2.73 +  val is_IDT_constructor : theory -> string * typ -> bool
    2.74 +  val is_IDT_recursor : theory -> string * typ -> bool
    2.75 +  val is_const_of_class: theory -> string * typ -> bool
    2.76 +  val string_of_typ : typ -> string
    2.77 +end;
    2.78 +
    2.79 +structure Refute : REFUTE =
    2.80 +struct
    2.81 +
    2.82 +open Prop_Logic;
    2.83 +
    2.84 +(* We use 'REFUTE' only for internal error conditions that should    *)
    2.85 +(* never occur in the first place (i.e. errors caused by bugs in our *)
    2.86 +(* code).  Otherwise (e.g. to indicate invalid input data) we use    *)
    2.87 +(* 'error'.                                                          *)
    2.88 +exception REFUTE of string * string;  (* ("in function", "cause") *)
    2.89 +
    2.90 +(* should be raised by an interpreter when more variables would be *)
    2.91 +(* required than allowed by 'maxvars'                              *)
    2.92 +exception MAXVARS_EXCEEDED;
    2.93 +
    2.94 +
    2.95 +(* ------------------------------------------------------------------------- *)
    2.96 +(* TREES                                                                     *)
    2.97 +(* ------------------------------------------------------------------------- *)
    2.98 +
    2.99 +(* ------------------------------------------------------------------------- *)
   2.100 +(* tree: implements an arbitrarily (but finitely) branching tree as a list   *)
   2.101 +(*       of (lists of ...) elements                                          *)
   2.102 +(* ------------------------------------------------------------------------- *)
   2.103 +
   2.104 +datatype 'a tree =
   2.105 +    Leaf of 'a
   2.106 +  | Node of ('a tree) list;
   2.107 +
   2.108 +(* ('a -> 'b) -> 'a tree -> 'b tree *)
   2.109 +
   2.110 +fun tree_map f tr =
   2.111 +  case tr of
   2.112 +    Leaf x  => Leaf (f x)
   2.113 +  | Node xs => Node (map (tree_map f) xs);
   2.114 +
   2.115 +(* ('a * 'b -> 'a) -> 'a * ('b tree) -> 'a *)
   2.116 +
   2.117 +fun tree_foldl f =
   2.118 +  let
   2.119 +    fun itl (e, Leaf x)  = f(e,x)
   2.120 +      | itl (e, Node xs) = Library.foldl (tree_foldl f) (e,xs)
   2.121 +  in
   2.122 +    itl
   2.123 +  end;
   2.124 +
   2.125 +(* 'a tree * 'b tree -> ('a * 'b) tree *)
   2.126 +
   2.127 +fun tree_pair (t1, t2) =
   2.128 +  case t1 of
   2.129 +    Leaf x =>
   2.130 +      (case t2 of
   2.131 +          Leaf y => Leaf (x,y)
   2.132 +        | Node _ => raise REFUTE ("tree_pair",
   2.133 +            "trees are of different height (second tree is higher)"))
   2.134 +  | Node xs =>
   2.135 +      (case t2 of
   2.136 +          (* '~~' will raise an exception if the number of branches in   *)
   2.137 +          (* both trees is different at the current node                 *)
   2.138 +          Node ys => Node (map tree_pair (xs ~~ ys))
   2.139 +        | Leaf _  => raise REFUTE ("tree_pair",
   2.140 +            "trees are of different height (first tree is higher)"));
   2.141 +
   2.142 +(* ------------------------------------------------------------------------- *)
   2.143 +(* params: parameters that control the translation into a propositional      *)
   2.144 +(*         formula/model generation                                          *)
   2.145 +(*                                                                           *)
   2.146 +(* The following parameters are supported (and required (!), except for      *)
   2.147 +(* "sizes" and "expect"):                                                    *)
   2.148 +(*                                                                           *)
   2.149 +(* Name          Type    Description                                         *)
   2.150 +(*                                                                           *)
   2.151 +(* "sizes"       (string * int) list                                         *)
   2.152 +(*                       Size of ground types (e.g. 'a=2), or depth of IDTs. *)
   2.153 +(* "minsize"     int     If >0, minimal size of each ground type/IDT depth.  *)
   2.154 +(* "maxsize"     int     If >0, maximal size of each ground type/IDT depth.  *)
   2.155 +(* "maxvars"     int     If >0, use at most 'maxvars' Boolean variables      *)
   2.156 +(*                       when transforming the term into a propositional     *)
   2.157 +(*                       formula.                                            *)
   2.158 +(* "maxtime"     int     If >0, terminate after at most 'maxtime' seconds.   *)
   2.159 +(* "satsolver"   string  SAT solver to be used.                              *)
   2.160 +(* "no_assms"    bool    If "true", assumptions in structured proofs are     *)
   2.161 +(*                       not considered.                                     *)
   2.162 +(* "expect"      string  Expected result ("genuine", "potential", "none", or *)
   2.163 +(*                       "unknown").                                         *)
   2.164 +(* ------------------------------------------------------------------------- *)
   2.165 +
   2.166 +type params =
   2.167 +  {
   2.168 +    sizes    : (string * int) list,
   2.169 +    minsize  : int,
   2.170 +    maxsize  : int,
   2.171 +    maxvars  : int,
   2.172 +    maxtime  : int,
   2.173 +    satsolver: string,
   2.174 +    no_assms : bool,
   2.175 +    expect   : string
   2.176 +  };
   2.177 +
   2.178 +(* ------------------------------------------------------------------------- *)
   2.179 +(* interpretation: a term's interpretation is given by a variable of type    *)
   2.180 +(*                 'interpretation'                                          *)
   2.181 +(* ------------------------------------------------------------------------- *)
   2.182 +
   2.183 +type interpretation =
   2.184 +  prop_formula list tree;
   2.185 +
   2.186 +(* ------------------------------------------------------------------------- *)
   2.187 +(* model: a model specifies the size of types and the interpretation of      *)
   2.188 +(*        terms                                                              *)
   2.189 +(* ------------------------------------------------------------------------- *)
   2.190 +
   2.191 +type model =
   2.192 +  (typ * int) list * (term * interpretation) list;
   2.193 +
   2.194 +(* ------------------------------------------------------------------------- *)
   2.195 +(* arguments: additional arguments required during interpretation of terms   *)
   2.196 +(* ------------------------------------------------------------------------- *)
   2.197 +
   2.198 +type arguments =
   2.199 +  {
   2.200 +    (* just passed unchanged from 'params': *)
   2.201 +    maxvars   : int,
   2.202 +    (* whether to use 'make_equality' or 'make_def_equality': *)
   2.203 +    def_eq    : bool,
   2.204 +    (* the following may change during the translation: *)
   2.205 +    next_idx  : int,
   2.206 +    bounds    : interpretation list,
   2.207 +    wellformed: prop_formula
   2.208 +  };
   2.209 +
   2.210 +structure Data = Theory_Data
   2.211 +(
   2.212 +  type T =
   2.213 +    {interpreters: (string * (Proof.context -> model -> arguments -> term ->
   2.214 +      (interpretation * model * arguments) option)) list,
   2.215 +     printers: (string * (Proof.context -> model -> typ -> interpretation ->
   2.216 +      (int -> bool) -> term option)) list,
   2.217 +     parameters: string Symtab.table};
   2.218 +  val empty = {interpreters = [], printers = [], parameters = Symtab.empty};
   2.219 +  val extend = I;
   2.220 +  fun merge
   2.221 +    ({interpreters = in1, printers = pr1, parameters = pa1},
   2.222 +     {interpreters = in2, printers = pr2, parameters = pa2}) : T =
   2.223 +    {interpreters = AList.merge (op =) (K true) (in1, in2),
   2.224 +     printers = AList.merge (op =) (K true) (pr1, pr2),
   2.225 +     parameters = Symtab.merge (op =) (pa1, pa2)};
   2.226 +);
   2.227 +
   2.228 +val get_data = Data.get o Proof_Context.theory_of;
   2.229 +
   2.230 +
   2.231 +(* ------------------------------------------------------------------------- *)
   2.232 +(* interpret: interprets the term 't' using a suitable interpreter; returns  *)
   2.233 +(*            the interpretation and a (possibly extended) model that keeps  *)
   2.234 +(*            track of the interpretation of subterms                        *)
   2.235 +(* ------------------------------------------------------------------------- *)
   2.236 +
   2.237 +fun interpret ctxt model args t =
   2.238 +  case get_first (fn (_, f) => f ctxt model args t)
   2.239 +      (#interpreters (get_data ctxt)) of
   2.240 +    NONE => raise REFUTE ("interpret",
   2.241 +      "no interpreter for term " ^ quote (Syntax.string_of_term ctxt t))
   2.242 +  | SOME x => x;
   2.243 +
   2.244 +(* ------------------------------------------------------------------------- *)
   2.245 +(* print: converts the interpretation 'intr', which must denote a term of    *)
   2.246 +(*        type 'T', into a term using a suitable printer                     *)
   2.247 +(* ------------------------------------------------------------------------- *)
   2.248 +
   2.249 +fun print ctxt model T intr assignment =
   2.250 +  case get_first (fn (_, f) => f ctxt model T intr assignment)
   2.251 +      (#printers (get_data ctxt)) of
   2.252 +    NONE => raise REFUTE ("print",
   2.253 +      "no printer for type " ^ quote (Syntax.string_of_typ ctxt T))
   2.254 +  | SOME x => x;
   2.255 +
   2.256 +(* ------------------------------------------------------------------------- *)
   2.257 +(* print_model: turns the model into a string, using a fixed interpretation  *)
   2.258 +(*              (given by an assignment for Boolean variables) and suitable  *)
   2.259 +(*              printers                                                     *)
   2.260 +(* ------------------------------------------------------------------------- *)
   2.261 +
   2.262 +fun print_model ctxt model assignment =
   2.263 +  let
   2.264 +    val (typs, terms) = model
   2.265 +    val typs_msg =
   2.266 +      if null typs then
   2.267 +        "empty universe (no type variables in term)\n"
   2.268 +      else
   2.269 +        "Size of types: " ^ commas (map (fn (T, i) =>
   2.270 +          Syntax.string_of_typ ctxt T ^ ": " ^ string_of_int i) typs) ^ "\n"
   2.271 +    val show_consts_msg =
   2.272 +      if not (Config.get ctxt show_consts) andalso Library.exists (is_Const o fst) terms then
   2.273 +        "enable \"show_consts\" to show the interpretation of constants\n"
   2.274 +      else
   2.275 +        ""
   2.276 +    val terms_msg =
   2.277 +      if null terms then
   2.278 +        "empty interpretation (no free variables in term)\n"
   2.279 +      else
   2.280 +        cat_lines (map_filter (fn (t, intr) =>
   2.281 +          (* print constants only if 'show_consts' is true *)
   2.282 +          if Config.get ctxt show_consts orelse not (is_Const t) then
   2.283 +            SOME (Syntax.string_of_term ctxt t ^ ": " ^
   2.284 +              Syntax.string_of_term ctxt
   2.285 +                (print ctxt model (Term.type_of t) intr assignment))
   2.286 +          else
   2.287 +            NONE) terms) ^ "\n"
   2.288 +  in
   2.289 +    typs_msg ^ show_consts_msg ^ terms_msg
   2.290 +  end;
   2.291 +
   2.292 +
   2.293 +(* ------------------------------------------------------------------------- *)
   2.294 +(* PARAMETER MANAGEMENT                                                      *)
   2.295 +(* ------------------------------------------------------------------------- *)
   2.296 +
   2.297 +fun add_interpreter name f = Data.map (fn {interpreters, printers, parameters} =>
   2.298 +  case AList.lookup (op =) interpreters name of
   2.299 +    NONE => {interpreters = (name, f) :: interpreters,
   2.300 +      printers = printers, parameters = parameters}
   2.301 +  | SOME _ => error ("Interpreter " ^ name ^ " already declared"));
   2.302 +
   2.303 +fun add_printer name f = Data.map (fn {interpreters, printers, parameters} =>
   2.304 +  case AList.lookup (op =) printers name of
   2.305 +    NONE => {interpreters = interpreters,
   2.306 +      printers = (name, f) :: printers, parameters = parameters}
   2.307 +  | SOME _ => error ("Printer " ^ name ^ " already declared"));
   2.308 +
   2.309 +(* ------------------------------------------------------------------------- *)
   2.310 +(* set_default_param: stores the '(name, value)' pair in Data's              *)
   2.311 +(*                    parameter table                                        *)
   2.312 +(* ------------------------------------------------------------------------- *)
   2.313 +
   2.314 +fun set_default_param (name, value) = Data.map
   2.315 +  (fn {interpreters, printers, parameters} =>
   2.316 +    {interpreters = interpreters, printers = printers,
   2.317 +      parameters = Symtab.update (name, value) parameters});
   2.318 +
   2.319 +(* ------------------------------------------------------------------------- *)
   2.320 +(* get_default_param: retrieves the value associated with 'name' from        *)
   2.321 +(*                    Data's parameter table                                 *)
   2.322 +(* ------------------------------------------------------------------------- *)
   2.323 +
   2.324 +val get_default_param = Symtab.lookup o #parameters o get_data;
   2.325 +
   2.326 +(* ------------------------------------------------------------------------- *)
   2.327 +(* get_default_params: returns a list of all '(name, value)' pairs that are  *)
   2.328 +(*                     stored in Data's parameter table                      *)
   2.329 +(* ------------------------------------------------------------------------- *)
   2.330 +
   2.331 +val get_default_params = Symtab.dest o #parameters o get_data;
   2.332 +
   2.333 +(* ------------------------------------------------------------------------- *)
   2.334 +(* actual_params: takes a (possibly empty) list 'params' of parameters that  *)
   2.335 +(*      override the default parameters currently specified, and             *)
   2.336 +(*      returns a record that can be passed to 'find_model'.                 *)
   2.337 +(* ------------------------------------------------------------------------- *)
   2.338 +
   2.339 +fun actual_params ctxt override =
   2.340 +  let
   2.341 +    (* (string * string) list * string -> bool *)
   2.342 +    fun read_bool (parms, name) =
   2.343 +      case AList.lookup (op =) parms name of
   2.344 +        SOME "true" => true
   2.345 +      | SOME "false" => false
   2.346 +      | SOME s => error ("parameter " ^ quote name ^
   2.347 +          " (value is " ^ quote s ^ ") must be \"true\" or \"false\"")
   2.348 +      | NONE   => error ("parameter " ^ quote name ^
   2.349 +          " must be assigned a value")
   2.350 +    (* (string * string) list * string -> int *)
   2.351 +    fun read_int (parms, name) =
   2.352 +      case AList.lookup (op =) parms name of
   2.353 +        SOME s =>
   2.354 +          (case Int.fromString s of
   2.355 +            SOME i => i
   2.356 +          | NONE   => error ("parameter " ^ quote name ^
   2.357 +            " (value is " ^ quote s ^ ") must be an integer value"))
   2.358 +      | NONE => error ("parameter " ^ quote name ^
   2.359 +          " must be assigned a value")
   2.360 +    (* (string * string) list * string -> string *)
   2.361 +    fun read_string (parms, name) =
   2.362 +      case AList.lookup (op =) parms name of
   2.363 +        SOME s => s
   2.364 +      | NONE => error ("parameter " ^ quote name ^
   2.365 +        " must be assigned a value")
   2.366 +    (* 'override' first, defaults last: *)
   2.367 +    (* (string * string) list *)
   2.368 +    val allparams = override @ get_default_params ctxt
   2.369 +    (* int *)
   2.370 +    val minsize = read_int (allparams, "minsize")
   2.371 +    val maxsize = read_int (allparams, "maxsize")
   2.372 +    val maxvars = read_int (allparams, "maxvars")
   2.373 +    val maxtime = read_int (allparams, "maxtime")
   2.374 +    (* string *)
   2.375 +    val satsolver = read_string (allparams, "satsolver")
   2.376 +    val no_assms = read_bool (allparams, "no_assms")
   2.377 +    val expect = the_default "" (AList.lookup (op =) allparams "expect")
   2.378 +    (* all remaining parameters of the form "string=int" are collected in *)
   2.379 +    (* 'sizes'                                                            *)
   2.380 +    (* TODO: it is currently not possible to specify a size for a type    *)
   2.381 +    (*       whose name is one of the other parameters (e.g. 'maxvars')   *)
   2.382 +    (* (string * int) list *)
   2.383 +    val sizes = map_filter
   2.384 +      (fn (name, value) => Option.map (pair name) (Int.fromString value))
   2.385 +      (filter (fn (name, _) => name<>"minsize" andalso name<>"maxsize"
   2.386 +        andalso name<>"maxvars" andalso name<>"maxtime"
   2.387 +        andalso name<>"satsolver" andalso name<>"no_assms") allparams)
   2.388 +  in
   2.389 +    {sizes=sizes, minsize=minsize, maxsize=maxsize, maxvars=maxvars,
   2.390 +      maxtime=maxtime, satsolver=satsolver, no_assms=no_assms, expect=expect}
   2.391 +  end;
   2.392 +
   2.393 +
   2.394 +(* ------------------------------------------------------------------------- *)
   2.395 +(* TRANSLATION HOL -> PROPOSITIONAL LOGIC, BOOLEAN ASSIGNMENT -> MODEL       *)
   2.396 +(* ------------------------------------------------------------------------- *)
   2.397 +
   2.398 +val typ_of_dtyp = ATP_Util.typ_of_dtyp
   2.399 +
   2.400 +(* ------------------------------------------------------------------------- *)
   2.401 +(* close_form: universal closure over schematic variables in 't'             *)
   2.402 +(* ------------------------------------------------------------------------- *)
   2.403 +
   2.404 +(* Term.term -> Term.term *)
   2.405 +
   2.406 +fun close_form t =
   2.407 +  let
   2.408 +    val vars = sort_wrt (fst o fst) (Term.add_vars t [])
   2.409 +  in
   2.410 +    fold (fn ((x, i), T) => fn t' =>
   2.411 +      Logic.all_const T $ Abs (x, T, abstract_over (Var ((x, i), T), t'))) vars t
   2.412 +  end;
   2.413 +
   2.414 +val monomorphic_term = ATP_Util.monomorphic_term
   2.415 +val specialize_type = ATP_Util.specialize_type
   2.416 +
   2.417 +(* ------------------------------------------------------------------------- *)
   2.418 +(* is_const_of_class: returns 'true' iff 'Const (s, T)' is a constant that   *)
   2.419 +(*                    denotes membership to an axiomatic type class          *)
   2.420 +(* ------------------------------------------------------------------------- *)
   2.421 +
   2.422 +fun is_const_of_class thy (s, _) =
   2.423 +  let
   2.424 +    val class_const_names = map Logic.const_of_class (Sign.all_classes thy)
   2.425 +  in
   2.426 +    (* I'm not quite sure if checking the name 's' is sufficient, *)
   2.427 +    (* or if we should also check the type 'T'.                   *)
   2.428 +    member (op =) class_const_names s
   2.429 +  end;
   2.430 +
   2.431 +(* ------------------------------------------------------------------------- *)
   2.432 +(* is_IDT_constructor: returns 'true' iff 'Const (s, T)' is the constructor  *)
   2.433 +(*                     of an inductive datatype in 'thy'                     *)
   2.434 +(* ------------------------------------------------------------------------- *)
   2.435 +
   2.436 +fun is_IDT_constructor thy (s, T) =
   2.437 +  (case body_type T of
   2.438 +    Type (s', _) =>
   2.439 +      (case Datatype.get_constrs thy s' of
   2.440 +        SOME constrs =>
   2.441 +          List.exists (fn (cname, cty) =>
   2.442 +            cname = s andalso Sign.typ_instance thy (T, cty)) constrs
   2.443 +      | NONE => false)
   2.444 +  | _  => false);
   2.445 +
   2.446 +(* ------------------------------------------------------------------------- *)
   2.447 +(* is_IDT_recursor: returns 'true' iff 'Const (s, T)' is the recursion       *)
   2.448 +(*                  operator of an inductive datatype in 'thy'               *)
   2.449 +(* ------------------------------------------------------------------------- *)
   2.450 +
   2.451 +fun is_IDT_recursor thy (s, _) =
   2.452 +  let
   2.453 +    val rec_names = Symtab.fold (append o #rec_names o snd)
   2.454 +      (Datatype.get_all thy) []
   2.455 +  in
   2.456 +    (* I'm not quite sure if checking the name 's' is sufficient, *)
   2.457 +    (* or if we should also check the type 'T'.                   *)
   2.458 +    member (op =) rec_names s
   2.459 +  end;
   2.460 +
   2.461 +(* ------------------------------------------------------------------------- *)
   2.462 +(* norm_rhs: maps  f ?t1 ... ?tn == rhs  to  %t1...tn. rhs                   *)
   2.463 +(* ------------------------------------------------------------------------- *)
   2.464 +
   2.465 +fun norm_rhs eqn =
   2.466 +  let
   2.467 +    fun lambda (v as Var ((x, _), T)) t = Abs (x, T, abstract_over (v, t))
   2.468 +      | lambda v t = raise TERM ("lambda", [v, t])
   2.469 +    val (lhs, rhs) = Logic.dest_equals eqn
   2.470 +    val (_, args) = Term.strip_comb lhs
   2.471 +  in
   2.472 +    fold lambda (rev args) rhs
   2.473 +  end
   2.474 +
   2.475 +(* ------------------------------------------------------------------------- *)
   2.476 +(* get_def: looks up the definition of a constant                            *)
   2.477 +(* ------------------------------------------------------------------------- *)
   2.478 +
   2.479 +fun get_def thy (s, T) =
   2.480 +  let
   2.481 +    (* (string * Term.term) list -> (string * Term.term) option *)
   2.482 +    fun get_def_ax [] = NONE
   2.483 +      | get_def_ax ((axname, ax) :: axioms) =
   2.484 +          (let
   2.485 +            val (lhs, _) = Logic.dest_equals ax  (* equations only *)
   2.486 +            val c        = Term.head_of lhs
   2.487 +            val (s', T') = Term.dest_Const c
   2.488 +          in
   2.489 +            if s=s' then
   2.490 +              let
   2.491 +                val typeSubs = Sign.typ_match thy (T', T) Vartab.empty
   2.492 +                val ax'      = monomorphic_term typeSubs ax
   2.493 +                val rhs      = norm_rhs ax'
   2.494 +              in
   2.495 +                SOME (axname, rhs)
   2.496 +              end
   2.497 +            else
   2.498 +              get_def_ax axioms
   2.499 +          end handle ERROR _         => get_def_ax axioms
   2.500 +                   | TERM _          => get_def_ax axioms
   2.501 +                   | Type.TYPE_MATCH => get_def_ax axioms)
   2.502 +  in
   2.503 +    get_def_ax (Theory.all_axioms_of thy)
   2.504 +  end;
   2.505 +
   2.506 +(* ------------------------------------------------------------------------- *)
   2.507 +(* get_typedef: looks up the definition of a type, as created by "typedef"   *)
   2.508 +(* ------------------------------------------------------------------------- *)
   2.509 +
   2.510 +fun get_typedef thy T =
   2.511 +  let
   2.512 +    (* (string * Term.term) list -> (string * Term.term) option *)
   2.513 +    fun get_typedef_ax [] = NONE
   2.514 +      | get_typedef_ax ((axname, ax) :: axioms) =
   2.515 +          (let
   2.516 +            (* Term.term -> Term.typ option *)
   2.517 +            fun type_of_type_definition (Const (s', T')) =
   2.518 +                  if s'= @{const_name type_definition} then
   2.519 +                    SOME T'
   2.520 +                  else
   2.521 +                    NONE
   2.522 +              | type_of_type_definition (Free _) = NONE
   2.523 +              | type_of_type_definition (Var _) = NONE
   2.524 +              | type_of_type_definition (Bound _) = NONE
   2.525 +              | type_of_type_definition (Abs (_, _, body)) =
   2.526 +                  type_of_type_definition body
   2.527 +              | type_of_type_definition (t1 $ t2) =
   2.528 +                  (case type_of_type_definition t1 of
   2.529 +                    SOME x => SOME x
   2.530 +                  | NONE => type_of_type_definition t2)
   2.531 +          in
   2.532 +            case type_of_type_definition ax of
   2.533 +              SOME T' =>
   2.534 +                let
   2.535 +                  val T'' = domain_type (domain_type T')
   2.536 +                  val typeSubs = Sign.typ_match thy (T'', T) Vartab.empty
   2.537 +                in
   2.538 +                  SOME (axname, monomorphic_term typeSubs ax)
   2.539 +                end
   2.540 +            | NONE => get_typedef_ax axioms
   2.541 +          end handle ERROR _         => get_typedef_ax axioms
   2.542 +                   | TERM _          => get_typedef_ax axioms
   2.543 +                   | Type.TYPE_MATCH => get_typedef_ax axioms)
   2.544 +  in
   2.545 +    get_typedef_ax (Theory.all_axioms_of thy)
   2.546 +  end;
   2.547 +
   2.548 +(* ------------------------------------------------------------------------- *)
   2.549 +(* get_classdef: looks up the defining axiom for an axiomatic type class, as *)
   2.550 +(*               created by the "axclass" command                            *)
   2.551 +(* ------------------------------------------------------------------------- *)
   2.552 +
   2.553 +fun get_classdef thy class =
   2.554 +  let
   2.555 +    val axname = class ^ "_class_def"
   2.556 +  in
   2.557 +    Option.map (pair axname)
   2.558 +      (AList.lookup (op =) (Theory.all_axioms_of thy) axname)
   2.559 +  end;
   2.560 +
   2.561 +(* ------------------------------------------------------------------------- *)
   2.562 +(* unfold_defs: unfolds all defined constants in a term 't', beta-eta        *)
   2.563 +(*              normalizes the result term; certain constants are not        *)
   2.564 +(*              unfolded (cf. 'collect_axioms' and the various interpreters  *)
   2.565 +(*              below): if the interpretation respects a definition anyway,  *)
   2.566 +(*              that definition does not need to be unfolded                 *)
   2.567 +(* ------------------------------------------------------------------------- *)
   2.568 +
   2.569 +(* Note: we could intertwine unfolding of constants and beta-(eta-)       *)
   2.570 +(*       normalization; this would save some unfolding for terms where    *)
   2.571 +(*       constants are eliminated by beta-reduction (e.g. 'K c1 c2').  On *)
   2.572 +(*       the other hand, this would cause additional work for terms where *)
   2.573 +(*       constants are duplicated by beta-reduction (e.g. 'S c1 c2 c3').  *)
   2.574 +
   2.575 +fun unfold_defs thy t =
   2.576 +  let
   2.577 +    (* Term.term -> Term.term *)
   2.578 +    fun unfold_loop t =
   2.579 +      case t of
   2.580 +      (* Pure *)
   2.581 +        Const (@{const_name all}, _) => t
   2.582 +      | Const (@{const_name "=="}, _) => t
   2.583 +      | Const (@{const_name "==>"}, _) => t
   2.584 +      | Const (@{const_name TYPE}, _) => t  (* axiomatic type classes *)
   2.585 +      (* HOL *)
   2.586 +      | Const (@{const_name Trueprop}, _) => t
   2.587 +      | Const (@{const_name Not}, _) => t
   2.588 +      | (* redundant, since 'True' is also an IDT constructor *)
   2.589 +        Const (@{const_name True}, _) => t
   2.590 +      | (* redundant, since 'False' is also an IDT constructor *)
   2.591 +        Const (@{const_name False}, _) => t
   2.592 +      | Const (@{const_name undefined}, _) => t
   2.593 +      | Const (@{const_name The}, _) => t
   2.594 +      | Const (@{const_name Hilbert_Choice.Eps}, _) => t
   2.595 +      | Const (@{const_name All}, _) => t
   2.596 +      | Const (@{const_name Ex}, _) => t
   2.597 +      | Const (@{const_name HOL.eq}, _) => t
   2.598 +      | Const (@{const_name HOL.conj}, _) => t
   2.599 +      | Const (@{const_name HOL.disj}, _) => t
   2.600 +      | Const (@{const_name HOL.implies}, _) => t
   2.601 +      (* sets *)
   2.602 +      | Const (@{const_name Collect}, _) => t
   2.603 +      | Const (@{const_name Set.member}, _) => t
   2.604 +      (* other optimizations *)
   2.605 +      | Const (@{const_name Finite_Set.card}, _) => t
   2.606 +      | Const (@{const_name Finite_Set.finite}, _) => t
   2.607 +      | Const (@{const_name Orderings.less}, Type ("fun", [@{typ nat},
   2.608 +          Type ("fun", [@{typ nat}, @{typ bool}])])) => t
   2.609 +      | Const (@{const_name Groups.plus}, Type ("fun", [@{typ nat},
   2.610 +          Type ("fun", [@{typ nat}, @{typ nat}])])) => t
   2.611 +      | Const (@{const_name Groups.minus}, Type ("fun", [@{typ nat},
   2.612 +          Type ("fun", [@{typ nat}, @{typ nat}])])) => t
   2.613 +      | Const (@{const_name Groups.times}, Type ("fun", [@{typ nat},
   2.614 +          Type ("fun", [@{typ nat}, @{typ nat}])])) => t
   2.615 +      | Const (@{const_name List.append}, _) => t
   2.616 +(* UNSOUND
   2.617 +      | Const (@{const_name lfp}, _) => t
   2.618 +      | Const (@{const_name gfp}, _) => t
   2.619 +*)
   2.620 +      | Const (@{const_name fst}, _) => t
   2.621 +      | Const (@{const_name snd}, _) => t
   2.622 +      (* simply-typed lambda calculus *)
   2.623 +      | Const (s, T) =>
   2.624 +          (if is_IDT_constructor thy (s, T)
   2.625 +            orelse is_IDT_recursor thy (s, T) then
   2.626 +            t  (* do not unfold IDT constructors/recursors *)
   2.627 +          (* unfold the constant if there is a defining equation *)
   2.628 +          else
   2.629 +            case get_def thy (s, T) of
   2.630 +              SOME ((*axname*) _, rhs) =>
   2.631 +              (* Note: if the term to be unfolded (i.e. 'Const (s, T)')  *)
   2.632 +              (* occurs on the right-hand side of the equation, i.e. in  *)
   2.633 +              (* 'rhs', we must not use this equation to unfold, because *)
   2.634 +              (* that would loop.  Here would be the right place to      *)
   2.635 +              (* check this.  However, getting this really right seems   *)
   2.636 +              (* difficult because the user may state arbitrary axioms,  *)
   2.637 +              (* which could interact with overloading to create loops.  *)
   2.638 +              ((*tracing (" unfolding: " ^ axname);*)
   2.639 +               unfold_loop rhs)
   2.640 +            | NONE => t)
   2.641 +      | Free _ => t
   2.642 +      | Var _ => t
   2.643 +      | Bound _ => t
   2.644 +      | Abs (s, T, body) => Abs (s, T, unfold_loop body)
   2.645 +      | t1 $ t2 => (unfold_loop t1) $ (unfold_loop t2)
   2.646 +    val result = Envir.beta_eta_contract (unfold_loop t)
   2.647 +  in
   2.648 +    result
   2.649 +  end;
   2.650 +
   2.651 +(* ------------------------------------------------------------------------- *)
   2.652 +(* collect_axioms: collects (monomorphic, universally quantified, unfolded   *)
   2.653 +(*                 versions of) all HOL axioms that are relevant w.r.t 't'   *)
   2.654 +(* ------------------------------------------------------------------------- *)
   2.655 +
   2.656 +(* Note: to make the collection of axioms more easily extensible, this    *)
   2.657 +(*       function could be based on user-supplied "axiom collectors",     *)
   2.658 +(*       similar to 'interpret'/interpreters or 'print'/printers          *)
   2.659 +
   2.660 +(* Note: currently we use "inverse" functions to the definitional         *)
   2.661 +(*       mechanisms provided by Isabelle/HOL, e.g. for "axclass",         *)
   2.662 +(*       "typedef", "definition".  A more general approach could consider *)
   2.663 +(*       *every* axiom of the theory and collect it if it has a constant/ *)
   2.664 +(*       type/typeclass in common with the term 't'.                      *)
   2.665 +
   2.666 +(* Which axioms are "relevant" for a particular term/type goes hand in    *)
   2.667 +(* hand with the interpretation of that term/type by its interpreter (see *)
   2.668 +(* way below): if the interpretation respects an axiom anyway, the axiom  *)
   2.669 +(* does not need to be added as a constraint here.                        *)
   2.670 +
   2.671 +(* To avoid collecting the same axiom multiple times, we use an           *)
   2.672 +(* accumulator 'axs' which contains all axioms collected so far.          *)
   2.673 +
   2.674 +fun collect_axioms ctxt t =
   2.675 +  let
   2.676 +    val thy = Proof_Context.theory_of ctxt
   2.677 +    val _ = tracing "Adding axioms..."
   2.678 +    val axioms = Theory.all_axioms_of thy
   2.679 +    fun collect_this_axiom (axname, ax) axs =
   2.680 +      let
   2.681 +        val ax' = unfold_defs thy ax
   2.682 +      in
   2.683 +        if member (op aconv) axs ax' then axs
   2.684 +        else (tracing axname; collect_term_axioms ax' (ax' :: axs))
   2.685 +      end
   2.686 +    and collect_sort_axioms T axs =
   2.687 +      let
   2.688 +        val sort =
   2.689 +          (case T of
   2.690 +            TFree (_, sort) => sort
   2.691 +          | TVar (_, sort)  => sort
   2.692 +          | _ => raise REFUTE ("collect_axioms",
   2.693 +              "type " ^ Syntax.string_of_typ ctxt T ^ " is not a variable"))
   2.694 +        (* obtain axioms for all superclasses *)
   2.695 +        val superclasses = sort @ maps (Sign.super_classes thy) sort
   2.696 +        (* merely an optimization, because 'collect_this_axiom' disallows *)
   2.697 +        (* duplicate axioms anyway:                                       *)
   2.698 +        val superclasses = distinct (op =) superclasses
   2.699 +        val class_axioms = maps (fn class => map (fn ax =>
   2.700 +          ("<" ^ class ^ ">", Thm.prop_of ax))
   2.701 +          (#axioms (AxClass.get_info thy class) handle ERROR _ => []))
   2.702 +          superclasses
   2.703 +        (* replace the (at most one) schematic type variable in each axiom *)
   2.704 +        (* by the actual type 'T'                                          *)
   2.705 +        val monomorphic_class_axioms = map (fn (axname, ax) =>
   2.706 +          (case Term.add_tvars ax [] of
   2.707 +            [] => (axname, ax)
   2.708 +          | [(idx, S)] => (axname, monomorphic_term (Vartab.make [(idx, (S, T))]) ax)
   2.709 +          | _ =>
   2.710 +            raise REFUTE ("collect_axioms", "class axiom " ^ axname ^ " (" ^
   2.711 +              Syntax.string_of_term ctxt ax ^
   2.712 +              ") contains more than one type variable")))
   2.713 +          class_axioms
   2.714 +      in
   2.715 +        fold collect_this_axiom monomorphic_class_axioms axs
   2.716 +      end
   2.717 +    and collect_type_axioms T axs =
   2.718 +      case T of
   2.719 +      (* simple types *)
   2.720 +        Type ("prop", []) => axs
   2.721 +      | Type ("fun", [T1, T2]) => collect_type_axioms T2 (collect_type_axioms T1 axs)
   2.722 +      | Type (@{type_name set}, [T1]) => collect_type_axioms T1 axs
   2.723 +      (* axiomatic type classes *)
   2.724 +      | Type ("itself", [T1]) => collect_type_axioms T1 axs
   2.725 +      | Type (s, Ts) =>
   2.726 +        (case Datatype.get_info thy s of
   2.727 +          SOME _ =>  (* inductive datatype *)
   2.728 +            (* only collect relevant type axioms for the argument types *)
   2.729 +            fold collect_type_axioms Ts axs
   2.730 +        | NONE =>
   2.731 +          (case get_typedef thy T of
   2.732 +            SOME (axname, ax) =>
   2.733 +              collect_this_axiom (axname, ax) axs
   2.734 +          | NONE =>
   2.735 +            (* unspecified type, perhaps introduced with "typedecl" *)
   2.736 +            (* at least collect relevant type axioms for the argument types *)
   2.737 +            fold collect_type_axioms Ts axs))
   2.738 +      (* axiomatic type classes *)
   2.739 +      | TFree _ => collect_sort_axioms T axs
   2.740 +      (* axiomatic type classes *)
   2.741 +      | TVar _ => collect_sort_axioms T axs
   2.742 +    and collect_term_axioms t axs =
   2.743 +      case t of
   2.744 +      (* Pure *)
   2.745 +        Const (@{const_name all}, _) => axs
   2.746 +      | Const (@{const_name "=="}, _) => axs
   2.747 +      | Const (@{const_name "==>"}, _) => axs
   2.748 +      (* axiomatic type classes *)
   2.749 +      | Const (@{const_name TYPE}, T) => collect_type_axioms T axs
   2.750 +      (* HOL *)
   2.751 +      | Const (@{const_name Trueprop}, _) => axs
   2.752 +      | Const (@{const_name Not}, _) => axs
   2.753 +      (* redundant, since 'True' is also an IDT constructor *)
   2.754 +      | Const (@{const_name True}, _) => axs
   2.755 +      (* redundant, since 'False' is also an IDT constructor *)
   2.756 +      | Const (@{const_name False}, _) => axs
   2.757 +      | Const (@{const_name undefined}, T) => collect_type_axioms T axs
   2.758 +      | Const (@{const_name The}, T) =>
   2.759 +          let
   2.760 +            val ax = specialize_type thy (@{const_name The}, T)
   2.761 +              (the (AList.lookup (op =) axioms "HOL.the_eq_trivial"))
   2.762 +          in
   2.763 +            collect_this_axiom ("HOL.the_eq_trivial", ax) axs
   2.764 +          end
   2.765 +      | Const (@{const_name Hilbert_Choice.Eps}, T) =>
   2.766 +          let
   2.767 +            val ax = specialize_type thy (@{const_name Hilbert_Choice.Eps}, T)
   2.768 +              (the (AList.lookup (op =) axioms "Hilbert_Choice.someI"))
   2.769 +          in
   2.770 +            collect_this_axiom ("Hilbert_Choice.someI", ax) axs
   2.771 +          end
   2.772 +      | Const (@{const_name All}, T) => collect_type_axioms T axs
   2.773 +      | Const (@{const_name Ex}, T) => collect_type_axioms T axs
   2.774 +      | Const (@{const_name HOL.eq}, T) => collect_type_axioms T axs
   2.775 +      | Const (@{const_name HOL.conj}, _) => axs
   2.776 +      | Const (@{const_name HOL.disj}, _) => axs
   2.777 +      | Const (@{const_name HOL.implies}, _) => axs
   2.778 +      (* sets *)
   2.779 +      | Const (@{const_name Collect}, T) => collect_type_axioms T axs
   2.780 +      | Const (@{const_name Set.member}, T) => collect_type_axioms T axs
   2.781 +      (* other optimizations *)
   2.782 +      | Const (@{const_name Finite_Set.card}, T) => collect_type_axioms T axs
   2.783 +      | Const (@{const_name Finite_Set.finite}, T) =>
   2.784 +        collect_type_axioms T axs
   2.785 +      | Const (@{const_name Orderings.less}, T as Type ("fun", [@{typ nat},
   2.786 +        Type ("fun", [@{typ nat}, @{typ bool}])])) =>
   2.787 +          collect_type_axioms T axs
   2.788 +      | Const (@{const_name Groups.plus}, T as Type ("fun", [@{typ nat},
   2.789 +        Type ("fun", [@{typ nat}, @{typ nat}])])) =>
   2.790 +          collect_type_axioms T axs
   2.791 +      | Const (@{const_name Groups.minus}, T as Type ("fun", [@{typ nat},
   2.792 +        Type ("fun", [@{typ nat}, @{typ nat}])])) =>
   2.793 +          collect_type_axioms T axs
   2.794 +      | Const (@{const_name Groups.times}, T as Type ("fun", [@{typ nat},
   2.795 +        Type ("fun", [@{typ nat}, @{typ nat}])])) =>
   2.796 +          collect_type_axioms T axs
   2.797 +      | Const (@{const_name List.append}, T) => collect_type_axioms T axs
   2.798 +(* UNSOUND
   2.799 +      | Const (@{const_name lfp}, T) => collect_type_axioms T axs
   2.800 +      | Const (@{const_name gfp}, T) => collect_type_axioms T axs
   2.801 +*)
   2.802 +      | Const (@{const_name fst}, T) => collect_type_axioms T axs
   2.803 +      | Const (@{const_name snd}, T) => collect_type_axioms T axs
   2.804 +      (* simply-typed lambda calculus *)
   2.805 +      | Const (s, T) =>
   2.806 +          if is_const_of_class thy (s, T) then
   2.807 +            (* axiomatic type classes: add "OFCLASS(?'a::c, c_class)" *)
   2.808 +            (* and the class definition                               *)
   2.809 +            let
   2.810 +              val class = Logic.class_of_const s
   2.811 +              val of_class = Logic.mk_of_class (TVar (("'a", 0), [class]), class)
   2.812 +              val ax_in = SOME (specialize_type thy (s, T) of_class)
   2.813 +                (* type match may fail due to sort constraints *)
   2.814 +                handle Type.TYPE_MATCH => NONE
   2.815 +              val ax_1 = Option.map (fn ax => (Syntax.string_of_term ctxt ax, ax)) ax_in
   2.816 +              val ax_2 = Option.map (apsnd (specialize_type thy (s, T))) (get_classdef thy class)
   2.817 +            in
   2.818 +              collect_type_axioms T (fold collect_this_axiom (map_filter I [ax_1, ax_2]) axs)
   2.819 +            end
   2.820 +          else if is_IDT_constructor thy (s, T)
   2.821 +            orelse is_IDT_recursor thy (s, T)
   2.822 +          then
   2.823 +            (* only collect relevant type axioms *)
   2.824 +            collect_type_axioms T axs
   2.825 +          else
   2.826 +            (* other constants should have been unfolded, with some *)
   2.827 +            (* exceptions: e.g. Abs_xxx/Rep_xxx functions for       *)
   2.828 +            (* typedefs, or type-class related constants            *)
   2.829 +            (* only collect relevant type axioms *)
   2.830 +            collect_type_axioms T axs
   2.831 +      | Free (_, T) => collect_type_axioms T axs
   2.832 +      | Var (_, T) => collect_type_axioms T axs
   2.833 +      | Bound _ => axs
   2.834 +      | Abs (_, T, body) => collect_term_axioms body (collect_type_axioms T axs)
   2.835 +      | t1 $ t2 => collect_term_axioms t2 (collect_term_axioms t1 axs)
   2.836 +    val result = map close_form (collect_term_axioms t [])
   2.837 +    val _ = tracing " ...done."
   2.838 +  in
   2.839 +    result
   2.840 +  end;
   2.841 +
   2.842 +(* ------------------------------------------------------------------------- *)
   2.843 +(* ground_types: collects all ground types in a term (including argument     *)
   2.844 +(*               types of other types), suppressing duplicates.  Does not    *)
   2.845 +(*               return function types, set types, non-recursive IDTs, or    *)
   2.846 +(*               'propT'.  For IDTs, also the argument types of constructors *)
   2.847 +(*               and all mutually recursive IDTs are considered.             *)
   2.848 +(* ------------------------------------------------------------------------- *)
   2.849 +
   2.850 +fun ground_types ctxt t =
   2.851 +  let
   2.852 +    val thy = Proof_Context.theory_of ctxt
   2.853 +    fun collect_types T acc =
   2.854 +      (case T of
   2.855 +        Type ("fun", [T1, T2]) => collect_types T1 (collect_types T2 acc)
   2.856 +      | Type ("prop", []) => acc
   2.857 +      | Type (@{type_name set}, [T1]) => collect_types T1 acc
   2.858 +      | Type (s, Ts) =>
   2.859 +          (case Datatype.get_info thy s of
   2.860 +            SOME info =>  (* inductive datatype *)
   2.861 +              let
   2.862 +                val index = #index info
   2.863 +                val descr = #descr info
   2.864 +                val (_, typs, _) = the (AList.lookup (op =) descr index)
   2.865 +                val typ_assoc = typs ~~ Ts
   2.866 +                (* sanity check: every element in 'dtyps' must be a *)
   2.867 +                (* 'DtTFree'                                        *)
   2.868 +                val _ = if Library.exists (fn d =>
   2.869 +                  case d of Datatype.DtTFree _ => false | _ => true) typs then
   2.870 +                  raise REFUTE ("ground_types", "datatype argument (for type "
   2.871 +                    ^ Syntax.string_of_typ ctxt T ^ ") is not a variable")
   2.872 +                else ()
   2.873 +                (* required for mutually recursive datatypes; those need to   *)
   2.874 +                (* be added even if they are an instance of an otherwise non- *)
   2.875 +                (* recursive datatype                                         *)
   2.876 +                fun collect_dtyp d acc =
   2.877 +                  let
   2.878 +                    val dT = typ_of_dtyp descr typ_assoc d
   2.879 +                  in
   2.880 +                    case d of
   2.881 +                      Datatype.DtTFree _ =>
   2.882 +                      collect_types dT acc
   2.883 +                    | Datatype.DtType (_, ds) =>
   2.884 +                      collect_types dT (fold_rev collect_dtyp ds acc)
   2.885 +                    | Datatype.DtRec i =>
   2.886 +                      if member (op =) acc dT then
   2.887 +                        acc  (* prevent infinite recursion *)
   2.888 +                      else
   2.889 +                        let
   2.890 +                          val (_, dtyps, dconstrs) = the (AList.lookup (op =) descr i)
   2.891 +                          (* if the current type is a recursive IDT (i.e. a depth *)
   2.892 +                          (* is required), add it to 'acc'                        *)
   2.893 +                          val acc_dT = if Library.exists (fn (_, ds) =>
   2.894 +                            Library.exists Datatype_Aux.is_rec_type ds) dconstrs then
   2.895 +                              insert (op =) dT acc
   2.896 +                            else acc
   2.897 +                          (* collect argument types *)
   2.898 +                          val acc_dtyps = fold_rev collect_dtyp dtyps acc_dT
   2.899 +                          (* collect constructor types *)
   2.900 +                          val acc_dconstrs = fold_rev collect_dtyp (maps snd dconstrs) acc_dtyps
   2.901 +                        in
   2.902 +                          acc_dconstrs
   2.903 +                        end
   2.904 +                  end
   2.905 +              in
   2.906 +                (* argument types 'Ts' could be added here, but they are also *)
   2.907 +                (* added by 'collect_dtyp' automatically                      *)
   2.908 +                collect_dtyp (Datatype.DtRec index) acc
   2.909 +              end
   2.910 +          | NONE =>
   2.911 +            (* not an inductive datatype, e.g. defined via "typedef" or *)
   2.912 +            (* "typedecl"                                               *)
   2.913 +            insert (op =) T (fold collect_types Ts acc))
   2.914 +      | TFree _ => insert (op =) T acc
   2.915 +      | TVar _ => insert (op =) T acc)
   2.916 +  in
   2.917 +    fold_types collect_types t []
   2.918 +  end;
   2.919 +
   2.920 +(* ------------------------------------------------------------------------- *)
   2.921 +(* string_of_typ: (rather naive) conversion from types to strings, used to   *)
   2.922 +(*                look up the size of a type in 'sizes'.  Parameterized      *)
   2.923 +(*                types with different parameters (e.g. "'a list" vs. "bool  *)
   2.924 +(*                list") are identified.                                     *)
   2.925 +(* ------------------------------------------------------------------------- *)
   2.926 +
   2.927 +(* Term.typ -> string *)
   2.928 +
   2.929 +fun string_of_typ (Type (s, _))     = s
   2.930 +  | string_of_typ (TFree (s, _))    = s
   2.931 +  | string_of_typ (TVar ((s,_), _)) = s;
   2.932 +
   2.933 +(* ------------------------------------------------------------------------- *)
   2.934 +(* first_universe: returns the "first" (i.e. smallest) universe by assigning *)
   2.935 +(*                 'minsize' to every type for which no size is specified in *)
   2.936 +(*                 'sizes'                                                   *)
   2.937 +(* ------------------------------------------------------------------------- *)
   2.938 +
   2.939 +(* Term.typ list -> (string * int) list -> int -> (Term.typ * int) list *)
   2.940 +
   2.941 +fun first_universe xs sizes minsize =
   2.942 +  let
   2.943 +    fun size_of_typ T =
   2.944 +      case AList.lookup (op =) sizes (string_of_typ T) of
   2.945 +        SOME n => n
   2.946 +      | NONE => minsize
   2.947 +  in
   2.948 +    map (fn T => (T, size_of_typ T)) xs
   2.949 +  end;
   2.950 +
   2.951 +(* ------------------------------------------------------------------------- *)
   2.952 +(* next_universe: enumerates all universes (i.e. assignments of sizes to     *)
   2.953 +(*                types), where the minimal size of a type is given by       *)
   2.954 +(*                'minsize', the maximal size is given by 'maxsize', and a   *)
   2.955 +(*                type may have a fixed size given in 'sizes'                *)
   2.956 +(* ------------------------------------------------------------------------- *)
   2.957 +
   2.958 +(* (Term.typ * int) list -> (string * int) list -> int -> int ->
   2.959 +  (Term.typ * int) list option *)
   2.960 +
   2.961 +fun next_universe xs sizes minsize maxsize =
   2.962 +  let
   2.963 +    (* creates the "first" list of length 'len', where the sum of all list *)
   2.964 +    (* elements is 'sum', and the length of the list is 'len'              *)
   2.965 +    (* int -> int -> int -> int list option *)
   2.966 +    fun make_first _ 0 sum =
   2.967 +          if sum = 0 then
   2.968 +            SOME []
   2.969 +          else
   2.970 +            NONE
   2.971 +      | make_first max len sum =
   2.972 +          if sum <= max orelse max < 0 then
   2.973 +            Option.map (fn xs' => sum :: xs') (make_first max (len-1) 0)
   2.974 +          else
   2.975 +            Option.map (fn xs' => max :: xs') (make_first max (len-1) (sum-max))
   2.976 +    (* enumerates all int lists with a fixed length, where 0<=x<='max' for *)
   2.977 +    (* all list elements x (unless 'max'<0)                                *)
   2.978 +    (* int -> int -> int -> int list -> int list option *)
   2.979 +    fun next _ _ _ [] =
   2.980 +          NONE
   2.981 +      | next max len sum [x] =
   2.982 +          (* we've reached the last list element, so there's no shift possible *)
   2.983 +          make_first max (len+1) (sum+x+1)  (* increment 'sum' by 1 *)
   2.984 +      | next max len sum (x1::x2::xs) =
   2.985 +          if x1>0 andalso (x2<max orelse max<0) then
   2.986 +            (* we can shift *)
   2.987 +            SOME (the (make_first max (len+1) (sum+x1-1)) @ (x2+1) :: xs)
   2.988 +          else
   2.989 +            (* continue search *)
   2.990 +            next max (len+1) (sum+x1) (x2::xs)
   2.991 +    (* only consider those types for which the size is not fixed *)
   2.992 +    val mutables = filter_out (AList.defined (op =) sizes o string_of_typ o fst) xs
   2.993 +    (* subtract 'minsize' from every size (will be added again at the end) *)
   2.994 +    val diffs = map (fn (_, n) => n-minsize) mutables
   2.995 +  in
   2.996 +    case next (maxsize-minsize) 0 0 diffs of
   2.997 +      SOME diffs' =>
   2.998 +        (* merge with those types for which the size is fixed *)
   2.999 +        SOME (fst (fold_map (fn (T, _) => fn ds =>
  2.1000 +          case AList.lookup (op =) sizes (string_of_typ T) of
  2.1001 +          (* return the fixed size *)
  2.1002 +            SOME n => ((T, n), ds)
  2.1003 +          (* consume the head of 'ds', add 'minsize' *)
  2.1004 +          | NONE   => ((T, minsize + hd ds), tl ds))
  2.1005 +          xs diffs'))
  2.1006 +    | NONE => NONE
  2.1007 +  end;
  2.1008 +
  2.1009 +(* ------------------------------------------------------------------------- *)
  2.1010 +(* toTrue: converts the interpretation of a Boolean value to a propositional *)
  2.1011 +(*         formula that is true iff the interpretation denotes "true"        *)
  2.1012 +(* ------------------------------------------------------------------------- *)
  2.1013 +
  2.1014 +(* interpretation -> prop_formula *)
  2.1015 +
  2.1016 +fun toTrue (Leaf [fm, _]) = fm
  2.1017 +  | toTrue _ = raise REFUTE ("toTrue", "interpretation does not denote a Boolean value");
  2.1018 +
  2.1019 +(* ------------------------------------------------------------------------- *)
  2.1020 +(* toFalse: converts the interpretation of a Boolean value to a              *)
  2.1021 +(*          propositional formula that is true iff the interpretation        *)
  2.1022 +(*          denotes "false"                                                  *)
  2.1023 +(* ------------------------------------------------------------------------- *)
  2.1024 +
  2.1025 +(* interpretation -> prop_formula *)
  2.1026 +
  2.1027 +fun toFalse (Leaf [_, fm]) = fm
  2.1028 +  | toFalse _ = raise REFUTE ("toFalse", "interpretation does not denote a Boolean value");
  2.1029 +
  2.1030 +(* ------------------------------------------------------------------------- *)
  2.1031 +(* find_model: repeatedly calls 'interpret' with appropriate parameters,     *)
  2.1032 +(*             applies a SAT solver, and (in case a model is found) displays *)
  2.1033 +(*             the model to the user by calling 'print_model'                *)
  2.1034 +(* {...}     : parameters that control the translation/model generation      *)
  2.1035 +(* assm_ts   : assumptions to be considered unless "no_assms" is specified   *)
  2.1036 +(* t         : term to be translated into a propositional formula            *)
  2.1037 +(* negate    : if true, find a model that makes 't' false (rather than true) *)
  2.1038 +(* ------------------------------------------------------------------------- *)
  2.1039 +
  2.1040 +fun find_model ctxt
  2.1041 +    {sizes, minsize, maxsize, maxvars, maxtime, satsolver, no_assms, expect}
  2.1042 +    assm_ts t negate =
  2.1043 +  let
  2.1044 +    val thy = Proof_Context.theory_of ctxt
  2.1045 +    (* string -> string *)
  2.1046 +    fun check_expect outcome_code =
  2.1047 +      if expect = "" orelse outcome_code = expect then outcome_code
  2.1048 +      else error ("Unexpected outcome: " ^ quote outcome_code ^ ".")
  2.1049 +    (* unit -> string *)
  2.1050 +    fun wrapper () =
  2.1051 +      let
  2.1052 +        val timer = Timer.startRealTimer ()
  2.1053 +        val t =
  2.1054 +          if no_assms then t
  2.1055 +          else if negate then Logic.list_implies (assm_ts, t)
  2.1056 +          else Logic.mk_conjunction_list (t :: assm_ts)
  2.1057 +        val u = unfold_defs thy t
  2.1058 +        val _ = tracing ("Unfolded term: " ^ Syntax.string_of_term ctxt u)
  2.1059 +        val axioms = collect_axioms ctxt u
  2.1060 +        (* Term.typ list *)
  2.1061 +        val types = fold (union (op =) o ground_types ctxt) (u :: axioms) []
  2.1062 +        val _ = tracing ("Ground types: "
  2.1063 +          ^ (if null types then "none."
  2.1064 +             else commas (map (Syntax.string_of_typ ctxt) types)))
  2.1065 +        (* we can only consider fragments of recursive IDTs, so we issue a  *)
  2.1066 +        (* warning if the formula contains a recursive IDT                  *)
  2.1067 +        (* TODO: no warning needed for /positive/ occurrences of IDTs       *)
  2.1068 +        val maybe_spurious = Library.exists (fn
  2.1069 +            Type (s, _) =>
  2.1070 +              (case Datatype.get_info thy s of
  2.1071 +                SOME info =>  (* inductive datatype *)
  2.1072 +                  let
  2.1073 +                    val index           = #index info
  2.1074 +                    val descr           = #descr info
  2.1075 +                    val (_, _, constrs) = the (AList.lookup (op =) descr index)
  2.1076 +                  in
  2.1077 +                    (* recursive datatype? *)
  2.1078 +                    Library.exists (fn (_, ds) =>
  2.1079 +                      Library.exists Datatype_Aux.is_rec_type ds) constrs
  2.1080 +                  end
  2.1081 +              | NONE => false)
  2.1082 +          | _ => false) types
  2.1083 +        val _ =
  2.1084 +          if maybe_spurious then
  2.1085 +            warning ("Term contains a recursive datatype; "
  2.1086 +              ^ "countermodel(s) may be spurious!")
  2.1087 +          else
  2.1088 +            ()
  2.1089 +        (* (Term.typ * int) list -> string *)
  2.1090 +        fun find_model_loop universe =
  2.1091 +          let
  2.1092 +            val msecs_spent = Time.toMilliseconds (Timer.checkRealTimer timer)
  2.1093 +            val _ = maxtime = 0 orelse msecs_spent < 1000 * maxtime
  2.1094 +                    orelse raise TimeLimit.TimeOut
  2.1095 +            val init_model = (universe, [])
  2.1096 +            val init_args  = {maxvars = maxvars, def_eq = false, next_idx = 1,
  2.1097 +              bounds = [], wellformed = True}
  2.1098 +            val _ = tracing ("Translating term (sizes: "
  2.1099 +              ^ commas (map (fn (_, n) => string_of_int n) universe) ^ ") ...")
  2.1100 +            (* translate 'u' and all axioms *)
  2.1101 +            val (intrs, (model, args)) = fold_map (fn t' => fn (m, a) =>
  2.1102 +              let
  2.1103 +                val (i, m', a') = interpret ctxt m a t'
  2.1104 +              in
  2.1105 +                (* set 'def_eq' to 'true' *)
  2.1106 +                (i, (m', {maxvars = #maxvars a', def_eq = true,
  2.1107 +                  next_idx = #next_idx a', bounds = #bounds a',
  2.1108 +                  wellformed = #wellformed a'}))
  2.1109 +              end) (u :: axioms) (init_model, init_args)
  2.1110 +            (* make 'u' either true or false, and make all axioms true, and *)
  2.1111 +            (* add the well-formedness side condition                       *)
  2.1112 +            val fm_u = (if negate then toFalse else toTrue) (hd intrs)
  2.1113 +            val fm_ax = Prop_Logic.all (map toTrue (tl intrs))
  2.1114 +            val fm = Prop_Logic.all [#wellformed args, fm_ax, fm_u]
  2.1115 +            val _ =
  2.1116 +              (if satsolver = "dpll" orelse satsolver = "enumerate" then
  2.1117 +                warning ("Using SAT solver " ^ quote satsolver ^
  2.1118 +                         "; for better performance, consider installing an \
  2.1119 +                         \external solver.")
  2.1120 +               else ());
  2.1121 +            val solver =
  2.1122 +              SatSolver.invoke_solver satsolver
  2.1123 +              handle Option.Option =>
  2.1124 +                     error ("Unknown SAT solver: " ^ quote satsolver ^
  2.1125 +                            ". Available solvers: " ^
  2.1126 +                            commas (map (quote o fst) (!SatSolver.solvers)) ^ ".")
  2.1127 +          in
  2.1128 +            Output.urgent_message "Invoking SAT solver...";
  2.1129 +            (case solver fm of
  2.1130 +              SatSolver.SATISFIABLE assignment =>
  2.1131 +                (Output.urgent_message ("Model found:\n" ^ print_model ctxt model
  2.1132 +                  (fn i => case assignment i of SOME b => b | NONE => true));
  2.1133 +                 if maybe_spurious then "potential" else "genuine")
  2.1134 +            | SatSolver.UNSATISFIABLE _ =>
  2.1135 +                (Output.urgent_message "No model exists.";
  2.1136 +                case next_universe universe sizes minsize maxsize of
  2.1137 +                  SOME universe' => find_model_loop universe'
  2.1138 +                | NONE => (Output.urgent_message
  2.1139 +                    "Search terminated, no larger universe within the given limits.";
  2.1140 +                    "none"))
  2.1141 +            | SatSolver.UNKNOWN =>
  2.1142 +                (Output.urgent_message "No model found.";
  2.1143 +                case next_universe universe sizes minsize maxsize of
  2.1144 +                  SOME universe' => find_model_loop universe'
  2.1145 +                | NONE => (Output.urgent_message
  2.1146 +                  "Search terminated, no larger universe within the given limits.";
  2.1147 +                  "unknown"))) handle SatSolver.NOT_CONFIGURED =>
  2.1148 +              (error ("SAT solver " ^ quote satsolver ^ " is not configured.");
  2.1149 +               "unknown")
  2.1150 +          end
  2.1151 +          handle MAXVARS_EXCEEDED =>
  2.1152 +            (Output.urgent_message ("Search terminated, number of Boolean variables ("
  2.1153 +              ^ string_of_int maxvars ^ " allowed) exceeded.");
  2.1154 +              "unknown")
  2.1155 +
  2.1156 +        val outcome_code = find_model_loop (first_universe types sizes minsize)
  2.1157 +      in
  2.1158 +        check_expect outcome_code
  2.1159 +      end
  2.1160 +  in
  2.1161 +    (* some parameter sanity checks *)
  2.1162 +    minsize>=1 orelse
  2.1163 +      error ("\"minsize\" is " ^ string_of_int minsize ^ ", must be at least 1");
  2.1164 +    maxsize>=1 orelse
  2.1165 +      error ("\"maxsize\" is " ^ string_of_int maxsize ^ ", must be at least 1");
  2.1166 +    maxsize>=minsize orelse
  2.1167 +      error ("\"maxsize\" (=" ^ string_of_int maxsize ^
  2.1168 +      ") is less than \"minsize\" (=" ^ string_of_int minsize ^ ").");
  2.1169 +    maxvars>=0 orelse
  2.1170 +      error ("\"maxvars\" is " ^ string_of_int maxvars ^ ", must be at least 0");
  2.1171 +    maxtime>=0 orelse
  2.1172 +      error ("\"maxtime\" is " ^ string_of_int maxtime ^ ", must be at least 0");
  2.1173 +    (* enter loop with or without time limit *)
  2.1174 +    Output.urgent_message ("Trying to find a model that "
  2.1175 +      ^ (if negate then "refutes" else "satisfies") ^ ": "
  2.1176 +      ^ Syntax.string_of_term ctxt t);
  2.1177 +    if maxtime > 0 then (
  2.1178 +      TimeLimit.timeLimit (Time.fromSeconds maxtime)
  2.1179 +        wrapper ()
  2.1180 +      handle TimeLimit.TimeOut =>
  2.1181 +        (Output.urgent_message ("Search terminated, time limit (" ^
  2.1182 +            string_of_int maxtime
  2.1183 +            ^ (if maxtime=1 then " second" else " seconds") ^ ") exceeded.");
  2.1184 +         check_expect "unknown")
  2.1185 +    ) else wrapper ()
  2.1186 +  end;
  2.1187 +
  2.1188 +
  2.1189 +(* ------------------------------------------------------------------------- *)
  2.1190 +(* INTERFACE, PART 2: FINDING A MODEL                                        *)
  2.1191 +(* ------------------------------------------------------------------------- *)
  2.1192 +
  2.1193 +(* ------------------------------------------------------------------------- *)
  2.1194 +(* satisfy_term: calls 'find_model' to find a model that satisfies 't'       *)
  2.1195 +(* params      : list of '(name, value)' pairs used to override default      *)
  2.1196 +(*               parameters                                                  *)
  2.1197 +(* ------------------------------------------------------------------------- *)
  2.1198 +
  2.1199 +fun satisfy_term ctxt params assm_ts t =
  2.1200 +  find_model ctxt (actual_params ctxt params) assm_ts t false;
  2.1201 +
  2.1202 +(* ------------------------------------------------------------------------- *)
  2.1203 +(* refute_term: calls 'find_model' to find a model that refutes 't'          *)
  2.1204 +(* params     : list of '(name, value)' pairs used to override default       *)
  2.1205 +(*              parameters                                                   *)
  2.1206 +(* ------------------------------------------------------------------------- *)
  2.1207 +
  2.1208 +fun refute_term ctxt params assm_ts t =
  2.1209 +  let
  2.1210 +    (* disallow schematic type variables, since we cannot properly negate  *)
  2.1211 +    (* terms containing them (their logical meaning is that there EXISTS a *)
  2.1212 +    (* type s.t. ...; to refute such a formula, we would have to show that *)
  2.1213 +    (* for ALL types, not ...)                                             *)
  2.1214 +    val _ = null (Term.add_tvars t []) orelse
  2.1215 +      error "Term to be refuted contains schematic type variables"
  2.1216 +
  2.1217 +    (* existential closure over schematic variables *)
  2.1218 +    val vars = sort_wrt (fst o fst) (Term.add_vars t [])
  2.1219 +    (* Term.term *)
  2.1220 +    val ex_closure = fold (fn ((x, i), T) => fn t' =>
  2.1221 +      HOLogic.exists_const T $
  2.1222 +        Abs (x, T, abstract_over (Var ((x, i), T), t'))) vars t
  2.1223 +    (* Note: If 't' is of type 'propT' (rather than 'boolT'), applying   *)
  2.1224 +    (* 'HOLogic.exists_const' is not type-correct.  However, this is not *)
  2.1225 +    (* really a problem as long as 'find_model' still interprets the     *)
  2.1226 +    (* resulting term correctly, without checking its type.              *)
  2.1227 +
  2.1228 +    (* replace outermost universally quantified variables by Free's:     *)
  2.1229 +    (* refuting a term with Free's is generally faster than refuting a   *)
  2.1230 +    (* term with (nested) quantifiers, because quantifiers are expanded, *)
  2.1231 +    (* while the SAT solver searches for an interpretation for Free's.   *)
  2.1232 +    (* Also we get more information back that way, namely an             *)
  2.1233 +    (* interpretation which includes values for the (formerly)           *)
  2.1234 +    (* quantified variables.                                             *)
  2.1235 +    (* maps  !!x1...xn. !xk...xm. t   to   t  *)
  2.1236 +    fun strip_all_body (Const (@{const_name all}, _) $ Abs (_, _, t)) =
  2.1237 +          strip_all_body t
  2.1238 +      | strip_all_body (Const (@{const_name Trueprop}, _) $ t) =
  2.1239 +          strip_all_body t
  2.1240 +      | strip_all_body (Const (@{const_name All}, _) $ Abs (_, _, t)) =
  2.1241 +          strip_all_body t
  2.1242 +      | strip_all_body t = t
  2.1243 +    (* maps  !!x1...xn. !xk...xm. t   to   [x1, ..., xn, xk, ..., xm]  *)
  2.1244 +    fun strip_all_vars (Const (@{const_name all}, _) $ Abs (a, T, t)) =
  2.1245 +          (a, T) :: strip_all_vars t
  2.1246 +      | strip_all_vars (Const (@{const_name Trueprop}, _) $ t) =
  2.1247 +          strip_all_vars t
  2.1248 +      | strip_all_vars (Const (@{const_name All}, _) $ Abs (a, T, t)) =
  2.1249 +          (a, T) :: strip_all_vars t
  2.1250 +      | strip_all_vars _ = [] : (string * typ) list
  2.1251 +    val strip_t = strip_all_body ex_closure
  2.1252 +    val frees = Term.rename_wrt_term strip_t (strip_all_vars ex_closure)
  2.1253 +    val subst_t = Term.subst_bounds (map Free frees, strip_t)
  2.1254 +  in
  2.1255 +    find_model ctxt (actual_params ctxt params) assm_ts subst_t true
  2.1256 +  end;
  2.1257 +
  2.1258 +(* ------------------------------------------------------------------------- *)
  2.1259 +(* refute_goal                                                               *)
  2.1260 +(* ------------------------------------------------------------------------- *)
  2.1261 +
  2.1262 +fun refute_goal ctxt params th i =
  2.1263 +  let
  2.1264 +    val t = th |> prop_of
  2.1265 +  in
  2.1266 +    if Logic.count_prems t = 0 then
  2.1267 +      (Output.urgent_message "No subgoal!"; "none")
  2.1268 +    else
  2.1269 +      let
  2.1270 +        val assms = map term_of (Assumption.all_assms_of ctxt)
  2.1271 +        val (t, frees) = Logic.goal_params t i
  2.1272 +      in
  2.1273 +        refute_term ctxt params assms (subst_bounds (frees, t))
  2.1274 +      end
  2.1275 +  end
  2.1276 +
  2.1277 +
  2.1278 +(* ------------------------------------------------------------------------- *)
  2.1279 +(* INTERPRETERS: Auxiliary Functions                                         *)
  2.1280 +(* ------------------------------------------------------------------------- *)
  2.1281 +
  2.1282 +(* ------------------------------------------------------------------------- *)
  2.1283 +(* make_constants: returns all interpretations for type 'T' that consist of  *)
  2.1284 +(*                 unit vectors with 'True'/'False' only (no Boolean         *)
  2.1285 +(*                 variables)                                                *)
  2.1286 +(* ------------------------------------------------------------------------- *)
  2.1287 +
  2.1288 +fun make_constants ctxt model T =
  2.1289 +  let
  2.1290 +    (* returns a list with all unit vectors of length n *)
  2.1291 +    (* int -> interpretation list *)
  2.1292 +    fun unit_vectors n =
  2.1293 +      let
  2.1294 +        (* returns the k-th unit vector of length n *)
  2.1295 +        (* int * int -> interpretation *)
  2.1296 +        fun unit_vector (k, n) =
  2.1297 +          Leaf ((replicate (k-1) False) @ (True :: (replicate (n-k) False)))
  2.1298 +        (* int -> interpretation list *)
  2.1299 +        fun unit_vectors_loop k =
  2.1300 +          if k>n then [] else unit_vector (k,n) :: unit_vectors_loop (k+1)
  2.1301 +      in
  2.1302 +        unit_vectors_loop 1
  2.1303 +      end
  2.1304 +    (* returns a list of lists, each one consisting of n (possibly *)
  2.1305 +    (* identical) elements from 'xs'                               *)
  2.1306 +    (* int -> 'a list -> 'a list list *)
  2.1307 +    fun pick_all 1 xs = map single xs
  2.1308 +      | pick_all n xs =
  2.1309 +          let val rec_pick = pick_all (n - 1) xs in
  2.1310 +            maps (fn x => map (cons x) rec_pick) xs
  2.1311 +          end
  2.1312 +    (* returns all constant interpretations that have the same tree *)
  2.1313 +    (* structure as the interpretation argument                     *)
  2.1314 +    (* interpretation -> interpretation list *)
  2.1315 +    fun make_constants_intr (Leaf xs) = unit_vectors (length xs)
  2.1316 +      | make_constants_intr (Node xs) = map Node (pick_all (length xs)
  2.1317 +          (make_constants_intr (hd xs)))
  2.1318 +    (* obtain the interpretation for a variable of type 'T' *)
  2.1319 +    val (i, _, _) = interpret ctxt model {maxvars=0, def_eq=false, next_idx=1,
  2.1320 +      bounds=[], wellformed=True} (Free ("dummy", T))
  2.1321 +  in
  2.1322 +    make_constants_intr i
  2.1323 +  end;
  2.1324 +
  2.1325 +(* ------------------------------------------------------------------------- *)
  2.1326 +(* size_of_type: returns the number of elements in a type 'T' (i.e. 'length  *)
  2.1327 +(*               (make_constants T)', but implemented more efficiently)      *)
  2.1328 +(* ------------------------------------------------------------------------- *)
  2.1329 +
  2.1330 +(* returns 0 for an empty ground type or a function type with empty      *)
  2.1331 +(* codomain, but fails for a function type with empty domain --          *)
  2.1332 +(* admissibility of datatype constructor argument types (see "Inductive  *)
  2.1333 +(* datatypes in HOL - lessons learned ...", S. Berghofer, M. Wenzel,     *)
  2.1334 +(* TPHOLs 99) ensures that recursive, possibly empty, datatype fragments *)
  2.1335 +(* never occur as the domain of a function type that is the type of a    *)
  2.1336 +(* constructor argument                                                  *)
  2.1337 +
  2.1338 +fun size_of_type ctxt model T =
  2.1339 +  let
  2.1340 +    (* returns the number of elements that have the same tree structure as a *)
  2.1341 +    (* given interpretation                                                  *)
  2.1342 +    fun size_of_intr (Leaf xs) = length xs
  2.1343 +      | size_of_intr (Node xs) = Integer.pow (length xs) (size_of_intr (hd xs))
  2.1344 +    (* obtain the interpretation for a variable of type 'T' *)
  2.1345 +    val (i, _, _) = interpret ctxt model {maxvars=0, def_eq=false, next_idx=1,
  2.1346 +      bounds=[], wellformed=True} (Free ("dummy", T))
  2.1347 +  in
  2.1348 +    size_of_intr i
  2.1349 +  end;
  2.1350 +
  2.1351 +(* ------------------------------------------------------------------------- *)
  2.1352 +(* TT/FF: interpretations that denote "true" or "false", respectively        *)
  2.1353 +(* ------------------------------------------------------------------------- *)
  2.1354 +
  2.1355 +(* interpretation *)
  2.1356 +
  2.1357 +val TT = Leaf [True, False];
  2.1358 +
  2.1359 +val FF = Leaf [False, True];
  2.1360 +
  2.1361 +(* ------------------------------------------------------------------------- *)
  2.1362 +(* make_equality: returns an interpretation that denotes (extensional)       *)
  2.1363 +(*                equality of two interpretations                            *)
  2.1364 +(* - two interpretations are 'equal' iff they are both defined and denote    *)
  2.1365 +(*   the same value                                                          *)
  2.1366 +(* - two interpretations are 'not_equal' iff they are both defined at least  *)
  2.1367 +(*   partially, and a defined part denotes different values                  *)
  2.1368 +(* - a completely undefined interpretation is neither 'equal' nor            *)
  2.1369 +(*   'not_equal' to another interpretation                                   *)
  2.1370 +(* ------------------------------------------------------------------------- *)
  2.1371 +
  2.1372 +(* We could in principle represent '=' on a type T by a particular        *)
  2.1373 +(* interpretation.  However, the size of that interpretation is quadratic *)
  2.1374 +(* in the size of T.  Therefore comparing the interpretations 'i1' and    *)
  2.1375 +(* 'i2' directly is more efficient than constructing the interpretation   *)
  2.1376 +(* for equality on T first, and "applying" this interpretation to 'i1'    *)
  2.1377 +(* and 'i2' in the usual way (cf. 'interpretation_apply') then.           *)
  2.1378 +
  2.1379 +(* interpretation * interpretation -> interpretation *)
  2.1380 +
  2.1381 +fun make_equality (i1, i2) =
  2.1382 +  let
  2.1383 +    (* interpretation * interpretation -> prop_formula *)
  2.1384 +    fun equal (i1, i2) =
  2.1385 +      (case i1 of
  2.1386 +        Leaf xs =>
  2.1387 +          (case i2 of
  2.1388 +            Leaf ys => Prop_Logic.dot_product (xs, ys)  (* defined and equal *)
  2.1389 +          | Node _  => raise REFUTE ("make_equality",
  2.1390 +            "second interpretation is higher"))
  2.1391 +      | Node xs =>
  2.1392 +          (case i2 of
  2.1393 +            Leaf _  => raise REFUTE ("make_equality",
  2.1394 +            "first interpretation is higher")
  2.1395 +          | Node ys => Prop_Logic.all (map equal (xs ~~ ys))))
  2.1396 +    (* interpretation * interpretation -> prop_formula *)
  2.1397 +    fun not_equal (i1, i2) =
  2.1398 +      (case i1 of
  2.1399 +        Leaf xs =>
  2.1400 +          (case i2 of
  2.1401 +            (* defined and not equal *)
  2.1402 +            Leaf ys => Prop_Logic.all ((Prop_Logic.exists xs)
  2.1403 +            :: (Prop_Logic.exists ys)
  2.1404 +            :: (map (fn (x,y) => SOr (SNot x, SNot y)) (xs ~~ ys)))
  2.1405 +          | Node _  => raise REFUTE ("make_equality",
  2.1406 +            "second interpretation is higher"))
  2.1407 +      | Node xs =>
  2.1408 +          (case i2 of
  2.1409 +            Leaf _  => raise REFUTE ("make_equality",
  2.1410 +            "first interpretation is higher")
  2.1411 +          | Node ys => Prop_Logic.exists (map not_equal (xs ~~ ys))))
  2.1412 +  in
  2.1413 +    (* a value may be undefined; therefore 'not_equal' is not just the *)
  2.1414 +    (* negation of 'equal'                                             *)
  2.1415 +    Leaf [equal (i1, i2), not_equal (i1, i2)]
  2.1416 +  end;
  2.1417 +
  2.1418 +(* ------------------------------------------------------------------------- *)
  2.1419 +(* make_def_equality: returns an interpretation that denotes (extensional)   *)
  2.1420 +(*                    equality of two interpretations                        *)
  2.1421 +(* This function treats undefined/partially defined interpretations          *)
  2.1422 +(* different from 'make_equality': two undefined interpretations are         *)
  2.1423 +(* considered equal, while a defined interpretation is considered not equal  *)
  2.1424 +(* to an undefined interpretation.                                           *)
  2.1425 +(* ------------------------------------------------------------------------- *)
  2.1426 +
  2.1427 +(* interpretation * interpretation -> interpretation *)
  2.1428 +
  2.1429 +fun make_def_equality (i1, i2) =
  2.1430 +  let
  2.1431 +    (* interpretation * interpretation -> prop_formula *)
  2.1432 +    fun equal (i1, i2) =
  2.1433 +      (case i1 of
  2.1434 +        Leaf xs =>
  2.1435 +          (case i2 of
  2.1436 +            (* defined and equal, or both undefined *)
  2.1437 +            Leaf ys => SOr (Prop_Logic.dot_product (xs, ys),
  2.1438 +            SAnd (Prop_Logic.all (map SNot xs), Prop_Logic.all (map SNot ys)))
  2.1439 +          | Node _  => raise REFUTE ("make_def_equality",
  2.1440 +            "second interpretation is higher"))
  2.1441 +      | Node xs =>
  2.1442 +          (case i2 of
  2.1443 +            Leaf _  => raise REFUTE ("make_def_equality",
  2.1444 +            "first interpretation is higher")
  2.1445 +          | Node ys => Prop_Logic.all (map equal (xs ~~ ys))))
  2.1446 +    (* interpretation *)
  2.1447 +    val eq = equal (i1, i2)
  2.1448 +  in
  2.1449 +    Leaf [eq, SNot eq]
  2.1450 +  end;
  2.1451 +
  2.1452 +(* ------------------------------------------------------------------------- *)
  2.1453 +(* interpretation_apply: returns an interpretation that denotes the result   *)
  2.1454 +(*                       of applying the function denoted by 'i1' to the     *)
  2.1455 +(*                       argument denoted by 'i2'                            *)
  2.1456 +(* ------------------------------------------------------------------------- *)
  2.1457 +
  2.1458 +(* interpretation * interpretation -> interpretation *)
  2.1459 +
  2.1460 +fun interpretation_apply (i1, i2) =
  2.1461 +  let
  2.1462 +    (* interpretation * interpretation -> interpretation *)
  2.1463 +    fun interpretation_disjunction (tr1,tr2) =
  2.1464 +      tree_map (fn (xs,ys) => map (fn (x,y) => SOr(x,y)) (xs ~~ ys))
  2.1465 +        (tree_pair (tr1,tr2))
  2.1466 +    (* prop_formula * interpretation -> interpretation *)
  2.1467 +    fun prop_formula_times_interpretation (fm,tr) =
  2.1468 +      tree_map (map (fn x => SAnd (fm,x))) tr
  2.1469 +    (* prop_formula list * interpretation list -> interpretation *)
  2.1470 +    fun prop_formula_list_dot_product_interpretation_list ([fm],[tr]) =
  2.1471 +          prop_formula_times_interpretation (fm,tr)
  2.1472 +      | prop_formula_list_dot_product_interpretation_list (fm::fms,tr::trees) =
  2.1473 +          interpretation_disjunction (prop_formula_times_interpretation (fm,tr),
  2.1474 +            prop_formula_list_dot_product_interpretation_list (fms,trees))
  2.1475 +      | prop_formula_list_dot_product_interpretation_list (_,_) =
  2.1476 +          raise REFUTE ("interpretation_apply", "empty list (in dot product)")
  2.1477 +    (* returns a list of lists, each one consisting of one element from each *)
  2.1478 +    (* element of 'xss'                                                      *)
  2.1479 +    (* 'a list list -> 'a list list *)
  2.1480 +    fun pick_all [xs] = map single xs
  2.1481 +      | pick_all (xs::xss) =
  2.1482 +          let val rec_pick = pick_all xss in
  2.1483 +            maps (fn x => map (cons x) rec_pick) xs
  2.1484 +          end
  2.1485 +      | pick_all _ = raise REFUTE ("interpretation_apply", "empty list (in pick_all)")
  2.1486 +    (* interpretation -> prop_formula list *)
  2.1487 +    fun interpretation_to_prop_formula_list (Leaf xs) = xs
  2.1488 +      | interpretation_to_prop_formula_list (Node trees) =
  2.1489 +          map Prop_Logic.all (pick_all
  2.1490 +            (map interpretation_to_prop_formula_list trees))
  2.1491 +  in
  2.1492 +    case i1 of
  2.1493 +      Leaf _ =>
  2.1494 +        raise REFUTE ("interpretation_apply", "first interpretation is a leaf")
  2.1495 +    | Node xs =>
  2.1496 +        prop_formula_list_dot_product_interpretation_list
  2.1497 +          (interpretation_to_prop_formula_list i2, xs)
  2.1498 +  end;
  2.1499 +
  2.1500 +(* ------------------------------------------------------------------------- *)
  2.1501 +(* eta_expand: eta-expands a term 't' by adding 'i' lambda abstractions      *)
  2.1502 +(* ------------------------------------------------------------------------- *)
  2.1503 +
  2.1504 +(* Term.term -> int -> Term.term *)
  2.1505 +
  2.1506 +fun eta_expand t i =
  2.1507 +  let
  2.1508 +    val Ts = Term.binder_types (Term.fastype_of t)
  2.1509 +    val t' = Term.incr_boundvars i t
  2.1510 +  in
  2.1511 +    fold_rev (fn T => fn term => Abs ("<eta_expand>", T, term))
  2.1512 +      (List.take (Ts, i))
  2.1513 +      (Term.list_comb (t', map Bound (i-1 downto 0)))
  2.1514 +  end;
  2.1515 +
  2.1516 +(* ------------------------------------------------------------------------- *)
  2.1517 +(* size_of_dtyp: the size of (an initial fragment of) an inductive data type *)
  2.1518 +(*               is the sum (over its constructors) of the product (over     *)
  2.1519 +(*               their arguments) of the size of the argument types          *)
  2.1520 +(* ------------------------------------------------------------------------- *)
  2.1521 +
  2.1522 +fun size_of_dtyp ctxt typ_sizes descr typ_assoc constructors =
  2.1523 +  Integer.sum (map (fn (_, dtyps) =>
  2.1524 +    Integer.prod (map (size_of_type ctxt (typ_sizes, []) o
  2.1525 +      (typ_of_dtyp descr typ_assoc)) dtyps))
  2.1526 +        constructors);
  2.1527 +
  2.1528 +
  2.1529 +(* ------------------------------------------------------------------------- *)
  2.1530 +(* INTERPRETERS: Actual Interpreters                                         *)
  2.1531 +(* ------------------------------------------------------------------------- *)
  2.1532 +
  2.1533 +(* simply typed lambda calculus: Isabelle's basic term syntax, with type *)
  2.1534 +(* variables, function types, and propT                                  *)
  2.1535 +
  2.1536 +fun stlc_interpreter ctxt model args t =
  2.1537 +  let
  2.1538 +    val (typs, terms) = model
  2.1539 +    val {maxvars, def_eq, next_idx, bounds, wellformed} = args
  2.1540 +    (* Term.typ -> (interpretation * model * arguments) option *)
  2.1541 +    fun interpret_groundterm T =
  2.1542 +      let
  2.1543 +        (* unit -> (interpretation * model * arguments) option *)
  2.1544 +        fun interpret_groundtype () =
  2.1545 +          let
  2.1546 +            (* the model must specify a size for ground types *)
  2.1547 +            val size =
  2.1548 +              if T = Term.propT then 2
  2.1549 +              else the (AList.lookup (op =) typs T)
  2.1550 +            val next = next_idx + size
  2.1551 +            (* check if 'maxvars' is large enough *)
  2.1552 +            val _ = (if next - 1 > maxvars andalso maxvars > 0 then
  2.1553 +              raise MAXVARS_EXCEEDED else ())
  2.1554 +            (* prop_formula list *)
  2.1555 +            val fms  = map BoolVar (next_idx upto (next_idx + size - 1))
  2.1556 +            (* interpretation *)
  2.1557 +            val intr = Leaf fms
  2.1558 +            (* prop_formula list -> prop_formula *)
  2.1559 +            fun one_of_two_false [] = True
  2.1560 +              | one_of_two_false (x::xs) = SAnd (Prop_Logic.all (map (fn x' =>
  2.1561 +                  SOr (SNot x, SNot x')) xs), one_of_two_false xs)
  2.1562 +            (* prop_formula *)
  2.1563 +            val wf = one_of_two_false fms
  2.1564 +          in
  2.1565 +            (* extend the model, increase 'next_idx', add well-formedness *)
  2.1566 +            (* condition                                                  *)
  2.1567 +            SOME (intr, (typs, (t, intr)::terms), {maxvars = maxvars,
  2.1568 +              def_eq = def_eq, next_idx = next, bounds = bounds,
  2.1569 +              wellformed = SAnd (wellformed, wf)})
  2.1570 +          end
  2.1571 +      in
  2.1572 +        case T of
  2.1573 +          Type ("fun", [T1, T2]) =>
  2.1574 +            let
  2.1575 +              (* we create 'size_of_type ... T1' different copies of the        *)
  2.1576 +              (* interpretation for 'T2', which are then combined into a single *)
  2.1577 +              (* new interpretation                                             *)
  2.1578 +              (* make fresh copies, with different variable indices *)
  2.1579 +              (* 'idx': next variable index                         *)
  2.1580 +              (* 'n'  : number of copies                            *)
  2.1581 +              (* int -> int -> (int * interpretation list * prop_formula *)
  2.1582 +              fun make_copies idx 0 = (idx, [], True)
  2.1583 +                | make_copies idx n =
  2.1584 +                    let
  2.1585 +                      val (copy, _, new_args) = interpret ctxt (typs, [])
  2.1586 +                        {maxvars = maxvars, def_eq = false, next_idx = idx,
  2.1587 +                        bounds = [], wellformed = True} (Free ("dummy", T2))
  2.1588 +                      val (idx', copies, wf') = make_copies (#next_idx new_args) (n-1)
  2.1589 +                    in
  2.1590 +                      (idx', copy :: copies, SAnd (#wellformed new_args, wf'))
  2.1591 +                    end
  2.1592 +              val (next, copies, wf) = make_copies next_idx
  2.1593 +                (size_of_type ctxt model T1)
  2.1594 +              (* combine copies into a single interpretation *)
  2.1595 +              val intr = Node copies
  2.1596 +            in
  2.1597 +              (* extend the model, increase 'next_idx', add well-formedness *)
  2.1598 +              (* condition                                                  *)
  2.1599 +              SOME (intr, (typs, (t, intr)::terms), {maxvars = maxvars,
  2.1600 +                def_eq = def_eq, next_idx = next, bounds = bounds,
  2.1601 +                wellformed = SAnd (wellformed, wf)})
  2.1602 +            end
  2.1603 +        | Type _  => interpret_groundtype ()
  2.1604 +        | TFree _ => interpret_groundtype ()
  2.1605 +        | TVar  _ => interpret_groundtype ()
  2.1606 +      end
  2.1607 +  in
  2.1608 +    case AList.lookup (op =) terms t of
  2.1609 +      SOME intr =>
  2.1610 +        (* return an existing interpretation *)
  2.1611 +        SOME (intr, model, args)
  2.1612 +    | NONE =>
  2.1613 +        (case t of
  2.1614 +          Const (_, T) => interpret_groundterm T
  2.1615 +        | Free (_, T) => interpret_groundterm T
  2.1616 +        | Var (_, T) => interpret_groundterm T
  2.1617 +        | Bound i => SOME (nth (#bounds args) i, model, args)
  2.1618 +        | Abs (_, T, body) =>
  2.1619 +            let
  2.1620 +              (* create all constants of type 'T' *)
  2.1621 +              val constants = make_constants ctxt model T
  2.1622 +              (* interpret the 'body' separately for each constant *)
  2.1623 +              val (bodies, (model', args')) = fold_map
  2.1624 +                (fn c => fn (m, a) =>
  2.1625 +                  let
  2.1626 +                    (* add 'c' to 'bounds' *)
  2.1627 +                    val (i', m', a') = interpret ctxt m {maxvars = #maxvars a,
  2.1628 +                      def_eq = #def_eq a, next_idx = #next_idx a,
  2.1629 +                      bounds = (c :: #bounds a), wellformed = #wellformed a} body
  2.1630 +                  in
  2.1631 +                    (* keep the new model m' and 'next_idx' and 'wellformed', *)
  2.1632 +                    (* but use old 'bounds'                                   *)
  2.1633 +                    (i', (m', {maxvars = maxvars, def_eq = def_eq,
  2.1634 +                      next_idx = #next_idx a', bounds = bounds,
  2.1635 +                      wellformed = #wellformed a'}))
  2.1636 +                  end)
  2.1637 +                constants (model, args)
  2.1638 +            in
  2.1639 +              SOME (Node bodies, model', args')
  2.1640 +            end
  2.1641 +        | t1 $ t2 =>
  2.1642 +            let
  2.1643 +              (* interpret 't1' and 't2' separately *)
  2.1644 +              val (intr1, model1, args1) = interpret ctxt model args t1
  2.1645 +              val (intr2, model2, args2) = interpret ctxt model1 args1 t2
  2.1646 +            in
  2.1647 +              SOME (interpretation_apply (intr1, intr2), model2, args2)
  2.1648 +            end)
  2.1649 +  end;
  2.1650 +
  2.1651 +fun Pure_interpreter ctxt model args t =
  2.1652 +  case t of
  2.1653 +    Const (@{const_name all}, _) $ t1 =>
  2.1654 +      let
  2.1655 +        val (i, m, a) = interpret ctxt model args t1
  2.1656 +      in
  2.1657 +        case i of
  2.1658 +          Node xs =>
  2.1659 +            (* 3-valued logic *)
  2.1660 +            let
  2.1661 +              val fmTrue  = Prop_Logic.all (map toTrue xs)
  2.1662 +              val fmFalse = Prop_Logic.exists (map toFalse xs)
  2.1663 +            in
  2.1664 +              SOME (Leaf [fmTrue, fmFalse], m, a)
  2.1665 +            end
  2.1666 +        | _ =>
  2.1667 +          raise REFUTE ("Pure_interpreter",
  2.1668 +            "\"all\" is followed by a non-function")
  2.1669 +      end
  2.1670 +  | Const (@{const_name all}, _) =>
  2.1671 +      SOME (interpret ctxt model args (eta_expand t 1))
  2.1672 +  | Const (@{const_name "=="}, _) $ t1 $ t2 =>
  2.1673 +      let
  2.1674 +        val (i1, m1, a1) = interpret ctxt model args t1
  2.1675 +        val (i2, m2, a2) = interpret ctxt m1 a1 t2
  2.1676 +      in
  2.1677 +        (* we use either 'make_def_equality' or 'make_equality' *)
  2.1678 +        SOME ((if #def_eq args then make_def_equality else make_equality)
  2.1679 +          (i1, i2), m2, a2)
  2.1680 +      end
  2.1681 +  | Const (@{const_name "=="}, _) $ _ =>
  2.1682 +      SOME (interpret ctxt model args (eta_expand t 1))
  2.1683 +  | Const (@{const_name "=="}, _) =>
  2.1684 +      SOME (interpret ctxt model args (eta_expand t 2))
  2.1685 +  | Const (@{const_name "==>"}, _) $ t1 $ t2 =>
  2.1686 +      (* 3-valued logic *)
  2.1687 +      let
  2.1688 +        val (i1, m1, a1) = interpret ctxt model args t1
  2.1689 +        val (i2, m2, a2) = interpret ctxt m1 a1 t2
  2.1690 +        val fmTrue = Prop_Logic.SOr (toFalse i1, toTrue i2)
  2.1691 +        val fmFalse = Prop_Logic.SAnd (toTrue i1, toFalse i2)
  2.1692 +      in
  2.1693 +        SOME (Leaf [fmTrue, fmFalse], m2, a2)
  2.1694 +      end
  2.1695 +  | Const (@{const_name "==>"}, _) $ _ =>
  2.1696 +      SOME (interpret ctxt model args (eta_expand t 1))
  2.1697 +  | Const (@{const_name "==>"}, _) =>
  2.1698 +      SOME (interpret ctxt model args (eta_expand t 2))
  2.1699 +  | _ => NONE;
  2.1700 +
  2.1701 +fun HOLogic_interpreter ctxt model args t =
  2.1702 +(* Providing interpretations directly is more efficient than unfolding the *)
  2.1703 +(* logical constants.  In HOL however, logical constants can themselves be *)
  2.1704 +(* arguments.  They are then translated using eta-expansion.               *)
  2.1705 +  case t of
  2.1706 +    Const (@{const_name Trueprop}, _) =>
  2.1707 +      SOME (Node [TT, FF], model, args)
  2.1708 +  | Const (@{const_name Not}, _) =>
  2.1709 +      SOME (Node [FF, TT], model, args)
  2.1710 +  (* redundant, since 'True' is also an IDT constructor *)
  2.1711 +  | Const (@{const_name True}, _) =>
  2.1712 +      SOME (TT, model, args)
  2.1713 +  (* redundant, since 'False' is also an IDT constructor *)
  2.1714 +  | Const (@{const_name False}, _) =>
  2.1715 +      SOME (FF, model, args)
  2.1716 +  | Const (@{const_name All}, _) $ t1 =>  (* similar to "all" (Pure) *)
  2.1717 +      let
  2.1718 +        val (i, m, a) = interpret ctxt model args t1
  2.1719 +      in
  2.1720 +        case i of
  2.1721 +          Node xs =>
  2.1722 +            (* 3-valued logic *)
  2.1723 +            let
  2.1724 +              val fmTrue = Prop_Logic.all (map toTrue xs)
  2.1725 +              val fmFalse = Prop_Logic.exists (map toFalse xs)
  2.1726 +            in
  2.1727 +              SOME (Leaf [fmTrue, fmFalse], m, a)
  2.1728 +            end
  2.1729 +        | _ =>
  2.1730 +          raise REFUTE ("HOLogic_interpreter",
  2.1731 +            "\"All\" is followed by a non-function")
  2.1732 +      end
  2.1733 +  | Const (@{const_name All}, _) =>
  2.1734 +      SOME (interpret ctxt model args (eta_expand t 1))
  2.1735 +  | Const (@{const_name Ex}, _) $ t1 =>
  2.1736 +      let
  2.1737 +        val (i, m, a) = interpret ctxt model args t1
  2.1738 +      in
  2.1739 +        case i of
  2.1740 +          Node xs =>
  2.1741 +            (* 3-valued logic *)
  2.1742 +            let
  2.1743 +              val fmTrue = Prop_Logic.exists (map toTrue xs)
  2.1744 +              val fmFalse = Prop_Logic.all (map toFalse xs)
  2.1745 +            in
  2.1746 +              SOME (Leaf [fmTrue, fmFalse], m, a)
  2.1747 +            end
  2.1748 +        | _ =>
  2.1749 +          raise REFUTE ("HOLogic_interpreter",
  2.1750 +            "\"Ex\" is followed by a non-function")
  2.1751 +      end
  2.1752 +  | Const (@{const_name Ex}, _) =>
  2.1753 +      SOME (interpret ctxt model args (eta_expand t 1))
  2.1754 +  | Const (@{const_name HOL.eq}, _) $ t1 $ t2 =>  (* similar to "==" (Pure) *)
  2.1755 +      let
  2.1756 +        val (i1, m1, a1) = interpret ctxt model args t1
  2.1757 +        val (i2, m2, a2) = interpret ctxt m1 a1 t2
  2.1758 +      in
  2.1759 +        SOME (make_equality (i1, i2), m2, a2)
  2.1760 +      end
  2.1761 +  | Const (@{const_name HOL.eq}, _) $ _ =>
  2.1762 +      SOME (interpret ctxt model args (eta_expand t 1))
  2.1763 +  | Const (@{const_name HOL.eq}, _) =>
  2.1764 +      SOME (interpret ctxt model args (eta_expand t 2))
  2.1765 +  | Const (@{const_name HOL.conj}, _) $ t1 $ t2 =>
  2.1766 +      (* 3-valued logic *)
  2.1767 +      let
  2.1768 +        val (i1, m1, a1) = interpret ctxt model args t1
  2.1769 +        val (i2, m2, a2) = interpret ctxt m1 a1 t2
  2.1770 +        val fmTrue = Prop_Logic.SAnd (toTrue i1, toTrue i2)
  2.1771 +        val fmFalse = Prop_Logic.SOr (toFalse i1, toFalse i2)
  2.1772 +      in
  2.1773 +        SOME (Leaf [fmTrue, fmFalse], m2, a2)
  2.1774 +      end
  2.1775 +  | Const (@{const_name HOL.conj}, _) $ _ =>
  2.1776 +      SOME (interpret ctxt model args (eta_expand t 1))
  2.1777 +  | Const (@{const_name HOL.conj}, _) =>
  2.1778 +      SOME (interpret ctxt model args (eta_expand t 2))
  2.1779 +      (* this would make "undef" propagate, even for formulae like *)
  2.1780 +      (* "False & undef":                                          *)
  2.1781 +      (* SOME (Node [Node [TT, FF], Node [FF, FF]], model, args) *)
  2.1782 +  | Const (@{const_name HOL.disj}, _) $ t1 $ t2 =>
  2.1783 +      (* 3-valued logic *)
  2.1784 +      let
  2.1785 +        val (i1, m1, a1) = interpret ctxt model args t1
  2.1786 +        val (i2, m2, a2) = interpret ctxt m1 a1 t2
  2.1787 +        val fmTrue = Prop_Logic.SOr (toTrue i1, toTrue i2)
  2.1788 +        val fmFalse = Prop_Logic.SAnd (toFalse i1, toFalse i2)
  2.1789 +      in
  2.1790 +        SOME (Leaf [fmTrue, fmFalse], m2, a2)
  2.1791 +      end
  2.1792 +  | Const (@{const_name HOL.disj}, _) $ _ =>
  2.1793 +      SOME (interpret ctxt model args (eta_expand t 1))
  2.1794 +  | Const (@{const_name HOL.disj}, _) =>
  2.1795 +      SOME (interpret ctxt model args (eta_expand t 2))
  2.1796 +      (* this would make "undef" propagate, even for formulae like *)
  2.1797 +      (* "True | undef":                                           *)
  2.1798 +      (* SOME (Node [Node [TT, TT], Node [TT, FF]], model, args) *)
  2.1799 +  | Const (@{const_name HOL.implies}, _) $ t1 $ t2 =>  (* similar to "==>" (Pure) *)
  2.1800 +      (* 3-valued logic *)
  2.1801 +      let
  2.1802 +        val (i1, m1, a1) = interpret ctxt model args t1
  2.1803 +        val (i2, m2, a2) = interpret ctxt m1 a1 t2
  2.1804 +        val fmTrue = Prop_Logic.SOr (toFalse i1, toTrue i2)
  2.1805 +        val fmFalse = Prop_Logic.SAnd (toTrue i1, toFalse i2)
  2.1806 +      in
  2.1807 +        SOME (Leaf [fmTrue, fmFalse], m2, a2)
  2.1808 +      end
  2.1809 +  | Const (@{const_name HOL.implies}, _) $ _ =>
  2.1810 +      SOME (interpret ctxt model args (eta_expand t 1))
  2.1811 +  | Const (@{const_name HOL.implies}, _) =>
  2.1812 +      SOME (interpret ctxt model args (eta_expand t 2))
  2.1813 +      (* this would make "undef" propagate, even for formulae like *)
  2.1814 +      (* "False --> undef":                                        *)
  2.1815 +      (* SOME (Node [Node [TT, FF], Node [TT, TT]], model, args) *)
  2.1816 +  | _ => NONE;
  2.1817 +
  2.1818 +(* interprets variables and constants whose type is an IDT (this is        *)
  2.1819 +(* relatively easy and merely requires us to compute the size of the IDT); *)
  2.1820 +(* constructors of IDTs however are properly interpreted by                *)
  2.1821 +(* 'IDT_constructor_interpreter'                                           *)
  2.1822 +
  2.1823 +fun IDT_interpreter ctxt model args t =
  2.1824 +  let
  2.1825 +    val thy = Proof_Context.theory_of ctxt
  2.1826 +    val (typs, terms) = model
  2.1827 +    (* Term.typ -> (interpretation * model * arguments) option *)
  2.1828 +    fun interpret_term (Type (s, Ts)) =
  2.1829 +          (case Datatype.get_info thy s of
  2.1830 +            SOME info =>  (* inductive datatype *)
  2.1831 +              let
  2.1832 +                (* int option -- only recursive IDTs have an associated depth *)
  2.1833 +                val depth = AList.lookup (op =) typs (Type (s, Ts))
  2.1834 +                (* sanity check: depth must be at least 0 *)
  2.1835 +                val _ =
  2.1836 +                  (case depth of SOME n =>
  2.1837 +                    if n < 0 then
  2.1838 +                      raise REFUTE ("IDT_interpreter", "negative depth")
  2.1839 +                    else ()
  2.1840 +                  | _ => ())
  2.1841 +              in
  2.1842 +                (* termination condition to avoid infinite recursion *)
  2.1843 +                if depth = (SOME 0) then
  2.1844 +                  (* return a leaf of size 0 *)
  2.1845 +                  SOME (Leaf [], model, args)
  2.1846 +                else
  2.1847 +                  let
  2.1848 +                    val index               = #index info
  2.1849 +                    val descr               = #descr info
  2.1850 +                    val (_, dtyps, constrs) = the (AList.lookup (op =) descr index)
  2.1851 +                    val typ_assoc           = dtyps ~~ Ts
  2.1852 +                    (* sanity check: every element in 'dtyps' must be a 'DtTFree' *)
  2.1853 +                    val _ =
  2.1854 +                      if Library.exists (fn d =>
  2.1855 +                        case d of Datatype.DtTFree _ => false | _ => true) dtyps
  2.1856 +                      then
  2.1857 +                        raise REFUTE ("IDT_interpreter",
  2.1858 +                          "datatype argument (for type "
  2.1859 +                          ^ Syntax.string_of_typ ctxt (Type (s, Ts))
  2.1860 +                          ^ ") is not a variable")
  2.1861 +                      else ()
  2.1862 +                    (* if the model specifies a depth for the current type, *)
  2.1863 +                    (* decrement it to avoid infinite recursion             *)
  2.1864 +                    val typs' = case depth of NONE => typs | SOME n =>
  2.1865 +                      AList.update (op =) (Type (s, Ts), n-1) typs
  2.1866 +                    (* recursively compute the size of the datatype *)
  2.1867 +                    val size     = size_of_dtyp ctxt typs' descr typ_assoc constrs
  2.1868 +                    val next_idx = #next_idx args
  2.1869 +                    val next     = next_idx+size
  2.1870 +                    (* check if 'maxvars' is large enough *)
  2.1871 +                    val _        = (if next-1 > #maxvars args andalso
  2.1872 +                      #maxvars args > 0 then raise MAXVARS_EXCEEDED else ())
  2.1873 +                    (* prop_formula list *)
  2.1874 +                    val fms      = map BoolVar (next_idx upto (next_idx+size-1))
  2.1875 +                    (* interpretation *)
  2.1876 +                    val intr     = Leaf fms
  2.1877 +                    (* prop_formula list -> prop_formula *)
  2.1878 +                    fun one_of_two_false [] = True
  2.1879 +                      | one_of_two_false (x::xs) = SAnd (Prop_Logic.all (map (fn x' =>
  2.1880 +                          SOr (SNot x, SNot x')) xs), one_of_two_false xs)
  2.1881 +                    (* prop_formula *)
  2.1882 +                    val wf = one_of_two_false fms
  2.1883 +                  in
  2.1884 +                    (* extend the model, increase 'next_idx', add well-formedness *)
  2.1885 +                    (* condition                                                  *)
  2.1886 +                    SOME (intr, (typs, (t, intr)::terms), {maxvars = #maxvars args,
  2.1887 +                      def_eq = #def_eq args, next_idx = next, bounds = #bounds args,
  2.1888 +                      wellformed = SAnd (#wellformed args, wf)})
  2.1889 +                  end
  2.1890 +              end
  2.1891 +          | NONE =>  (* not an inductive datatype *)
  2.1892 +              NONE)
  2.1893 +      | interpret_term _ =  (* a (free or schematic) type variable *)
  2.1894 +          NONE
  2.1895 +  in
  2.1896 +    case AList.lookup (op =) terms t of
  2.1897 +      SOME intr =>
  2.1898 +        (* return an existing interpretation *)
  2.1899 +        SOME (intr, model, args)
  2.1900 +    | NONE =>
  2.1901 +        (case t of
  2.1902 +          Free (_, T) => interpret_term T
  2.1903 +        | Var (_, T) => interpret_term T
  2.1904 +        | Const (_, T) => interpret_term T
  2.1905 +        | _ => NONE)
  2.1906 +  end;
  2.1907 +
  2.1908 +(* This function imposes an order on the elements of a datatype fragment  *)
  2.1909 +(* as follows: C_i x_1 ... x_n < C_j y_1 ... y_m iff i < j or             *)
  2.1910 +(* (x_1, ..., x_n) < (y_1, ..., y_m).  With this order, a constructor is  *)
  2.1911 +(* a function C_i that maps some argument indices x_1, ..., x_n to the    *)
  2.1912 +(* datatype element given by index C_i x_1 ... x_n.  The idea remains the *)
  2.1913 +(* same for recursive datatypes, although the computation of indices gets *)
  2.1914 +(* a little tricky.                                                       *)
  2.1915 +
  2.1916 +fun IDT_constructor_interpreter ctxt model args t =
  2.1917 +  let
  2.1918 +    val thy = Proof_Context.theory_of ctxt
  2.1919 +    (* returns a list of canonical representations for terms of the type 'T' *)
  2.1920 +    (* It would be nice if we could just use 'print' for this, but 'print'   *)
  2.1921 +    (* for IDTs calls 'IDT_constructor_interpreter' again, and this could    *)
  2.1922 +    (* lead to infinite recursion when we have (mutually) recursive IDTs.    *)
  2.1923 +    (* (Term.typ * int) list -> Term.typ -> Term.term list *)
  2.1924 +    fun canonical_terms typs T =
  2.1925 +          (case T of
  2.1926 +            Type ("fun", [T1, T2]) =>
  2.1927 +            (* 'T2' might contain a recursive IDT, so we cannot use 'print' (at *)
  2.1928 +            (* least not for 'T2'                                               *)
  2.1929 +            let
  2.1930 +              (* returns a list of lists, each one consisting of n (possibly *)
  2.1931 +              (* identical) elements from 'xs'                               *)
  2.1932 +              (* int -> 'a list -> 'a list list *)
  2.1933 +              fun pick_all 1 xs = map single xs
  2.1934 +                | pick_all n xs =
  2.1935 +                    let val rec_pick = pick_all (n-1) xs in
  2.1936 +                      maps (fn x => map (cons x) rec_pick) xs
  2.1937 +                    end
  2.1938 +              (* ["x1", ..., "xn"] *)
  2.1939 +              val terms1 = canonical_terms typs T1
  2.1940 +              (* ["y1", ..., "ym"] *)
  2.1941 +              val terms2 = canonical_terms typs T2
  2.1942 +              (* [[("x1", "y1"), ..., ("xn", "y1")], ..., *)
  2.1943 +              (*   [("x1", "ym"), ..., ("xn", "ym")]]     *)
  2.1944 +              val functions = map (curry (op ~~) terms1)
  2.1945 +                (pick_all (length terms1) terms2)
  2.1946 +              (* [["(x1, y1)", ..., "(xn, y1)"], ..., *)
  2.1947 +              (*   ["(x1, ym)", ..., "(xn, ym)"]]     *)
  2.1948 +              val pairss = map (map HOLogic.mk_prod) functions
  2.1949 +              (* Term.typ *)
  2.1950 +              val HOLogic_prodT = HOLogic.mk_prodT (T1, T2)
  2.1951 +              val HOLogic_setT  = HOLogic.mk_setT HOLogic_prodT
  2.1952 +              (* Term.term *)
  2.1953 +              val HOLogic_empty_set = Const (@{const_abbrev Set.empty}, HOLogic_setT)
  2.1954 +              val HOLogic_insert    =
  2.1955 +                Const (@{const_name insert}, HOLogic_prodT --> HOLogic_setT --> HOLogic_setT)
  2.1956 +            in
  2.1957 +              (* functions as graphs, i.e. as a (HOL) set of pairs "(x, y)" *)
  2.1958 +              map (fn ps => fold_rev (fn pair => fn acc => HOLogic_insert $ pair $ acc) ps
  2.1959 +                HOLogic_empty_set) pairss
  2.1960 +            end
  2.1961 +      | Type (s, Ts) =>
  2.1962 +          (case Datatype.get_info thy s of
  2.1963 +            SOME info =>
  2.1964 +              (case AList.lookup (op =) typs T of
  2.1965 +                SOME 0 =>
  2.1966 +                  (* termination condition to avoid infinite recursion *)
  2.1967 +                  []  (* at depth 0, every IDT is empty *)
  2.1968 +              | _ =>
  2.1969 +                let
  2.1970 +                  val index = #index info
  2.1971 +                  val descr = #descr info
  2.1972 +                  val (_, dtyps, constrs) = the (AList.lookup (op =) descr index)
  2.1973 +                  val typ_assoc = dtyps ~~ Ts
  2.1974 +                  (* sanity check: every element in 'dtyps' must be a 'DtTFree' *)
  2.1975 +                  val _ =
  2.1976 +                    if Library.exists (fn d =>
  2.1977 +                      case d of Datatype.DtTFree _ => false | _ => true) dtyps
  2.1978 +                    then
  2.1979 +                      raise REFUTE ("IDT_constructor_interpreter",
  2.1980 +                        "datatype argument (for type "
  2.1981 +                        ^ Syntax.string_of_typ ctxt T
  2.1982 +                        ^ ") is not a variable")
  2.1983 +                    else ()
  2.1984 +                  (* decrement depth for the IDT 'T' *)
  2.1985 +                  val typs' =
  2.1986 +                    (case AList.lookup (op =) typs T of NONE => typs
  2.1987 +                    | SOME n => AList.update (op =) (T, n-1) typs)
  2.1988 +                  fun constructor_terms terms [] = terms
  2.1989 +                    | constructor_terms terms (d::ds) =
  2.1990 +                        let
  2.1991 +                          val dT = typ_of_dtyp descr typ_assoc d
  2.1992 +                          val d_terms = canonical_terms typs' dT
  2.1993 +                        in
  2.1994 +                          (* C_i x_1 ... x_n < C_i y_1 ... y_n if *)
  2.1995 +                          (* (x_1, ..., x_n) < (y_1, ..., y_n)    *)
  2.1996 +                          constructor_terms
  2.1997 +                            (map_product (curry op $) terms d_terms) ds
  2.1998 +                        end
  2.1999 +                in
  2.2000 +                  (* C_i ... < C_j ... if i < j *)
  2.2001 +                  maps (fn (cname, ctyps) =>
  2.2002 +                    let
  2.2003 +                      val cTerm = Const (cname,
  2.2004 +                        map (typ_of_dtyp descr typ_assoc) ctyps ---> T)
  2.2005 +                    in
  2.2006 +                      constructor_terms [cTerm] ctyps
  2.2007 +                    end) constrs
  2.2008 +                end)
  2.2009 +          | NONE =>
  2.2010 +              (* not an inductive datatype; in this case the argument types in *)
  2.2011 +              (* 'Ts' may not be IDTs either, so 'print' should be safe        *)
  2.2012 +              map (fn intr => print ctxt (typs, []) T intr (K false))
  2.2013 +                (make_constants ctxt (typs, []) T))
  2.2014 +      | _ =>  (* TFree ..., TVar ... *)
  2.2015 +          map (fn intr => print ctxt (typs, []) T intr (K false))
  2.2016 +            (make_constants ctxt (typs, []) T))
  2.2017 +    val (typs, terms) = model
  2.2018 +  in
  2.2019 +    case AList.lookup (op =) terms t of
  2.2020 +      SOME intr =>
  2.2021 +        (* return an existing interpretation *)
  2.2022 +        SOME (intr, model, args)
  2.2023 +    | NONE =>
  2.2024 +        (case t of
  2.2025 +          Const (s, T) =>
  2.2026 +            (case body_type T of
  2.2027 +              Type (s', Ts') =>
  2.2028 +                (case Datatype.get_info thy s' of
  2.2029 +                  SOME info =>  (* body type is an inductive datatype *)
  2.2030 +                    let
  2.2031 +                      val index               = #index info
  2.2032 +                      val descr               = #descr info
  2.2033 +                      val (_, dtyps, constrs) = the (AList.lookup (op =) descr index)
  2.2034 +                      val typ_assoc           = dtyps ~~ Ts'
  2.2035 +                      (* sanity check: every element in 'dtyps' must be a 'DtTFree' *)
  2.2036 +                      val _ = if Library.exists (fn d =>
  2.2037 +                          case d of Datatype.DtTFree _ => false | _ => true) dtyps
  2.2038 +                        then
  2.2039 +                          raise REFUTE ("IDT_constructor_interpreter",
  2.2040 +                            "datatype argument (for type "
  2.2041 +                            ^ Syntax.string_of_typ ctxt (Type (s', Ts'))
  2.2042 +                            ^ ") is not a variable")
  2.2043 +                        else ()
  2.2044 +                      (* split the constructors into those occuring before/after *)
  2.2045 +                      (* 'Const (s, T)'                                          *)
  2.2046 +                      val (constrs1, constrs2) = take_prefix (fn (cname, ctypes) =>
  2.2047 +                        not (cname = s andalso Sign.typ_instance thy (T,
  2.2048 +                          map (typ_of_dtyp descr typ_assoc) ctypes
  2.2049 +                            ---> Type (s', Ts')))) constrs
  2.2050 +                    in
  2.2051 +                      case constrs2 of
  2.2052 +                        [] =>
  2.2053 +                          (* 'Const (s, T)' is not a constructor of this datatype *)
  2.2054 +                          NONE
  2.2055 +                      | (_, ctypes)::_ =>
  2.2056 +                          let
  2.2057 +                            (* int option -- only /recursive/ IDTs have an associated *)
  2.2058 +                            (*               depth                                    *)
  2.2059 +                            val depth = AList.lookup (op =) typs (Type (s', Ts'))
  2.2060 +                            (* this should never happen: at depth 0, this IDT fragment *)
  2.2061 +                            (* is definitely empty, and in this case we don't need to  *)
  2.2062 +                            (* interpret its constructors                              *)
  2.2063 +                            val _ = (case depth of SOME 0 =>
  2.2064 +                                raise REFUTE ("IDT_constructor_interpreter",
  2.2065 +                                  "depth is 0")
  2.2066 +                              | _ => ())
  2.2067 +                            val typs' = (case depth of NONE => typs | SOME n =>
  2.2068 +                              AList.update (op =) (Type (s', Ts'), n-1) typs)
  2.2069 +                            (* elements of the datatype come before elements generated *)
  2.2070 +                            (* by 'Const (s, T)' iff they are generated by a           *)
  2.2071 +                            (* constructor in constrs1                                 *)
  2.2072 +                            val offset = size_of_dtyp ctxt typs' descr typ_assoc constrs1
  2.2073 +                            (* compute the total (current) size of the datatype *)
  2.2074 +                            val total = offset +
  2.2075 +                              size_of_dtyp ctxt typs' descr typ_assoc constrs2
  2.2076 +                            (* sanity check *)
  2.2077 +                            val _ = if total <> size_of_type ctxt (typs, [])
  2.2078 +                              (Type (s', Ts')) then
  2.2079 +                                raise REFUTE ("IDT_constructor_interpreter",
  2.2080 +                                  "total is not equal to current size")
  2.2081 +                              else ()
  2.2082 +                            (* returns an interpretation where everything is mapped to *)
  2.2083 +                            (* an "undefined" element of the datatype                  *)
  2.2084 +                            fun make_undef [] = Leaf (replicate total False)
  2.2085 +                              | make_undef (d::ds) =
  2.2086 +                                  let
  2.2087 +                                    (* compute the current size of the type 'd' *)
  2.2088 +                                    val dT   = typ_of_dtyp descr typ_assoc d
  2.2089 +                                    val size = size_of_type ctxt (typs, []) dT
  2.2090 +                                  in
  2.2091 +                                    Node (replicate size (make_undef ds))
  2.2092 +                                  end
  2.2093 +                            (* returns the interpretation for a constructor *)
  2.2094 +                            fun make_constr [] offset =
  2.2095 +                                  if offset < total then
  2.2096 +                                    (Leaf (replicate offset False @ True ::
  2.2097 +                                      (replicate (total - offset - 1) False)), offset + 1)
  2.2098 +                                  else
  2.2099 +                                    raise REFUTE ("IDT_constructor_interpreter",
  2.2100 +                                      "offset >= total")
  2.2101 +                              | make_constr (d::ds) offset =
  2.2102 +                                  let
  2.2103 +                                    (* Term.typ *)
  2.2104 +                                    val dT = typ_of_dtyp descr typ_assoc d
  2.2105 +                                    (* compute canonical term representations for all   *)
  2.2106 +                                    (* elements of the type 'd' (with the reduced depth *)
  2.2107 +                                    (* for the IDT)                                     *)
  2.2108 +                                    val terms' = canonical_terms typs' dT
  2.2109 +                                    (* sanity check *)
  2.2110 +                                    val _ =
  2.2111 +                                      if length terms' <> size_of_type ctxt (typs', []) dT
  2.2112 +                                      then
  2.2113 +                                        raise REFUTE ("IDT_constructor_interpreter",
  2.2114 +                                          "length of terms' is not equal to old size")
  2.2115 +                                      else ()
  2.2116 +                                    (* compute canonical term representations for all   *)
  2.2117 +                                    (* elements of the type 'd' (with the current depth *)
  2.2118 +                                    (* for the IDT)                                     *)
  2.2119 +                                    val terms = canonical_terms typs dT
  2.2120 +                                    (* sanity check *)
  2.2121 +                                    val _ =
  2.2122 +                                      if length terms <> size_of_type ctxt (typs, []) dT
  2.2123 +                                      then
  2.2124 +                                        raise REFUTE ("IDT_constructor_interpreter",
  2.2125 +                                          "length of terms is not equal to current size")
  2.2126 +                                      else ()
  2.2127 +                                    (* sanity check *)
  2.2128 +                                    val _ =
  2.2129 +                                      if length terms < length terms' then
  2.2130 +                                        raise REFUTE ("IDT_constructor_interpreter",
  2.2131 +                                          "current size is less than old size")
  2.2132 +                                      else ()
  2.2133 +                                    (* sanity check: every element of terms' must also be *)
  2.2134 +                                    (*               present in terms                     *)
  2.2135 +                                    val _ =
  2.2136 +                                      if forall (member (op =) terms) terms' then ()
  2.2137 +                                      else
  2.2138 +                                        raise REFUTE ("IDT_constructor_interpreter",
  2.2139 +                                          "element has disappeared")
  2.2140 +                                    (* sanity check: the order on elements of terms' is    *)
  2.2141 +                                    (*               the same in terms, for those elements *)
  2.2142 +                                    val _ =
  2.2143 +                                      let
  2.2144 +                                        fun search (x::xs) (y::ys) =
  2.2145 +                                              if x = y then search xs ys else search (x::xs) ys
  2.2146 +                                          | search (_::_) [] =
  2.2147 +                                              raise REFUTE ("IDT_constructor_interpreter",
  2.2148 +                                                "element order not preserved")
  2.2149 +                                          | search [] _ = ()
  2.2150 +                                      in search terms' terms end
  2.2151 +                                    (* int * interpretation list *)
  2.2152 +                                    val (intrs, new_offset) =
  2.2153 +                                      fold_map (fn t_elem => fn off =>
  2.2154 +                                        (* if 't_elem' existed at the previous depth,    *)
  2.2155 +                                        (* proceed recursively, otherwise map the entire *)
  2.2156 +                                        (* subtree to "undefined"                        *)
  2.2157 +                                        if member (op =) terms' t_elem then
  2.2158 +                                          make_constr ds off
  2.2159 +                                        else
  2.2160 +                                          (make_undef ds, off))
  2.2161 +                                      terms offset
  2.2162 +                                  in
  2.2163 +                                    (Node intrs, new_offset)
  2.2164 +                                  end
  2.2165 +                          in
  2.2166 +                            SOME (fst (make_constr ctypes offset), model, args)
  2.2167 +                          end
  2.2168 +                    end
  2.2169 +                | NONE =>  (* body type is not an inductive datatype *)
  2.2170 +                    NONE)
  2.2171 +            | _ =>  (* body type is a (free or schematic) type variable *)
  2.2172 +              NONE)
  2.2173 +        | _ =>  (* term is not a constant *)
  2.2174 +          NONE)
  2.2175 +  end;
  2.2176 +
  2.2177 +(* Difficult code ahead.  Make sure you understand the                *)
  2.2178 +(* 'IDT_constructor_interpreter' and the order in which it enumerates *)
  2.2179 +(* elements of an IDT before you try to understand this function.     *)
  2.2180 +
  2.2181 +fun IDT_recursion_interpreter ctxt model args t =
  2.2182 +  let
  2.2183 +    val thy = Proof_Context.theory_of ctxt
  2.2184 +  in
  2.2185 +    (* careful: here we descend arbitrarily deep into 't', possibly before *)
  2.2186 +    (* any other interpreter for atomic terms has had a chance to look at  *)
  2.2187 +    (* 't'                                                                 *)
  2.2188 +    case strip_comb t of
  2.2189 +      (Const (s, T), params) =>
  2.2190 +        (* iterate over all datatypes in 'thy' *)
  2.2191 +        Symtab.fold (fn (_, info) => fn result =>
  2.2192 +          case result of
  2.2193 +            SOME _ =>
  2.2194 +              result  (* just keep 'result' *)
  2.2195 +          | NONE =>
  2.2196 +              if member (op =) (#rec_names info) s then
  2.2197 +                (* we do have a recursion operator of one of the (mutually *)
  2.2198 +                (* recursive) datatypes given by 'info'                    *)
  2.2199 +                let
  2.2200 +                  (* number of all constructors, including those of different  *)
  2.2201 +                  (* (mutually recursive) datatypes within the same descriptor *)
  2.2202 +                  val mconstrs_count =
  2.2203 +                    Integer.sum (map (fn (_, (_, _, cs)) => length cs) (#descr info))
  2.2204 +                in
  2.2205 +                  if mconstrs_count < length params then
  2.2206 +                    (* too many actual parameters; for now we'll use the *)
  2.2207 +                    (* 'stlc_interpreter' to strip off one application   *)
  2.2208 +                    NONE
  2.2209 +                  else if mconstrs_count > length params then
  2.2210 +                    (* too few actual parameters; we use eta expansion          *)
  2.2211 +                    (* Note that the resulting expansion of lambda abstractions *)
  2.2212 +                    (* by the 'stlc_interpreter' may be rather slow (depending  *)
  2.2213 +                    (* on the argument types and the size of the IDT, of        *)
  2.2214 +                    (* course).                                                 *)
  2.2215 +                    SOME (interpret ctxt model args (eta_expand t
  2.2216 +                      (mconstrs_count - length params)))
  2.2217 +                  else  (* mconstrs_count = length params *)
  2.2218 +                    let
  2.2219 +                      (* interpret each parameter separately *)
  2.2220 +                      val (p_intrs, (model', args')) = fold_map (fn p => fn (m, a) =>
  2.2221 +                        let
  2.2222 +                          val (i, m', a') = interpret ctxt m a p
  2.2223 +                        in
  2.2224 +                          (i, (m', a'))
  2.2225 +                        end) params (model, args)
  2.2226 +                      val (typs, _) = model'
  2.2227 +                      (* 'index' is /not/ necessarily the index of the IDT that *)
  2.2228 +                      (* the recursion operator is associated with, but merely  *)
  2.2229 +                      (* the index of some mutually recursive IDT               *)
  2.2230 +                      val index         = #index info
  2.2231 +                      val descr         = #descr info
  2.2232 +                      val (_, dtyps, _) = the (AList.lookup (op =) descr index)
  2.2233 +                      (* sanity check: we assume that the order of constructors *)
  2.2234 +                      (*               in 'descr' is the same as the order of   *)
  2.2235 +                      (*               corresponding parameters, otherwise the  *)
  2.2236 +                      (*               association code below won't match the   *)
  2.2237 +                      (*               right constructors/parameters; we also   *)
  2.2238 +                      (*               assume that the order of recursion       *)
  2.2239 +                      (*               operators in '#rec_names info' is the    *)
  2.2240 +                      (*               same as the order of corresponding       *)
  2.2241 +                      (*               datatypes in 'descr'                     *)
  2.2242 +                      val _ = if map fst descr <> (0 upto (length descr - 1)) then
  2.2243 +                          raise REFUTE ("IDT_recursion_interpreter",
  2.2244 +                            "order of constructors and corresponding parameters/" ^
  2.2245 +                              "recursion operators and corresponding datatypes " ^
  2.2246 +                              "different?")
  2.2247 +                        else ()
  2.2248 +                      (* sanity check: every element in 'dtyps' must be a *)
  2.2249 +                      (*               'DtTFree'                          *)
  2.2250 +                      val _ =
  2.2251 +                        if Library.exists (fn d =>
  2.2252 +                          case d of Datatype.DtTFree _ => false
  2.2253 +                                  | _ => true) dtyps
  2.2254 +                        then
  2.2255 +                          raise REFUTE ("IDT_recursion_interpreter",
  2.2256 +                            "datatype argument is not a variable")
  2.2257 +                        else ()
  2.2258 +                      (* the type of a recursion operator is *)
  2.2259 +                      (* [T1, ..., Tn, IDT] ---> Tresult     *)
  2.2260 +                      val IDT = nth (binder_types T) mconstrs_count
  2.2261 +                      (* by our assumption on the order of recursion operators *)
  2.2262 +                      (* and datatypes, this is the index of the datatype      *)
  2.2263 +                      (* corresponding to the given recursion operator         *)
  2.2264 +                      val idt_index = find_index (fn s' => s' = s) (#rec_names info)
  2.2265 +                      (* mutually recursive types must have the same type   *)
  2.2266 +                      (* parameters, unless the mutual recursion comes from *)
  2.2267 +                      (* indirect recursion                                 *)
  2.2268 +                      fun rec_typ_assoc acc [] = acc
  2.2269 +                        | rec_typ_assoc acc ((d, T)::xs) =
  2.2270 +                            (case AList.lookup op= acc d of
  2.2271 +                              NONE =>
  2.2272 +                                (case d of
  2.2273 +                                  Datatype.DtTFree _ =>
  2.2274 +                                  (* add the association, proceed *)
  2.2275 +                                  rec_typ_assoc ((d, T)::acc) xs
  2.2276 +                                | Datatype.DtType (s, ds) =>
  2.2277 +                                    let
  2.2278 +                                      val (s', Ts) = dest_Type T
  2.2279 +                                    in
  2.2280 +                                      if s=s' then
  2.2281 +                                        rec_typ_assoc ((d, T)::acc) ((ds ~~ Ts) @ xs)
  2.2282 +                                      else
  2.2283 +                                        raise REFUTE ("IDT_recursion_interpreter",
  2.2284 +                                          "DtType/Type mismatch")
  2.2285 +                                    end
  2.2286 +                                | Datatype.DtRec i =>
  2.2287 +                                    let
  2.2288 +                                      val (_, ds, _) = the (AList.lookup (op =) descr i)
  2.2289 +                                      val (_, Ts)    = dest_Type T
  2.2290 +                                    in
  2.2291 +                                      rec_typ_assoc ((d, T)::acc) ((ds ~~ Ts) @ xs)
  2.2292 +                                    end)
  2.2293 +                            | SOME T' =>
  2.2294 +                                if T=T' then
  2.2295 +                                  (* ignore the association since it's already *)
  2.2296 +                                  (* present, proceed                          *)
  2.2297 +                                  rec_typ_assoc acc xs
  2.2298 +                                else
  2.2299 +                                  raise REFUTE ("IDT_recursion_interpreter",
  2.2300 +                                    "different type associations for the same dtyp"))
  2.2301 +                      val typ_assoc = filter
  2.2302 +                        (fn (Datatype.DtTFree _, _) => true | (_, _) => false)
  2.2303 +                        (rec_typ_assoc []
  2.2304 +                          (#2 (the (AList.lookup (op =) descr idt_index)) ~~ (snd o dest_Type) IDT))
  2.2305 +                      (* sanity check: typ_assoc must associate types to the   *)
  2.2306 +                      (*               elements of 'dtyps' (and only to those) *)
  2.2307 +                      val _ =
  2.2308 +                        if not (eq_set (op =) (dtyps, map fst typ_assoc))
  2.2309 +                        then
  2.2310 +                          raise REFUTE ("IDT_recursion_interpreter",
  2.2311 +                            "type association has extra/missing elements")
  2.2312 +                        else ()
  2.2313 +                      (* interpret each constructor in the descriptor (including *)
  2.2314 +                      (* those of mutually recursive datatypes)                  *)
  2.2315 +                      (* (int * interpretation list) list *)
  2.2316 +                      val mc_intrs = map (fn (idx, (_, _, cs)) =>
  2.2317 +                        let
  2.2318 +                          val c_return_typ = typ_of_dtyp descr typ_assoc
  2.2319 +                            (Datatype.DtRec idx)
  2.2320 +                        in
  2.2321 +                          (idx, map (fn (cname, cargs) =>
  2.2322 +                            (#1 o interpret ctxt (typs, []) {maxvars=0,
  2.2323 +                              def_eq=false, next_idx=1, bounds=[],
  2.2324 +                              wellformed=True}) (Const (cname, map (typ_of_dtyp
  2.2325 +                              descr typ_assoc) cargs ---> c_return_typ))) cs)
  2.2326 +                        end) descr
  2.2327 +                      (* associate constructors with corresponding parameters *)
  2.2328 +                      (* (int * (interpretation * interpretation) list) list *)
  2.2329 +                      val (mc_p_intrs, p_intrs') = fold_map
  2.2330 +                        (fn (idx, c_intrs) => fn p_intrs' =>
  2.2331 +                          let
  2.2332 +                            val len = length c_intrs
  2.2333 +                          in
  2.2334 +                            ((idx, c_intrs ~~ List.take (p_intrs', len)),
  2.2335 +                              List.drop (p_intrs', len))
  2.2336 +                          end) mc_intrs p_intrs
  2.2337 +                      (* sanity check: no 'p_intr' may be left afterwards *)
  2.2338 +                      val _ =
  2.2339 +                        if p_intrs' <> [] then
  2.2340 +                          raise REFUTE ("IDT_recursion_interpreter",
  2.2341 +                            "more parameter than constructor interpretations")
  2.2342 +                        else ()
  2.2343 +                      (* The recursion operator, applied to 'mconstrs_count'     *)
  2.2344 +                      (* arguments, is a function that maps every element of the *)
  2.2345 +                      (* inductive datatype to an element of some result type.   *)
  2.2346 +                      (* Recursion operators for mutually recursive IDTs are     *)
  2.2347 +                      (* translated simultaneously.                              *)
  2.2348 +                      (* Since the order on datatype elements is given by an     *)
  2.2349 +                      (* order on constructors (and then by the order on         *)
  2.2350 +                      (* argument tuples), we can simply copy corresponding      *)
  2.2351 +                      (* subtrees from 'p_intrs', in the order in which they are *)
  2.2352 +                      (* given.                                                  *)
  2.2353 +                      (* interpretation * interpretation -> interpretation list *)
  2.2354 +                      fun ci_pi (Leaf xs, pi) =
  2.2355 +                            (* if the constructor does not match the arguments to a *)
  2.2356 +                            (* defined element of the IDT, the corresponding value  *)
  2.2357 +                            (* of the parameter must be ignored                     *)
  2.2358 +                            if List.exists (equal True) xs then [pi] else []
  2.2359 +                        | ci_pi (Node xs, Node ys) = maps ci_pi (xs ~~ ys)
  2.2360 +                        | ci_pi (Node _, Leaf _) =
  2.2361 +                            raise REFUTE ("IDT_recursion_interpreter",
  2.2362 +                              "constructor takes more arguments than the " ^
  2.2363 +                                "associated parameter")
  2.2364 +                      (* (int * interpretation list) list *)
  2.2365 +                      val rec_operators = map (fn (idx, c_p_intrs) =>
  2.2366 +                        (idx, maps ci_pi c_p_intrs)) mc_p_intrs
  2.2367 +                      (* sanity check: every recursion operator must provide as  *)
  2.2368 +                      (*               many values as the corresponding datatype *)
  2.2369 +                      (*               has elements                              *)
  2.2370 +                      val _ = map (fn (idx, intrs) =>
  2.2371 +                        let
  2.2372 +                          val T = typ_of_dtyp descr typ_assoc
  2.2373 +                            (Datatype.DtRec idx)
  2.2374 +                        in
  2.2375 +                          if length intrs <> size_of_type ctxt (typs, []) T then
  2.2376 +                            raise REFUTE ("IDT_recursion_interpreter",
  2.2377 +                              "wrong number of interpretations for rec. operator")
  2.2378 +                          else ()
  2.2379 +                        end) rec_operators
  2.2380 +                      (* For non-recursive datatypes, we are pretty much done at *)
  2.2381 +                      (* this point.  For recursive datatypes however, we still  *)
  2.2382 +                      (* need to apply the interpretations in 'rec_operators' to *)
  2.2383 +                      (* (recursively obtained) interpretations for recursive    *)
  2.2384 +                      (* constructor arguments.  To do so more efficiently, we   *)
  2.2385 +                      (* copy 'rec_operators' into arrays first.  Each Boolean   *)
  2.2386 +                      (* indicates whether the recursive arguments have been     *)
  2.2387 +                      (* considered already.                                     *)
  2.2388 +                      (* (int * (bool * interpretation) Array.array) list *)
  2.2389 +                      val REC_OPERATORS = map (fn (idx, intrs) =>
  2.2390 +                        (idx, Array.fromList (map (pair false) intrs)))
  2.2391 +                        rec_operators
  2.2392 +                      (* takes an interpretation, and if some leaf of this     *)
  2.2393 +                      (* interpretation is the 'elem'-th element of the type,  *)
  2.2394 +                      (* the indices of the arguments leading to this leaf are *)
  2.2395 +                      (* returned                                              *)
  2.2396 +                      (* interpretation -> int -> int list option *)
  2.2397 +                      fun get_args (Leaf xs) elem =
  2.2398 +                            if find_index (fn x => x = True) xs = elem then
  2.2399 +                              SOME []
  2.2400 +                            else
  2.2401 +                              NONE
  2.2402 +                        | get_args (Node xs) elem =
  2.2403 +                            let
  2.2404 +                              (* interpretation list * int -> int list option *)
  2.2405 +                              fun search ([], _) =
  2.2406 +                                NONE
  2.2407 +                                | search (x::xs, n) =
  2.2408 +                                (case get_args x elem of
  2.2409 +                                  SOME result => SOME (n::result)
  2.2410 +                                | NONE        => search (xs, n+1))
  2.2411 +                            in
  2.2412 +                              search (xs, 0)
  2.2413 +                            end
  2.2414 +                      (* returns the index of the constructor and indices for *)
  2.2415 +                      (* its arguments that generate the 'elem'-th element of *)
  2.2416 +                      (* the datatype given by 'idx'                          *)
  2.2417 +                      (* int -> int -> int * int list *)
  2.2418 +                      fun get_cargs idx elem =
  2.2419 +                        let
  2.2420 +                          (* int * interpretation list -> int * int list *)
  2.2421 +                          fun get_cargs_rec (_, []) =
  2.2422 +                                raise REFUTE ("IDT_recursion_interpreter",
  2.2423 +                                  "no matching constructor found for datatype element")
  2.2424 +                            | get_cargs_rec (n, x::xs) =
  2.2425 +                                (case get_args x elem of
  2.2426 +                                  SOME args => (n, args)
  2.2427 +                                | NONE => get_cargs_rec (n+1, xs))
  2.2428 +                        in
  2.2429 +                          get_cargs_rec (0, the (AList.lookup (op =) mc_intrs idx))
  2.2430 +                        end
  2.2431 +                      (* computes one entry in 'REC_OPERATORS', and recursively *)
  2.2432 +                      (* all entries needed for it, where 'idx' gives the       *)
  2.2433 +                      (* datatype and 'elem' the element of it                  *)
  2.2434 +                      (* int -> int -> interpretation *)
  2.2435 +                      fun compute_array_entry idx elem =
  2.2436 +                        let
  2.2437 +                          val arr = the (AList.lookup (op =) REC_OPERATORS idx)
  2.2438 +                          val (flag, intr) = Array.sub (arr, elem)
  2.2439 +                        in
  2.2440 +                          if flag then
  2.2441 +                            (* simply return the previously computed result *)
  2.2442 +                            intr
  2.2443 +                          else
  2.2444 +                            (* we have to apply 'intr' to interpretations for all *)
  2.2445 +                            (* recursive arguments                                *)
  2.2446 +                            let
  2.2447 +                              (* int * int list *)
  2.2448 +                              val (c, args) = get_cargs idx elem
  2.2449 +                              (* find the indices of the constructor's /recursive/ *)
  2.2450 +                              (* arguments                                         *)
  2.2451 +                              val (_, _, constrs) = the (AList.lookup (op =) descr idx)
  2.2452 +                              val (_, dtyps) = nth constrs c
  2.2453 +                              val rec_dtyps_args = filter
  2.2454 +                                (Datatype_Aux.is_rec_type o fst) (dtyps ~~ args)
  2.2455 +                              (* map those indices to interpretations *)
  2.2456 +                              val rec_dtyps_intrs = map (fn (dtyp, arg) =>
  2.2457 +                                let
  2.2458 +                                  val dT = typ_of_dtyp descr typ_assoc dtyp
  2.2459 +                                  val consts = make_constants ctxt (typs, []) dT
  2.2460 +                                  val arg_i = nth consts arg
  2.2461 +                                in
  2.2462 +                                  (dtyp, arg_i)
  2.2463 +                                end) rec_dtyps_args
  2.2464 +                              (* takes the dtyp and interpretation of an element, *)
  2.2465 +                              (* and computes the interpretation for the          *)
  2.2466 +                              (* corresponding recursive argument                 *)
  2.2467 +                              fun rec_intr (Datatype.DtRec i) (Leaf xs) =
  2.2468 +                                    (* recursive argument is "rec_i params elem" *)
  2.2469 +                                    compute_array_entry i (find_index (fn x => x = True) xs)
  2.2470 +                                | rec_intr (Datatype.DtRec _) (Node _) =
  2.2471 +                                    raise REFUTE ("IDT_recursion_interpreter",
  2.2472 +                                      "interpretation for IDT is a node")
  2.2473 +                                | rec_intr (Datatype.DtType ("fun", [_, dt2])) (Node xs) =
  2.2474 +                                    (* recursive argument is something like     *)
  2.2475 +                                    (* "\<lambda>x::dt1. rec_? params (elem x)" *)
  2.2476 +                                    Node (map (rec_intr dt2) xs)
  2.2477 +                                | rec_intr (Datatype.DtType ("fun", [_, _])) (Leaf _) =
  2.2478 +                                    raise REFUTE ("IDT_recursion_interpreter",
  2.2479 +                                      "interpretation for function dtyp is a leaf")
  2.2480 +                                | rec_intr _ _ =
  2.2481 +                                    (* admissibility ensures that every recursive type *)
  2.2482 +                                    (* is of the form 'Dt_1 -> ... -> Dt_k ->          *)
  2.2483 +                                    (* (DtRec i)'                                      *)
  2.2484 +                                    raise REFUTE ("IDT_recursion_interpreter",
  2.2485 +                                      "non-recursive codomain in recursive dtyp")
  2.2486 +                              (* obtain interpretations for recursive arguments *)
  2.2487 +                              (* interpretation list *)
  2.2488 +                              val arg_intrs = map (uncurry rec_intr) rec_dtyps_intrs
  2.2489 +                              (* apply 'intr' to all recursive arguments *)
  2.2490 +                              val result = fold (fn arg_i => fn i =>
  2.2491 +                                interpretation_apply (i, arg_i)) arg_intrs intr
  2.2492 +                              (* update 'REC_OPERATORS' *)
  2.2493 +                              val _ = Array.update (arr, elem, (true, result))
  2.2494 +                            in
  2.2495 +                              result
  2.2496 +                            end
  2.2497 +                        end
  2.2498 +                      val idt_size = Array.length (the (AList.lookup (op =) REC_OPERATORS idt_index))
  2.2499 +                      (* sanity check: the size of 'IDT' should be 'idt_size' *)
  2.2500 +                      val _ =
  2.2501 +                          if idt_size <> size_of_type ctxt (typs, []) IDT then
  2.2502 +                            raise REFUTE ("IDT_recursion_interpreter",
  2.2503 +                              "unexpected size of IDT (wrong type associated?)")
  2.2504 +                          else ()
  2.2505 +                      (* interpretation *)
  2.2506 +                      val rec_op = Node (map_range (compute_array_entry idt_index) idt_size)
  2.2507 +                    in
  2.2508 +                      SOME (rec_op, model', args')
  2.2509 +                    end
  2.2510 +                end
  2.2511 +              else
  2.2512 +                NONE  (* not a recursion operator of this datatype *)
  2.2513 +          ) (Datatype.get_all thy) NONE
  2.2514 +    | _ =>  (* head of term is not a constant *)
  2.2515 +      NONE
  2.2516 +  end;
  2.2517 +
  2.2518 +fun set_interpreter ctxt model args t =
  2.2519 +  let
  2.2520 +    val (typs, terms) = model
  2.2521 +  in
  2.2522 +    case AList.lookup (op =) terms t of
  2.2523 +      SOME intr =>
  2.2524 +        (* return an existing interpretation *)
  2.2525 +        SOME (intr, model, args)
  2.2526 +    | NONE =>
  2.2527 +        (case t of
  2.2528 +          Free (x, Type (@{type_name set}, [T])) =>
  2.2529 +          let
  2.2530 +            val (intr, _, args') =
  2.2531 +              interpret ctxt (typs, []) args (Free (x, T --> HOLogic.boolT))
  2.2532 +          in
  2.2533 +            SOME (intr, (typs, (t, intr)::terms), args')
  2.2534 +          end
  2.2535 +        | Var ((x, i), Type (@{type_name set}, [T])) =>
  2.2536 +          let
  2.2537 +            val (intr, _, args') =
  2.2538 +              interpret ctxt (typs, []) args (Var ((x,i), T --> HOLogic.boolT))
  2.2539 +          in
  2.2540 +            SOME (intr, (typs, (t, intr)::terms), args')
  2.2541 +          end
  2.2542 +        | Const (s, Type (@{type_name set}, [T])) =>
  2.2543 +          let
  2.2544 +            val (intr, _, args') =
  2.2545 +              interpret ctxt (typs, []) args (Const (s, T --> HOLogic.boolT))
  2.2546 +          in
  2.2547 +            SOME (intr, (typs, (t, intr)::terms), args')
  2.2548 +          end
  2.2549 +        (* 'Collect' == identity *)
  2.2550 +        | Const (@{const_name Collect}, _) $ t1 =>
  2.2551 +            SOME (interpret ctxt model args t1)
  2.2552 +        | Const (@{const_name Collect}, _) =>
  2.2553 +            SOME (interpret ctxt model args (eta_expand t 1))
  2.2554 +        (* 'op :' == application *)
  2.2555 +        | Const (@{const_name Set.member}, _) $ t1 $ t2 =>
  2.2556 +            SOME (interpret ctxt model args (t2 $ t1))
  2.2557 +        | Const (@{const_name Set.member}, _) $ _ =>
  2.2558 +            SOME (interpret ctxt model args (eta_expand t 1))
  2.2559 +        | Const (@{const_name Set.member}, _) =>
  2.2560 +            SOME (interpret ctxt model args (eta_expand t 2))
  2.2561 +        | _ => NONE)
  2.2562 +  end;
  2.2563 +
  2.2564 +(* only an optimization: 'card' could in principle be interpreted with *)
  2.2565 +(* interpreters available already (using its definition), but the code *)
  2.2566 +(* below is more efficient                                             *)
  2.2567 +
  2.2568 +fun Finite_Set_card_interpreter ctxt model args t =
  2.2569 +  case t of
  2.2570 +    Const (@{const_name Finite_Set.card},
  2.2571 +        Type ("fun", [Type (@{type_name set}, [T]), @{typ nat}])) =>
  2.2572 +      let
  2.2573 +        (* interpretation -> int *)
  2.2574 +        fun number_of_elements (Node xs) =
  2.2575 +            fold (fn x => fn n =>
  2.2576 +              if x = TT then
  2.2577 +                n + 1
  2.2578 +              else if x = FF then
  2.2579 +                n
  2.2580 +              else
  2.2581 +                raise REFUTE ("Finite_Set_card_interpreter",
  2.2582 +                  "interpretation for set type does not yield a Boolean"))
  2.2583 +              xs 0
  2.2584 +          | number_of_elements (Leaf _) =
  2.2585 +              raise REFUTE ("Finite_Set_card_interpreter",
  2.2586 +                "interpretation for set type is a leaf")
  2.2587 +        val size_of_nat = size_of_type ctxt model (@{typ nat})
  2.2588 +        (* takes an interpretation for a set and returns an interpretation *)
  2.2589 +        (* for a 'nat' denoting the set's cardinality                      *)
  2.2590 +        (* interpretation -> interpretation *)
  2.2591 +        fun card i =
  2.2592 +          let
  2.2593 +            val n = number_of_elements i
  2.2594 +          in
  2.2595 +            if n < size_of_nat then
  2.2596 +              Leaf ((replicate n False) @ True ::
  2.2597 +                (replicate (size_of_nat-n-1) False))
  2.2598 +            else
  2.2599 +              Leaf (replicate size_of_nat False)
  2.2600 +          end
  2.2601 +        val set_constants = make_constants ctxt model (HOLogic.mk_setT T)
  2.2602 +      in
  2.2603 +        SOME (Node (map card set_constants), model, args)
  2.2604 +      end
  2.2605 +  | _ => NONE;
  2.2606 +
  2.2607 +(* only an optimization: 'finite' could in principle be interpreted with  *)
  2.2608 +(* interpreters available already (using its definition), but the code    *)
  2.2609 +(* below is more efficient                                                *)
  2.2610 +
  2.2611 +fun Finite_Set_finite_interpreter ctxt model args t =
  2.2612 +  case t of
  2.2613 +    Const (@{const_name Finite_Set.finite},
  2.2614 +           Type ("fun", [_, @{typ bool}])) $ _ =>
  2.2615 +        (* we only consider finite models anyway, hence EVERY set is *)
  2.2616 +        (* "finite"                                                  *)
  2.2617 +        SOME (TT, model, args)
  2.2618 +  | Const (@{const_name Finite_Set.finite},
  2.2619 +           Type ("fun", [set_T, @{typ bool}])) =>
  2.2620 +      let
  2.2621 +        val size_of_set = size_of_type ctxt model set_T
  2.2622 +      in
  2.2623 +        (* we only consider finite models anyway, hence EVERY set is *)
  2.2624 +        (* "finite"                                                  *)
  2.2625 +        SOME (Node (replicate size_of_set TT), model, args)
  2.2626 +      end
  2.2627 +  | _ => NONE;
  2.2628 +
  2.2629 +(* only an optimization: 'less' could in principle be interpreted with *)
  2.2630 +(* interpreters available already (using its definition), but the code     *)
  2.2631 +(* below is more efficient                                                 *)
  2.2632 +
  2.2633 +fun Nat_less_interpreter ctxt model args t =
  2.2634 +  case t of
  2.2635 +    Const (@{const_name Orderings.less}, Type ("fun", [@{typ nat},
  2.2636 +        Type ("fun", [@{typ nat}, @{typ bool}])])) =>
  2.2637 +      let
  2.2638 +        val size_of_nat = size_of_type ctxt model (@{typ nat})
  2.2639 +        (* the 'n'-th nat is not less than the first 'n' nats, while it *)
  2.2640 +        (* is less than the remaining 'size_of_nat - n' nats            *)
  2.2641 +        (* int -> interpretation *)
  2.2642 +        fun less n = Node ((replicate n FF) @ (replicate (size_of_nat - n) TT))
  2.2643 +      in
  2.2644 +        SOME (Node (map less (1 upto size_of_nat)), model, args)
  2.2645 +      end
  2.2646 +  | _ => NONE;
  2.2647 +
  2.2648 +(* only an optimization: 'plus' could in principle be interpreted with *)
  2.2649 +(* interpreters available already (using its definition), but the code     *)
  2.2650 +(* below is more efficient                                                 *)
  2.2651 +
  2.2652 +fun Nat_plus_interpreter ctxt model args t =
  2.2653 +  case t of
  2.2654 +    Const (@{const_name Groups.plus}, Type ("fun", [@{typ nat},
  2.2655 +        Type ("fun", [@{typ nat}, @{typ nat}])])) =>
  2.2656 +      let
  2.2657 +        val size_of_nat = size_of_type ctxt model (@{typ nat})
  2.2658 +        (* int -> int -> interpretation *)
  2.2659 +        fun plus m n =
  2.2660 +          let
  2.2661 +            val element = m + n
  2.2662 +          in
  2.2663 +            if element > size_of_nat - 1 then
  2.2664 +              Leaf (replicate size_of_nat False)
  2.2665 +            else
  2.2666 +              Leaf ((replicate element False) @ True ::
  2.2667 +                (replicate (size_of_nat - element - 1) False))
  2.2668 +          end
  2.2669 +      in
  2.2670 +        SOME (Node (map_range (fn m => Node (map_range (plus m) size_of_nat)) size_of_nat),
  2.2671 +          model, args)
  2.2672 +      end
  2.2673 +  | _ => NONE;
  2.2674 +
  2.2675 +(* only an optimization: 'minus' could in principle be interpreted *)
  2.2676 +(* with interpreters available already (using its definition), but the *)
  2.2677 +(* code below is more efficient                                        *)
  2.2678 +
  2.2679 +fun Nat_minus_interpreter ctxt model args t =
  2.2680 +  case t of
  2.2681 +    Const (@{const_name Groups.minus}, Type ("fun", [@{typ nat},
  2.2682 +        Type ("fun", [@{typ nat}, @{typ nat}])])) =>
  2.2683 +      let
  2.2684 +        val size_of_nat = size_of_type ctxt model (@{typ nat})
  2.2685 +        (* int -> int -> interpretation *)
  2.2686 +        fun minus m n =
  2.2687 +          let
  2.2688 +            val element = Int.max (m-n, 0)
  2.2689 +          in
  2.2690 +            Leaf ((replicate element False) @ True ::
  2.2691 +              (replicate (size_of_nat - element - 1) False))
  2.2692 +          end
  2.2693 +      in
  2.2694 +        SOME (Node (map_range (fn m => Node (map_range (minus m) size_of_nat)) size_of_nat),
  2.2695 +          model, args)
  2.2696 +      end
  2.2697 +  | _ => NONE;
  2.2698 +
  2.2699 +(* only an optimization: 'times' could in principle be interpreted *)
  2.2700 +(* with interpreters available already (using its definition), but the *)
  2.2701 +(* code below is more efficient                                        *)
  2.2702 +
  2.2703 +fun Nat_times_interpreter ctxt model args t =
  2.2704 +  case t of
  2.2705 +    Const (@{const_name Groups.times}, Type ("fun", [@{typ nat},
  2.2706 +        Type ("fun", [@{typ nat}, @{typ nat}])])) =>
  2.2707 +      let
  2.2708 +        val size_of_nat = size_of_type ctxt model (@{typ nat})
  2.2709 +        (* nat -> nat -> interpretation *)
  2.2710 +        fun mult m n =
  2.2711 +          let
  2.2712 +            val element = m * n
  2.2713 +          in
  2.2714 +            if element > size_of_nat - 1 then
  2.2715 +              Leaf (replicate size_of_nat False)
  2.2716 +            else
  2.2717 +              Leaf ((replicate element False) @ True ::
  2.2718 +                (replicate (size_of_nat - element - 1) False))
  2.2719 +          end
  2.2720 +      in
  2.2721 +        SOME (Node (map_range (fn m => Node (map_range (mult m) size_of_nat)) size_of_nat),
  2.2722 +          model, args)
  2.2723 +      end
  2.2724 +  | _ => NONE;
  2.2725 +
  2.2726 +(* only an optimization: 'append' could in principle be interpreted with *)
  2.2727 +(* interpreters available already (using its definition), but the code   *)
  2.2728 +(* below is more efficient                                               *)
  2.2729 +
  2.2730 +fun List_append_interpreter ctxt model args t =
  2.2731 +  case t of
  2.2732 +    Const (@{const_name List.append}, Type ("fun", [Type ("List.list", [T]), Type ("fun",
  2.2733 +        [Type ("List.list", [_]), Type ("List.list", [_])])])) =>
  2.2734 +      let
  2.2735 +        val size_elem = size_of_type ctxt model T
  2.2736 +        val size_list = size_of_type ctxt model (Type ("List.list", [T]))
  2.2737 +        (* maximal length of lists; 0 if we only consider the empty list *)
  2.2738 +        val list_length =
  2.2739 +          let
  2.2740 +            (* int -> int -> int -> int *)
  2.2741 +            fun list_length_acc len lists total =
  2.2742 +              if lists = total then
  2.2743 +                len
  2.2744 +              else if lists < total then
  2.2745 +                list_length_acc (len+1) (lists*size_elem) (total-lists)
  2.2746 +              else
  2.2747 +                raise REFUTE ("List_append_interpreter",
  2.2748 +                  "size_list not equal to 1 + size_elem + ... + " ^
  2.2749 +                    "size_elem^len, for some len")
  2.2750 +          in
  2.2751 +            list_length_acc 0 1 size_list
  2.2752 +          end
  2.2753 +        val elements = 0 upto (size_list-1)
  2.2754 +        (* FIXME: there should be a nice formula, which computes the same as *)
  2.2755 +        (*        the following, but without all this intermediate tree      *)
  2.2756 +        (*        length/offset stuff                                        *)
  2.2757 +        (* associate each list with its length and offset in a complete tree *)
  2.2758 +        (* of width 'size_elem' and depth 'length_list' (with 'size_list'    *)
  2.2759 +        (* nodes total)                                                      *)
  2.2760 +        (* (int * (int * int)) list *)
  2.2761 +        val (lenoff_lists, _) = fold_map (fn elem => fn (offsets, off) =>
  2.2762 +          (* corresponds to a pre-order traversal of the tree *)
  2.2763 +          let
  2.2764 +            val len = length offsets
  2.2765 +            (* associate the given element with len/off *)
  2.2766 +            val assoc = (elem, (len, off))
  2.2767 +          in
  2.2768 +            if len < list_length then
  2.2769 +              (* go to first child node *)
  2.2770 +              (assoc, (off :: offsets, off * size_elem))
  2.2771 +            else if off mod size_elem < size_elem - 1 then
  2.2772 +              (* go to next sibling node *)
  2.2773 +              (assoc, (offsets, off + 1))
  2.2774 +            else
  2.2775 +              (* go back up the stack until we find a level where we can go *)
  2.2776 +              (* to the next sibling node                                   *)
  2.2777 +              let
  2.2778 +                val offsets' = snd (take_prefix
  2.2779 +                  (fn off' => off' mod size_elem = size_elem - 1) offsets)
  2.2780 +              in
  2.2781 +                case offsets' of
  2.2782 +                  [] =>
  2.2783 +                    (* we're at the last node in the tree; the next value *)
  2.2784 +                    (* won't be used anyway                               *)
  2.2785 +                    (assoc, ([], 0))
  2.2786 +                | off'::offs' =>
  2.2787 +                    (* go to next sibling node *)
  2.2788 +                    (assoc, (offs', off' + 1))
  2.2789 +              end
  2.2790 +          end) elements ([], 0)
  2.2791 +        (* we also need the reverse association (from length/offset to *)
  2.2792 +        (* index)                                                      *)
  2.2793 +        val lenoff'_lists = map Library.swap lenoff_lists
  2.2794 +        (* returns the interpretation for "(list no. m) @ (list no. n)" *)
  2.2795 +        (* nat -> nat -> interpretation *)
  2.2796 +        fun append m n =
  2.2797 +          let
  2.2798 +            val (len_m, off_m) = the (AList.lookup (op =) lenoff_lists m)
  2.2799 +            val (len_n, off_n) = the (AList.lookup (op =) lenoff_lists n)
  2.2800 +            val len_elem = len_m + len_n
  2.2801 +            val off_elem = off_m * Integer.pow len_n size_elem + off_n
  2.2802 +          in
  2.2803 +            case AList.lookup op= lenoff'_lists (len_elem, off_elem) of
  2.2804 +              NONE =>
  2.2805 +                (* undefined *)
  2.2806 +                Leaf (replicate size_list False)
  2.2807 +            | SOME element =>
  2.2808 +                Leaf ((replicate element False) @ True ::
  2.2809 +                  (replicate (size_list - element - 1) False))
  2.2810 +          end
  2.2811 +      in
  2.2812 +        SOME (Node (map (fn m => Node (map (append m) elements)) elements),
  2.2813 +          model, args)
  2.2814 +      end
  2.2815 +  | _ => NONE;
  2.2816 +
  2.2817 +(* only an optimization: 'lfp' could in principle be interpreted with  *)
  2.2818 +(* interpreters available already (using its definition), but the code *)
  2.2819 +(* below is more efficient                                             *)
  2.2820 +
  2.2821 +fun lfp_interpreter ctxt model args t =
  2.2822 +  case t of
  2.2823 +    Const (@{const_name lfp}, Type ("fun", [Type ("fun",
  2.2824 +      [Type (@{type_name set}, [T]),
  2.2825 +       Type (@{type_name set}, [_])]),
  2.2826 +       Type (@{type_name set}, [_])])) =>
  2.2827 +      let
  2.2828 +        val size_elem = size_of_type ctxt model T
  2.2829 +        (* the universe (i.e. the set that contains every element) *)
  2.2830 +        val i_univ = Node (replicate size_elem TT)
  2.2831 +        (* all sets with elements from type 'T' *)
  2.2832 +        val i_sets = make_constants ctxt model (HOLogic.mk_setT T)
  2.2833 +        (* all functions that map sets to sets *)
  2.2834 +        val i_funs = make_constants ctxt model (Type ("fun",
  2.2835 +          [HOLogic.mk_setT T, HOLogic.mk_setT T]))
  2.2836 +        (* "lfp(f) == Inter({u. f(u) <= u})" *)
  2.2837 +        (* interpretation * interpretation -> bool *)
  2.2838 +        fun is_subset (Node subs, Node sups) =
  2.2839 +              forall (fn (sub, sup) => (sub = FF) orelse (sup = TT)) (subs ~~ sups)
  2.2840 +          | is_subset (_, _) =
  2.2841 +              raise REFUTE ("lfp_interpreter",
  2.2842 +                "is_subset: interpretation for set is not a node")
  2.2843 +        (* interpretation * interpretation -> interpretation *)
  2.2844 +        fun intersection (Node xs, Node ys) =
  2.2845 +              Node (map (fn (x, y) => if x=TT andalso y=TT then TT else FF)
  2.2846 +                (xs ~~ ys))
  2.2847 +          | intersection (_, _) =
  2.2848 +              raise REFUTE ("lfp_interpreter",
  2.2849 +                "intersection: interpretation for set is not a node")
  2.2850 +        (* interpretation -> interpretaion *)
  2.2851 +        fun lfp (Node resultsets) =
  2.2852 +              fold (fn (set, resultset) => fn acc =>
  2.2853 +                if is_subset (resultset, set) then
  2.2854 +                  intersection (acc, set)
  2.2855 +                else
  2.2856 +                  acc) (i_sets ~~ resultsets) i_univ
  2.2857 +          | lfp _ =
  2.2858 +              raise REFUTE ("lfp_interpreter",
  2.2859 +                "lfp: interpretation for function is not a node")
  2.2860 +      in
  2.2861 +        SOME (Node (map lfp i_funs), model, args)
  2.2862 +      end
  2.2863 +  | _ => NONE;
  2.2864 +
  2.2865 +(* only an optimization: 'gfp' could in principle be interpreted with  *)
  2.2866 +(* interpreters available already (using its definition), but the code *)
  2.2867 +(* below is more efficient                                             *)
  2.2868 +
  2.2869 +fun gfp_interpreter ctxt model args t =
  2.2870 +  case t of
  2.2871 +    Const (@{const_name gfp}, Type ("fun", [Type ("fun",
  2.2872 +      [Type (@{type_name set}, [T]),
  2.2873 +       Type (@{type_name set}, [_])]),
  2.2874 +       Type (@{type_name set}, [_])])) =>
  2.2875 +      let
  2.2876 +        val size_elem = size_of_type ctxt model T
  2.2877 +        (* the universe (i.e. the set that contains every element) *)
  2.2878 +        val i_univ = Node (replicate size_elem TT)
  2.2879 +        (* all sets with elements from type 'T' *)
  2.2880 +        val i_sets = make_constants ctxt model (HOLogic.mk_setT T)
  2.2881 +        (* all functions that map sets to sets *)
  2.2882 +        val i_funs = make_constants ctxt model (Type ("fun",
  2.2883 +          [HOLogic.mk_setT T, HOLogic.mk_setT T]))
  2.2884 +        (* "gfp(f) == Union({u. u <= f(u)})" *)
  2.2885 +        (* interpretation * interpretation -> bool *)
  2.2886 +        fun is_subset (Node subs, Node sups) =
  2.2887 +              forall (fn (sub, sup) => (sub = FF) orelse (sup = TT))
  2.2888 +                (subs ~~ sups)
  2.2889 +          | is_subset (_, _) =
  2.2890 +              raise REFUTE ("gfp_interpreter",
  2.2891 +                "is_subset: interpretation for set is not a node")
  2.2892 +        (* interpretation * interpretation -> interpretation *)
  2.2893 +        fun union (Node xs, Node ys) =
  2.2894 +              Node (map (fn (x,y) => if x=TT orelse y=TT then TT else FF)
  2.2895 +                   (xs ~~ ys))
  2.2896 +          | union (_, _) =
  2.2897 +              raise REFUTE ("gfp_interpreter",
  2.2898 +                "union: interpretation for set is not a node")
  2.2899 +        (* interpretation -> interpretaion *)
  2.2900 +        fun gfp (Node resultsets) =
  2.2901 +              fold (fn (set, resultset) => fn acc =>
  2.2902 +                if is_subset (set, resultset) then
  2.2903 +                  union (acc, set)
  2.2904 +                else
  2.2905 +                  acc) (i_sets ~~ resultsets) i_univ
  2.2906 +          | gfp _ =
  2.2907 +              raise REFUTE ("gfp_interpreter",
  2.2908 +                "gfp: interpretation for function is not a node")
  2.2909 +      in
  2.2910 +        SOME (Node (map gfp i_funs), model, args)
  2.2911 +      end
  2.2912 +  | _ => NONE;
  2.2913 +
  2.2914 +(* only an optimization: 'fst' could in principle be interpreted with  *)
  2.2915 +(* interpreters available already (using its definition), but the code *)
  2.2916 +(* below is more efficient                                             *)
  2.2917 +
  2.2918 +fun Product_Type_fst_interpreter ctxt model args t =
  2.2919 +  case t of
  2.2920 +    Const (@{const_name fst}, Type ("fun", [Type (@{type_name Product_Type.prod}, [T, U]), _])) =>
  2.2921 +      let
  2.2922 +        val constants_T = make_constants ctxt model T
  2.2923 +        val size_U = size_of_type ctxt model U
  2.2924 +      in
  2.2925 +        SOME (Node (maps (replicate size_U) constants_T), model, args)
  2.2926 +      end
  2.2927 +  | _ => NONE;
  2.2928 +
  2.2929 +(* only an optimization: 'snd' could in principle be interpreted with  *)
  2.2930 +(* interpreters available already (using its definition), but the code *)
  2.2931 +(* below is more efficient                                             *)
  2.2932 +
  2.2933 +fun Product_Type_snd_interpreter ctxt model args t =
  2.2934 +  case t of
  2.2935 +    Const (@{const_name snd}, Type ("fun", [Type (@{type_name Product_Type.prod}, [T, U]), _])) =>
  2.2936 +      let
  2.2937 +        val size_T = size_of_type ctxt model T
  2.2938 +        val constants_U = make_constants ctxt model U
  2.2939 +      in
  2.2940 +        SOME (Node (flat (replicate size_T constants_U)), model, args)
  2.2941 +      end
  2.2942 +  | _ => NONE;
  2.2943 +
  2.2944 +
  2.2945 +(* ------------------------------------------------------------------------- *)
  2.2946 +(* PRINTERS                                                                  *)
  2.2947 +(* ------------------------------------------------------------------------- *)
  2.2948 +
  2.2949 +fun stlc_printer ctxt model T intr assignment =
  2.2950 +  let
  2.2951 +    (* string -> string *)
  2.2952 +    val strip_leading_quote = perhaps (try (unprefix "'"))
  2.2953 +    (* Term.typ -> string *)
  2.2954 +    fun string_of_typ (Type (s, _)) = s
  2.2955 +      | string_of_typ (TFree (x, _)) = strip_leading_quote x
  2.2956 +      | string_of_typ (TVar ((x,i), _)) =
  2.2957 +          strip_leading_quote x ^ string_of_int i
  2.2958 +    (* interpretation -> int *)
  2.2959 +    fun index_from_interpretation (Leaf xs) =
  2.2960 +          find_index (Prop_Logic.eval assignment) xs
  2.2961 +      | index_from_interpretation _ =
  2.2962 +          raise REFUTE ("stlc_printer",
  2.2963 +            "interpretation for ground type is not a leaf")
  2.2964 +  in
  2.2965 +    case T of
  2.2966 +      Type ("fun", [T1, T2]) =>
  2.2967 +        let
  2.2968 +          (* create all constants of type 'T1' *)
  2.2969 +          val constants = make_constants ctxt model T1
  2.2970 +          (* interpretation list *)
  2.2971 +          val results =
  2.2972 +            (case intr of
  2.2973 +              Node xs => xs
  2.2974 +            | _ => raise REFUTE ("stlc_printer",
  2.2975 +              "interpretation for function type is a leaf"))
  2.2976 +          (* Term.term list *)
  2.2977 +          val pairs = map (fn (arg, result) =>
  2.2978 +            HOLogic.mk_prod
  2.2979 +              (print ctxt model T1 arg assignment,
  2.2980 +               print ctxt model T2 result assignment))
  2.2981 +            (constants ~~ results)
  2.2982 +          (* Term.typ *)
  2.2983 +          val HOLogic_prodT = HOLogic.mk_prodT (T1, T2)
  2.2984 +          val HOLogic_setT  = HOLogic.mk_setT HOLogic_prodT
  2.2985 +          (* Term.term *)
  2.2986 +          val HOLogic_empty_set = Const (@{const_abbrev Set.empty}, HOLogic_setT)
  2.2987 +          val HOLogic_insert    =
  2.2988 +            Const (@{const_name insert}, HOLogic_prodT --> HOLogic_setT --> HOLogic_setT)
  2.2989 +        in
  2.2990 +          SOME (fold_rev (fn pair => fn acc => HOLogic_insert $ pair $ acc) pairs HOLogic_empty_set)
  2.2991 +        end
  2.2992 +    | Type ("prop", []) =>
  2.2993 +        (case index_from_interpretation intr of
  2.2994 +          ~1 => SOME (HOLogic.mk_Trueprop (Const (@{const_name undefined}, HOLogic.boolT)))
  2.2995 +        | 0  => SOME (HOLogic.mk_Trueprop @{term True})
  2.2996 +        | 1  => SOME (HOLogic.mk_Trueprop @{term False})
  2.2997 +        | _  => raise REFUTE ("stlc_interpreter",
  2.2998 +          "illegal interpretation for a propositional value"))
  2.2999 +    | Type _  =>
  2.3000 +        if index_from_interpretation intr = (~1) then
  2.3001 +          SOME (Const (@{const_name undefined}, T))
  2.3002 +        else
  2.3003 +          SOME (Const (string_of_typ T ^
  2.3004 +            string_of_int (index_from_interpretation intr), T))
  2.3005 +    | TFree _ =>
  2.3006 +        if index_from_interpretation intr = (~1) then
  2.3007 +          SOME (Const (@{const_name undefined}, T))
  2.3008 +        else
  2.3009 +          SOME (Const (string_of_typ T ^
  2.3010 +            string_of_int (index_from_interpretation intr), T))
  2.3011 +    | TVar _  =>
  2.3012 +        if index_from_interpretation intr = (~1) then
  2.3013 +          SOME (Const (@{const_name undefined}, T))
  2.3014 +        else
  2.3015 +          SOME (Const (string_of_typ T ^
  2.3016 +            string_of_int (index_from_interpretation intr), T))
  2.3017 +  end;
  2.3018 +
  2.3019 +fun set_printer ctxt model T intr assignment =
  2.3020 +  (case T of
  2.3021 +    Type (@{type_name set}, [T1]) =>
  2.3022 +    let
  2.3023 +      (* create all constants of type 'T1' *)
  2.3024 +      val constants = make_constants ctxt model T1
  2.3025 +      (* interpretation list *)
  2.3026 +      val results = (case intr of
  2.3027 +          Node xs => xs
  2.3028 +        | _       => raise REFUTE ("set_printer",
  2.3029 +          "interpretation for set type is a leaf"))
  2.3030 +      (* Term.term list *)
  2.3031 +      val elements = List.mapPartial (fn (arg, result) =>
  2.3032 +        case result of
  2.3033 +          Leaf [fmTrue, (* fmFalse *) _] =>
  2.3034 +          if Prop_Logic.eval assignment fmTrue then
  2.3035 +            SOME (print ctxt model T1 arg assignment)
  2.3036 +          else (* if Prop_Logic.eval assignment fmFalse then *)
  2.3037 +            NONE
  2.3038 +        | _ =>
  2.3039 +          raise REFUTE ("set_printer",
  2.3040 +            "illegal interpretation for a Boolean value"))
  2.3041 +        (constants ~~ results)
  2.3042 +      (* Term.typ *)
  2.3043 +      val HOLogic_setT1     = HOLogic.mk_setT T1
  2.3044 +      (* Term.term *)
  2.3045 +      val HOLogic_empty_set = Const (@{const_abbrev Set.empty}, HOLogic_setT1)
  2.3046 +      val HOLogic_insert    =
  2.3047 +        Const (@{const_name insert}, T1 --> HOLogic_setT1 --> HOLogic_setT1)
  2.3048 +    in
  2.3049 +      SOME (Library.foldl (fn (acc, elem) => HOLogic_insert $ elem $ acc)
  2.3050 +        (HOLogic_empty_set, elements))
  2.3051 +    end
  2.3052 +  | _ =>
  2.3053 +    NONE);
  2.3054 +
  2.3055 +fun IDT_printer ctxt model T intr assignment =
  2.3056 +  let
  2.3057 +    val thy = Proof_Context.theory_of ctxt
  2.3058 +  in
  2.3059 +    (case T of
  2.3060 +      Type (s, Ts) =>
  2.3061 +        (case Datatype.get_info thy s of
  2.3062 +          SOME info =>  (* inductive datatype *)
  2.3063 +            let
  2.3064 +              val (typs, _)           = model
  2.3065 +              val index               = #index info
  2.3066 +              val descr               = #descr info
  2.3067 +              val (_, dtyps, constrs) = the (AList.lookup (op =) descr index)
  2.3068 +              val typ_assoc           = dtyps ~~ Ts
  2.3069 +              (* sanity check: every element in 'dtyps' must be a 'DtTFree' *)
  2.3070 +              val _ =
  2.3071 +                if Library.exists (fn d =>
  2.3072 +                  case d of Datatype.DtTFree _ => false | _ => true) dtyps
  2.3073 +                then
  2.3074 +                  raise REFUTE ("IDT_printer", "datatype argument (for type " ^
  2.3075 +                    Syntax.string_of_typ ctxt (Type (s, Ts)) ^ ") is not a variable")
  2.3076 +                else ()
  2.3077 +              (* the index of the element in the datatype *)
  2.3078 +              val element =
  2.3079 +                (case intr of
  2.3080 +                  Leaf xs => find_index (Prop_Logic.eval assignment) xs
  2.3081 +                | Node _  => raise REFUTE ("IDT_printer",
  2.3082 +                  "interpretation is not a leaf"))
  2.3083 +            in
  2.3084 +              if element < 0 then
  2.3085 +                SOME (Const (@{const_name undefined}, Type (s, Ts)))
  2.3086 +              else
  2.3087 +                let
  2.3088 +                  (* takes a datatype constructor, and if for some arguments this  *)
  2.3089 +                  (* constructor generates the datatype's element that is given by *)
  2.3090 +                  (* 'element', returns the constructor (as a term) as well as the *)
  2.3091 +                  (* indices of the arguments                                      *)
  2.3092 +                  fun get_constr_args (cname, cargs) =
  2.3093 +                    let
  2.3094 +                      val cTerm      = Const (cname,
  2.3095 +                        map (typ_of_dtyp descr typ_assoc) cargs ---> Type (s, Ts))
  2.3096 +                      val (iC, _, _) = interpret ctxt (typs, []) {maxvars=0,
  2.3097 +                        def_eq=false, next_idx=1, bounds=[], wellformed=True} cTerm
  2.3098 +                      (* interpretation -> int list option *)
  2.3099 +                      fun get_args (Leaf xs) =
  2.3100 +                            if find_index (fn x => x = True) xs = element then
  2.3101 +                              SOME []
  2.3102 +                            else
  2.3103 +                              NONE
  2.3104 +                        | get_args (Node xs) =
  2.3105 +                            let
  2.3106 +                              (* interpretation * int -> int list option *)
  2.3107 +                              fun search ([], _) =
  2.3108 +                                NONE
  2.3109 +                                | search (x::xs, n) =
  2.3110 +                                (case get_args x of
  2.3111 +                                  SOME result => SOME (n::result)
  2.3112 +                                | NONE        => search (xs, n+1))
  2.3113 +                            in
  2.3114 +                              search (xs, 0)
  2.3115 +                            end
  2.3116 +                    in
  2.3117 +                      Option.map (fn args => (cTerm, cargs, args)) (get_args iC)
  2.3118 +                    end
  2.3119 +                  val (cTerm, cargs, args) =
  2.3120 +                    (* we could speed things up by computing the correct          *)
  2.3121 +                    (* constructor directly (rather than testing all              *)
  2.3122 +                    (* constructors), based on the order in which constructors    *)
  2.3123 +                    (* generate elements of datatypes; the current implementation *)
  2.3124 +                    (* of 'IDT_printer' however is independent of the internals   *)
  2.3125 +                    (* of 'IDT_constructor_interpreter'                           *)
  2.3126 +                    (case get_first get_constr_args constrs of
  2.3127 +                      SOME x => x
  2.3128 +                    | NONE   => raise REFUTE ("IDT_printer",
  2.3129 +                      "no matching constructor found for element " ^
  2.3130 +                      string_of_int element))
  2.3131 +                  val argsTerms = map (fn (d, n) =>
  2.3132 +                    let
  2.3133 +                      val dT = typ_of_dtyp descr typ_assoc d
  2.3134 +                      (* we only need the n-th element of this list, so there   *)
  2.3135 +                      (* might be a more efficient implementation that does not *)
  2.3136 +                      (* generate all constants                                 *)
  2.3137 +                      val consts = make_constants ctxt (typs, []) dT
  2.3138 +                    in
  2.3139 +                      print ctxt (typs, []) dT (nth consts n) assignment
  2.3140 +                    end) (cargs ~~ args)
  2.3141 +                in
  2.3142 +                  SOME (list_comb (cTerm, argsTerms))
  2.3143 +                end
  2.3144 +            end
  2.3145 +        | NONE =>  (* not an inductive datatype *)
  2.3146 +            NONE)
  2.3147 +    | _ =>  (* a (free or schematic) type variable *)
  2.3148 +        NONE)
  2.3149 +  end;
  2.3150 +
  2.3151 +
  2.3152 +(* ------------------------------------------------------------------------- *)
  2.3153 +(* use 'setup Refute.setup' in an Isabelle theory to initialize the 'Refute' *)
  2.3154 +(* structure                                                                 *)
  2.3155 +(* ------------------------------------------------------------------------- *)
  2.3156 +
  2.3157 +(* ------------------------------------------------------------------------- *)
  2.3158 +(* Note: the interpreters and printers are used in reverse order; however,   *)
  2.3159 +(*       an interpreter that can handle non-atomic terms ends up being       *)
  2.3160 +(*       applied before the 'stlc_interpreter' breaks the term apart into    *)
  2.3161 +(*       subterms that are then passed to other interpreters!                *)
  2.3162 +(* ------------------------------------------------------------------------- *)
  2.3163 +
  2.3164 +val setup =
  2.3165 +   add_interpreter "stlc"    stlc_interpreter #>
  2.3166 +   add_interpreter "Pure"    Pure_interpreter #>
  2.3167 +   add_interpreter "HOLogic" HOLogic_interpreter #>
  2.3168 +   add_interpreter "set"     set_interpreter #>
  2.3169 +   add_interpreter "IDT"             IDT_interpreter #>
  2.3170 +   add_interpreter "IDT_constructor" IDT_constructor_interpreter #>
  2.3171 +   add_interpreter "IDT_recursion"   IDT_recursion_interpreter #>
  2.3172 +   add_interpreter "Finite_Set.card"    Finite_Set_card_interpreter #>
  2.3173 +   add_interpreter "Finite_Set.finite"  Finite_Set_finite_interpreter #>
  2.3174 +   add_interpreter "Nat_Orderings.less" Nat_less_interpreter #>
  2.3175 +   add_interpreter "Nat_HOL.plus"       Nat_plus_interpreter #>
  2.3176 +   add_interpreter "Nat_HOL.minus"      Nat_minus_interpreter #>
  2.3177 +   add_interpreter "Nat_HOL.times"      Nat_times_interpreter #>
  2.3178 +   add_interpreter "List.append" List_append_interpreter #>
  2.3179 +(* UNSOUND
  2.3180 +   add_interpreter "lfp" lfp_interpreter #>
  2.3181 +   add_interpreter "gfp" gfp_interpreter #>
  2.3182 +*)
  2.3183 +   add_interpreter "Product_Type.fst" Product_Type_fst_interpreter #>
  2.3184 +   add_interpreter "Product_Type.snd" Product_Type_snd_interpreter #>
  2.3185 +   add_printer "stlc" stlc_printer #>
  2.3186 +   add_printer "set" set_printer #>
  2.3187 +   add_printer "IDT"  IDT_printer;
  2.3188 +
  2.3189 +
  2.3190 +
  2.3191 +(** outer syntax commands 'refute' and 'refute_params' **)
  2.3192 +
  2.3193 +(* argument parsing *)
  2.3194 +
  2.3195 +(*optional list of arguments of the form [name1=value1, name2=value2, ...]*)
  2.3196 +
  2.3197 +val scan_parm = Parse.name -- (Scan.optional (@{keyword "="} |-- Parse.name) "true")
  2.3198 +val scan_parms = Scan.optional (@{keyword "["} |-- Parse.list scan_parm --| @{keyword "]"}) [];
  2.3199 +
  2.3200 +
  2.3201 +(* 'refute' command *)
  2.3202 +
  2.3203 +val _ =
  2.3204 +  Outer_Syntax.improper_command @{command_spec "refute"}
  2.3205 +    "try to find a model that refutes a given subgoal"
  2.3206 +    (scan_parms -- Scan.optional Parse.nat 1 >>
  2.3207 +      (fn (parms, i) =>
  2.3208 +        Toplevel.keep (fn state =>
  2.3209 +          let
  2.3210 +            val ctxt = Toplevel.context_of state;
  2.3211 +            val {goal = st, ...} = Proof.raw_goal (Toplevel.proof_of state);
  2.3212 +          in refute_goal ctxt parms st i; () end)));
  2.3213 +
  2.3214 +
  2.3215 +(* 'refute_params' command *)
  2.3216 +
  2.3217 +val _ =
  2.3218 +  Outer_Syntax.command @{command_spec "refute_params"}
  2.3219 +    "show/store default parameters for the 'refute' command"
  2.3220 +    (scan_parms >> (fn parms =>
  2.3221 +      Toplevel.theory (fn thy =>
  2.3222 +        let
  2.3223 +          val thy' = fold set_default_param parms thy;
  2.3224 +          val output =
  2.3225 +            (case get_default_params (Proof_Context.init_global thy') of
  2.3226 +              [] => "none"
  2.3227 +            | new_defaults => cat_lines (map (fn (x, y) => x ^ "=" ^ y) new_defaults));
  2.3228 +          val _ = writeln ("Default parameters for 'refute':\n" ^ output);
  2.3229 +        in thy' end)));
  2.3230 +
  2.3231 +end;
  2.3232 +
     3.1 --- a/src/HOL/ROOT	Wed Oct 31 11:23:21 2012 +0100
     3.2 +++ b/src/HOL/ROOT	Wed Oct 31 11:23:21 2012 +0100
     3.3 @@ -49,6 +49,7 @@
     3.4      (* Code_Prolog  FIXME cf. 76965c356d2a *)
     3.5      Code_Real_Approx_By_Float
     3.6      Target_Numeral
     3.7 +    Refute
     3.8    theories [condition = ISABELLE_FULL_TEST]
     3.9      Sum_of_Squares_Remote
    3.10    files "document/root.bib" "document/root.tex"
    3.11 @@ -422,6 +423,7 @@
    3.12      Chinese
    3.13      Serbian
    3.14      "~~/src/HOL/Library/FinFun_Syntax"
    3.15 +    "~~/src/HOL/Library/Refute"
    3.16    theories
    3.17      Iff_Oracle
    3.18      Coercion_Examples
     4.1 --- a/src/HOL/Refute.thy	Wed Oct 31 11:23:21 2012 +0100
     4.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.3 @@ -1,113 +0,0 @@
     4.4 -(*  Title:      HOL/Refute.thy
     4.5 -    Author:     Tjark Weber
     4.6 -    Copyright   2003-2007
     4.7 -
     4.8 -Basic setup and documentation for the 'refute' (and 'refute_params') command.
     4.9 -*)
    4.10 -
    4.11 -header {* Refute *}
    4.12 -
    4.13 -theory Refute
    4.14 -imports Hilbert_Choice List Sledgehammer
    4.15 -keywords "refute" :: diag and "refute_params" :: thy_decl
    4.16 -begin
    4.17 -
    4.18 -ML_file "Tools/refute.ML"
    4.19 -setup Refute.setup
    4.20 -
    4.21 -refute_params
    4.22 - [itself = 1,
    4.23 -  minsize = 1,
    4.24 -  maxsize = 8,
    4.25 -  maxvars = 10000,
    4.26 -  maxtime = 60,
    4.27 -  satsolver = auto,
    4.28 -  no_assms = false]
    4.29 -
    4.30 -text {*
    4.31 -\small
    4.32 -\begin{verbatim}
    4.33 -(* ------------------------------------------------------------------------- *)
    4.34 -(* REFUTE                                                                    *)
    4.35 -(*                                                                           *)
    4.36 -(* We use a SAT solver to search for a (finite) model that refutes a given   *)
    4.37 -(* HOL formula.                                                              *)
    4.38 -(* ------------------------------------------------------------------------- *)
    4.39 -
    4.40 -(* ------------------------------------------------------------------------- *)
    4.41 -(* NOTE                                                                      *)
    4.42 -(*                                                                           *)
    4.43 -(* I strongly recommend that you install a stand-alone SAT solver if you     *)
    4.44 -(* want to use 'refute'.  For details see 'HOL/Tools/sat_solver.ML'.  If you *)
    4.45 -(* have installed (a supported version of) zChaff, simply set 'ZCHAFF_HOME'  *)
    4.46 -(* in 'etc/settings'.                                                        *)
    4.47 -(* ------------------------------------------------------------------------- *)
    4.48 -
    4.49 -(* ------------------------------------------------------------------------- *)
    4.50 -(* USAGE                                                                     *)
    4.51 -(*                                                                           *)
    4.52 -(* See the file 'HOL/ex/Refute_Examples.thy' for examples.  The supported    *)
    4.53 -(* parameters are explained below.                                           *)
    4.54 -(* ------------------------------------------------------------------------- *)
    4.55 -
    4.56 -(* ------------------------------------------------------------------------- *)
    4.57 -(* CURRENT LIMITATIONS                                                       *)
    4.58 -(*                                                                           *)
    4.59 -(* 'refute' currently accepts formulas of higher-order predicate logic (with *)
    4.60 -(* equality), including free/bound/schematic variables, lambda abstractions, *)
    4.61 -(* sets and set membership, "arbitrary", "The", "Eps", records and           *)
    4.62 -(* inductively defined sets.  Constants are unfolded automatically, and sort *)
    4.63 -(* axioms are added as well.  Other, user-asserted axioms however are        *)
    4.64 -(* ignored.  Inductive datatypes and recursive functions are supported, but  *)
    4.65 -(* may lead to spurious countermodels.                                       *)
    4.66 -(*                                                                           *)
    4.67 -(* The (space) complexity of the algorithm is non-elementary.                *)
    4.68 -(*                                                                           *)
    4.69 -(* Schematic type variables are not supported.                               *)
    4.70 -(* ------------------------------------------------------------------------- *)
    4.71 -
    4.72 -(* ------------------------------------------------------------------------- *)
    4.73 -(* PARAMETERS                                                                *)
    4.74 -(*                                                                           *)
    4.75 -(* The following global parameters are currently supported (and required,    *)
    4.76 -(* except for "expect"):                                                     *)
    4.77 -(*                                                                           *)
    4.78 -(* Name          Type    Description                                         *)
    4.79 -(*                                                                           *)
    4.80 -(* "minsize"     int     Only search for models with size at least           *)
    4.81 -(*                       'minsize'.                                          *)
    4.82 -(* "maxsize"     int     If >0, only search for models with size at most     *)
    4.83 -(*                       'maxsize'.                                          *)
    4.84 -(* "maxvars"     int     If >0, use at most 'maxvars' boolean variables      *)
    4.85 -(*                       when transforming the term into a propositional     *)
    4.86 -(*                       formula.                                            *)
    4.87 -(* "maxtime"     int     If >0, terminate after at most 'maxtime' seconds.   *)
    4.88 -(*                       This value is ignored under some ML compilers.      *)
    4.89 -(* "satsolver"   string  Name of the SAT solver to be used.                  *)
    4.90 -(* "no_assms"    bool    If "true", assumptions in structured proofs are     *)
    4.91 -(*                       not considered.                                     *)
    4.92 -(* "expect"      string  Expected result ("genuine", "potential", "none", or *)
    4.93 -(*                       "unknown").                                         *)
    4.94 -(*                                                                           *)
    4.95 -(* The size of particular types can be specified in the form type=size       *)
    4.96 -(* (where 'type' is a string, and 'size' is an int).  Examples:              *)
    4.97 -(* "'a"=1                                                                    *)
    4.98 -(* "List.list"=2                                                             *)
    4.99 -(* ------------------------------------------------------------------------- *)
   4.100 -
   4.101 -(* ------------------------------------------------------------------------- *)
   4.102 -(* FILES                                                                     *)
   4.103 -(*                                                                           *)
   4.104 -(* HOL/Tools/prop_logic.ML     Propositional logic                           *)
   4.105 -(* HOL/Tools/sat_solver.ML     SAT solvers                                   *)
   4.106 -(* HOL/Tools/refute.ML         Translation HOL -> propositional logic and    *)
   4.107 -(*                             Boolean assignment -> HOL model               *)
   4.108 -(* HOL/Refute.thy              This file: loads the ML files, basic setup,   *)
   4.109 -(*                             documentation                                 *)
   4.110 -(* HOL/SAT.thy                 Sets default parameters                       *)
   4.111 -(* HOL/ex/Refute_Examples.thy  Examples                                      *)
   4.112 -(* ------------------------------------------------------------------------- *)
   4.113 -\end{verbatim}
   4.114 -*}
   4.115 -
   4.116 -end
     5.1 --- a/src/HOL/SAT.thy	Wed Oct 31 11:23:21 2012 +0100
     5.2 +++ b/src/HOL/SAT.thy	Wed Oct 31 11:23:21 2012 +0100
     5.3 @@ -8,7 +8,7 @@
     5.4  header {* Reconstructing external resolution proofs for propositional logic *}
     5.5  
     5.6  theory SAT
     5.7 -imports Refute
     5.8 +imports Hilbert_Choice List Sledgehammer
     5.9  begin
    5.10  
    5.11  ML_file "Tools/sat_funcs.ML"
     6.1 --- a/src/HOL/TPTP/ATP_Problem_Import.thy	Wed Oct 31 11:23:21 2012 +0100
     6.2 +++ b/src/HOL/TPTP/ATP_Problem_Import.thy	Wed Oct 31 11:23:21 2012 +0100
     6.3 @@ -5,7 +5,10 @@
     6.4  header {* ATP Problem Importer *}
     6.5  
     6.6  theory ATP_Problem_Import
     6.7 -imports Complex_Main TPTP_Interpret
     6.8 +imports
     6.9 +  Complex_Main
    6.10 +  TPTP_Interpret
    6.11 +  "~~/src/HOL/Library/Refute"
    6.12  begin
    6.13  
    6.14  ML_file "sledgehammer_tactics.ML"
     7.1 --- a/src/HOL/TPTP/atp_problem_import.ML	Wed Oct 31 11:23:21 2012 +0100
     7.2 +++ b/src/HOL/TPTP/atp_problem_import.ML	Wed Oct 31 11:23:21 2012 +0100
     7.3 @@ -72,7 +72,7 @@
     7.4      val thy = Proof_Context.theory_of ctxt
     7.5      val (defs, pseudo_defs) =
     7.6        defs |> map (ATP_Util.abs_extensionalize_term ctxt
     7.7 -                   #> aptrueprop (open_form I))
     7.8 +                   #> aptrueprop (hol_open_form I))
     7.9             |> List.partition (ATP_Util.is_legitimate_tptp_def
    7.10                                o perhaps (try HOLogic.dest_Trueprop)
    7.11                                o ATP_Util.unextensionalize_def)
     8.1 --- a/src/HOL/Tools/Nitpick/nitpick_hol.ML	Wed Oct 31 11:23:21 2012 +0100
     8.2 +++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML	Wed Oct 31 11:23:21 2012 +0100
     8.3 @@ -1311,10 +1311,10 @@
     8.4      |> map snd
     8.5    end
     8.6  
     8.7 -(* Ideally we would check against "Complex_Main", not "Refute", but any theory
     8.8 -   will do as long as it contains all the "axioms" and "axiomatization"
     8.9 +(* Ideally we would check against "Complex_Main", not "Hilbert_Choice", but any
    8.10 +   theory will do as long as it contains all the "axioms" and "axiomatization"
    8.11     commands. *)
    8.12 -fun is_built_in_theory thy = Theory.subthy (thy, @{theory Refute})
    8.13 +fun is_built_in_theory thy = Theory.subthy (thy, @{theory Hilbert_Choice})
    8.14  
    8.15  fun all_nondefs_of ctxt subst =
    8.16    ctxt |> Spec_Rules.get
     9.1 --- a/src/HOL/Tools/Nitpick/nitpick_isar.ML	Wed Oct 31 11:23:21 2012 +0100
     9.2 +++ b/src/HOL/Tools/Nitpick/nitpick_isar.ML	Wed Oct 31 11:23:21 2012 +0100
     9.3 @@ -351,8 +351,6 @@
     9.4                     commas (map (quote o Syntax.string_of_term ctxt) ts)) ^
     9.5                  " (" ^ quote loc ^ "): " ^
     9.6                  commas (map (Syntax.string_of_typ ctxt) Ts) ^ ".")
     9.7 -       | Refute.REFUTE (loc, details) =>
     9.8 -         error ("Unhandled Refute error (" ^ quote loc ^ "): " ^ details ^ ".")
     9.9  
    9.10  fun pick_nits override_params mode i step state =
    9.11    let
    10.1 --- a/src/HOL/Tools/Nitpick/nitpick_util.ML	Wed Oct 31 11:23:21 2012 +0100
    10.2 +++ b/src/HOL/Tools/Nitpick/nitpick_util.ML	Wed Oct 31 11:23:21 2012 +0100
    10.3 @@ -252,14 +252,34 @@
    10.4  val nat_T = @{typ nat}
    10.5  val int_T = @{typ int}
    10.6  
    10.7 -val simple_string_of_typ = Refute.string_of_typ
    10.8 -val is_real_constr = Refute.is_IDT_constructor
    10.9 +fun simple_string_of_typ (Type (s, _))     = s
   10.10 +  | simple_string_of_typ (TFree (s, _))    = s
   10.11 +  | simple_string_of_typ (TVar ((s, _), _)) = s
   10.12 +
   10.13 +fun is_real_constr thy (s, T) =
   10.14 +  case body_type T of
   10.15 +    Type (s', _) =>
   10.16 +    (case Datatype.get_constrs thy s' of
   10.17 +       SOME constrs =>
   10.18 +       List.exists (fn (cname, cty) =>
   10.19 +         cname = s andalso Sign.typ_instance thy (T, cty)) constrs
   10.20 +     | NONE => false)
   10.21 +  | _  => false
   10.22 +
   10.23  val typ_of_dtyp = ATP_Util.typ_of_dtyp
   10.24  val varify_type = ATP_Util.varify_type
   10.25  val instantiate_type = ATP_Util.instantiate_type
   10.26  val varify_and_instantiate_type = ATP_Util.varify_and_instantiate_type
   10.27 -val is_of_class_const = Refute.is_const_of_class
   10.28 -val get_class_def = Refute.get_classdef
   10.29 +
   10.30 +fun is_of_class_const thy (s, _) =
   10.31 +  member (op =) (map Logic.const_of_class (Sign.all_classes thy)) s
   10.32 +
   10.33 +fun get_class_def thy class =
   10.34 +  let val axname = class ^ "_class_def" in
   10.35 +    Option.map (pair axname)
   10.36 +      (AList.lookup (op =) (Theory.all_axioms_of thy) axname)
   10.37 +  end;
   10.38 +
   10.39  val monomorphic_term = ATP_Util.monomorphic_term
   10.40  val specialize_type = ATP_Util.specialize_type
   10.41  val eta_expand = ATP_Util.eta_expand
    11.1 --- a/src/HOL/Tools/refute.ML	Wed Oct 31 11:23:21 2012 +0100
    11.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.3 @@ -1,3229 +0,0 @@
    11.4 -(*  Title:      HOL/Tools/refute.ML
    11.5 -    Author:     Tjark Weber, TU Muenchen
    11.6 -
    11.7 -Finite model generation for HOL formulas, using a SAT solver.
    11.8 -*)
    11.9 -
   11.10 -(* ------------------------------------------------------------------------- *)
   11.11 -(* Declares the 'REFUTE' signature as well as a structure 'Refute'.          *)
   11.12 -(* Documentation is available in the Isabelle/Isar theory 'HOL/Refute.thy'.  *)
   11.13 -(* ------------------------------------------------------------------------- *)
   11.14 -
   11.15 -signature REFUTE =
   11.16 -sig
   11.17 -
   11.18 -  exception REFUTE of string * string
   11.19 -
   11.20 -(* ------------------------------------------------------------------------- *)
   11.21 -(* Model/interpretation related code (translation HOL -> propositional logic *)
   11.22 -(* ------------------------------------------------------------------------- *)
   11.23 -
   11.24 -  type params
   11.25 -  type interpretation
   11.26 -  type model
   11.27 -  type arguments
   11.28 -
   11.29 -  exception MAXVARS_EXCEEDED
   11.30 -
   11.31 -  val add_interpreter : string -> (Proof.context -> model -> arguments -> term ->
   11.32 -    (interpretation * model * arguments) option) -> theory -> theory
   11.33 -  val add_printer : string -> (Proof.context -> model -> typ ->
   11.34 -    interpretation -> (int -> bool) -> term option) -> theory -> theory
   11.35 -
   11.36 -  val interpret : Proof.context -> model -> arguments -> term ->
   11.37 -    (interpretation * model * arguments)
   11.38 -
   11.39 -  val print : Proof.context -> model -> typ -> interpretation -> (int -> bool) -> term
   11.40 -  val print_model : Proof.context -> model -> (int -> bool) -> string
   11.41 -
   11.42 -(* ------------------------------------------------------------------------- *)
   11.43 -(* Interface                                                                 *)
   11.44 -(* ------------------------------------------------------------------------- *)
   11.45 -
   11.46 -  val set_default_param  : (string * string) -> theory -> theory
   11.47 -  val get_default_param  : Proof.context -> string -> string option
   11.48 -  val get_default_params : Proof.context -> (string * string) list
   11.49 -  val actual_params      : Proof.context -> (string * string) list -> params
   11.50 -
   11.51 -  val find_model :
   11.52 -    Proof.context -> params -> term list -> term -> bool -> string
   11.53 -
   11.54 -  (* tries to find a model for a formula: *)
   11.55 -  val satisfy_term :
   11.56 -    Proof.context -> (string * string) list -> term list -> term -> string
   11.57 -  (* tries to find a model that refutes a formula: *)
   11.58 -  val refute_term :
   11.59 -    Proof.context -> (string * string) list -> term list -> term -> string
   11.60 -  val refute_goal :
   11.61 -    Proof.context -> (string * string) list -> thm -> int -> string
   11.62 -
   11.63 -  val setup : theory -> theory
   11.64 -
   11.65 -(* ------------------------------------------------------------------------- *)
   11.66 -(* Additional functions used by Nitpick (to be factored out)                 *)
   11.67 -(* ------------------------------------------------------------------------- *)
   11.68 -
   11.69 -  val get_classdef : theory -> string -> (string * term) option
   11.70 -  val norm_rhs : term -> term
   11.71 -  val get_def : theory -> string * typ -> (string * term) option
   11.72 -  val get_typedef : theory -> typ -> (string * term) option
   11.73 -  val is_IDT_constructor : theory -> string * typ -> bool
   11.74 -  val is_IDT_recursor : theory -> string * typ -> bool
   11.75 -  val is_const_of_class: theory -> string * typ -> bool
   11.76 -  val string_of_typ : typ -> string
   11.77 -end;
   11.78 -
   11.79 -structure Refute : REFUTE =
   11.80 -struct
   11.81 -
   11.82 -open Prop_Logic;
   11.83 -
   11.84 -(* We use 'REFUTE' only for internal error conditions that should    *)
   11.85 -(* never occur in the first place (i.e. errors caused by bugs in our *)
   11.86 -(* code).  Otherwise (e.g. to indicate invalid input data) we use    *)
   11.87 -(* 'error'.                                                          *)
   11.88 -exception REFUTE of string * string;  (* ("in function", "cause") *)
   11.89 -
   11.90 -(* should be raised by an interpreter when more variables would be *)
   11.91 -(* required than allowed by 'maxvars'                              *)
   11.92 -exception MAXVARS_EXCEEDED;
   11.93 -
   11.94 -
   11.95 -(* ------------------------------------------------------------------------- *)
   11.96 -(* TREES                                                                     *)
   11.97 -(* ------------------------------------------------------------------------- *)
   11.98 -
   11.99 -(* ------------------------------------------------------------------------- *)
  11.100 -(* tree: implements an arbitrarily (but finitely) branching tree as a list   *)
  11.101 -(*       of (lists of ...) elements                                          *)
  11.102 -(* ------------------------------------------------------------------------- *)
  11.103 -
  11.104 -datatype 'a tree =
  11.105 -    Leaf of 'a
  11.106 -  | Node of ('a tree) list;
  11.107 -
  11.108 -(* ('a -> 'b) -> 'a tree -> 'b tree *)
  11.109 -
  11.110 -fun tree_map f tr =
  11.111 -  case tr of
  11.112 -    Leaf x  => Leaf (f x)
  11.113 -  | Node xs => Node (map (tree_map f) xs);
  11.114 -
  11.115 -(* ('a * 'b -> 'a) -> 'a * ('b tree) -> 'a *)
  11.116 -
  11.117 -fun tree_foldl f =
  11.118 -  let
  11.119 -    fun itl (e, Leaf x)  = f(e,x)
  11.120 -      | itl (e, Node xs) = Library.foldl (tree_foldl f) (e,xs)
  11.121 -  in
  11.122 -    itl
  11.123 -  end;
  11.124 -
  11.125 -(* 'a tree * 'b tree -> ('a * 'b) tree *)
  11.126 -
  11.127 -fun tree_pair (t1, t2) =
  11.128 -  case t1 of
  11.129 -    Leaf x =>
  11.130 -      (case t2 of
  11.131 -          Leaf y => Leaf (x,y)
  11.132 -        | Node _ => raise REFUTE ("tree_pair",
  11.133 -            "trees are of different height (second tree is higher)"))
  11.134 -  | Node xs =>
  11.135 -      (case t2 of
  11.136 -          (* '~~' will raise an exception if the number of branches in   *)
  11.137 -          (* both trees is different at the current node                 *)
  11.138 -          Node ys => Node (map tree_pair (xs ~~ ys))
  11.139 -        | Leaf _  => raise REFUTE ("tree_pair",
  11.140 -            "trees are of different height (first tree is higher)"));
  11.141 -
  11.142 -(* ------------------------------------------------------------------------- *)
  11.143 -(* params: parameters that control the translation into a propositional      *)
  11.144 -(*         formula/model generation                                          *)
  11.145 -(*                                                                           *)
  11.146 -(* The following parameters are supported (and required (!), except for      *)
  11.147 -(* "sizes" and "expect"):                                                    *)
  11.148 -(*                                                                           *)
  11.149 -(* Name          Type    Description                                         *)
  11.150 -(*                                                                           *)
  11.151 -(* "sizes"       (string * int) list                                         *)
  11.152 -(*                       Size of ground types (e.g. 'a=2), or depth of IDTs. *)
  11.153 -(* "minsize"     int     If >0, minimal size of each ground type/IDT depth.  *)
  11.154 -(* "maxsize"     int     If >0, maximal size of each ground type/IDT depth.  *)
  11.155 -(* "maxvars"     int     If >0, use at most 'maxvars' Boolean variables      *)
  11.156 -(*                       when transforming the term into a propositional     *)
  11.157 -(*                       formula.                                            *)
  11.158 -(* "maxtime"     int     If >0, terminate after at most 'maxtime' seconds.   *)
  11.159 -(* "satsolver"   string  SAT solver to be used.                              *)
  11.160 -(* "no_assms"    bool    If "true", assumptions in structured proofs are     *)
  11.161 -(*                       not considered.                                     *)
  11.162 -(* "expect"      string  Expected result ("genuine", "potential", "none", or *)
  11.163 -(*                       "unknown").                                         *)
  11.164 -(* ------------------------------------------------------------------------- *)
  11.165 -
  11.166 -type params =
  11.167 -  {
  11.168 -    sizes    : (string * int) list,
  11.169 -    minsize  : int,
  11.170 -    maxsize  : int,
  11.171 -    maxvars  : int,
  11.172 -    maxtime  : int,
  11.173 -    satsolver: string,
  11.174 -    no_assms : bool,
  11.175 -    expect   : string
  11.176 -  };
  11.177 -
  11.178 -(* ------------------------------------------------------------------------- *)
  11.179 -(* interpretation: a term's interpretation is given by a variable of type    *)
  11.180 -(*                 'interpretation'                                          *)
  11.181 -(* ------------------------------------------------------------------------- *)
  11.182 -
  11.183 -type interpretation =
  11.184 -  prop_formula list tree;
  11.185 -
  11.186 -(* ------------------------------------------------------------------------- *)
  11.187 -(* model: a model specifies the size of types and the interpretation of      *)
  11.188 -(*        terms                                                              *)
  11.189 -(* ------------------------------------------------------------------------- *)
  11.190 -
  11.191 -type model =
  11.192 -  (typ * int) list * (term * interpretation) list;
  11.193 -
  11.194 -(* ------------------------------------------------------------------------- *)
  11.195 -(* arguments: additional arguments required during interpretation of terms   *)
  11.196 -(* ------------------------------------------------------------------------- *)
  11.197 -
  11.198 -type arguments =
  11.199 -  {
  11.200 -    (* just passed unchanged from 'params': *)
  11.201 -    maxvars   : int,
  11.202 -    (* whether to use 'make_equality' or 'make_def_equality': *)
  11.203 -    def_eq    : bool,
  11.204 -    (* the following may change during the translation: *)
  11.205 -    next_idx  : int,
  11.206 -    bounds    : interpretation list,
  11.207 -    wellformed: prop_formula
  11.208 -  };
  11.209 -
  11.210 -structure Data = Theory_Data
  11.211 -(
  11.212 -  type T =
  11.213 -    {interpreters: (string * (Proof.context -> model -> arguments -> term ->
  11.214 -      (interpretation * model * arguments) option)) list,
  11.215 -     printers: (string * (Proof.context -> model -> typ -> interpretation ->
  11.216 -      (int -> bool) -> term option)) list,
  11.217 -     parameters: string Symtab.table};
  11.218 -  val empty = {interpreters = [], printers = [], parameters = Symtab.empty};
  11.219 -  val extend = I;
  11.220 -  fun merge
  11.221 -    ({interpreters = in1, printers = pr1, parameters = pa1},
  11.222 -     {interpreters = in2, printers = pr2, parameters = pa2}) : T =
  11.223 -    {interpreters = AList.merge (op =) (K true) (in1, in2),
  11.224 -     printers = AList.merge (op =) (K true) (pr1, pr2),
  11.225 -     parameters = Symtab.merge (op =) (pa1, pa2)};
  11.226 -);
  11.227 -
  11.228 -val get_data = Data.get o Proof_Context.theory_of;
  11.229 -
  11.230 -
  11.231 -(* ------------------------------------------------------------------------- *)
  11.232 -(* interpret: interprets the term 't' using a suitable interpreter; returns  *)
  11.233 -(*            the interpretation and a (possibly extended) model that keeps  *)
  11.234 -(*            track of the interpretation of subterms                        *)
  11.235 -(* ------------------------------------------------------------------------- *)
  11.236 -
  11.237 -fun interpret ctxt model args t =
  11.238 -  case get_first (fn (_, f) => f ctxt model args t)
  11.239 -      (#interpreters (get_data ctxt)) of
  11.240 -    NONE => raise REFUTE ("interpret",
  11.241 -      "no interpreter for term " ^ quote (Syntax.string_of_term ctxt t))
  11.242 -  | SOME x => x;
  11.243 -
  11.244 -(* ------------------------------------------------------------------------- *)
  11.245 -(* print: converts the interpretation 'intr', which must denote a term of    *)
  11.246 -(*        type 'T', into a term using a suitable printer                     *)
  11.247 -(* ------------------------------------------------------------------------- *)
  11.248 -
  11.249 -fun print ctxt model T intr assignment =
  11.250 -  case get_first (fn (_, f) => f ctxt model T intr assignment)
  11.251 -      (#printers (get_data ctxt)) of
  11.252 -    NONE => raise REFUTE ("print",
  11.253 -      "no printer for type " ^ quote (Syntax.string_of_typ ctxt T))
  11.254 -  | SOME x => x;
  11.255 -
  11.256 -(* ------------------------------------------------------------------------- *)
  11.257 -(* print_model: turns the model into a string, using a fixed interpretation  *)
  11.258 -(*              (given by an assignment for Boolean variables) and suitable  *)
  11.259 -(*              printers                                                     *)
  11.260 -(* ------------------------------------------------------------------------- *)
  11.261 -
  11.262 -fun print_model ctxt model assignment =
  11.263 -  let
  11.264 -    val (typs, terms) = model
  11.265 -    val typs_msg =
  11.266 -      if null typs then
  11.267 -        "empty universe (no type variables in term)\n"
  11.268 -      else
  11.269 -        "Size of types: " ^ commas (map (fn (T, i) =>
  11.270 -          Syntax.string_of_typ ctxt T ^ ": " ^ string_of_int i) typs) ^ "\n"
  11.271 -    val show_consts_msg =
  11.272 -      if not (Config.get ctxt show_consts) andalso Library.exists (is_Const o fst) terms then
  11.273 -        "enable \"show_consts\" to show the interpretation of constants\n"
  11.274 -      else
  11.275 -        ""
  11.276 -    val terms_msg =
  11.277 -      if null terms then
  11.278 -        "empty interpretation (no free variables in term)\n"
  11.279 -      else
  11.280 -        cat_lines (map_filter (fn (t, intr) =>
  11.281 -          (* print constants only if 'show_consts' is true *)
  11.282 -          if Config.get ctxt show_consts orelse not (is_Const t) then
  11.283 -            SOME (Syntax.string_of_term ctxt t ^ ": " ^
  11.284 -              Syntax.string_of_term ctxt
  11.285 -                (print ctxt model (Term.type_of t) intr assignment))
  11.286 -          else
  11.287 -            NONE) terms) ^ "\n"
  11.288 -  in
  11.289 -    typs_msg ^ show_consts_msg ^ terms_msg
  11.290 -  end;
  11.291 -
  11.292 -
  11.293 -(* ------------------------------------------------------------------------- *)
  11.294 -(* PARAMETER MANAGEMENT                                                      *)
  11.295 -(* ------------------------------------------------------------------------- *)
  11.296 -
  11.297 -fun add_interpreter name f = Data.map (fn {interpreters, printers, parameters} =>
  11.298 -  case AList.lookup (op =) interpreters name of
  11.299 -    NONE => {interpreters = (name, f) :: interpreters,
  11.300 -      printers = printers, parameters = parameters}
  11.301 -  | SOME _ => error ("Interpreter " ^ name ^ " already declared"));
  11.302 -
  11.303 -fun add_printer name f = Data.map (fn {interpreters, printers, parameters} =>
  11.304 -  case AList.lookup (op =) printers name of
  11.305 -    NONE => {interpreters = interpreters,
  11.306 -      printers = (name, f) :: printers, parameters = parameters}
  11.307 -  | SOME _ => error ("Printer " ^ name ^ " already declared"));
  11.308 -
  11.309 -(* ------------------------------------------------------------------------- *)
  11.310 -(* set_default_param: stores the '(name, value)' pair in Data's              *)
  11.311 -(*                    parameter table                                        *)
  11.312 -(* ------------------------------------------------------------------------- *)
  11.313 -
  11.314 -fun set_default_param (name, value) = Data.map
  11.315 -  (fn {interpreters, printers, parameters} =>
  11.316 -    {interpreters = interpreters, printers = printers,
  11.317 -      parameters = Symtab.update (name, value) parameters});
  11.318 -
  11.319 -(* ------------------------------------------------------------------------- *)
  11.320 -(* get_default_param: retrieves the value associated with 'name' from        *)
  11.321 -(*                    Data's parameter table                                 *)
  11.322 -(* ------------------------------------------------------------------------- *)
  11.323 -
  11.324 -val get_default_param = Symtab.lookup o #parameters o get_data;
  11.325 -
  11.326 -(* ------------------------------------------------------------------------- *)
  11.327 -(* get_default_params: returns a list of all '(name, value)' pairs that are  *)
  11.328 -(*                     stored in Data's parameter table                      *)
  11.329 -(* ------------------------------------------------------------------------- *)
  11.330 -
  11.331 -val get_default_params = Symtab.dest o #parameters o get_data;
  11.332 -
  11.333 -(* ------------------------------------------------------------------------- *)
  11.334 -(* actual_params: takes a (possibly empty) list 'params' of parameters that  *)
  11.335 -(*      override the default parameters currently specified, and             *)
  11.336 -(*      returns a record that can be passed to 'find_model'.                 *)
  11.337 -(* ------------------------------------------------------------------------- *)
  11.338 -
  11.339 -fun actual_params ctxt override =
  11.340 -  let
  11.341 -    (* (string * string) list * string -> bool *)
  11.342 -    fun read_bool (parms, name) =
  11.343 -      case AList.lookup (op =) parms name of
  11.344 -        SOME "true" => true
  11.345 -      | SOME "false" => false
  11.346 -      | SOME s => error ("parameter " ^ quote name ^
  11.347 -          " (value is " ^ quote s ^ ") must be \"true\" or \"false\"")
  11.348 -      | NONE   => error ("parameter " ^ quote name ^
  11.349 -          " must be assigned a value")
  11.350 -    (* (string * string) list * string -> int *)
  11.351 -    fun read_int (parms, name) =
  11.352 -      case AList.lookup (op =) parms name of
  11.353 -        SOME s =>
  11.354 -          (case Int.fromString s of
  11.355 -            SOME i => i
  11.356 -          | NONE   => error ("parameter " ^ quote name ^
  11.357 -            " (value is " ^ quote s ^ ") must be an integer value"))
  11.358 -      | NONE => error ("parameter " ^ quote name ^
  11.359 -          " must be assigned a value")
  11.360 -    (* (string * string) list * string -> string *)
  11.361 -    fun read_string (parms, name) =
  11.362 -      case AList.lookup (op =) parms name of
  11.363 -        SOME s => s
  11.364 -      | NONE => error ("parameter " ^ quote name ^
  11.365 -        " must be assigned a value")
  11.366 -    (* 'override' first, defaults last: *)
  11.367 -    (* (string * string) list *)
  11.368 -    val allparams = override @ get_default_params ctxt
  11.369 -    (* int *)
  11.370 -    val minsize = read_int (allparams, "minsize")
  11.371 -    val maxsize = read_int (allparams, "maxsize")
  11.372 -    val maxvars = read_int (allparams, "maxvars")
  11.373 -    val maxtime = read_int (allparams, "maxtime")
  11.374 -    (* string *)
  11.375 -    val satsolver = read_string (allparams, "satsolver")
  11.376 -    val no_assms = read_bool (allparams, "no_assms")
  11.377 -    val expect = the_default "" (AList.lookup (op =) allparams "expect")
  11.378 -    (* all remaining parameters of the form "string=int" are collected in *)
  11.379 -    (* 'sizes'                                                            *)
  11.380 -    (* TODO: it is currently not possible to specify a size for a type    *)
  11.381 -    (*       whose name is one of the other parameters (e.g. 'maxvars')   *)
  11.382 -    (* (string * int) list *)
  11.383 -    val sizes = map_filter
  11.384 -      (fn (name, value) => Option.map (pair name) (Int.fromString value))
  11.385 -      (filter (fn (name, _) => name<>"minsize" andalso name<>"maxsize"
  11.386 -        andalso name<>"maxvars" andalso name<>"maxtime"
  11.387 -        andalso name<>"satsolver" andalso name<>"no_assms") allparams)
  11.388 -  in
  11.389 -    {sizes=sizes, minsize=minsize, maxsize=maxsize, maxvars=maxvars,
  11.390 -      maxtime=maxtime, satsolver=satsolver, no_assms=no_assms, expect=expect}
  11.391 -  end;
  11.392 -
  11.393 -
  11.394 -(* ------------------------------------------------------------------------- *)
  11.395 -(* TRANSLATION HOL -> PROPOSITIONAL LOGIC, BOOLEAN ASSIGNMENT -> MODEL       *)
  11.396 -(* ------------------------------------------------------------------------- *)
  11.397 -
  11.398 -val typ_of_dtyp = ATP_Util.typ_of_dtyp
  11.399 -
  11.400 -(* ------------------------------------------------------------------------- *)
  11.401 -(* close_form: universal closure over schematic variables in 't'             *)
  11.402 -(* ------------------------------------------------------------------------- *)
  11.403 -
  11.404 -(* Term.term -> Term.term *)
  11.405 -
  11.406 -fun close_form t =
  11.407 -  let
  11.408 -    val vars = sort_wrt (fst o fst) (Term.add_vars t [])
  11.409 -  in
  11.410 -    fold (fn ((x, i), T) => fn t' =>
  11.411 -      Logic.all_const T $ Abs (x, T, abstract_over (Var ((x, i), T), t'))) vars t
  11.412 -  end;
  11.413 -
  11.414 -val monomorphic_term = ATP_Util.monomorphic_term
  11.415 -val specialize_type = ATP_Util.specialize_type
  11.416 -
  11.417 -(* ------------------------------------------------------------------------- *)
  11.418 -(* is_const_of_class: returns 'true' iff 'Const (s, T)' is a constant that   *)
  11.419 -(*                    denotes membership to an axiomatic type class          *)
  11.420 -(* ------------------------------------------------------------------------- *)
  11.421 -
  11.422 -fun is_const_of_class thy (s, _) =
  11.423 -  let
  11.424 -    val class_const_names = map Logic.const_of_class (Sign.all_classes thy)
  11.425 -  in
  11.426 -    (* I'm not quite sure if checking the name 's' is sufficient, *)
  11.427 -    (* or if we should also check the type 'T'.                   *)
  11.428 -    member (op =) class_const_names s
  11.429 -  end;
  11.430 -
  11.431 -(* ------------------------------------------------------------------------- *)
  11.432 -(* is_IDT_constructor: returns 'true' iff 'Const (s, T)' is the constructor  *)
  11.433 -(*                     of an inductive datatype in 'thy'                     *)
  11.434 -(* ------------------------------------------------------------------------- *)
  11.435 -
  11.436 -fun is_IDT_constructor thy (s, T) =
  11.437 -  (case body_type T of
  11.438 -    Type (s', _) =>
  11.439 -      (case Datatype.get_constrs thy s' of
  11.440 -        SOME constrs =>
  11.441 -          List.exists (fn (cname, cty) =>
  11.442 -            cname = s andalso Sign.typ_instance thy (T, cty)) constrs
  11.443 -      | NONE => false)
  11.444 -  | _  => false);
  11.445 -
  11.446 -(* ------------------------------------------------------------------------- *)
  11.447 -(* is_IDT_recursor: returns 'true' iff 'Const (s, T)' is the recursion       *)
  11.448 -(*                  operator of an inductive datatype in 'thy'               *)
  11.449 -(* ------------------------------------------------------------------------- *)
  11.450 -
  11.451 -fun is_IDT_recursor thy (s, _) =
  11.452 -  let
  11.453 -    val rec_names = Symtab.fold (append o #rec_names o snd)
  11.454 -      (Datatype.get_all thy) []
  11.455 -  in
  11.456 -    (* I'm not quite sure if checking the name 's' is sufficient, *)
  11.457 -    (* or if we should also check the type 'T'.                   *)
  11.458 -    member (op =) rec_names s
  11.459 -  end;
  11.460 -
  11.461 -(* ------------------------------------------------------------------------- *)
  11.462 -(* norm_rhs: maps  f ?t1 ... ?tn == rhs  to  %t1...tn. rhs                   *)
  11.463 -(* ------------------------------------------------------------------------- *)
  11.464 -
  11.465 -fun norm_rhs eqn =
  11.466 -  let
  11.467 -    fun lambda (v as Var ((x, _), T)) t = Abs (x, T, abstract_over (v, t))
  11.468 -      | lambda v t = raise TERM ("lambda", [v, t])
  11.469 -    val (lhs, rhs) = Logic.dest_equals eqn
  11.470 -    val (_, args) = Term.strip_comb lhs
  11.471 -  in
  11.472 -    fold lambda (rev args) rhs
  11.473 -  end
  11.474 -
  11.475 -(* ------------------------------------------------------------------------- *)
  11.476 -(* get_def: looks up the definition of a constant                            *)
  11.477 -(* ------------------------------------------------------------------------- *)
  11.478 -
  11.479 -fun get_def thy (s, T) =
  11.480 -  let
  11.481 -    (* (string * Term.term) list -> (string * Term.term) option *)
  11.482 -    fun get_def_ax [] = NONE
  11.483 -      | get_def_ax ((axname, ax) :: axioms) =
  11.484 -          (let
  11.485 -            val (lhs, _) = Logic.dest_equals ax  (* equations only *)
  11.486 -            val c        = Term.head_of lhs
  11.487 -            val (s', T') = Term.dest_Const c
  11.488 -          in
  11.489 -            if s=s' then
  11.490 -              let
  11.491 -                val typeSubs = Sign.typ_match thy (T', T) Vartab.empty
  11.492 -                val ax'      = monomorphic_term typeSubs ax
  11.493 -                val rhs      = norm_rhs ax'
  11.494 -              in
  11.495 -                SOME (axname, rhs)
  11.496 -              end
  11.497 -            else
  11.498 -              get_def_ax axioms
  11.499 -          end handle ERROR _         => get_def_ax axioms
  11.500 -                   | TERM _          => get_def_ax axioms
  11.501 -                   | Type.TYPE_MATCH => get_def_ax axioms)
  11.502 -  in
  11.503 -    get_def_ax (Theory.all_axioms_of thy)
  11.504 -  end;
  11.505 -
  11.506 -(* ------------------------------------------------------------------------- *)
  11.507 -(* get_typedef: looks up the definition of a type, as created by "typedef"   *)
  11.508 -(* ------------------------------------------------------------------------- *)
  11.509 -
  11.510 -fun get_typedef thy T =
  11.511 -  let
  11.512 -    (* (string * Term.term) list -> (string * Term.term) option *)
  11.513 -    fun get_typedef_ax [] = NONE
  11.514 -      | get_typedef_ax ((axname, ax) :: axioms) =
  11.515 -          (let
  11.516 -            (* Term.term -> Term.typ option *)
  11.517 -            fun type_of_type_definition (Const (s', T')) =
  11.518 -                  if s'= @{const_name type_definition} then
  11.519 -                    SOME T'
  11.520 -                  else
  11.521 -                    NONE
  11.522 -              | type_of_type_definition (Free _) = NONE
  11.523 -              | type_of_type_definition (Var _) = NONE
  11.524 -              | type_of_type_definition (Bound _) = NONE
  11.525 -              | type_of_type_definition (Abs (_, _, body)) =
  11.526 -                  type_of_type_definition body
  11.527 -              | type_of_type_definition (t1 $ t2) =
  11.528 -                  (case type_of_type_definition t1 of
  11.529 -                    SOME x => SOME x
  11.530 -                  | NONE => type_of_type_definition t2)
  11.531 -          in
  11.532 -            case type_of_type_definition ax of
  11.533 -              SOME T' =>
  11.534 -                let
  11.535 -                  val T'' = domain_type (domain_type T')
  11.536 -                  val typeSubs = Sign.typ_match thy (T'', T) Vartab.empty
  11.537 -                in
  11.538 -                  SOME (axname, monomorphic_term typeSubs ax)
  11.539 -                end
  11.540 -            | NONE => get_typedef_ax axioms
  11.541 -          end handle ERROR _         => get_typedef_ax axioms
  11.542 -                   | TERM _          => get_typedef_ax axioms
  11.543 -                   | Type.TYPE_MATCH => get_typedef_ax axioms)
  11.544 -  in
  11.545 -    get_typedef_ax (Theory.all_axioms_of thy)
  11.546 -  end;
  11.547 -
  11.548 -(* ------------------------------------------------------------------------- *)
  11.549 -(* get_classdef: looks up the defining axiom for an axiomatic type class, as *)
  11.550 -(*               created by the "axclass" command                            *)
  11.551 -(* ------------------------------------------------------------------------- *)
  11.552 -
  11.553 -fun get_classdef thy class =
  11.554 -  let
  11.555 -    val axname = class ^ "_class_def"
  11.556 -  in
  11.557 -    Option.map (pair axname)
  11.558 -      (AList.lookup (op =) (Theory.all_axioms_of thy) axname)
  11.559 -  end;
  11.560 -
  11.561 -(* ------------------------------------------------------------------------- *)
  11.562 -(* unfold_defs: unfolds all defined constants in a term 't', beta-eta        *)
  11.563 -(*              normalizes the result term; certain constants are not        *)
  11.564 -(*              unfolded (cf. 'collect_axioms' and the various interpreters  *)
  11.565 -(*              below): if the interpretation respects a definition anyway,  *)
  11.566 -(*              that definition does not need to be unfolded                 *)
  11.567 -(* ------------------------------------------------------------------------- *)
  11.568 -
  11.569 -(* Note: we could intertwine unfolding of constants and beta-(eta-)       *)
  11.570 -(*       normalization; this would save some unfolding for terms where    *)
  11.571 -(*       constants are eliminated by beta-reduction (e.g. 'K c1 c2').  On *)
  11.572 -(*       the other hand, this would cause additional work for terms where *)
  11.573 -(*       constants are duplicated by beta-reduction (e.g. 'S c1 c2 c3').  *)
  11.574 -
  11.575 -fun unfold_defs thy t =
  11.576 -  let
  11.577 -    (* Term.term -> Term.term *)
  11.578 -    fun unfold_loop t =
  11.579 -      case t of
  11.580 -      (* Pure *)
  11.581 -        Const (@{const_name all}, _) => t
  11.582 -      | Const (@{const_name "=="}, _) => t
  11.583 -      | Const (@{const_name "==>"}, _) => t
  11.584 -      | Const (@{const_name TYPE}, _) => t  (* axiomatic type classes *)
  11.585 -      (* HOL *)
  11.586 -      | Const (@{const_name Trueprop}, _) => t
  11.587 -      | Const (@{const_name Not}, _) => t
  11.588 -      | (* redundant, since 'True' is also an IDT constructor *)
  11.589 -        Const (@{const_name True}, _) => t
  11.590 -      | (* redundant, since 'False' is also an IDT constructor *)
  11.591 -        Const (@{const_name False}, _) => t
  11.592 -      | Const (@{const_name undefined}, _) => t
  11.593 -      | Const (@{const_name The}, _) => t
  11.594 -      | Const (@{const_name Hilbert_Choice.Eps}, _) => t
  11.595 -      | Const (@{const_name All}, _) => t
  11.596 -      | Const (@{const_name Ex}, _) => t
  11.597 -      | Const (@{const_name HOL.eq}, _) => t
  11.598 -      | Const (@{const_name HOL.conj}, _) => t
  11.599 -      | Const (@{const_name HOL.disj}, _) => t
  11.600 -      | Const (@{const_name HOL.implies}, _) => t
  11.601 -      (* sets *)
  11.602 -      | Const (@{const_name Collect}, _) => t
  11.603 -      | Const (@{const_name Set.member}, _) => t
  11.604 -      (* other optimizations *)
  11.605 -      | Const (@{const_name Finite_Set.card}, _) => t
  11.606 -      | Const (@{const_name Finite_Set.finite}, _) => t
  11.607 -      | Const (@{const_name Orderings.less}, Type ("fun", [@{typ nat},
  11.608 -          Type ("fun", [@{typ nat}, @{typ bool}])])) => t
  11.609 -      | Const (@{const_name Groups.plus}, Type ("fun", [@{typ nat},
  11.610 -          Type ("fun", [@{typ nat}, @{typ nat}])])) => t
  11.611 -      | Const (@{const_name Groups.minus}, Type ("fun", [@{typ nat},
  11.612 -          Type ("fun", [@{typ nat}, @{typ nat}])])) => t
  11.613 -      | Const (@{const_name Groups.times}, Type ("fun", [@{typ nat},
  11.614 -          Type ("fun", [@{typ nat}, @{typ nat}])])) => t
  11.615 -      | Const (@{const_name List.append}, _) => t
  11.616 -(* UNSOUND
  11.617 -      | Const (@{const_name lfp}, _) => t
  11.618 -      | Const (@{const_name gfp}, _) => t
  11.619 -*)
  11.620 -      | Const (@{const_name fst}, _) => t
  11.621 -      | Const (@{const_name snd}, _) => t
  11.622 -      (* simply-typed lambda calculus *)
  11.623 -      | Const (s, T) =>
  11.624 -          (if is_IDT_constructor thy (s, T)
  11.625 -            orelse is_IDT_recursor thy (s, T) then
  11.626 -            t  (* do not unfold IDT constructors/recursors *)
  11.627 -          (* unfold the constant if there is a defining equation *)
  11.628 -          else
  11.629 -            case get_def thy (s, T) of
  11.630 -              SOME ((*axname*) _, rhs) =>
  11.631 -              (* Note: if the term to be unfolded (i.e. 'Const (s, T)')  *)
  11.632 -              (* occurs on the right-hand side of the equation, i.e. in  *)
  11.633 -              (* 'rhs', we must not use this equation to unfold, because *)
  11.634 -              (* that would loop.  Here would be the right place to      *)
  11.635 -              (* check this.  However, getting this really right seems   *)
  11.636 -              (* difficult because the user may state arbitrary axioms,  *)
  11.637 -              (* which could interact with overloading to create loops.  *)
  11.638 -              ((*tracing (" unfolding: " ^ axname);*)
  11.639 -               unfold_loop rhs)
  11.640 -            | NONE => t)
  11.641 -      | Free _ => t
  11.642 -      | Var _ => t
  11.643 -      | Bound _ => t
  11.644 -      | Abs (s, T, body) => Abs (s, T, unfold_loop body)
  11.645 -      | t1 $ t2 => (unfold_loop t1) $ (unfold_loop t2)
  11.646 -    val result = Envir.beta_eta_contract (unfold_loop t)
  11.647 -  in
  11.648 -    result
  11.649 -  end;
  11.650 -
  11.651 -(* ------------------------------------------------------------------------- *)
  11.652 -(* collect_axioms: collects (monomorphic, universally quantified, unfolded   *)
  11.653 -(*                 versions of) all HOL axioms that are relevant w.r.t 't'   *)
  11.654 -(* ------------------------------------------------------------------------- *)
  11.655 -
  11.656 -(* Note: to make the collection of axioms more easily extensible, this    *)
  11.657 -(*       function could be based on user-supplied "axiom collectors",     *)
  11.658 -(*       similar to 'interpret'/interpreters or 'print'/printers          *)
  11.659 -
  11.660 -(* Note: currently we use "inverse" functions to the definitional         *)
  11.661 -(*       mechanisms provided by Isabelle/HOL, e.g. for "axclass",         *)
  11.662 -(*       "typedef", "definition".  A more general approach could consider *)
  11.663 -(*       *every* axiom of the theory and collect it if it has a constant/ *)
  11.664 -(*       type/typeclass in common with the term 't'.                      *)
  11.665 -
  11.666 -(* Which axioms are "relevant" for a particular term/type goes hand in    *)
  11.667 -(* hand with the interpretation of that term/type by its interpreter (see *)
  11.668 -(* way below): if the interpretation respects an axiom anyway, the axiom  *)
  11.669 -(* does not need to be added as a constraint here.                        *)
  11.670 -
  11.671 -(* To avoid collecting the same axiom multiple times, we use an           *)
  11.672 -(* accumulator 'axs' which contains all axioms collected so far.          *)
  11.673 -
  11.674 -fun collect_axioms ctxt t =
  11.675 -  let
  11.676 -    val thy = Proof_Context.theory_of ctxt
  11.677 -    val _ = tracing "Adding axioms..."
  11.678 -    val axioms = Theory.all_axioms_of thy
  11.679 -    fun collect_this_axiom (axname, ax) axs =
  11.680 -      let
  11.681 -        val ax' = unfold_defs thy ax
  11.682 -      in
  11.683 -        if member (op aconv) axs ax' then axs
  11.684 -        else (tracing axname; collect_term_axioms ax' (ax' :: axs))
  11.685 -      end
  11.686 -    and collect_sort_axioms T axs =
  11.687 -      let
  11.688 -        val sort =
  11.689 -          (case T of
  11.690 -            TFree (_, sort) => sort
  11.691 -          | TVar (_, sort)  => sort
  11.692 -          | _ => raise REFUTE ("collect_axioms",
  11.693 -              "type " ^ Syntax.string_of_typ ctxt T ^ " is not a variable"))
  11.694 -        (* obtain axioms for all superclasses *)
  11.695 -        val superclasses = sort @ maps (Sign.super_classes thy) sort
  11.696 -        (* merely an optimization, because 'collect_this_axiom' disallows *)
  11.697 -        (* duplicate axioms anyway:                                       *)
  11.698 -        val superclasses = distinct (op =) superclasses
  11.699 -        val class_axioms = maps (fn class => map (fn ax =>
  11.700 -          ("<" ^ class ^ ">", Thm.prop_of ax))
  11.701 -          (#axioms (AxClass.get_info thy class) handle ERROR _ => []))
  11.702 -          superclasses
  11.703 -        (* replace the (at most one) schematic type variable in each axiom *)
  11.704 -        (* by the actual type 'T'                                          *)
  11.705 -        val monomorphic_class_axioms = map (fn (axname, ax) =>
  11.706 -          (case Term.add_tvars ax [] of
  11.707 -            [] => (axname, ax)
  11.708 -          | [(idx, S)] => (axname, monomorphic_term (Vartab.make [(idx, (S, T))]) ax)
  11.709 -          | _ =>
  11.710 -            raise REFUTE ("collect_axioms", "class axiom " ^ axname ^ " (" ^
  11.711 -              Syntax.string_of_term ctxt ax ^
  11.712 -              ") contains more than one type variable")))
  11.713 -          class_axioms
  11.714 -      in
  11.715 -        fold collect_this_axiom monomorphic_class_axioms axs
  11.716 -      end
  11.717 -    and collect_type_axioms T axs =
  11.718 -      case T of
  11.719 -      (* simple types *)
  11.720 -        Type ("prop", []) => axs
  11.721 -      | Type ("fun", [T1, T2]) => collect_type_axioms T2 (collect_type_axioms T1 axs)
  11.722 -      | Type (@{type_name set}, [T1]) => collect_type_axioms T1 axs
  11.723 -      (* axiomatic type classes *)
  11.724 -      | Type ("itself", [T1]) => collect_type_axioms T1 axs
  11.725 -      | Type (s, Ts) =>
  11.726 -        (case Datatype.get_info thy s of
  11.727 -          SOME _ =>  (* inductive datatype *)
  11.728 -            (* only collect relevant type axioms for the argument types *)
  11.729 -            fold collect_type_axioms Ts axs
  11.730 -        | NONE =>
  11.731 -          (case get_typedef thy T of
  11.732 -            SOME (axname, ax) =>
  11.733 -              collect_this_axiom (axname, ax) axs
  11.734 -          | NONE =>
  11.735 -            (* unspecified type, perhaps introduced with "typedecl" *)
  11.736 -            (* at least collect relevant type axioms for the argument types *)
  11.737 -            fold collect_type_axioms Ts axs))
  11.738 -      (* axiomatic type classes *)
  11.739 -      | TFree _ => collect_sort_axioms T axs
  11.740 -      (* axiomatic type classes *)
  11.741 -      | TVar _ => collect_sort_axioms T axs
  11.742 -    and collect_term_axioms t axs =
  11.743 -      case t of
  11.744 -      (* Pure *)
  11.745 -        Const (@{const_name all}, _) => axs
  11.746 -      | Const (@{const_name "=="}, _) => axs
  11.747 -      | Const (@{const_name "==>"}, _) => axs
  11.748 -      (* axiomatic type classes *)
  11.749 -      | Const (@{const_name TYPE}, T) => collect_type_axioms T axs
  11.750 -      (* HOL *)
  11.751 -      | Const (@{const_name Trueprop}, _) => axs
  11.752 -      | Const (@{const_name Not}, _) => axs
  11.753 -      (* redundant, since 'True' is also an IDT constructor *)
  11.754 -      | Const (@{const_name True}, _) => axs
  11.755 -      (* redundant, since 'False' is also an IDT constructor *)
  11.756 -      | Const (@{const_name False}, _) => axs
  11.757 -      | Const (@{const_name undefined}, T) => collect_type_axioms T axs
  11.758 -      | Const (@{const_name The}, T) =>
  11.759 -          let
  11.760 -            val ax = specialize_type thy (@{const_name The}, T)
  11.761 -              (the (AList.lookup (op =) axioms "HOL.the_eq_trivial"))
  11.762 -          in
  11.763 -            collect_this_axiom ("HOL.the_eq_trivial", ax) axs
  11.764 -          end
  11.765 -      | Const (@{const_name Hilbert_Choice.Eps}, T) =>
  11.766 -          let
  11.767 -            val ax = specialize_type thy (@{const_name Hilbert_Choice.Eps}, T)
  11.768 -              (the (AList.lookup (op =) axioms "Hilbert_Choice.someI"))
  11.769 -          in
  11.770 -            collect_this_axiom ("Hilbert_Choice.someI", ax) axs
  11.771 -          end
  11.772 -      | Const (@{const_name All}, T) => collect_type_axioms T axs
  11.773 -      | Const (@{const_name Ex}, T) => collect_type_axioms T axs
  11.774 -      | Const (@{const_name HOL.eq}, T) => collect_type_axioms T axs
  11.775 -      | Const (@{const_name HOL.conj}, _) => axs
  11.776 -      | Const (@{const_name HOL.disj}, _) => axs
  11.777 -      | Const (@{const_name HOL.implies}, _) => axs
  11.778 -      (* sets *)
  11.779 -      | Const (@{const_name Collect}, T) => collect_type_axioms T axs
  11.780 -      | Const (@{const_name Set.member}, T) => collect_type_axioms T axs
  11.781 -      (* other optimizations *)
  11.782 -      | Const (@{const_name Finite_Set.card}, T) => collect_type_axioms T axs
  11.783 -      | Const (@{const_name Finite_Set.finite}, T) =>
  11.784 -        collect_type_axioms T axs
  11.785 -      | Const (@{const_name Orderings.less}, T as Type ("fun", [@{typ nat},
  11.786 -        Type ("fun", [@{typ nat}, @{typ bool}])])) =>
  11.787 -          collect_type_axioms T axs
  11.788 -      | Const (@{const_name Groups.plus}, T as Type ("fun", [@{typ nat},
  11.789 -        Type ("fun", [@{typ nat}, @{typ nat}])])) =>
  11.790 -          collect_type_axioms T axs
  11.791 -      | Const (@{const_name Groups.minus}, T as Type ("fun", [@{typ nat},
  11.792 -        Type ("fun", [@{typ nat}, @{typ nat}])])) =>
  11.793 -          collect_type_axioms T axs
  11.794 -      | Const (@{const_name Groups.times}, T as Type ("fun", [@{typ nat},
  11.795 -        Type ("fun", [@{typ nat}, @{typ nat}])])) =>
  11.796 -          collect_type_axioms T axs
  11.797 -      | Const (@{const_name List.append}, T) => collect_type_axioms T axs
  11.798 -(* UNSOUND
  11.799 -      | Const (@{const_name lfp}, T) => collect_type_axioms T axs
  11.800 -      | Const (@{const_name gfp}, T) => collect_type_axioms T axs
  11.801 -*)
  11.802 -      | Const (@{const_name fst}, T) => collect_type_axioms T axs
  11.803 -      | Const (@{const_name snd}, T) => collect_type_axioms T axs
  11.804 -      (* simply-typed lambda calculus *)
  11.805 -      | Const (s, T) =>
  11.806 -          if is_const_of_class thy (s, T) then
  11.807 -            (* axiomatic type classes: add "OFCLASS(?'a::c, c_class)" *)
  11.808 -            (* and the class definition                               *)
  11.809 -            let
  11.810 -              val class = Logic.class_of_const s
  11.811 -              val of_class = Logic.mk_of_class (TVar (("'a", 0), [class]), class)
  11.812 -              val ax_in = SOME (specialize_type thy (s, T) of_class)
  11.813 -                (* type match may fail due to sort constraints *)
  11.814 -                handle Type.TYPE_MATCH => NONE
  11.815 -              val ax_1 = Option.map (fn ax => (Syntax.string_of_term ctxt ax, ax)) ax_in
  11.816 -              val ax_2 = Option.map (apsnd (specialize_type thy (s, T))) (get_classdef thy class)
  11.817 -            in
  11.818 -              collect_type_axioms T (fold collect_this_axiom (map_filter I [ax_1, ax_2]) axs)
  11.819 -            end
  11.820 -          else if is_IDT_constructor thy (s, T)
  11.821 -            orelse is_IDT_recursor thy (s, T)
  11.822 -          then
  11.823 -            (* only collect relevant type axioms *)
  11.824 -            collect_type_axioms T axs
  11.825 -          else
  11.826 -            (* other constants should have been unfolded, with some *)
  11.827 -            (* exceptions: e.g. Abs_xxx/Rep_xxx functions for       *)
  11.828 -            (* typedefs, or type-class related constants            *)
  11.829 -            (* only collect relevant type axioms *)
  11.830 -            collect_type_axioms T axs
  11.831 -      | Free (_, T) => collect_type_axioms T axs
  11.832 -      | Var (_, T) => collect_type_axioms T axs
  11.833 -      | Bound _ => axs
  11.834 -      | Abs (_, T, body) => collect_term_axioms body (collect_type_axioms T axs)
  11.835 -      | t1 $ t2 => collect_term_axioms t2 (collect_term_axioms t1 axs)
  11.836 -    val result = map close_form (collect_term_axioms t [])
  11.837 -    val _ = tracing " ...done."
  11.838 -  in
  11.839 -    result
  11.840 -  end;
  11.841 -
  11.842 -(* ------------------------------------------------------------------------- *)
  11.843 -(* ground_types: collects all ground types in a term (including argument     *)
  11.844 -(*               types of other types), suppressing duplicates.  Does not    *)
  11.845 -(*               return function types, set types, non-recursive IDTs, or    *)
  11.846 -(*               'propT'.  For IDTs, also the argument types of constructors *)
  11.847 -(*               and all mutually recursive IDTs are considered.             *)
  11.848 -(* ------------------------------------------------------------------------- *)
  11.849 -
  11.850 -fun ground_types ctxt t =
  11.851 -  let
  11.852 -    val thy = Proof_Context.theory_of ctxt
  11.853 -    fun collect_types T acc =
  11.854 -      (case T of
  11.855 -        Type ("fun", [T1, T2]) => collect_types T1 (collect_types T2 acc)
  11.856 -      | Type ("prop", []) => acc
  11.857 -      | Type (@{type_name set}, [T1]) => collect_types T1 acc
  11.858 -      | Type (s, Ts) =>
  11.859 -          (case Datatype.get_info thy s of
  11.860 -            SOME info =>  (* inductive datatype *)
  11.861 -              let
  11.862 -                val index = #index info
  11.863 -                val descr = #descr info
  11.864 -                val (_, typs, _) = the (AList.lookup (op =) descr index)
  11.865 -                val typ_assoc = typs ~~ Ts
  11.866 -                (* sanity check: every element in 'dtyps' must be a *)
  11.867 -                (* 'DtTFree'                                        *)
  11.868 -                val _ = if Library.exists (fn d =>
  11.869 -                  case d of Datatype.DtTFree _ => false | _ => true) typs then
  11.870 -                  raise REFUTE ("ground_types", "datatype argument (for type "
  11.871 -                    ^ Syntax.string_of_typ ctxt T ^ ") is not a variable")
  11.872 -                else ()
  11.873 -                (* required for mutually recursive datatypes; those need to   *)
  11.874 -                (* be added even if they are an instance of an otherwise non- *)
  11.875 -                (* recursive datatype                                         *)
  11.876 -                fun collect_dtyp d acc =
  11.877 -                  let
  11.878 -                    val dT = typ_of_dtyp descr typ_assoc d
  11.879 -                  in
  11.880 -                    case d of
  11.881 -                      Datatype.DtTFree _ =>
  11.882 -                      collect_types dT acc
  11.883 -                    | Datatype.DtType (_, ds) =>
  11.884 -                      collect_types dT (fold_rev collect_dtyp ds acc)
  11.885 -                    | Datatype.DtRec i =>
  11.886 -                      if member (op =) acc dT then
  11.887 -                        acc  (* prevent infinite recursion *)
  11.888 -                      else
  11.889 -                        let
  11.890 -                          val (_, dtyps, dconstrs) = the (AList.lookup (op =) descr i)
  11.891 -                          (* if the current type is a recursive IDT (i.e. a depth *)
  11.892 -                          (* is required), add it to 'acc'                        *)
  11.893 -                          val acc_dT = if Library.exists (fn (_, ds) =>
  11.894 -                            Library.exists Datatype_Aux.is_rec_type ds) dconstrs then
  11.895 -                              insert (op =) dT acc
  11.896 -                            else acc
  11.897 -                          (* collect argument types *)
  11.898 -                          val acc_dtyps = fold_rev collect_dtyp dtyps acc_dT
  11.899 -                          (* collect constructor types *)
  11.900 -                          val acc_dconstrs = fold_rev collect_dtyp (maps snd dconstrs) acc_dtyps
  11.901 -                        in
  11.902 -                          acc_dconstrs
  11.903 -                        end
  11.904 -                  end
  11.905 -              in
  11.906 -                (* argument types 'Ts' could be added here, but they are also *)
  11.907 -                (* added by 'collect_dtyp' automatically                      *)
  11.908 -                collect_dtyp (Datatype.DtRec index) acc
  11.909 -              end
  11.910 -          | NONE =>
  11.911 -            (* not an inductive datatype, e.g. defined via "typedef" or *)
  11.912 -            (* "typedecl"                                               *)
  11.913 -            insert (op =) T (fold collect_types Ts acc))
  11.914 -      | TFree _ => insert (op =) T acc
  11.915 -      | TVar _ => insert (op =) T acc)
  11.916 -  in
  11.917 -    fold_types collect_types t []
  11.918 -  end;
  11.919 -
  11.920 -(* ------------------------------------------------------------------------- *)
  11.921 -(* string_of_typ: (rather naive) conversion from types to strings, used to   *)
  11.922 -(*                look up the size of a type in 'sizes'.  Parameterized      *)
  11.923 -(*                types with different parameters (e.g. "'a list" vs. "bool  *)
  11.924 -(*                list") are identified.                                     *)
  11.925 -(* ------------------------------------------------------------------------- *)
  11.926 -
  11.927 -(* Term.typ -> string *)
  11.928 -
  11.929 -fun string_of_typ (Type (s, _))     = s
  11.930 -  | string_of_typ (TFree (s, _))    = s
  11.931 -  | string_of_typ (TVar ((s,_), _)) = s;
  11.932 -
  11.933 -(* ------------------------------------------------------------------------- *)
  11.934 -(* first_universe: returns the "first" (i.e. smallest) universe by assigning *)
  11.935 -(*                 'minsize' to every type for which no size is specified in *)
  11.936 -(*                 'sizes'                                                   *)
  11.937 -(* ------------------------------------------------------------------------- *)
  11.938 -
  11.939 -(* Term.typ list -> (string * int) list -> int -> (Term.typ * int) list *)
  11.940 -
  11.941 -fun first_universe xs sizes minsize =
  11.942 -  let
  11.943 -    fun size_of_typ T =
  11.944 -      case AList.lookup (op =) sizes (string_of_typ T) of
  11.945 -        SOME n => n
  11.946 -      | NONE => minsize
  11.947 -  in
  11.948 -    map (fn T => (T, size_of_typ T)) xs
  11.949 -  end;
  11.950 -
  11.951 -(* ------------------------------------------------------------------------- *)
  11.952 -(* next_universe: enumerates all universes (i.e. assignments of sizes to     *)
  11.953 -(*                types), where the minimal size of a type is given by       *)
  11.954 -(*                'minsize', the maximal size is given by 'maxsize', and a   *)
  11.955 -(*                type may have a fixed size given in 'sizes'                *)
  11.956 -(* ------------------------------------------------------------------------- *)
  11.957 -
  11.958 -(* (Term.typ * int) list -> (string * int) list -> int -> int ->
  11.959 -  (Term.typ * int) list option *)
  11.960 -
  11.961 -fun next_universe xs sizes minsize maxsize =
  11.962 -  let
  11.963 -    (* creates the "first" list of length 'len', where the sum of all list *)
  11.964 -    (* elements is 'sum', and the length of the list is 'len'              *)
  11.965 -    (* int -> int -> int -> int list option *)
  11.966 -    fun make_first _ 0 sum =
  11.967 -          if sum = 0 then
  11.968 -            SOME []
  11.969 -          else
  11.970 -            NONE
  11.971 -      | make_first max len sum =
  11.972 -          if sum <= max orelse max < 0 then
  11.973 -            Option.map (fn xs' => sum :: xs') (make_first max (len-1) 0)
  11.974 -          else
  11.975 -            Option.map (fn xs' => max :: xs') (make_first max (len-1) (sum-max))
  11.976 -    (* enumerates all int lists with a fixed length, where 0<=x<='max' for *)
  11.977 -    (* all list elements x (unless 'max'<0)                                *)
  11.978 -    (* int -> int -> int -> int list -> int list option *)
  11.979 -    fun next _ _ _ [] =
  11.980 -          NONE
  11.981 -      | next max len sum [x] =
  11.982 -          (* we've reached the last list element, so there's no shift possible *)
  11.983 -          make_first max (len+1) (sum+x+1)  (* increment 'sum' by 1 *)
  11.984 -      | next max len sum (x1::x2::xs) =
  11.985 -          if x1>0 andalso (x2<max orelse max<0) then
  11.986 -            (* we can shift *)
  11.987 -            SOME (the (make_first max (len+1) (sum+x1-1)) @ (x2+1) :: xs)
  11.988 -          else
  11.989 -            (* continue search *)
  11.990 -            next max (len+1) (sum+x1) (x2::xs)
  11.991 -    (* only consider those types for which the size is not fixed *)
  11.992 -    val mutables = filter_out (AList.defined (op =) sizes o string_of_typ o fst) xs
  11.993 -    (* subtract 'minsize' from every size (will be added again at the end) *)
  11.994 -    val diffs = map (fn (_, n) => n-minsize) mutables
  11.995 -  in
  11.996 -    case next (maxsize-minsize) 0 0 diffs of
  11.997 -      SOME diffs' =>
  11.998 -        (* merge with those types for which the size is fixed *)
  11.999 -        SOME (fst (fold_map (fn (T, _) => fn ds =>
 11.1000 -          case AList.lookup (op =) sizes (string_of_typ T) of
 11.1001 -          (* return the fixed size *)
 11.1002 -            SOME n => ((T, n), ds)
 11.1003 -          (* consume the head of 'ds', add 'minsize' *)
 11.1004 -          | NONE   => ((T, minsize + hd ds), tl ds))
 11.1005 -          xs diffs'))
 11.1006 -    | NONE => NONE
 11.1007 -  end;
 11.1008 -
 11.1009 -(* ------------------------------------------------------------------------- *)
 11.1010 -(* toTrue: converts the interpretation of a Boolean value to a propositional *)
 11.1011 -(*         formula that is true iff the interpretation denotes "true"        *)
 11.1012 -(* ------------------------------------------------------------------------- *)
 11.1013 -
 11.1014 -(* interpretation -> prop_formula *)
 11.1015 -
 11.1016 -fun toTrue (Leaf [fm, _]) = fm
 11.1017 -  | toTrue _ = raise REFUTE ("toTrue", "interpretation does not denote a Boolean value");
 11.1018 -
 11.1019 -(* ------------------------------------------------------------------------- *)
 11.1020 -(* toFalse: converts the interpretation of a Boolean value to a              *)
 11.1021 -(*          propositional formula that is true iff the interpretation        *)
 11.1022 -(*          denotes "false"                                                  *)
 11.1023 -(* ------------------------------------------------------------------------- *)
 11.1024 -
 11.1025 -(* interpretation -> prop_formula *)
 11.1026 -
 11.1027 -fun toFalse (Leaf [_, fm]) = fm
 11.1028 -  | toFalse _ = raise REFUTE ("toFalse", "interpretation does not denote a Boolean value");
 11.1029 -
 11.1030 -(* ------------------------------------------------------------------------- *)
 11.1031 -(* find_model: repeatedly calls 'interpret' with appropriate parameters,     *)
 11.1032 -(*             applies a SAT solver, and (in case a model is found) displays *)
 11.1033 -(*             the model to the user by calling 'print_model'                *)
 11.1034 -(* {...}     : parameters that control the translation/model generation      *)
 11.1035 -(* assm_ts   : assumptions to be considered unless "no_assms" is specified   *)
 11.1036 -(* t         : term to be translated into a propositional formula            *)
 11.1037 -(* negate    : if true, find a model that makes 't' false (rather than true) *)
 11.1038 -(* ------------------------------------------------------------------------- *)
 11.1039 -
 11.1040 -fun find_model ctxt
 11.1041 -    {sizes, minsize, maxsize, maxvars, maxtime, satsolver, no_assms, expect}
 11.1042 -    assm_ts t negate =
 11.1043 -  let
 11.1044 -    val thy = Proof_Context.theory_of ctxt
 11.1045 -    (* string -> string *)
 11.1046 -    fun check_expect outcome_code =
 11.1047 -      if expect = "" orelse outcome_code = expect then outcome_code
 11.1048 -      else error ("Unexpected outcome: " ^ quote outcome_code ^ ".")
 11.1049 -    (* unit -> string *)
 11.1050 -    fun wrapper () =
 11.1051 -      let
 11.1052 -        val timer = Timer.startRealTimer ()
 11.1053 -        val t =
 11.1054 -          if no_assms then t
 11.1055 -          else if negate then Logic.list_implies (assm_ts, t)
 11.1056 -          else Logic.mk_conjunction_list (t :: assm_ts)
 11.1057 -        val u = unfold_defs thy t
 11.1058 -        val _ = tracing ("Unfolded term: " ^ Syntax.string_of_term ctxt u)
 11.1059 -        val axioms = collect_axioms ctxt u
 11.1060 -        (* Term.typ list *)
 11.1061 -        val types = fold (union (op =) o ground_types ctxt) (u :: axioms) []
 11.1062 -        val _ = tracing ("Ground types: "
 11.1063 -          ^ (if null types then "none."
 11.1064 -             else commas (map (Syntax.string_of_typ ctxt) types)))
 11.1065 -        (* we can only consider fragments of recursive IDTs, so we issue a  *)
 11.1066 -        (* warning if the formula contains a recursive IDT                  *)
 11.1067 -        (* TODO: no warning needed for /positive/ occurrences of IDTs       *)
 11.1068 -        val maybe_spurious = Library.exists (fn
 11.1069 -            Type (s, _) =>
 11.1070 -              (case Datatype.get_info thy s of
 11.1071 -                SOME info =>  (* inductive datatype *)
 11.1072 -                  let
 11.1073 -                    val index           = #index info
 11.1074 -                    val descr           = #descr info
 11.1075 -                    val (_, _, constrs) = the (AList.lookup (op =) descr index)
 11.1076 -                  in
 11.1077 -                    (* recursive datatype? *)
 11.1078 -                    Library.exists (fn (_, ds) =>
 11.1079 -                      Library.exists Datatype_Aux.is_rec_type ds) constrs
 11.1080 -                  end
 11.1081 -              | NONE => false)
 11.1082 -          | _ => false) types
 11.1083 -        val _ =
 11.1084 -          if maybe_spurious then
 11.1085 -            warning ("Term contains a recursive datatype; "
 11.1086 -              ^ "countermodel(s) may be spurious!")
 11.1087 -          else
 11.1088 -            ()
 11.1089 -        (* (Term.typ * int) list -> string *)
 11.1090 -        fun find_model_loop universe =
 11.1091 -          let
 11.1092 -            val msecs_spent = Time.toMilliseconds (Timer.checkRealTimer timer)
 11.1093 -            val _ = maxtime = 0 orelse msecs_spent < 1000 * maxtime
 11.1094 -                    orelse raise TimeLimit.TimeOut
 11.1095 -            val init_model = (universe, [])
 11.1096 -            val init_args  = {maxvars = maxvars, def_eq = false, next_idx = 1,
 11.1097 -              bounds = [], wellformed = True}
 11.1098 -            val _ = tracing ("Translating term (sizes: "
 11.1099 -              ^ commas (map (fn (_, n) => string_of_int n) universe) ^ ") ...")
 11.1100 -            (* translate 'u' and all axioms *)
 11.1101 -            val (intrs, (model, args)) = fold_map (fn t' => fn (m, a) =>
 11.1102 -              let
 11.1103 -                val (i, m', a') = interpret ctxt m a t'
 11.1104 -              in
 11.1105 -                (* set 'def_eq' to 'true' *)
 11.1106 -                (i, (m', {maxvars = #maxvars a', def_eq = true,
 11.1107 -                  next_idx = #next_idx a', bounds = #bounds a',
 11.1108 -                  wellformed = #wellformed a'}))
 11.1109 -              end) (u :: axioms) (init_model, init_args)
 11.1110 -            (* make 'u' either true or false, and make all axioms true, and *)
 11.1111 -            (* add the well-formedness side condition                       *)
 11.1112 -            val fm_u = (if negate then toFalse else toTrue) (hd intrs)
 11.1113 -            val fm_ax = Prop_Logic.all (map toTrue (tl intrs))
 11.1114 -            val fm = Prop_Logic.all [#wellformed args, fm_ax, fm_u]
 11.1115 -            val _ =
 11.1116 -              (if satsolver = "dpll" orelse satsolver = "enumerate" then
 11.1117 -                warning ("Using SAT solver " ^ quote satsolver ^
 11.1118 -                         "; for better performance, consider installing an \
 11.1119 -                         \external solver.")
 11.1120 -               else ());
 11.1121 -            val solver =
 11.1122 -              SatSolver.invoke_solver satsolver
 11.1123 -              handle Option.Option =>
 11.1124 -                     error ("Unknown SAT solver: " ^ quote satsolver ^
 11.1125 -                            ". Available solvers: " ^
 11.1126 -                            commas (map (quote o fst) (!SatSolver.solvers)) ^ ".")
 11.1127 -          in
 11.1128 -            Output.urgent_message "Invoking SAT solver...";
 11.1129 -            (case solver fm of
 11.1130 -              SatSolver.SATISFIABLE assignment =>
 11.1131 -                (Output.urgent_message ("Model found:\n" ^ print_model ctxt model
 11.1132 -                  (fn i => case assignment i of SOME b => b | NONE => true));
 11.1133 -                 if maybe_spurious then "potential" else "genuine")
 11.1134 -            | SatSolver.UNSATISFIABLE _ =>
 11.1135 -                (Output.urgent_message "No model exists.";
 11.1136 -                case next_universe universe sizes minsize maxsize of
 11.1137 -                  SOME universe' => find_model_loop universe'
 11.1138 -                | NONE => (Output.urgent_message
 11.1139 -                    "Search terminated, no larger universe within the given limits.";
 11.1140 -                    "none"))
 11.1141 -            | SatSolver.UNKNOWN =>
 11.1142 -                (Output.urgent_message "No model found.";
 11.1143 -                case next_universe universe sizes minsize maxsize of
 11.1144 -                  SOME universe' => find_model_loop universe'
 11.1145 -                | NONE => (Output.urgent_message
 11.1146 -                  "Search terminated, no larger universe within the given limits.";
 11.1147 -                  "unknown"))) handle SatSolver.NOT_CONFIGURED =>
 11.1148 -              (error ("SAT solver " ^ quote satsolver ^ " is not configured.");
 11.1149 -               "unknown")
 11.1150 -          end
 11.1151 -          handle MAXVARS_EXCEEDED =>
 11.1152 -            (Output.urgent_message ("Search terminated, number of Boolean variables ("
 11.1153 -              ^ string_of_int maxvars ^ " allowed) exceeded.");
 11.1154 -              "unknown")
 11.1155 -
 11.1156 -        val outcome_code = find_model_loop (first_universe types sizes minsize)
 11.1157 -      in
 11.1158 -        check_expect outcome_code
 11.1159 -      end
 11.1160 -  in
 11.1161 -    (* some parameter sanity checks *)
 11.1162 -    minsize>=1 orelse
 11.1163 -      error ("\"minsize\" is " ^ string_of_int minsize ^ ", must be at least 1");
 11.1164 -    maxsize>=1 orelse
 11.1165 -      error ("\"maxsize\" is " ^ string_of_int maxsize ^ ", must be at least 1");
 11.1166 -    maxsize>=minsize orelse
 11.1167 -      error ("\"maxsize\" (=" ^ string_of_int maxsize ^
 11.1168 -      ") is less than \"minsize\" (=" ^ string_of_int minsize ^ ").");
 11.1169 -    maxvars>=0 orelse
 11.1170 -      error ("\"maxvars\" is " ^ string_of_int maxvars ^ ", must be at least 0");
 11.1171 -    maxtime>=0 orelse
 11.1172 -      error ("\"maxtime\" is " ^ string_of_int maxtime ^ ", must be at least 0");
 11.1173 -    (* enter loop with or without time limit *)
 11.1174 -    Output.urgent_message ("Trying to find a model that "
 11.1175 -      ^ (if negate then "refutes" else "satisfies") ^ ": "
 11.1176 -      ^ Syntax.string_of_term ctxt t);
 11.1177 -    if maxtime > 0 then (
 11.1178 -      TimeLimit.timeLimit (Time.fromSeconds maxtime)
 11.1179 -        wrapper ()
 11.1180 -      handle TimeLimit.TimeOut =>
 11.1181 -        (Output.urgent_message ("Search terminated, time limit (" ^
 11.1182 -            string_of_int maxtime
 11.1183 -            ^ (if maxtime=1 then " second" else " seconds") ^ ") exceeded.");
 11.1184 -         check_expect "unknown")
 11.1185 -    ) else wrapper ()
 11.1186 -  end;
 11.1187 -
 11.1188 -
 11.1189 -(* ------------------------------------------------------------------------- *)
 11.1190 -(* INTERFACE, PART 2: FINDING A MODEL                                        *)
 11.1191 -(* ------------------------------------------------------------------------- *)
 11.1192 -
 11.1193 -(* ------------------------------------------------------------------------- *)
 11.1194 -(* satisfy_term: calls 'find_model' to find a model that satisfies 't'       *)
 11.1195 -(* params      : list of '(name, value)' pairs used to override default      *)
 11.1196 -(*               parameters                                                  *)
 11.1197 -(* ------------------------------------------------------------------------- *)
 11.1198 -
 11.1199 -fun satisfy_term ctxt params assm_ts t =
 11.1200 -  find_model ctxt (actual_params ctxt params) assm_ts t false;
 11.1201 -
 11.1202 -(* ------------------------------------------------------------------------- *)
 11.1203 -(* refute_term: calls 'find_model' to find a model that refutes 't'          *)
 11.1204 -(* params     : list of '(name, value)' pairs used to override default       *)
 11.1205 -(*              parameters                                                   *)
 11.1206 -(* ------------------------------------------------------------------------- *)
 11.1207 -
 11.1208 -fun refute_term ctxt params assm_ts t =
 11.1209 -  let
 11.1210 -    (* disallow schematic type variables, since we cannot properly negate  *)
 11.1211 -    (* terms containing them (their logical meaning is that there EXISTS a *)
 11.1212 -    (* type s.t. ...; to refute such a formula, we would have to show that *)
 11.1213 -    (* for ALL types, not ...)                                             *)
 11.1214 -    val _ = null (Term.add_tvars t []) orelse
 11.1215 -      error "Term to be refuted contains schematic type variables"
 11.1216 -
 11.1217 -    (* existential closure over schematic variables *)
 11.1218 -    val vars = sort_wrt (fst o fst) (Term.add_vars t [])
 11.1219 -    (* Term.term *)
 11.1220 -    val ex_closure = fold (fn ((x, i), T) => fn t' =>
 11.1221 -      HOLogic.exists_const T $
 11.1222 -        Abs (x, T, abstract_over (Var ((x, i), T), t'))) vars t
 11.1223 -    (* Note: If 't' is of type 'propT' (rather than 'boolT'), applying   *)
 11.1224 -    (* 'HOLogic.exists_const' is not type-correct.  However, this is not *)
 11.1225 -    (* really a problem as long as 'find_model' still interprets the     *)
 11.1226 -    (* resulting term correctly, without checking its type.              *)
 11.1227 -
 11.1228 -    (* replace outermost universally quantified variables by Free's:     *)
 11.1229 -    (* refuting a term with Free's is generally faster than refuting a   *)
 11.1230 -    (* term with (nested) quantifiers, because quantifiers are expanded, *)
 11.1231 -    (* while the SAT solver searches for an interpretation for Free's.   *)
 11.1232 -    (* Also we get more information back that way, namely an             *)
 11.1233 -    (* interpretation which includes values for the (formerly)           *)
 11.1234 -    (* quantified variables.                                             *)
 11.1235 -    (* maps  !!x1...xn. !xk...xm. t   to   t  *)
 11.1236 -    fun strip_all_body (Const (@{const_name all}, _) $ Abs (_, _, t)) =
 11.1237 -          strip_all_body t
 11.1238 -      | strip_all_body (Const (@{const_name Trueprop}, _) $ t) =
 11.1239 -          strip_all_body t
 11.1240 -      | strip_all_body (Const (@{const_name All}, _) $ Abs (_, _, t)) =
 11.1241 -          strip_all_body t
 11.1242 -      | strip_all_body t = t
 11.1243 -    (* maps  !!x1...xn. !xk...xm. t   to   [x1, ..., xn, xk, ..., xm]  *)
 11.1244 -    fun strip_all_vars (Const (@{const_name all}, _) $ Abs (a, T, t)) =
 11.1245 -          (a, T) :: strip_all_vars t
 11.1246 -      | strip_all_vars (Const (@{const_name Trueprop}, _) $ t) =
 11.1247 -          strip_all_vars t
 11.1248 -      | strip_all_vars (Const (@{const_name All}, _) $ Abs (a, T, t)) =
 11.1249 -          (a, T) :: strip_all_vars t
 11.1250 -      | strip_all_vars _ = [] : (string * typ) list
 11.1251 -    val strip_t = strip_all_body ex_closure
 11.1252 -    val frees = Term.rename_wrt_term strip_t (strip_all_vars ex_closure)
 11.1253 -    val subst_t = Term.subst_bounds (map Free frees, strip_t)
 11.1254 -  in
 11.1255 -    find_model ctxt (actual_params ctxt params) assm_ts subst_t true
 11.1256 -  end;
 11.1257 -
 11.1258 -(* ------------------------------------------------------------------------- *)
 11.1259 -(* refute_goal                                                               *)
 11.1260 -(* ------------------------------------------------------------------------- *)
 11.1261 -
 11.1262 -fun refute_goal ctxt params th i =
 11.1263 -  let
 11.1264 -    val t = th |> prop_of
 11.1265 -  in
 11.1266 -    if Logic.count_prems t = 0 then
 11.1267 -      (Output.urgent_message "No subgoal!"; "none")
 11.1268 -    else
 11.1269 -      let
 11.1270 -        val assms = map term_of (Assumption.all_assms_of ctxt)
 11.1271 -        val (t, frees) = Logic.goal_params t i
 11.1272 -      in
 11.1273 -        refute_term ctxt params assms (subst_bounds (frees, t))
 11.1274 -      end
 11.1275 -  end
 11.1276 -
 11.1277 -
 11.1278 -(* ------------------------------------------------------------------------- *)
 11.1279 -(* INTERPRETERS: Auxiliary Functions                                         *)
 11.1280 -(* ------------------------------------------------------------------------- *)
 11.1281 -
 11.1282 -(* ------------------------------------------------------------------------- *)
 11.1283 -(* make_constants: returns all interpretations for type 'T' that consist of  *)
 11.1284 -(*                 unit vectors with 'True'/'False' only (no Boolean         *)
 11.1285 -(*                 variables)                                                *)
 11.1286 -(* ------------------------------------------------------------------------- *)
 11.1287 -
 11.1288 -fun make_constants ctxt model T =
 11.1289 -  let
 11.1290 -    (* returns a list with all unit vectors of length n *)
 11.1291 -    (* int -> interpretation list *)
 11.1292 -    fun unit_vectors n =
 11.1293 -      let
 11.1294 -        (* returns the k-th unit vector of length n *)
 11.1295 -        (* int * int -> interpretation *)
 11.1296 -        fun unit_vector (k, n) =
 11.1297 -          Leaf ((replicate (k-1) False) @ (True :: (replicate (n-k) False)))
 11.1298 -        (* int -> interpretation list *)
 11.1299 -        fun unit_vectors_loop k =
 11.1300 -          if k>n then [] else unit_vector (k,n) :: unit_vectors_loop (k+1)
 11.1301 -      in
 11.1302 -        unit_vectors_loop 1
 11.1303 -      end
 11.1304 -    (* returns a list of lists, each one consisting of n (possibly *)
 11.1305 -    (* identical) elements from 'xs'                               *)
 11.1306 -    (* int -> 'a list -> 'a list list *)
 11.1307 -    fun pick_all 1 xs = map single xs
 11.1308 -      | pick_all n xs =
 11.1309 -          let val rec_pick = pick_all (n - 1) xs in
 11.1310 -            maps (fn x => map (cons x) rec_pick) xs
 11.1311 -          end
 11.1312 -    (* returns all constant interpretations that have the same tree *)
 11.1313 -    (* structure as the interpretation argument                     *)
 11.1314 -    (* interpretation -> interpretation list *)
 11.1315 -    fun make_constants_intr (Leaf xs) = unit_vectors (length xs)
 11.1316 -      | make_constants_intr (Node xs) = map Node (pick_all (length xs)
 11.1317 -          (make_constants_intr (hd xs)))
 11.1318 -    (* obtain the interpretation for a variable of type 'T' *)
 11.1319 -    val (i, _, _) = interpret ctxt model {maxvars=0, def_eq=false, next_idx=1,
 11.1320 -      bounds=[], wellformed=True} (Free ("dummy", T))
 11.1321 -  in
 11.1322 -    make_constants_intr i
 11.1323 -  end;
 11.1324 -
 11.1325 -(* ------------------------------------------------------------------------- *)
 11.1326 -(* size_of_type: returns the number of elements in a type 'T' (i.e. 'length  *)
 11.1327 -(*               (make_constants T)', but implemented more efficiently)      *)
 11.1328 -(* ------------------------------------------------------------------------- *)
 11.1329 -
 11.1330 -(* returns 0 for an empty ground type or a function type with empty      *)
 11.1331 -(* codomain, but fails for a function type with empty domain --          *)
 11.1332 -(* admissibility of datatype constructor argument types (see "Inductive  *)
 11.1333 -(* datatypes in HOL - lessons learned ...", S. Berghofer, M. Wenzel,     *)
 11.1334 -(* TPHOLs 99) ensures that recursive, possibly empty, datatype fragments *)
 11.1335 -(* never occur as the domain of a function type that is the type of a    *)
 11.1336 -(* constructor argument                                                  *)
 11.1337 -
 11.1338 -fun size_of_type ctxt model T =
 11.1339 -  let
 11.1340 -    (* returns the number of elements that have the same tree structure as a *)
 11.1341 -    (* given interpretation                                                  *)
 11.1342 -    fun size_of_intr (Leaf xs) = length xs
 11.1343 -      | size_of_intr (Node xs) = Integer.pow (length xs) (size_of_intr (hd xs))
 11.1344 -    (* obtain the interpretation for a variable of type 'T' *)
 11.1345 -    val (i, _, _) = interpret ctxt model {maxvars=0, def_eq=false, next_idx=1,
 11.1346 -      bounds=[], wellformed=True} (Free ("dummy", T))
 11.1347 -  in
 11.1348 -    size_of_intr i
 11.1349 -  end;
 11.1350 -
 11.1351 -(* ------------------------------------------------------------------------- *)
 11.1352 -(* TT/FF: interpretations that denote "true" or "false", respectively        *)
 11.1353 -(* ------------------------------------------------------------------------- *)
 11.1354 -
 11.1355 -(* interpretation *)
 11.1356 -
 11.1357 -val TT = Leaf [True, False];
 11.1358 -
 11.1359 -val FF = Leaf [False, True];
 11.1360 -
 11.1361 -(* ------------------------------------------------------------------------- *)
 11.1362 -(* make_equality: returns an interpretation that denotes (extensional)       *)
 11.1363 -(*                equality of two interpretations                            *)
 11.1364 -(* - two interpretations are 'equal' iff they are both defined and denote    *)
 11.1365 -(*   the same value                                                          *)
 11.1366 -(* - two interpretations are 'not_equal' iff they are both defined at least  *)
 11.1367 -(*   partially, and a defined part denotes different values                  *)
 11.1368 -(* - a completely undefined interpretation is neither 'equal' nor            *)
 11.1369 -(*   'not_equal' to another interpretation                                   *)
 11.1370 -(* ------------------------------------------------------------------------- *)
 11.1371 -
 11.1372 -(* We could in principle represent '=' on a type T by a particular        *)
 11.1373 -(* interpretation.  However, the size of that interpretation is quadratic *)
 11.1374 -(* in the size of T.  Therefore comparing the interpretations 'i1' and    *)
 11.1375 -(* 'i2' directly is more efficient than constructing the interpretation   *)
 11.1376 -(* for equality on T first, and "applying" this interpretation to 'i1'    *)
 11.1377 -(* and 'i2' in the usual way (cf. 'interpretation_apply') then.           *)
 11.1378 -
 11.1379 -(* interpretation * interpretation -> interpretation *)
 11.1380 -
 11.1381 -fun make_equality (i1, i2) =
 11.1382 -  let
 11.1383 -    (* interpretation * interpretation -> prop_formula *)
 11.1384 -    fun equal (i1, i2) =
 11.1385 -      (case i1 of
 11.1386 -        Leaf xs =>
 11.1387 -          (case i2 of
 11.1388 -            Leaf ys => Prop_Logic.dot_product (xs, ys)  (* defined and equal *)
 11.1389 -          | Node _  => raise REFUTE ("make_equality",
 11.1390 -            "second interpretation is higher"))
 11.1391 -      | Node xs =>
 11.1392 -          (case i2 of
 11.1393 -            Leaf _  => raise REFUTE ("make_equality",
 11.1394 -            "first interpretation is higher")
 11.1395 -          | Node ys => Prop_Logic.all (map equal (xs ~~ ys))))
 11.1396 -    (* interpretation * interpretation -> prop_formula *)
 11.1397 -    fun not_equal (i1, i2) =
 11.1398 -      (case i1 of
 11.1399 -        Leaf xs =>
 11.1400 -          (case i2 of
 11.1401 -            (* defined and not equal *)
 11.1402 -            Leaf ys => Prop_Logic.all ((Prop_Logic.exists xs)
 11.1403 -            :: (Prop_Logic.exists ys)
 11.1404 -            :: (map (fn (x,y) => SOr (SNot x, SNot y)) (xs ~~ ys)))
 11.1405 -          | Node _  => raise REFUTE ("make_equality",
 11.1406 -            "second interpretation is higher"))
 11.1407 -      | Node xs =>
 11.1408 -          (case i2 of
 11.1409 -            Leaf _  => raise REFUTE ("make_equality",
 11.1410 -            "first interpretation is higher")
 11.1411 -          | Node ys => Prop_Logic.exists (map not_equal (xs ~~ ys))))
 11.1412 -  in
 11.1413 -    (* a value may be undefined; therefore 'not_equal' is not just the *)
 11.1414 -    (* negation of 'equal'                                             *)
 11.1415 -    Leaf [equal (i1, i2), not_equal (i1, i2)]
 11.1416 -  end;
 11.1417 -
 11.1418 -(* ------------------------------------------------------------------------- *)
 11.1419 -(* make_def_equality: returns an interpretation that denotes (extensional)   *)
 11.1420 -(*                    equality of two interpretations                        *)
 11.1421 -(* This function treats undefined/partially defined interpretations          *)
 11.1422 -(* different from 'make_equality': two undefined interpretations are         *)
 11.1423 -(* considered equal, while a defined interpretation is considered not equal  *)
 11.1424 -(* to an undefined interpretation.                                           *)
 11.1425 -(* ------------------------------------------------------------------------- *)
 11.1426 -
 11.1427 -(* interpretation * interpretation -> interpretation *)
 11.1428 -
 11.1429 -fun make_def_equality (i1, i2) =
 11.1430 -  let
 11.1431 -    (* interpretation * interpretation -> prop_formula *)
 11.1432 -    fun equal (i1, i2) =
 11.1433 -      (case i1 of
 11.1434 -        Leaf xs =>
 11.1435 -          (case i2 of
 11.1436 -            (* defined and equal, or both undefined *)
 11.1437 -            Leaf ys => SOr (Prop_Logic.dot_product (xs, ys),
 11.1438 -            SAnd (Prop_Logic.all (map SNot xs), Prop_Logic.all (map SNot ys)))
 11.1439 -          | Node _  => raise REFUTE ("make_def_equality",
 11.1440 -            "second interpretation is higher"))
 11.1441 -      | Node xs =>
 11.1442 -          (case i2 of
 11.1443 -            Leaf _  => raise REFUTE ("make_def_equality",
 11.1444 -            "first interpretation is higher")
 11.1445 -          | Node ys => Prop_Logic.all (map equal (xs ~~ ys))))
 11.1446 -    (* interpretation *)
 11.1447 -    val eq = equal (i1, i2)
 11.1448 -  in
 11.1449 -    Leaf [eq, SNot eq]
 11.1450 -  end;
 11.1451 -
 11.1452 -(* ------------------------------------------------------------------------- *)
 11.1453 -(* interpretation_apply: returns an interpretation that denotes the result   *)
 11.1454 -(*                       of applying the function denoted by 'i1' to the     *)
 11.1455 -(*                       argument denoted by 'i2'                            *)
 11.1456 -(* ------------------------------------------------------------------------- *)
 11.1457 -
 11.1458 -(* interpretation * interpretation -> interpretation *)
 11.1459 -
 11.1460 -fun interpretation_apply (i1, i2) =
 11.1461 -  let
 11.1462 -    (* interpretation * interpretation -> interpretation *)
 11.1463 -    fun interpretation_disjunction (tr1,tr2) =
 11.1464 -      tree_map (fn (xs,ys) => map (fn (x,y) => SOr(x,y)) (xs ~~ ys))
 11.1465 -        (tree_pair (tr1,tr2))
 11.1466 -    (* prop_formula * interpretation -> interpretation *)
 11.1467 -    fun prop_formula_times_interpretation (fm,tr) =
 11.1468 -      tree_map (map (fn x => SAnd (fm,x))) tr
 11.1469 -    (* prop_formula list * interpretation list -> interpretation *)
 11.1470 -    fun prop_formula_list_dot_product_interpretation_list ([fm],[tr]) =
 11.1471 -          prop_formula_times_interpretation (fm,tr)
 11.1472 -      | prop_formula_list_dot_product_interpretation_list (fm::fms,tr::trees) =
 11.1473 -          interpretation_disjunction (prop_formula_times_interpretation (fm,tr),
 11.1474 -            prop_formula_list_dot_product_interpretation_list (fms,trees))
 11.1475 -      | prop_formula_list_dot_product_interpretation_list (_,_) =
 11.1476 -          raise REFUTE ("interpretation_apply", "empty list (in dot product)")
 11.1477 -    (* returns a list of lists, each one consisting of one element from each *)
 11.1478 -    (* element of 'xss'                                                      *)
 11.1479 -    (* 'a list list -> 'a list list *)
 11.1480 -    fun pick_all [xs] = map single xs
 11.1481 -      | pick_all (xs::xss) =
 11.1482 -          let val rec_pick = pick_all xss in
 11.1483 -            maps (fn x => map (cons x) rec_pick) xs
 11.1484 -          end
 11.1485 -      | pick_all _ = raise REFUTE ("interpretation_apply", "empty list (in pick_all)")
 11.1486 -    (* interpretation -> prop_formula list *)
 11.1487 -    fun interpretation_to_prop_formula_list (Leaf xs) = xs
 11.1488 -      | interpretation_to_prop_formula_list (Node trees) =
 11.1489 -          map Prop_Logic.all (pick_all
 11.1490 -            (map interpretation_to_prop_formula_list trees))
 11.1491 -  in
 11.1492 -    case i1 of
 11.1493 -      Leaf _ =>
 11.1494 -        raise REFUTE ("interpretation_apply", "first interpretation is a leaf")
 11.1495 -    | Node xs =>
 11.1496 -        prop_formula_list_dot_product_interpretation_list
 11.1497 -          (interpretation_to_prop_formula_list i2, xs)
 11.1498 -  end;
 11.1499 -
 11.1500 -(* ------------------------------------------------------------------------- *)
 11.1501 -(* eta_expand: eta-expands a term 't' by adding 'i' lambda abstractions      *)
 11.1502 -(* ------------------------------------------------------------------------- *)
 11.1503 -
 11.1504 -(* Term.term -> int -> Term.term *)
 11.1505 -
 11.1506 -fun eta_expand t i =
 11.1507 -  let
 11.1508 -    val Ts = Term.binder_types (Term.fastype_of t)
 11.1509 -    val t' = Term.incr_boundvars i t
 11.1510 -  in
 11.1511 -    fold_rev (fn T => fn term => Abs ("<eta_expand>", T, term))
 11.1512 -      (List.take (Ts, i))
 11.1513 -      (Term.list_comb (t', map Bound (i-1 downto 0)))
 11.1514 -  end;
 11.1515 -
 11.1516 -(* ------------------------------------------------------------------------- *)
 11.1517 -(* size_of_dtyp: the size of (an initial fragment of) an inductive data type *)
 11.1518 -(*               is the sum (over its constructors) of the product (over     *)
 11.1519 -(*               their arguments) of the size of the argument types          *)
 11.1520 -(* ------------------------------------------------------------------------- *)
 11.1521 -
 11.1522 -fun size_of_dtyp ctxt typ_sizes descr typ_assoc constructors =
 11.1523 -  Integer.sum (map (fn (_, dtyps) =>
 11.1524 -    Integer.prod (map (size_of_type ctxt (typ_sizes, []) o
 11.1525 -      (typ_of_dtyp descr typ_assoc)) dtyps))
 11.1526 -        constructors);
 11.1527 -
 11.1528 -
 11.1529 -(* ------------------------------------------------------------------------- *)
 11.1530 -(* INTERPRETERS: Actual Interpreters                                         *)
 11.1531 -(* ------------------------------------------------------------------------- *)
 11.1532 -
 11.1533 -(* simply typed lambda calculus: Isabelle's basic term syntax, with type *)
 11.1534 -(* variables, function types, and propT                                  *)
 11.1535 -
 11.1536 -fun stlc_interpreter ctxt model args t =
 11.1537 -  let
 11.1538 -    val (typs, terms) = model
 11.1539 -    val {maxvars, def_eq, next_idx, bounds, wellformed} = args
 11.1540 -    (* Term.typ -> (interpretation * model * arguments) option *)
 11.1541 -    fun interpret_groundterm T =
 11.1542 -      let
 11.1543 -        (* unit -> (interpretation * model * arguments) option *)
 11.1544 -        fun interpret_groundtype () =
 11.1545 -          let
 11.1546 -            (* the model must specify a size for ground types *)
 11.1547 -            val size =
 11.1548 -              if T = Term.propT then 2
 11.1549 -              else the (AList.lookup (op =) typs T)
 11.1550 -            val next = next_idx + size
 11.1551 -            (* check if 'maxvars' is large enough *)
 11.1552 -            val _ = (if next - 1 > maxvars andalso maxvars > 0 then
 11.1553 -              raise MAXVARS_EXCEEDED else ())
 11.1554 -            (* prop_formula list *)
 11.1555 -            val fms  = map BoolVar (next_idx upto (next_idx + size - 1))
 11.1556 -            (* interpretation *)
 11.1557 -            val intr = Leaf fms
 11.1558 -            (* prop_formula list -> prop_formula *)
 11.1559 -            fun one_of_two_false [] = True
 11.1560 -              | one_of_two_false (x::xs) = SAnd (Prop_Logic.all (map (fn x' =>
 11.1561 -                  SOr (SNot x, SNot x')) xs), one_of_two_false xs)
 11.1562 -            (* prop_formula *)
 11.1563 -            val wf = one_of_two_false fms
 11.1564 -          in
 11.1565 -            (* extend the model, increase 'next_idx', add well-formedness *)
 11.1566 -            (* condition                                                  *)
 11.1567 -            SOME (intr, (typs, (t, intr)::terms), {maxvars = maxvars,
 11.1568 -              def_eq = def_eq, next_idx = next, bounds = bounds,
 11.1569 -              wellformed = SAnd (wellformed, wf)})
 11.1570 -          end
 11.1571 -      in
 11.1572 -        case T of
 11.1573 -          Type ("fun", [T1, T2]) =>
 11.1574 -            let
 11.1575 -              (* we create 'size_of_type ... T1' different copies of the        *)
 11.1576 -              (* interpretation for 'T2', which are then combined into a single *)
 11.1577 -              (* new interpretation                                             *)
 11.1578 -              (* make fresh copies, with different variable indices *)
 11.1579 -              (* 'idx': next variable index                         *)
 11.1580 -              (* 'n'  : number of copies                            *)
 11.1581 -              (* int -> int -> (int * interpretation list * prop_formula *)
 11.1582 -              fun make_copies idx 0 = (idx, [], True)
 11.1583 -                | make_copies idx n =
 11.1584 -                    let
 11.1585 -                      val (copy, _, new_args) = interpret ctxt (typs, [])
 11.1586 -                        {maxvars = maxvars, def_eq = false, next_idx = idx,
 11.1587 -                        bounds = [], wellformed = True} (Free ("dummy", T2))
 11.1588 -                      val (idx', copies, wf') = make_copies (#next_idx new_args) (n-1)
 11.1589 -                    in
 11.1590 -                      (idx', copy :: copies, SAnd (#wellformed new_args, wf'))
 11.1591 -                    end
 11.1592 -              val (next, copies, wf) = make_copies next_idx
 11.1593 -                (size_of_type ctxt model T1)
 11.1594 -              (* combine copies into a single interpretation *)
 11.1595 -              val intr = Node copies
 11.1596 -            in
 11.1597 -              (* extend the model, increase 'next_idx', add well-formedness *)
 11.1598 -              (* condition                                                  *)
 11.1599 -              SOME (intr, (typs, (t, intr)::terms), {maxvars = maxvars,
 11.1600 -                def_eq = def_eq, next_idx = next, bounds = bounds,
 11.1601 -                wellformed = SAnd (wellformed, wf)})
 11.1602 -            end
 11.1603 -        | Type _  => interpret_groundtype ()
 11.1604 -        | TFree _ => interpret_groundtype ()
 11.1605 -        | TVar  _ => interpret_groundtype ()
 11.1606 -      end
 11.1607 -  in
 11.1608 -    case AList.lookup (op =) terms t of
 11.1609 -      SOME intr =>
 11.1610 -        (* return an existing interpretation *)
 11.1611 -        SOME (intr, model, args)
 11.1612 -    | NONE =>
 11.1613 -        (case t of
 11.1614 -          Const (_, T) => interpret_groundterm T
 11.1615 -        | Free (_, T) => interpret_groundterm T
 11.1616 -        | Var (_, T) => interpret_groundterm T
 11.1617 -        | Bound i => SOME (nth (#bounds args) i, model, args)
 11.1618 -        | Abs (_, T, body) =>
 11.1619 -            let
 11.1620 -              (* create all constants of type 'T' *)
 11.1621 -              val constants = make_constants ctxt model T
 11.1622 -              (* interpret the 'body' separately for each constant *)
 11.1623 -              val (bodies, (model', args')) = fold_map
 11.1624 -                (fn c => fn (m, a) =>
 11.1625 -                  let
 11.1626 -                    (* add 'c' to 'bounds' *)
 11.1627 -                    val (i', m', a') = interpret ctxt m {maxvars = #maxvars a,
 11.1628 -                      def_eq = #def_eq a, next_idx = #next_idx a,
 11.1629 -                      bounds = (c :: #bounds a), wellformed = #wellformed a} body
 11.1630 -                  in
 11.1631 -                    (* keep the new model m' and 'next_idx' and 'wellformed', *)
 11.1632 -                    (* but use old 'bounds'                                   *)
 11.1633 -                    (i', (m', {maxvars = maxvars, def_eq = def_eq,
 11.1634 -                      next_idx = #next_idx a', bounds = bounds,
 11.1635 -                      wellformed = #wellformed a'}))
 11.1636 -                  end)
 11.1637 -                constants (model, args)
 11.1638 -            in
 11.1639 -              SOME (Node bodies, model', args')
 11.1640 -            end
 11.1641 -        | t1 $ t2 =>
 11.1642 -            let
 11.1643 -              (* interpret 't1' and 't2' separately *)
 11.1644 -              val (intr1, model1, args1) = interpret ctxt model args t1
 11.1645 -              val (intr2, model2, args2) = interpret ctxt model1 args1 t2
 11.1646 -            in
 11.1647 -              SOME (interpretation_apply (intr1, intr2), model2, args2)
 11.1648 -            end)
 11.1649 -  end;
 11.1650 -
 11.1651 -fun Pure_interpreter ctxt model args t =
 11.1652 -  case t of
 11.1653 -    Const (@{const_name all}, _) $ t1 =>
 11.1654 -      let
 11.1655 -        val (i, m, a) = interpret ctxt model args t1
 11.1656 -      in
 11.1657 -        case i of
 11.1658 -          Node xs =>
 11.1659 -            (* 3-valued logic *)
 11.1660 -            let
 11.1661 -              val fmTrue  = Prop_Logic.all (map toTrue xs)
 11.1662 -              val fmFalse = Prop_Logic.exists (map toFalse xs)
 11.1663 -            in
 11.1664 -              SOME (Leaf [fmTrue, fmFalse], m, a)
 11.1665 -            end
 11.1666 -        | _ =>
 11.1667 -          raise REFUTE ("Pure_interpreter",
 11.1668 -            "\"all\" is followed by a non-function")
 11.1669 -      end
 11.1670 -  | Const (@{const_name all}, _) =>
 11.1671 -      SOME (interpret ctxt model args (eta_expand t 1))
 11.1672 -  | Const (@{const_name "=="}, _) $ t1 $ t2 =>
 11.1673 -      let
 11.1674 -        val (i1, m1, a1) = interpret ctxt model args t1
 11.1675 -        val (i2, m2, a2) = interpret ctxt m1 a1 t2
 11.1676 -      in
 11.1677 -        (* we use either 'make_def_equality' or 'make_equality' *)
 11.1678 -        SOME ((if #def_eq args then make_def_equality else make_equality)
 11.1679 -          (i1, i2), m2, a2)
 11.1680 -      end
 11.1681 -  | Const (@{const_name "=="}, _) $ _ =>
 11.1682 -      SOME (interpret ctxt model args (eta_expand t 1))
 11.1683 -  | Const (@{const_name "=="}, _) =>
 11.1684 -      SOME (interpret ctxt model args (eta_expand t 2))
 11.1685 -  | Const (@{const_name "==>"}, _) $ t1 $ t2 =>
 11.1686 -      (* 3-valued logic *)
 11.1687 -      let
 11.1688 -        val (i1, m1, a1) = interpret ctxt model args t1
 11.1689 -        val (i2, m2, a2) = interpret ctxt m1 a1 t2
 11.1690 -        val fmTrue = Prop_Logic.SOr (toFalse i1, toTrue i2)
 11.1691 -        val fmFalse = Prop_Logic.SAnd (toTrue i1, toFalse i2)
 11.1692 -      in
 11.1693 -        SOME (Leaf [fmTrue, fmFalse], m2, a2)
 11.1694 -      end
 11.1695 -  | Const (@{const_name "==>"}, _) $ _ =>
 11.1696 -      SOME (interpret ctxt model args (eta_expand t 1))
 11.1697 -  | Const (@{const_name "==>"}, _) =>
 11.1698 -      SOME (interpret ctxt model args (eta_expand t 2))
 11.1699 -  | _ => NONE;
 11.1700 -
 11.1701 -fun HOLogic_interpreter ctxt model args t =
 11.1702 -(* Providing interpretations directly is more efficient than unfolding the *)
 11.1703 -(* logical constants.  In HOL however, logical constants can themselves be *)
 11.1704 -(* arguments.  They are then translated using eta-expansion.               *)
 11.1705 -  case t of
 11.1706 -    Const (@{const_name Trueprop}, _) =>
 11.1707 -      SOME (Node [TT, FF], model, args)
 11.1708 -  | Const (@{const_name Not}, _) =>
 11.1709 -      SOME (Node [FF, TT], model, args)
 11.1710 -  (* redundant, since 'True' is also an IDT constructor *)
 11.1711 -  | Const (@{const_name True}, _) =>
 11.1712 -      SOME (TT, model, args)
 11.1713 -  (* redundant, since 'False' is also an IDT constructor *)
 11.1714 -  | Const (@{const_name False}, _) =>
 11.1715 -      SOME (FF, model, args)
 11.1716 -  | Const (@{const_name All}, _) $ t1 =>  (* similar to "all" (Pure) *)
 11.1717 -      let
 11.1718 -        val (i, m, a) = interpret ctxt model args t1
 11.1719 -      in
 11.1720 -        case i of
 11.1721 -          Node xs =>
 11.1722 -            (* 3-valued logic *)
 11.1723 -            let
 11.1724 -              val fmTrue = Prop_Logic.all (map toTrue xs)
 11.1725 -              val fmFalse = Prop_Logic.exists (map toFalse xs)
 11.1726 -            in
 11.1727 -              SOME (Leaf [fmTrue, fmFalse], m, a)
 11.1728 -            end
 11.1729 -        | _ =>
 11.1730 -          raise REFUTE ("HOLogic_interpreter",
 11.1731 -            "\"All\" is followed by a non-function")
 11.1732 -      end
 11.1733 -  | Const (@{const_name All}, _) =>
 11.1734 -      SOME (interpret ctxt model args (eta_expand t 1))
 11.1735 -  | Const (@{const_name Ex}, _) $ t1 =>
 11.1736 -      let
 11.1737 -        val (i, m, a) = interpret ctxt model args t1
 11.1738 -      in
 11.1739 -        case i of
 11.1740 -          Node xs =>
 11.1741 -            (* 3-valued logic *)
 11.1742 -            let
 11.1743 -              val fmTrue = Prop_Logic.exists (map toTrue xs)
 11.1744 -              val fmFalse = Prop_Logic.all (map toFalse xs)
 11.1745 -            in
 11.1746 -              SOME (Leaf [fmTrue, fmFalse], m, a)
 11.1747 -            end
 11.1748 -        | _ =>
 11.1749 -          raise REFUTE ("HOLogic_interpreter",
 11.1750 -            "\"Ex\" is followed by a non-function")
 11.1751 -      end
 11.1752 -  | Const (@{const_name Ex}, _) =>
 11.1753 -      SOME (interpret ctxt model args (eta_expand t 1))
 11.1754 -  | Const (@{const_name HOL.eq}, _) $ t1 $ t2 =>  (* similar to "==" (Pure) *)
 11.1755 -      let
 11.1756 -        val (i1, m1, a1) = interpret ctxt model args t1
 11.1757 -        val (i2, m2, a2) = interpret ctxt m1 a1 t2
 11.1758 -      in
 11.1759 -        SOME (make_equality (i1, i2), m2, a2)
 11.1760 -      end
 11.1761 -  | Const (@{const_name HOL.eq}, _) $ _ =>
 11.1762 -      SOME (interpret ctxt model args (eta_expand t 1))
 11.1763 -  | Const (@{const_name HOL.eq}, _) =>
 11.1764 -      SOME (interpret ctxt model args (eta_expand t 2))
 11.1765 -  | Const (@{const_name HOL.conj}, _) $ t1 $ t2 =>
 11.1766 -      (* 3-valued logic *)
 11.1767 -      let
 11.1768 -        val (i1, m1, a1) = interpret ctxt model args t1
 11.1769 -        val (i2, m2, a2) = interpret ctxt m1 a1 t2
 11.1770 -        val fmTrue = Prop_Logic.SAnd (toTrue i1, toTrue i2)
 11.1771 -        val fmFalse = Prop_Logic.SOr (toFalse i1, toFalse i2)
 11.1772 -      in
 11.1773 -        SOME (Leaf [fmTrue, fmFalse], m2, a2)
 11.1774 -      end
 11.1775 -  | Const (@{const_name HOL.conj}, _) $ _ =>
 11.1776 -      SOME (interpret ctxt model args (eta_expand t 1))
 11.1777 -  | Const (@{const_name HOL.conj}, _) =>
 11.1778 -      SOME (interpret ctxt model args (eta_expand t 2))
 11.1779 -      (* this would make "undef" propagate, even for formulae like *)
 11.1780 -      (* "False & undef":                                          *)
 11.1781 -      (* SOME (Node [Node [TT, FF], Node [FF, FF]], model, args) *)
 11.1782 -  | Const (@{const_name HOL.disj}, _) $ t1 $ t2 =>
 11.1783 -      (* 3-valued logic *)
 11.1784 -      let
 11.1785 -        val (i1, m1, a1) = interpret ctxt model args t1
 11.1786 -        val (i2, m2, a2) = interpret ctxt m1 a1 t2
 11.1787 -        val fmTrue = Prop_Logic.SOr (toTrue i1, toTrue i2)
 11.1788 -        val fmFalse = Prop_Logic.SAnd (toFalse i1, toFalse i2)
 11.1789 -      in
 11.1790 -        SOME (Leaf [fmTrue, fmFalse], m2, a2)
 11.1791 -      end
 11.1792 -  | Const (@{const_name HOL.disj}, _) $ _ =>
 11.1793 -      SOME (interpret ctxt model args (eta_expand t 1))
 11.1794 -  | Const (@{const_name HOL.disj}, _) =>
 11.1795 -      SOME (interpret ctxt model args (eta_expand t 2))
 11.1796 -      (* this would make "undef" propagate, even for formulae like *)
 11.1797 -      (* "True | undef":                                           *)
 11.1798 -      (* SOME (Node [Node [TT, TT], Node [TT, FF]], model, args) *)
 11.1799 -  | Const (@{const_name HOL.implies}, _) $ t1 $ t2 =>  (* similar to "==>" (Pure) *)
 11.1800 -      (* 3-valued logic *)
 11.1801 -      let
 11.1802 -        val (i1, m1, a1) = interpret ctxt model args t1
 11.1803 -        val (i2, m2, a2) = interpret ctxt m1 a1 t2
 11.1804 -        val fmTrue = Prop_Logic.SOr (toFalse i1, toTrue i2)
 11.1805 -        val fmFalse = Prop_Logic.SAnd (toTrue i1, toFalse i2)
 11.1806 -      in
 11.1807 -        SOME (Leaf [fmTrue, fmFalse], m2, a2)
 11.1808 -      end
 11.1809 -  | Const (@{const_name HOL.implies}, _) $ _ =>
 11.1810 -      SOME (interpret ctxt model args (eta_expand t 1))
 11.1811 -  | Const (@{const_name HOL.implies}, _) =>
 11.1812 -      SOME (interpret ctxt model args (eta_expand t 2))
 11.1813 -      (* this would make "undef" propagate, even for formulae like *)
 11.1814 -      (* "False --> undef":                                        *)
 11.1815 -      (* SOME (Node [Node [TT, FF], Node [TT, TT]], model, args) *)
 11.1816 -  | _ => NONE;
 11.1817 -
 11.1818 -(* interprets variables and constants whose type is an IDT (this is        *)
 11.1819 -(* relatively easy and merely requires us to compute the size of the IDT); *)
 11.1820 -(* constructors of IDTs however are properly interpreted by                *)
 11.1821 -(* 'IDT_constructor_interpreter'                                           *)
 11.1822 -
 11.1823 -fun IDT_interpreter ctxt model args t =
 11.1824 -  let
 11.1825 -    val thy = Proof_Context.theory_of ctxt
 11.1826 -    val (typs, terms) = model
 11.1827 -    (* Term.typ -> (interpretation * model * arguments) option *)
 11.1828 -    fun interpret_term (Type (s, Ts)) =
 11.1829 -          (case Datatype.get_info thy s of
 11.1830 -            SOME info =>  (* inductive datatype *)
 11.1831 -              let
 11.1832 -                (* int option -- only recursive IDTs have an associated depth *)
 11.1833 -                val depth = AList.lookup (op =) typs (Type (s, Ts))
 11.1834 -                (* sanity check: depth must be at least 0 *)
 11.1835 -                val _ =
 11.1836 -                  (case depth of SOME n =>
 11.1837 -                    if n < 0 then
 11.1838 -                      raise REFUTE ("IDT_interpreter", "negative depth")
 11.1839 -                    else ()
 11.1840 -                  | _ => ())
 11.1841 -              in
 11.1842 -                (* termination condition to avoid infinite recursion *)
 11.1843 -                if depth = (SOME 0) then
 11.1844 -                  (* return a leaf of size 0 *)
 11.1845 -                  SOME (Leaf [], model, args)
 11.1846 -                else
 11.1847 -                  let
 11.1848 -                    val index               = #index info
 11.1849 -                    val descr               = #descr info
 11.1850 -                    val (_, dtyps, constrs) = the (AList.lookup (op =) descr index)
 11.1851 -                    val typ_assoc           = dtyps ~~ Ts
 11.1852 -                    (* sanity check: every element in 'dtyps' must be a 'DtTFree' *)
 11.1853 -                    val _ =
 11.1854 -                      if Library.exists (fn d =>
 11.1855 -                        case d of Datatype.DtTFree _ => false | _ => true) dtyps
 11.1856 -                      then
 11.1857 -                        raise REFUTE ("IDT_interpreter",
 11.1858 -                          "datatype argument (for type "
 11.1859 -                          ^ Syntax.string_of_typ ctxt (Type (s, Ts))
 11.1860 -                          ^ ") is not a variable")
 11.1861 -                      else ()
 11.1862 -                    (* if the model specifies a depth for the current type, *)
 11.1863 -                    (* decrement it to avoid infinite recursion             *)
 11.1864 -                    val typs' = case depth of NONE => typs | SOME n =>
 11.1865 -                      AList.update (op =) (Type (s, Ts), n-1) typs
 11.1866 -                    (* recursively compute the size of the datatype *)
 11.1867 -                    val size     = size_of_dtyp ctxt typs' descr typ_assoc constrs
 11.1868 -                    val next_idx = #next_idx args
 11.1869 -                    val next     = next_idx+size
 11.1870 -                    (* check if 'maxvars' is large enough *)
 11.1871 -                    val _        = (if next-1 > #maxvars args andalso
 11.1872 -                      #maxvars args > 0 then raise MAXVARS_EXCEEDED else ())
 11.1873 -                    (* prop_formula list *)
 11.1874 -                    val fms      = map BoolVar (next_idx upto (next_idx+size-1))
 11.1875 -                    (* interpretation *)
 11.1876 -                    val intr     = Leaf fms
 11.1877 -                    (* prop_formula list -> prop_formula *)
 11.1878 -                    fun one_of_two_false [] = True
 11.1879 -                      | one_of_two_false (x::xs) = SAnd (Prop_Logic.all (map (fn x' =>
 11.1880 -                          SOr (SNot x, SNot x')) xs), one_of_two_false xs)
 11.1881 -                    (* prop_formula *)
 11.1882 -                    val wf = one_of_two_false fms
 11.1883 -                  in
 11.1884 -                    (* extend the model, increase 'next_idx', add well-formedness *)
 11.1885 -                    (* condition                                                  *)
 11.1886 -                    SOME (intr, (typs, (t, intr)::terms), {maxvars = #maxvars args,
 11.1887 -                      def_eq = #def_eq args, next_idx = next, bounds = #bounds args,
 11.1888 -                      wellformed = SAnd (#wellformed args, wf)})
 11.1889 -                  end
 11.1890 -              end
 11.1891 -          | NONE =>  (* not an inductive datatype *)
 11.1892 -              NONE)
 11.1893 -      | interpret_term _ =  (* a (free or schematic) type variable *)
 11.1894 -          NONE
 11.1895 -  in
 11.1896 -    case AList.lookup (op =) terms t of
 11.1897 -      SOME intr =>
 11.1898 -        (* return an existing interpretation *)
 11.1899 -        SOME (intr, model, args)
 11.1900 -    | NONE =>
 11.1901 -        (case t of
 11.1902 -          Free (_, T) => interpret_term T
 11.1903 -        | Var (_, T) => interpret_term T
 11.1904 -        | Const (_, T) => interpret_term T
 11.1905 -        | _ => NONE)
 11.1906 -  end;
 11.1907 -
 11.1908 -(* This function imposes an order on the elements of a datatype fragment  *)
 11.1909 -(* as follows: C_i x_1 ... x_n < C_j y_1 ... y_m iff i < j or             *)
 11.1910 -(* (x_1, ..., x_n) < (y_1, ..., y_m).  With this order, a constructor is  *)
 11.1911 -(* a function C_i that maps some argument indices x_1, ..., x_n to the    *)
 11.1912 -(* datatype element given by index C_i x_1 ... x_n.  The idea remains the *)
 11.1913 -(* same for recursive datatypes, although the computation of indices gets *)
 11.1914 -(* a little tricky.                                                       *)
 11.1915 -
 11.1916 -fun IDT_constructor_interpreter ctxt model args t =
 11.1917 -  let
 11.1918 -    val thy = Proof_Context.theory_of ctxt
 11.1919 -    (* returns a list of canonical representations for terms of the type 'T' *)
 11.1920 -    (* It would be nice if we could just use 'print' for this, but 'print'   *)
 11.1921 -    (* for IDTs calls 'IDT_constructor_interpreter' again, and this could    *)
 11.1922 -    (* lead to infinite recursion when we have (mutually) recursive IDTs.    *)
 11.1923 -    (* (Term.typ * int) list -> Term.typ -> Term.term list *)
 11.1924 -    fun canonical_terms typs T =
 11.1925 -          (case T of
 11.1926 -            Type ("fun", [T1, T2]) =>
 11.1927 -            (* 'T2' might contain a recursive IDT, so we cannot use 'print' (at *)
 11.1928 -            (* least not for 'T2'                                               *)
 11.1929 -            let
 11.1930 -              (* returns a list of lists, each one consisting of n (possibly *)
 11.1931 -              (* identical) elements from 'xs'                               *)
 11.1932 -              (* int -> 'a list -> 'a list list *)
 11.1933 -              fun pick_all 1 xs = map single xs
 11.1934 -                | pick_all n xs =
 11.1935 -                    let val rec_pick = pick_all (n-1) xs in
 11.1936 -                      maps (fn x => map (cons x) rec_pick) xs
 11.1937 -                    end
 11.1938 -              (* ["x1", ..., "xn"] *)
 11.1939 -              val terms1 = canonical_terms typs T1
 11.1940 -              (* ["y1", ..., "ym"] *)
 11.1941 -              val terms2 = canonical_terms typs T2
 11.1942 -              (* [[("x1", "y1"), ..., ("xn", "y1")], ..., *)
 11.1943 -              (*   [("x1", "ym"), ..., ("xn", "ym")]]     *)
 11.1944 -              val functions = map (curry (op ~~) terms1)
 11.1945 -                (pick_all (length terms1) terms2)
 11.1946 -              (* [["(x1, y1)", ..., "(xn, y1)"], ..., *)
 11.1947 -              (*   ["(x1, ym)", ..., "(xn, ym)"]]     *)
 11.1948 -              val pairss = map (map HOLogic.mk_prod) functions
 11.1949 -              (* Term.typ *)
 11.1950 -              val HOLogic_prodT = HOLogic.mk_prodT (T1, T2)
 11.1951 -              val HOLogic_setT  = HOLogic.mk_setT HOLogic_prodT
 11.1952 -              (* Term.term *)
 11.1953 -              val HOLogic_empty_set = Const (@{const_abbrev Set.empty}, HOLogic_setT)
 11.1954 -              val HOLogic_insert    =
 11.1955 -                Const (@{const_name insert}, HOLogic_prodT --> HOLogic_setT --> HOLogic_setT)
 11.1956 -            in
 11.1957 -              (* functions as graphs, i.e. as a (HOL) set of pairs "(x, y)" *)
 11.1958 -              map (fn ps => fold_rev (fn pair => fn acc => HOLogic_insert $ pair $ acc) ps
 11.1959 -                HOLogic_empty_set) pairss
 11.1960 -            end
 11.1961 -      | Type (s, Ts) =>
 11.1962 -          (case Datatype.get_info thy s of
 11.1963 -            SOME info =>
 11.1964 -              (case AList.lookup (op =) typs T of
 11.1965 -                SOME 0 =>
 11.1966 -                  (* termination condition to avoid infinite recursion *)
 11.1967 -                  []  (* at depth 0, every IDT is empty *)
 11.1968 -              | _ =>
 11.1969 -                let
 11.1970 -                  val index = #index info
 11.1971 -                  val descr = #descr info
 11.1972 -                  val (_, dtyps, constrs) = the (AList.lookup (op =) descr index)
 11.1973 -                  val typ_assoc = dtyps ~~ Ts
 11.1974 -                  (* sanity check: every element in 'dtyps' must be a 'DtTFree' *)
 11.1975 -                  val _ =
 11.1976 -                    if Library.exists (fn d =>
 11.1977 -                      case d of Datatype.DtTFree _ => false | _ => true) dtyps
 11.1978 -                    then
 11.1979 -                      raise REFUTE ("IDT_constructor_interpreter",
 11.1980 -                        "datatype argument (for type "
 11.1981 -                        ^ Syntax.string_of_typ ctxt T
 11.1982 -                        ^ ") is not a variable")
 11.1983 -                    else ()
 11.1984 -                  (* decrement depth for the IDT 'T' *)
 11.1985 -                  val typs' =
 11.1986 -                    (case AList.lookup (op =) typs T of NONE => typs
 11.1987 -                    | SOME n => AList.update (op =) (T, n-1) typs)
 11.1988 -                  fun constructor_terms terms [] = terms
 11.1989 -                    | constructor_terms terms (d::ds) =
 11.1990 -                        let
 11.1991 -                          val dT = typ_of_dtyp descr typ_assoc d
 11.1992 -                          val d_terms = canonical_terms typs' dT
 11.1993 -                        in
 11.1994 -                          (* C_i x_1 ... x_n < C_i y_1 ... y_n if *)
 11.1995 -                          (* (x_1, ..., x_n) < (y_1, ..., y_n)    *)
 11.1996 -                          constructor_terms
 11.1997 -                            (map_product (curry op $) terms d_terms) ds
 11.1998 -                        end
 11.1999 -                in
 11.2000 -                  (* C_i ... < C_j ... if i < j *)
 11.2001 -                  maps (fn (cname, ctyps) =>
 11.2002 -                    let
 11.2003 -                      val cTerm = Const (cname,
 11.2004 -                        map (typ_of_dtyp descr typ_assoc) ctyps ---> T)
 11.2005 -                    in
 11.2006 -                      constructor_terms [cTerm] ctyps
 11.2007 -                    end) constrs
 11.2008 -                end)
 11.2009 -          | NONE =>
 11.2010 -              (* not an inductive datatype; in this case the argument types in *)
 11.2011 -              (* 'Ts' may not be IDTs either, so 'print' should be safe        *)
 11.2012 -              map (fn intr => print ctxt (typs, []) T intr (K false))
 11.2013 -                (make_constants ctxt (typs, []) T))
 11.2014 -      | _ =>  (* TFree ..., TVar ... *)
 11.2015 -          map (fn intr => print ctxt (typs, []) T intr (K false))
 11.2016 -            (make_constants ctxt (typs, []) T))
 11.2017 -    val (typs, terms) = model
 11.2018 -  in
 11.2019 -    case AList.lookup (op =) terms t of
 11.2020 -      SOME intr =>
 11.2021 -        (* return an existing interpretation *)
 11.2022 -        SOME (intr, model, args)
 11.2023 -    | NONE =>
 11.2024 -        (case t of
 11.2025 -          Const (s, T) =>
 11.2026 -            (case body_type T of
 11.2027 -              Type (s', Ts') =>
 11.2028 -                (case Datatype.get_info thy s' of
 11.2029 -                  SOME info =>  (* body type is an inductive datatype *)
 11.2030 -                    let
 11.2031 -                      val index               = #index info
 11.2032 -                      val descr               = #descr info
 11.2033 -                      val (_, dtyps, constrs) = the (AList.lookup (op =) descr index)
 11.2034 -                      val typ_assoc           = dtyps ~~ Ts'
 11.2035 -                      (* sanity check: every element in 'dtyps' must be a 'DtTFree' *)
 11.2036 -                      val _ = if Library.exists (fn d =>
 11.2037 -                          case d of Datatype.DtTFree _ => false | _ => true) dtyps
 11.2038 -                        then
 11.2039 -                          raise REFUTE ("IDT_constructor_interpreter",
 11.2040 -                            "datatype argument (for type "
 11.2041 -                            ^ Syntax.string_of_typ ctxt (Type (s', Ts'))
 11.2042 -                            ^ ") is not a variable")
 11.2043 -                        else ()
 11.2044 -                      (* split the constructors into those occuring before/after *)
 11.2045 -                      (* 'Const (s, T)'                                          *)
 11.2046 -                      val (constrs1, constrs2) = take_prefix (fn (cname, ctypes) =>
 11.2047 -                        not (cname = s andalso Sign.typ_instance thy (T,
 11.2048 -                          map (typ_of_dtyp descr typ_assoc) ctypes
 11.2049 -                            ---> Type (s', Ts')))) constrs
 11.2050 -                    in
 11.2051 -                      case constrs2 of
 11.2052 -                        [] =>
 11.2053 -                          (* 'Const (s, T)' is not a constructor of this datatype *)
 11.2054 -                          NONE
 11.2055 -                      | (_, ctypes)::_ =>
 11.2056 -                          let
 11.2057 -                            (* int option -- only /recursive/ IDTs have an associated *)
 11.2058 -                            (*               depth                                    *)
 11.2059 -                            val depth = AList.lookup (op =) typs (Type (s', Ts'))
 11.2060 -                            (* this should never happen: at depth 0, this IDT fragment *)
 11.2061 -                            (* is definitely empty, and in this case we don't need to  *)
 11.2062 -                            (* interpret its constructors                              *)
 11.2063 -                            val _ = (case depth of SOME 0 =>
 11.2064 -                                raise REFUTE ("IDT_constructor_interpreter",
 11.2065 -                                  "depth is 0")
 11.2066 -                              | _ => ())
 11.2067 -                            val typs' = (case depth of NONE => typs | SOME n =>
 11.2068 -                              AList.update (op =) (Type (s', Ts'), n-1) typs)
 11.2069 -                            (* elements of the datatype come before elements generated *)
 11.2070 -                            (* by 'Const (s, T)' iff they are generated by a           *)
 11.2071 -                            (* constructor in constrs1                                 *)
 11.2072 -                            val offset = size_of_dtyp ctxt typs' descr typ_assoc constrs1
 11.2073 -                            (* compute the total (current) size of the datatype *)
 11.2074 -                            val total = offset +
 11.2075 -                              size_of_dtyp ctxt typs' descr typ_assoc constrs2
 11.2076 -                            (* sanity check *)
 11.2077 -                            val _ = if total <> size_of_type ctxt (typs, [])
 11.2078 -                              (Type (s', Ts')) then
 11.2079 -                                raise REFUTE ("IDT_constructor_interpreter",
 11.2080 -                                  "total is not equal to current size")
 11.2081 -                              else ()
 11.2082 -                            (* returns an interpretation where everything is mapped to *)
 11.2083 -                            (* an "undefined" element of the datatype                  *)
 11.2084 -                            fun make_undef [] = Leaf (replicate total False)
 11.2085 -                              | make_undef (d::ds) =
 11.2086 -                                  let
 11.2087 -                                    (* compute the current size of the type 'd' *)
 11.2088 -                                    val dT   = typ_of_dtyp descr typ_assoc d
 11.2089 -                                    val size = size_of_type ctxt (typs, []) dT
 11.2090 -                                  in
 11.2091 -                                    Node (replicate size (make_undef ds))
 11.2092 -                                  end
 11.2093 -                            (* returns the interpretation for a constructor *)
 11.2094 -                            fun make_constr [] offset =
 11.2095 -                                  if offset < total then
 11.2096 -                                    (Leaf (replicate offset False @ True ::
 11.2097 -                                      (replicate (total - offset - 1) False)), offset + 1)
 11.2098 -                                  else
 11.2099 -                                    raise REFUTE ("IDT_constructor_interpreter",
 11.2100 -                                      "offset >= total")
 11.2101 -                              | make_constr (d::ds) offset =
 11.2102 -                                  let
 11.2103 -                                    (* Term.typ *)
 11.2104 -                                    val dT = typ_of_dtyp descr typ_assoc d
 11.2105 -                                    (* compute canonical term representations for all   *)
 11.2106 -                                    (* elements of the type 'd' (with the reduced depth *)
 11.2107 -                                    (* for the IDT)                                     *)
 11.2108 -                                    val terms' = canonical_terms typs' dT
 11.2109 -                                    (* sanity check *)
 11.2110 -                                    val _ =
 11.2111 -                                      if length terms' <> size_of_type ctxt (typs', []) dT
 11.2112 -                                      then
 11.2113 -                                        raise REFUTE ("IDT_constructor_interpreter",
 11.2114 -                                          "length of terms' is not equal to old size")
 11.2115 -                                      else ()
 11.2116 -                                    (* compute canonical term representations for all   *)
 11.2117 -                                    (* elements of the type 'd' (with the current depth *)
 11.2118 -                                    (* for the IDT)                                     *)
 11.2119 -                                    val terms = canonical_terms typs dT
 11.2120 -                                    (* sanity check *)
 11.2121 -                                    val _ =
 11.2122 -                                      if length terms <> size_of_type ctxt (typs, []) dT
 11.2123 -                                      then
 11.2124 -                                        raise REFUTE ("IDT_constructor_interpreter",
 11.2125 -                                          "length of terms is not equal to current size")
 11.2126 -                                      else ()
 11.2127 -                                    (* sanity check *)
 11.2128 -                                    val _ =
 11.2129 -                                      if length terms < length terms' then
 11.2130 -                                        raise REFUTE ("IDT_constructor_interpreter",
 11.2131 -                                          "current size is less than old size")
 11.2132 -                                      else ()
 11.2133 -                                    (* sanity check: every element of terms' must also be *)
 11.2134 -                                    (*               present in terms                     *)
 11.2135 -                                    val _ =
 11.2136 -                                      if forall (member (op =) terms) terms' then ()
 11.2137 -                                      else
 11.2138 -                                        raise REFUTE ("IDT_constructor_interpreter",
 11.2139 -                                          "element has disappeared")
 11.2140 -                                    (* sanity check: the order on elements of terms' is    *)
 11.2141 -                                    (*               the same in terms, for those elements *)
 11.2142 -                                    val _ =
 11.2143 -                                      let
 11.2144 -                                        fun search (x::xs) (y::ys) =
 11.2145 -                                              if x = y then search xs ys else search (x::xs) ys
 11.2146 -                                          | search (_::_) [] =
 11.2147 -                                              raise REFUTE ("IDT_constructor_interpreter",
 11.2148 -                                                "element order not preserved")
 11.2149 -                                          | search [] _ = ()
 11.2150 -                                      in search terms' terms end
 11.2151 -                                    (* int * interpretation list *)
 11.2152 -                                    val (intrs, new_offset) =
 11.2153 -                                      fold_map (fn t_elem => fn off =>
 11.2154 -                                        (* if 't_elem' existed at the previous depth,    *)
 11.2155 -                                        (* proceed recursively, otherwise map the entire *)
 11.2156 -                                        (* subtree to "undefined"                        *)
 11.2157 -                                        if member (op =) terms' t_elem then
 11.2158 -                                          make_constr ds off
 11.2159 -                                        else
 11.2160 -                                          (make_undef ds, off))
 11.2161 -                                      terms offset
 11.2162 -                                  in
 11.2163 -                                    (Node intrs, new_offset)
 11.2164 -                                  end
 11.2165 -                          in
 11.2166 -                            SOME (fst (make_constr ctypes offset), model, args)
 11.2167 -                          end
 11.2168 -                    end
 11.2169 -                | NONE =>  (* body type is not an inductive datatype *)
 11.2170 -                    NONE)
 11.2171 -            | _ =>  (* body type is a (free or schematic) type variable *)
 11.2172 -              NONE)
 11.2173 -        | _ =>  (* term is not a constant *)
 11.2174 -          NONE)
 11.2175 -  end;
 11.2176 -
 11.2177 -(* Difficult code ahead.  Make sure you understand the                *)
 11.2178 -(* 'IDT_constructor_interpreter' and the order in which it enumerates *)
 11.2179 -(* elements of an IDT before you try to understand this function.     *)
 11.2180 -
 11.2181 -fun IDT_recursion_interpreter ctxt model args t =
 11.2182 -  let
 11.2183 -    val thy = Proof_Context.theory_of ctxt
 11.2184 -  in
 11.2185 -    (* careful: here we descend arbitrarily deep into 't', possibly before *)
 11.2186 -    (* any other interpreter for atomic terms has had a chance to look at  *)
 11.2187 -    (* 't'                                                                 *)
 11.2188 -    case strip_comb t of
 11.2189 -      (Const (s, T), params) =>
 11.2190 -        (* iterate over all datatypes in 'thy' *)
 11.2191 -        Symtab.fold (fn (_, info) => fn result =>
 11.2192 -          case result of
 11.2193 -            SOME _ =>
 11.2194 -              result  (* just keep 'result' *)
 11.2195 -          | NONE =>
 11.2196 -              if member (op =) (#rec_names info) s then
 11.2197 -                (* we do have a recursion operator of one of the (mutually *)
 11.2198 -                (* recursive) datatypes given by 'info'                    *)
 11.2199 -                let
 11.2200 -                  (* number of all constructors, including those of different  *)
 11.2201 -                  (* (mutually recursive) datatypes within the same descriptor *)
 11.2202 -                  val mconstrs_count =
 11.2203 -                    Integer.sum (map (fn (_, (_, _, cs)) => length cs) (#descr info))
 11.2204 -                in
 11.2205 -                  if mconstrs_count < length params then
 11.2206 -                    (* too many actual parameters; for now we'll use the *)
 11.2207 -                    (* 'stlc_interpreter' to strip off one application   *)
 11.2208 -                    NONE
 11.2209 -                  else if mconstrs_count > length params then
 11.2210 -                    (* too few actual parameters; we use eta expansion          *)
 11.2211 -                    (* Note that the resulting expansion of lambda abstractions *)
 11.2212 -                    (* by the 'stlc_interpreter' may be rather slow (depending  *)
 11.2213 -                    (* on the argument types and the size of the IDT, of        *)
 11.2214 -                    (* course).                                                 *)
 11.2215 -                    SOME (interpret ctxt model args (eta_expand t
 11.2216 -                      (mconstrs_count - length params)))
 11.2217 -                  else  (* mconstrs_count = length params *)
 11.2218 -                    let
 11.2219 -                      (* interpret each parameter separately *)
 11.2220 -                      val (p_intrs, (model', args')) = fold_map (fn p => fn (m, a) =>
 11.2221 -                        let
 11.2222 -                          val (i, m', a') = interpret ctxt m a p
 11.2223 -                        in
 11.2224 -                          (i, (m', a'))
 11.2225 -                        end) params (model, args)
 11.2226 -                      val (typs, _) = model'
 11.2227 -                      (* 'index' is /not/ necessarily the index of the IDT that *)
 11.2228 -                      (* the recursion operator is associated with, but merely  *)
 11.2229 -                      (* the index of some mutually recursive IDT               *)
 11.2230 -                      val index         = #index info
 11.2231 -                      val descr         = #descr info
 11.2232 -                      val (_, dtyps, _) = the (AList.lookup (op =) descr index)
 11.2233 -                      (* sanity check: we assume that the order of constructors *)
 11.2234 -                      (*               in 'descr' is the same as the order of   *)
 11.2235 -                      (*               corresponding parameters, otherwise the  *)
 11.2236 -                      (*               association code below won't match the   *)
 11.2237 -                      (*               right constructors/parameters; we also   *)
 11.2238 -                      (*               assume that the order of recursion       *)
 11.2239 -                      (*               operators in '#rec_names info' is the    *)
 11.2240 -                      (*               same as the order of corresponding       *)
 11.2241 -                      (*               datatypes in 'descr'                     *)
 11.2242 -                      val _ = if map fst descr <> (0 upto (length descr - 1)) then
 11.2243 -                          raise REFUTE ("IDT_recursion_interpreter",
 11.2244 -                            "order of constructors and corresponding parameters/" ^
 11.2245 -                              "recursion operators and corresponding datatypes " ^
 11.2246 -                              "different?")
 11.2247 -                        else ()
 11.2248 -                      (* sanity check: every element in 'dtyps' must be a *)
 11.2249 -                      (*               'DtTFree'                          *)
 11.2250 -                      val _ =
 11.2251 -                        if Library.exists (fn d =>
 11.2252 -                          case d of Datatype.DtTFree _ => false
 11.2253 -                                  | _ => true) dtyps
 11.2254 -                        then
 11.2255 -                          raise REFUTE ("IDT_recursion_interpreter",
 11.2256 -                            "datatype argument is not a variable")
 11.2257 -                        else ()
 11.2258 -                      (* the type of a recursion operator is *)
 11.2259 -                      (* [T1, ..., Tn, IDT] ---> Tresult     *)
 11.2260 -                      val IDT = nth (binder_types T) mconstrs_count
 11.2261 -                      (* by our assumption on the order of recursion operators *)
 11.2262 -                      (* and datatypes, this is the index of the datatype      *)
 11.2263 -                      (* corresponding to the given recursion operator         *)
 11.2264 -                      val idt_index = find_index (fn s' => s' = s) (#rec_names info)
 11.2265 -                      (* mutually recursive types must have the same type   *)
 11.2266 -                      (* parameters, unless the mutual recursion comes from *)
 11.2267 -                      (* indirect recursion                                 *)
 11.2268 -                      fun rec_typ_assoc acc [] = acc
 11.2269 -                        | rec_typ_assoc acc ((d, T)::xs) =
 11.2270 -                            (case AList.lookup op= acc d of
 11.2271 -                              NONE =>
 11.2272 -                                (case d of
 11.2273 -                                  Datatype.DtTFree _ =>
 11.2274 -                                  (* add the association, proceed *)
 11.2275 -                                  rec_typ_assoc ((d, T)::acc) xs
 11.2276 -                                | Datatype.DtType (s, ds) =>
 11.2277 -                                    let
 11.2278 -                                      val (s', Ts) = dest_Type T
 11.2279 -                                    in
 11.2280 -                                      if s=s' then
 11.2281 -                                        rec_typ_assoc ((d, T)::acc) ((ds ~~ Ts) @ xs)
 11.2282 -                                      else
 11.2283 -                                        raise REFUTE ("IDT_recursion_interpreter",
 11.2284 -                                          "DtType/Type mismatch")
 11.2285 -                                    end
 11.2286 -                                | Datatype.DtRec i =>
 11.2287 -                                    let
 11.2288 -                                      val (_, ds, _) = the (AList.lookup (op =) descr i)
 11.2289 -                                      val (_, Ts)    = dest_Type T
 11.2290 -                                    in
 11.2291 -                                      rec_typ_assoc ((d, T)::acc) ((ds ~~ Ts) @ xs)
 11.2292 -                                    end)
 11.2293 -                            | SOME T' =>
 11.2294 -                                if T=T' then
 11.2295 -                                  (* ignore the association since it's already *)
 11.2296 -                                  (* present, proceed                          *)
 11.2297 -                                  rec_typ_assoc acc xs
 11.2298 -                                else
 11.2299 -                                  raise REFUTE ("IDT_recursion_interpreter",
 11.2300 -                                    "different type associations for the same dtyp"))
 11.2301 -                      val typ_assoc = filter
 11.2302 -                        (fn (Datatype.DtTFree _, _) => true | (_, _) => false)
 11.2303 -                        (rec_typ_assoc []
 11.2304 -                          (#2 (the (AList.lookup (op =) descr idt_index)) ~~ (snd o dest_Type) IDT))
 11.2305 -                      (* sanity check: typ_assoc must associate types to the   *)
 11.2306 -                      (*               elements of 'dtyps' (and only to those) *)
 11.2307 -                      val _ =
 11.2308 -                        if not (eq_set (op =) (dtyps, map fst typ_assoc))
 11.2309 -                        then
 11.2310 -                          raise REFUTE ("IDT_recursion_interpreter",
 11.2311 -                            "type association has extra/missing elements")
 11.2312 -                        else ()
 11.2313 -                      (* interpret each constructor in the descriptor (including *)
 11.2314 -                      (* those of mutually recursive datatypes)                  *)
 11.2315 -                      (* (int * interpretation list) list *)
 11.2316 -                      val mc_intrs = map (fn (idx, (_, _, cs)) =>
 11.2317 -                        let
 11.2318 -                          val c_return_typ = typ_of_dtyp descr typ_assoc
 11.2319 -                            (Datatype.DtRec idx)
 11.2320 -                        in
 11.2321 -                          (idx, map (fn (cname, cargs) =>
 11.2322 -                            (#1 o interpret ctxt (typs, []) {maxvars=0,
 11.2323 -                              def_eq=false, next_idx=1, bounds=[],
 11.2324 -                              wellformed=True}) (Const (cname, map (typ_of_dtyp
 11.2325 -                              descr typ_assoc) cargs ---> c_return_typ))) cs)
 11.2326 -                        end) descr
 11.2327 -                      (* associate constructors with corresponding parameters *)
 11.2328 -                      (* (int * (interpretation * interpretation) list) list *)
 11.2329 -                      val (mc_p_intrs, p_intrs') = fold_map
 11.2330 -                        (fn (idx, c_intrs) => fn p_intrs' =>
 11.2331 -                          let
 11.2332 -                            val len = length c_intrs
 11.2333 -                          in
 11.2334 -                            ((idx, c_intrs ~~ List.take (p_intrs', len)),
 11.2335 -                              List.drop (p_intrs', len))
 11.2336 -                          end) mc_intrs p_intrs
 11.2337 -                      (* sanity check: no 'p_intr' may be left afterwards *)
 11.2338 -                      val _ =
 11.2339 -                        if p_intrs' <> [] then
 11.2340 -                          raise REFUTE ("IDT_recursion_interpreter",
 11.2341 -                            "more parameter than constructor interpretations")
 11.2342 -                        else ()
 11.2343 -                      (* The recursion operator, applied to 'mconstrs_count'     *)
 11.2344 -                      (* arguments, is a function that maps every element of the *)
 11.2345 -                      (* inductive datatype to an element of some result type.   *)
 11.2346 -                      (* Recursion operators for mutually recursive IDTs are     *)
 11.2347 -                      (* translated simultaneously.                              *)
 11.2348 -                      (* Since the order on datatype elements is given by an     *)
 11.2349 -                      (* order on constructors (and then by the order on         *)
 11.2350 -                      (* argument tuples), we can simply copy corresponding      *)
 11.2351 -                      (* subtrees from 'p_intrs', in the order in which they are *)
 11.2352 -                      (* given.                                                  *)
 11.2353 -                      (* interpretation * interpretation -> interpretation list *)
 11.2354 -                      fun ci_pi (Leaf xs, pi) =
 11.2355 -                            (* if the constructor does not match the arguments to a *)
 11.2356 -                            (* defined element of the IDT, the corresponding value  *)
 11.2357 -                            (* of the parameter must be ignored                     *)
 11.2358 -                            if List.exists (equal True) xs then [pi] else []
 11.2359 -                        | ci_pi (Node xs, Node ys) = maps ci_pi (xs ~~ ys)
 11.2360 -                        | ci_pi (Node _, Leaf _) =
 11.2361 -                            raise REFUTE ("IDT_recursion_interpreter",
 11.2362 -                              "constructor takes more arguments than the " ^
 11.2363 -                                "associated parameter")
 11.2364 -                      (* (int * interpretation list) list *)
 11.2365 -                      val rec_operators = map (fn (idx, c_p_intrs) =>
 11.2366 -                        (idx, maps ci_pi c_p_intrs)) mc_p_intrs
 11.2367 -                      (* sanity check: every recursion operator must provide as  *)
 11.2368 -                      (*               many values as the corresponding datatype *)
 11.2369 -                      (*               has elements                              *)
 11.2370 -                      val _ = map (fn (idx, intrs) =>
 11.2371 -                        let
 11.2372 -                          val T = typ_of_dtyp descr typ_assoc
 11.2373 -                            (Datatype.DtRec idx)
 11.2374 -                        in
 11.2375 -                          if length intrs <> size_of_type ctxt (typs, []) T then
 11.2376 -                            raise REFUTE ("IDT_recursion_interpreter",
 11.2377 -                              "wrong number of interpretations for rec. operator")
 11.2378 -                          else ()
 11.2379 -                        end) rec_operators
 11.2380 -                      (* For non-recursive datatypes, we are pretty much done at *)
 11.2381 -                      (* this point.  For recursive datatypes however, we still  *)
 11.2382 -                      (* need to apply the interpretations in 'rec_operators' to *)
 11.2383 -                      (* (recursively obtained) interpretations for recursive    *)
 11.2384 -                      (* constructor arguments.  To do so more efficiently, we   *)
 11.2385 -                      (* copy 'rec_operators' into arrays first.  Each Boolean   *)
 11.2386 -                      (* indicates whether the recursive arguments have been     *)
 11.2387 -                      (* considered already.                                     *)
 11.2388 -                      (* (int * (bool * interpretation) Array.array) list *)
 11.2389 -                      val REC_OPERATORS = map (fn (idx, intrs) =>
 11.2390 -                        (idx, Array.fromList (map (pair false) intrs)))
 11.2391 -                        rec_operators
 11.2392 -                      (* takes an interpretation, and if some leaf of this     *)
 11.2393 -                      (* interpretation is the 'elem'-th element of the type,  *)
 11.2394 -                      (* the indices of the arguments leading to this leaf are *)
 11.2395 -                      (* returned                                              *)
 11.2396 -                      (* interpretation -> int -> int list option *)
 11.2397 -                      fun get_args (Leaf xs) elem =
 11.2398 -                            if find_index (fn x => x = True) xs = elem then
 11.2399 -                              SOME []
 11.2400 -                            else
 11.2401 -                              NONE
 11.2402 -                        | get_args (Node xs) elem =
 11.2403 -                            let
 11.2404 -                              (* interpretation list * int -> int list option *)
 11.2405 -                              fun search ([], _) =
 11.2406 -                                NONE
 11.2407 -                                | search (x::xs, n) =
 11.2408 -                                (case get_args x elem of
 11.2409 -                                  SOME result => SOME (n::result)
 11.2410 -                                | NONE        => search (xs, n+1))
 11.2411 -                            in
 11.2412 -                              search (xs, 0)
 11.2413 -                            end
 11.2414 -                      (* returns the index of the constructor and indices for *)
 11.2415 -                      (* its arguments that generate the 'elem'-th element of *)
 11.2416 -                      (* the datatype given by 'idx'                          *)
 11.2417 -                      (* int -> int -> int * int list *)
 11.2418 -                      fun get_cargs idx elem =
 11.2419 -                        let
 11.2420 -                          (* int * interpretation list -> int * int list *)
 11.2421 -                          fun get_cargs_rec (_, []) =
 11.2422 -                                raise REFUTE ("IDT_recursion_interpreter",
 11.2423 -                                  "no matching constructor found for datatype element")
 11.2424 -                            | get_cargs_rec (n, x::xs) =
 11.2425 -                                (case get_args x elem of
 11.2426 -                                  SOME args => (n, args)
 11.2427 -                                | NONE => get_cargs_rec (n+1, xs))
 11.2428 -                        in
 11.2429 -                          get_cargs_rec (0, the (AList.lookup (op =) mc_intrs idx))
 11.2430 -                        end
 11.2431 -                      (* computes one entry in 'REC_OPERATORS', and recursively *)
 11.2432 -                      (* all entries needed for it, where 'idx' gives the       *)
 11.2433 -                      (* datatype and 'elem' the element of it                  *)
 11.2434 -                      (* int -> int -> interpretation *)
 11.2435 -                      fun compute_array_entry idx elem =
 11.2436 -                        let
 11.2437 -                          val arr = the (AList.lookup (op =) REC_OPERATORS idx)
 11.2438 -                          val (flag, intr) = Array.sub (arr, elem)
 11.2439 -                        in
 11.2440 -                          if flag then
 11.2441 -                            (* simply return the previously computed result *)
 11.2442 -                            intr
 11.2443 -                          else
 11.2444 -                            (* we have to apply 'intr' to interpretations for all *)
 11.2445 -                            (* recursive arguments                                *)
 11.2446 -                            let
 11.2447 -                              (* int * int list *)
 11.2448 -                              val (c, args) = get_cargs idx elem
 11.2449 -                              (* find the indices of the constructor's /recursive/ *)
 11.2450 -                              (* arguments                                         *)
 11.2451 -                              val (_, _, constrs) = the (AList.lookup (op =) descr idx)
 11.2452 -                              val (_, dtyps) = nth constrs c
 11.2453 -                              val rec_dtyps_args = filter
 11.2454 -                                (Datatype_Aux.is_rec_type o fst) (dtyps ~~ args)
 11.2455 -                              (* map those indices to interpretations *)
 11.2456 -                              val rec_dtyps_intrs = map (fn (dtyp, arg) =>
 11.2457 -                                let
 11.2458 -                                  val dT = typ_of_dtyp descr typ_assoc dtyp
 11.2459 -                                  val consts = make_constants ctxt (typs, []) dT
 11.2460 -                                  val arg_i = nth consts arg
 11.2461 -                                in
 11.2462 -                                  (dtyp, arg_i)
 11.2463 -                                end) rec_dtyps_args
 11.2464 -                              (* takes the dtyp and interpretation of an element, *)
 11.2465 -                              (* and computes the interpretation for the          *)
 11.2466 -                              (* corresponding recursive argument                 *)
 11.2467 -                              fun rec_intr (Datatype.DtRec i) (Leaf xs) =
 11.2468 -                                    (* recursive argument is "rec_i params elem" *)
 11.2469 -                                    compute_array_entry i (find_index (fn x => x = True) xs)
 11.2470 -                                | rec_intr (Datatype.DtRec _) (Node _) =
 11.2471 -                                    raise REFUTE ("IDT_recursion_interpreter",
 11.2472 -                                      "interpretation for IDT is a node")
 11.2473 -                                | rec_intr (Datatype.DtType ("fun", [_, dt2])) (Node xs) =
 11.2474 -                                    (* recursive argument is something like     *)
 11.2475 -                                    (* "\<lambda>x::dt1. rec_? params (elem x)" *)
 11.2476 -                                    Node (map (rec_intr dt2) xs)
 11.2477 -                                | rec_intr (Datatype.DtType ("fun", [_, _])) (Leaf _) =
 11.2478 -                                    raise REFUTE ("IDT_recursion_interpreter",
 11.2479 -                                      "interpretation for function dtyp is a leaf")
 11.2480 -                                | rec_intr _ _ =
 11.2481 -                                    (* admissibility ensures that every recursive type *)
 11.2482 -                                    (* is of the form 'Dt_1 -> ... -> Dt_k ->          *)
 11.2483 -                                    (* (DtRec i)'                                      *)
 11.2484 -                                    raise REFUTE ("IDT_recursion_interpreter",
 11.2485 -                                      "non-recursive codomain in recursive dtyp")
 11.2486 -                              (* obtain interpretations for recursive arguments *)
 11.2487 -                              (* interpretation list *)
 11.2488 -                              val arg_intrs = map (uncurry rec_intr) rec_dtyps_intrs
 11.2489 -                              (* apply 'intr' to all recursive arguments *)
 11.2490 -                              val result = fold (fn arg_i => fn i =>
 11.2491 -                                interpretation_apply (i, arg_i)) arg_intrs intr
 11.2492 -                              (* update 'REC_OPERATORS' *)
 11.2493 -                              val _ = Array.update (arr, elem, (true, result))
 11.2494 -                            in
 11.2495 -                              result
 11.2496 -                            end
 11.2497 -                        end
 11.2498 -                      val idt_size = Array.length (the (AList.lookup (op =) REC_OPERATORS idt_index))
 11.2499 -                      (* sanity check: the size of 'IDT' should be 'idt_size' *)
 11.2500 -                      val _ =
 11.2501 -                          if idt_size <> size_of_type ctxt (typs, []) IDT then
 11.2502 -                            raise REFUTE ("IDT_recursion_interpreter",
 11.2503 -                              "unexpected size of IDT (wrong type associated?)")
 11.2504 -                          else ()
 11.2505 -                      (* interpretation *)
 11.2506 -                      val rec_op = Node (map_range (compute_array_entry idt_index) idt_size)
 11.2507 -                    in
 11.2508 -                      SOME (rec_op, model', args')
 11.2509 -                    end
 11.2510 -                end
 11.2511 -              else
 11.2512 -                NONE  (* not a recursion operator of this datatype *)
 11.2513 -          ) (Datatype.get_all thy) NONE
 11.2514 -    | _ =>  (* head of term is not a constant *)
 11.2515 -      NONE
 11.2516 -  end;
 11.2517 -
 11.2518 -fun set_interpreter ctxt model args t =
 11.2519 -  let
 11.2520 -    val (typs, terms) = model
 11.2521 -  in
 11.2522 -    case AList.lookup (op =) terms t of
 11.2523 -      SOME intr =>
 11.2524 -        (* return an existing interpretation *)
 11.2525 -        SOME (intr, model, args)
 11.2526 -    | NONE =>
 11.2527 -        (case t of
 11.2528 -          Free (x, Type (@{type_name set}, [T])) =>
 11.2529 -          let
 11.2530 -            val (intr, _, args') =
 11.2531 -              interpret ctxt (typs, []) args (Free (x, T --> HOLogic.boolT))
 11.2532 -          in
 11.2533 -            SOME (intr, (typs, (t, intr)::terms), args')
 11.2534 -          end
 11.2535 -        | Var ((x, i), Type (@{type_name set}, [T])) =>
 11.2536 -          let
 11.2537 -            val (intr, _, args') =
 11.2538 -              interpret ctxt (typs, []) args (Var ((x,i), T --> HOLogic.boolT))
 11.2539 -          in
 11.2540 -            SOME (intr, (typs, (t, intr)::terms), args')
 11.2541 -          end
 11.2542 -        | Const (s, Type (@{type_name set}, [T])) =>
 11.2543 -          let
 11.2544 -            val (intr, _, args') =
 11.2545 -              interpret ctxt (typs, []) args (Const (s, T --> HOLogic.boolT))
 11.2546 -          in
 11.2547 -            SOME (intr, (typs, (t, intr)::terms), args')
 11.2548 -          end
 11.2549 -        (* 'Collect' == identity *)
 11.2550 -        | Const (@{const_name Collect}, _) $ t1 =>
 11.2551 -            SOME (interpret ctxt model args t1)
 11.2552 -        | Const (@{const_name Collect}, _) =>
 11.2553 -            SOME (interpret ctxt model args (eta_expand t 1))
 11.2554 -        (* 'op :' == application *)
 11.2555 -        | Const (@{const_name Set.member}, _) $ t1 $ t2 =>
 11.2556 -            SOME (interpret ctxt model args (t2 $ t1))
 11.2557 -        | Const (@{const_name Set.member}, _) $ _ =>
 11.2558 -            SOME (interpret ctxt model args (eta_expand t 1))
 11.2559 -        | Const (@{const_name Set.member}, _) =>
 11.2560 -            SOME (interpret ctxt model args (eta_expand t 2))
 11.2561 -        | _ => NONE)
 11.2562 -  end;
 11.2563 -
 11.2564 -(* only an optimization: 'card' could in principle be interpreted with *)
 11.2565 -(* interpreters available already (using its definition), but the code *)
 11.2566 -(* below is more efficient                                             *)
 11.2567 -
 11.2568 -fun Finite_Set_card_interpreter ctxt model args t =
 11.2569 -  case t of
 11.2570 -    Const (@{const_name Finite_Set.card},
 11.2571 -        Type ("fun", [Type (@{type_name set}, [T]), @{typ nat}])) =>
 11.2572 -      let
 11.2573 -        (* interpretation -> int *)
 11.2574 -        fun number_of_elements (Node xs) =
 11.2575 -            fold (fn x => fn n =>
 11.2576 -              if x = TT then
 11.2577 -                n + 1
 11.2578 -              else if x = FF then
 11.2579 -                n
 11.2580 -              else
 11.2581 -                raise REFUTE ("Finite_Set_card_interpreter",
 11.2582 -                  "interpretation for set type does not yield a Boolean"))
 11.2583 -              xs 0
 11.2584 -          | number_of_elements (Leaf _) =
 11.2585 -              raise REFUTE ("Finite_Set_card_interpreter",
 11.2586 -                "interpretation for set type is a leaf")
 11.2587 -        val size_of_nat = size_of_type ctxt model (@{typ nat})
 11.2588 -        (* takes an interpretation for a set and returns an interpretation *)
 11.2589 -        (* for a 'nat' denoting the set's cardinality                      *)
 11.2590 -        (* interpretation -> interpretation *)
 11.2591 -        fun card i =
 11.2592 -          let
 11.2593 -            val n = number_of_elements i
 11.2594 -          in
 11.2595 -            if n < size_of_nat then
 11.2596 -              Leaf ((replicate n False) @ True ::
 11.2597 -                (replicate (size_of_nat-n-1) False))
 11.2598 -            else
 11.2599 -              Leaf (replicate size_of_nat False)
 11.2600 -          end
 11.2601 -        val set_constants = make_constants ctxt model (HOLogic.mk_setT T)
 11.2602 -      in
 11.2603 -        SOME (Node (map card set_constants), model, args)
 11.2604 -      end
 11.2605 -  | _ => NONE;
 11.2606 -
 11.2607 -(* only an optimization: 'finite' could in principle be interpreted with  *)
 11.2608 -(* interpreters available already (using its definition), but the code    *)
 11.2609 -(* below is more efficient                                                *)
 11.2610 -
 11.2611 -fun Finite_Set_finite_interpreter ctxt model args t =
 11.2612 -  case t of
 11.2613 -    Const (@{const_name Finite_Set.finite},
 11.2614 -           Type ("fun", [_, @{typ bool}])) $ _ =>
 11.2615 -        (* we only consider finite models anyway, hence EVERY set is *)
 11.2616 -        (* "finite"                                                  *)
 11.2617 -        SOME (TT, model, args)
 11.2618 -  | Const (@{const_name Finite_Set.finite},
 11.2619 -           Type ("fun", [set_T, @{typ bool}])) =>
 11.2620 -      let
 11.2621 -        val size_of_set = size_of_type ctxt model set_T
 11.2622 -      in
 11.2623 -        (* we only consider finite models anyway, hence EVERY set is *)
 11.2624 -        (* "finite"                                                  *)
 11.2625 -        SOME (Node (replicate size_of_set TT), model, args)
 11.2626 -      end
 11.2627 -  | _ => NONE;
 11.2628 -
 11.2629 -(* only an optimization: 'less' could in principle be interpreted with *)
 11.2630 -(* interpreters available already (using its definition), but the code     *)
 11.2631 -(* below is more efficient                                                 *)
 11.2632 -
 11.2633 -fun Nat_less_interpreter ctxt model args t =
 11.2634 -  case t of
 11.2635 -    Const (@{const_name Orderings.less}, Type ("fun", [@{typ nat},
 11.2636 -        Type ("fun", [@{typ nat}, @{typ bool}])])) =>
 11.2637 -      let
 11.2638 -        val size_of_nat = size_of_type ctxt model (@{typ nat})
 11.2639 -        (* the 'n'-th nat is not less than the first 'n' nats, while it *)
 11.2640 -        (* is less than the remaining 'size_of_nat - n' nats            *)
 11.2641 -        (* int -> interpretation *)
 11.2642 -        fun less n = Node ((replicate n FF) @ (replicate (size_of_nat - n) TT))
 11.2643 -      in
 11.2644 -        SOME (Node (map less (1 upto size_of_nat)), model, args)
 11.2645 -      end
 11.2646 -  | _ => NONE;
 11.2647 -
 11.2648 -(* only an optimization: 'plus' could in principle be interpreted with *)
 11.2649 -(* interpreters available already (using its definition), but the code     *)
 11.2650 -(* below is more efficient                                                 *)
 11.2651 -
 11.2652 -fun Nat_plus_interpreter ctxt model args t =
 11.2653 -  case t of
 11.2654 -    Const (@{const_name Groups.plus}, Type ("fun", [@{typ nat},
 11.2655 -        Type ("fun", [@{typ nat}, @{typ nat}])])) =>
 11.2656 -      let
 11.2657 -        val size_of_nat = size_of_type ctxt model (@{typ nat})
 11.2658 -        (* int -> int -> interpretation *)
 11.2659 -        fun plus m n =
 11.2660 -          let
 11.2661 -            val element = m + n
 11.2662 -          in
 11.2663 -            if element > size_of_nat - 1 then
 11.2664 -              Leaf (replicate size_of_nat False)
 11.2665 -            else
 11.2666 -              Leaf ((replicate element False) @ True ::
 11.2667 -                (replicate (size_of_nat - element - 1) False))
 11.2668 -          end
 11.2669 -      in
 11.2670 -        SOME (Node (map_range (fn m => Node (map_range (plus m) size_of_nat)) size_of_nat),
 11.2671 -          model, args)
 11.2672 -      end
 11.2673 -  | _ => NONE;
 11.2674 -
 11.2675 -(* only an optimization: 'minus' could in principle be interpreted *)
 11.2676 -(* with interpreters available already (using its definition), but the *)
 11.2677 -(* code below is more efficient                                        *)
 11.2678 -
 11.2679 -fun Nat_minus_interpreter ctxt model args t =
 11.2680 -  case t of
 11.2681 -    Const (@{const_name Groups.minus}, Type ("fun", [@{typ nat},
 11.2682 -        Type ("fun", [@{typ nat}, @{typ nat}])])) =>
 11.2683 -      let
 11.2684 -        val size_of_nat = size_of_type ctxt model (@{typ nat})
 11.2685 -        (* int -> int -> interpretation *)
 11.2686 -        fun minus m n =
 11.2687 -          let
 11.2688 -            val element = Int.max (m-n, 0)
 11.2689 -          in
 11.2690 -            Leaf ((replicate element False) @ True ::
 11.2691 -              (replicate (size_of_nat - element - 1) False))
 11.2692 -          end
 11.2693 -      in
 11.2694 -        SOME (Node (map_range (fn m => Node (map_range (minus m) size_of_nat)) size_of_nat),
 11.2695 -          model, args)
 11.2696 -      end
 11.2697 -  | _ => NONE;
 11.2698 -
 11.2699 -(* only an optimization: 'times' could in principle be interpreted *)
 11.2700 -(* with interpreters available already (using its definition), but the *)
 11.2701 -(* code below is more efficient                                        *)
 11.2702 -
 11.2703 -fun Nat_times_interpreter ctxt model args t =
 11.2704 -  case t of
 11.2705 -    Const (@{const_name Groups.times}, Type ("fun", [@{typ nat},
 11.2706 -        Type ("fun", [@{typ nat}, @{typ nat}])])) =>
 11.2707 -      let
 11.2708 -        val size_of_nat = size_of_type ctxt model (@{typ nat})
 11.2709 -        (* nat -> nat -> interpretation *)
 11.2710 -        fun mult m n =
 11.2711 -          let
 11.2712 -            val element = m * n
 11.2713 -          in
 11.2714 -            if element > size_of_nat - 1 then
 11.2715 -              Leaf (replicate size_of_nat False)
 11.2716 -            else
 11.2717 -              Leaf ((replicate element False) @ True ::
 11.2718 -                (replicate (size_of_nat - element - 1) False))
 11.2719 -          end
 11.2720 -      in
 11.2721 -        SOME (Node (map_range (fn m => Node (map_range (mult m) size_of_nat)) size_of_nat),
 11.2722 -          model, args)
 11.2723 -      end
 11.2724 -  | _ => NONE;
 11.2725 -
 11.2726 -(* only an optimization: 'append' could in principle be interpreted with *)
 11.2727 -(* interpreters available already (using its definition), but the code   *)
 11.2728 -(* below is more efficient                                               *)
 11.2729 -
 11.2730 -fun List_append_interpreter ctxt model args t =
 11.2731 -  case t of
 11.2732 -    Const (@{const_name List.append}, Type ("fun", [Type ("List.list", [T]), Type ("fun",
 11.2733 -        [Type ("List.list", [_]), Type ("List.list", [_])])])) =>
 11.2734 -      let
 11.2735 -        val size_elem = size_of_type ctxt model T
 11.2736 -        val size_list = size_of_type ctxt model (Type ("List.list", [T]))
 11.2737 -        (* maximal length of lists; 0 if we only consider the empty list *)
 11.2738 -        val list_length =
 11.2739 -          let
 11.2740 -            (* int -> int -> int -> int *)
 11.2741 -            fun list_length_acc len lists total =
 11.2742 -              if lists = total then
 11.2743 -                len
 11.2744 -              else if lists < total then
 11.2745 -                list_length_acc (len+1) (lists*size_elem) (total-lists)
 11.2746 -              else
 11.2747 -                raise REFUTE ("List_append_interpreter",
 11.2748 -                  "size_list not equal to 1 + size_elem + ... + " ^
 11.2749 -                    "size_elem^len, for some len")
 11.2750 -          in
 11.2751 -            list_length_acc 0 1 size_list
 11.2752 -          end
 11.2753 -        val elements = 0 upto (size_list-1)
 11.2754 -        (* FIXME: there should be a nice formula, which computes the same as *)
 11.2755 -        (*        the following, but without all this intermediate tree      *)
 11.2756 -        (*        length/offset stuff                                        *)
 11.2757 -        (* associate each list with its length and offset in a complete tree *)
 11.2758 -        (* of width 'size_elem' and depth 'length_list' (with 'size_list'    *)
 11.2759 -        (* nodes total)                                                      *)
 11.2760 -        (* (int * (int * int)) list *)
 11.2761 -        val (lenoff_lists, _) = fold_map (fn elem => fn (offsets, off) =>
 11.2762 -          (* corresponds to a pre-order traversal of the tree *)
 11.2763 -          let
 11.2764 -            val len = length offsets
 11.2765 -            (* associate the given element with len/off *)
 11.2766 -            val assoc = (elem, (len, off))
 11.2767 -          in
 11.2768 -            if len < list_length then
 11.2769 -              (* go to first child node *)
 11.2770 -              (assoc, (off :: offsets, off * size_elem))
 11.2771 -            else if off mod size_elem < size_elem - 1 then
 11.2772 -              (* go to next sibling node *)
 11.2773 -              (assoc, (offsets, off + 1))
 11.2774 -            else
 11.2775 -              (* go back up the stack until we find a level where we can go *)
 11.2776 -              (* to the next sibling node                                   *)
 11.2777 -              let
 11.2778 -                val offsets' = snd (take_prefix
 11.2779 -                  (fn off' => off' mod size_elem = size_elem - 1) offsets)
 11.2780 -              in
 11.2781 -                case offsets' of
 11.2782 -                  [] =>
 11.2783 -                    (* we're at the last node in the tree; the next value *)
 11.2784 -                    (* won't be used anyway                               *)
 11.2785 -                    (assoc, ([], 0))
 11.2786 -                | off'::offs' =>
 11.2787 -                    (* go to next sibling node *)
 11.2788 -                    (assoc, (offs', off' + 1))
 11.2789 -              end
 11.2790 -          end) elements ([], 0)
 11.2791 -        (* we also need the reverse association (from length/offset to *)
 11.2792 -        (* index)                                                      *)
 11.2793 -        val lenoff'_lists = map Library.swap lenoff_lists
 11.2794 -        (* returns the interpretation for "(list no. m) @ (list no. n)" *)
 11.2795 -        (* nat -> nat -> interpretation *)
 11.2796 -        fun append m n =
 11.2797 -          let
 11.2798 -            val (len_m, off_m) = the (AList.lookup (op =) lenoff_lists m)
 11.2799 -            val (len_n, off_n) = the (AList.lookup (op =) lenoff_lists n)
 11.2800 -            val len_elem = len_m + len_n
 11.2801 -            val off_elem = off_m * Integer.pow len_n size_elem + off_n
 11.2802 -          in
 11.2803 -            case AList.lookup op= lenoff'_lists (len_elem, off_elem) of
 11.2804 -              NONE =>
 11.2805 -                (* undefined *)
 11.2806 -                Leaf (replicate size_list False)
 11.2807 -            | SOME element =>
 11.2808 -                Leaf ((replicate element False) @ True ::
 11.2809 -                  (replicate (size_list - element - 1) False))
 11.2810 -          end
 11.2811 -      in
 11.2812 -        SOME (Node (map (fn m => Node (map (append m) elements)) elements),
 11.2813 -          model, args)
 11.2814 -      end
 11.2815 -  | _ => NONE;
 11.2816 -
 11.2817 -(* only an optimization: 'lfp' could in principle be interpreted with  *)
 11.2818 -(* interpreters available already (using its definition), but the code *)
 11.2819 -(* below is more efficient                                             *)
 11.2820 -
 11.2821 -fun lfp_interpreter ctxt model args t =
 11.2822 -  case t of
 11.2823 -    Const (@{const_name lfp}, Type ("fun", [Type ("fun",
 11.2824 -      [Type (@{type_name set}, [T]),
 11.2825 -       Type (@{type_name set}, [_])]),
 11.2826 -       Type (@{type_name set}, [_])])) =>
 11.2827 -      let
 11.2828 -        val size_elem = size_of_type ctxt model T
 11.2829 -        (* the universe (i.e. the set that contains every element) *)
 11.2830 -        val i_univ = Node (replicate size_elem TT)
 11.2831 -        (* all sets with elements from type 'T' *)
 11.2832 -        val i_sets = make_constants ctxt model (HOLogic.mk_setT T)
 11.2833 -        (* all functions that map sets to sets *)
 11.2834 -        val i_funs = make_constants ctxt model (Type ("fun",
 11.2835 -          [HOLogic.mk_setT T, HOLogic.mk_setT T]))
 11.2836 -        (* "lfp(f) == Inter({u. f(u) <= u})" *)
 11.2837 -        (* interpretation * interpretation -> bool *)
 11.2838 -        fun is_subset (Node subs, Node sups) =
 11.2839 -              forall (fn (sub, sup) => (sub = FF) orelse (sup = TT)) (subs ~~ sups)
 11.2840 -          | is_subset (_, _) =
 11.2841 -              raise REFUTE ("lfp_interpreter",
 11.2842 -                "is_subset: interpretation for set is not a node")
 11.2843 -        (* interpretation * interpretation -> interpretation *)
 11.2844 -        fun intersection (Node xs, Node ys) =
 11.2845 -              Node (map (fn (x, y) => if x=TT andalso y=TT then TT else FF)
 11.2846 -                (xs ~~ ys))
 11.2847 -          | intersection (_, _) =
 11.2848 -              raise REFUTE ("lfp_interpreter",
 11.2849 -                "intersection: interpretation for set is not a node")
 11.2850 -        (* interpretation -> interpretaion *)
 11.2851 -        fun lfp (Node resultsets) =
 11.2852 -              fold (fn (set, resultset) => fn acc =>
 11.2853 -                if is_subset (resultset, set) then
 11.2854 -                  intersection (acc, set)
 11.2855 -                else
 11.2856 -                  acc) (i_sets ~~ resultsets) i_univ
 11.2857 -          | lfp _ =
 11.2858 -              raise REFUTE ("lfp_interpreter",
 11.2859 -                "lfp: interpretation for function is not a node")
 11.2860 -      in
 11.2861 -        SOME (Node (map lfp i_funs), model, args)
 11.2862 -      end
 11.2863 -  | _ => NONE;
 11.2864 -
 11.2865 -(* only an optimization: 'gfp' could in principle be interpreted with  *)
 11.2866 -(* interpreters available already (using its definition), but the code *)
 11.2867 -(* below is more efficient                                             *)
 11.2868 -
 11.2869 -fun gfp_interpreter ctxt model args t =
 11.2870 -  case t of
 11.2871 -    Const (@{const_name gfp}, Type ("fun", [Type ("fun",
 11.2872 -      [Type (@{type_name set}, [T]),
 11.2873 -       Type (@{type_name set}, [_])]),
 11.2874 -       Type (@{type_name set}, [_])])) =>
 11.2875 -      let
 11.2876 -        val size_elem = size_of_type ctxt model T
 11.2877 -        (* the universe (i.e. the set that contains every element) *)
 11.2878 -        val i_univ = Node (replicate size_elem TT)
 11.2879 -        (* all sets with elements from type 'T' *)
 11.2880 -        val i_sets = make_constants ctxt model (HOLogic.mk_setT T)
 11.2881 -        (* all functions that map sets to sets *)
 11.2882 -        val i_funs = make_constants ctxt model (Type ("fun",
 11.2883 -          [HOLogic.mk_setT T, HOLogic.mk_setT T]))
 11.2884 -        (* "gfp(f) == Union({u. u <= f(u)})" *)
 11.2885 -        (* interpretation * interpretation -> bool *)
 11.2886 -        fun is_subset (Node subs, Node sups) =
 11.2887 -              forall (fn (sub, sup) => (sub = FF) orelse (sup = TT))
 11.2888 -                (subs ~~ sups)
 11.2889 -          | is_subset (_, _) =
 11.2890 -              raise REFUTE ("gfp_interpreter",
 11.2891 -                "is_subset: interpretation for set is not a node")
 11.2892 -        (* interpretation * interpretation -> interpretation *)
 11.2893 -        fun union (Node xs, Node ys) =
 11.2894 -              Node (map (fn (x,y) => if x=TT orelse y=TT then TT else FF)
 11.2895 -                   (xs ~~ ys))
 11.2896 -          | union (_, _) =
 11.2897 -              raise REFUTE ("gfp_interpreter",
 11.2898 -                "union: interpretation for set is not a node")
 11.2899 -        (* interpretation -> interpretaion *)
 11.2900 -        fun gfp (Node resultsets) =
 11.2901 -              fold (fn (set, resultset) => fn acc =>
 11.2902 -                if is_subset (set, resultset) then
 11.2903 -                  union (acc, set)
 11.2904 -                else
 11.2905 -                  acc) (i_sets ~~ resultsets) i_univ
 11.2906 -          | gfp _ =
 11.2907 -              raise REFUTE ("gfp_interpreter",
 11.2908 -                "gfp: interpretation for function is not a node")
 11.2909 -      in
 11.2910 -        SOME (Node (map gfp i_funs), model, args)
 11.2911 -      end
 11.2912 -  | _ => NONE;
 11.2913 -
 11.2914 -(* only an optimization: 'fst' could in principle be interpreted with  *)
 11.2915 -(* interpreters available already (using its definition), but the code *)
 11.2916 -(* below is more efficient                                             *)
 11.2917 -
 11.2918 -fun Product_Type_fst_interpreter ctxt model args t =
 11.2919 -  case t of
 11.2920 -    Const (@{const_name fst}, Type ("fun", [Type (@{type_name Product_Type.prod}, [T, U]), _])) =>
 11.2921 -      let
 11.2922 -        val constants_T = make_constants ctxt model T
 11.2923 -        val size_U = size_of_type ctxt model U
 11.2924 -      in
 11.2925 -        SOME (Node (maps (replicate size_U) constants_T), model, args)
 11.2926 -      end
 11.2927 -  | _ => NONE;
 11.2928 -
 11.2929 -(* only an optimization: 'snd' could in principle be interpreted with  *)
 11.2930 -(* interpreters available already (using its definition), but the code *)
 11.2931 -(* below is more efficient                                             *)
 11.2932 -
 11.2933 -fun Product_Type_snd_interpreter ctxt model args t =
 11.2934 -  case t of
 11.2935 -    Const (@{const_name snd}, Type ("fun", [Type (@{type_name Product_Type.prod}, [T, U]), _])) =>
 11.2936 -      let
 11.2937 -        val size_T = size_of_type ctxt model T
 11.2938 -        val constants_U = make_constants ctxt model U
 11.2939 -      in
 11.2940 -        SOME (Node (flat (replicate size_T constants_U)), model, args)
 11.2941 -      end
 11.2942 -  | _ => NONE;
 11.2943 -
 11.2944 -
 11.2945 -(* ------------------------------------------------------------------------- *)
 11.2946 -(* PRINTERS                                                                  *)
 11.2947 -(* ------------------------------------------------------------------------- *)
 11.2948 -
 11.2949 -fun stlc_printer ctxt model T intr assignment =
 11.2950 -  let
 11.2951 -    (* string -> string *)
 11.2952 -    val strip_leading_quote = perhaps (try (unprefix "'"))
 11.2953 -    (* Term.typ -> string *)
 11.2954 -    fun string_of_typ (Type (s, _)) = s
 11.2955 -      | string_of_typ (TFree (x, _)) = strip_leading_quote x
 11.2956 -      | string_of_typ (TVar ((x,i), _)) =
 11.2957 -          strip_leading_quote x ^ string_of_int i
 11.2958 -    (* interpretation -> int *)
 11.2959 -    fun index_from_interpretation (Leaf xs) =
 11.2960 -          find_index (Prop_Logic.eval assignment) xs
 11.2961 -      | index_from_interpretation _ =
 11.2962 -          raise REFUTE ("stlc_printer",
 11.2963 -            "interpretation for ground type is not a leaf")
 11.2964 -  in
 11.2965 -    case T of
 11.2966 -      Type ("fun", [T1, T2]) =>
 11.2967 -        let
 11.2968 -          (* create all constants of type 'T1' *)
 11.2969 -          val constants = make_constants ctxt model T1
 11.2970 -          (* interpretation list *)
 11.2971 -          val results =
 11.2972 -            (case intr of
 11.2973 -              Node xs => xs
 11.2974 -            | _ => raise REFUTE ("stlc_printer",
 11.2975 -              "interpretation for function type is a leaf"))
 11.2976 -          (* Term.term list *)
 11.2977 -          val pairs = map (fn (arg, result) =>
 11.2978 -            HOLogic.mk_prod
 11.2979 -              (print ctxt model T1 arg assignment,
 11.2980 -               print ctxt model T2 result assignment))
 11.2981 -            (constants ~~ results)
 11.2982 -          (* Term.typ *)
 11.2983 -          val HOLogic_prodT = HOLogic.mk_prodT (T1, T2)
 11.2984 -          val HOLogic_setT  = HOLogic.mk_setT HOLogic_prodT
 11.2985 -          (* Term.term *)
 11.2986 -          val HOLogic_empty_set = Const (@{const_abbrev Set.empty}, HOLogic_setT)
 11.2987 -          val HOLogic_insert    =
 11.2988 -            Const (@{const_name insert}, HOLogic_prodT --> HOLogic_setT --> HOLogic_setT)
 11.2989 -        in
 11.2990 -          SOME (fold_rev (fn pair => fn acc => HOLogic_insert $ pair $ acc) pairs HOLogic_empty_set)
 11.2991 -        end
 11.2992 -    | Type ("prop", []) =>
 11.2993 -        (case index_from_interpretation intr of
 11.2994 -          ~1 => SOME (HOLogic.mk_Trueprop (Const (@{const_name undefined}, HOLogic.boolT)))
 11.2995 -        | 0  => SOME (HOLogic.mk_Trueprop @{term True})
 11.2996 -        | 1  => SOME (HOLogic.mk_Trueprop @{term False})
 11.2997 -        | _  => raise REFUTE ("stlc_interpreter",
 11.2998 -          "illegal interpretation for a propositional value"))
 11.2999 -    | Type _  =>
 11.3000 -        if index_from_interpretation intr = (~1) then
 11.3001 -          SOME (Const (@{const_name undefined}, T))
 11.3002 -        else
 11.3003 -          SOME (Const (string_of_typ T ^
 11.3004 -            string_of_int (index_from_interpretation intr), T))
 11.3005 -    | TFree _ =>
 11.3006 -        if index_from_interpretation intr = (~1) then
 11.3007 -          SOME (Const (@{const_name undefined}, T))
 11.3008 -        else
 11.3009 -          SOME (Const (string_of_typ T ^
 11.3010 -            string_of_int (index_from_interpretation intr), T))
 11.3011 -    | TVar _  =>
 11.3012 -        if index_from_interpretation intr = (~1) then
 11.3013 -          SOME (Const (@{const_name undefined}, T))
 11.3014 -        else
 11.3015 -          SOME (Const (string_of_typ T ^
 11.3016 -            string_of_int (index_from_interpretation intr), T))
 11.3017 -  end;
 11.3018 -
 11.3019 -fun set_printer ctxt model T intr assignment =
 11.3020 -  (case T of
 11.3021 -    Type (@{type_name set}, [T1]) =>
 11.3022 -    let
 11.3023 -      (* create all constants of type 'T1' *)
 11.3024 -      val constants = make_constants ctxt model T1
 11.3025 -      (* interpretation list *)
 11.3026 -      val results = (case intr of
 11.3027 -          Node xs => xs
 11.3028 -        | _       => raise REFUTE ("set_printer",
 11.3029 -          "interpretation for set type is a leaf"))
 11.3030 -      (* Term.term list *)
 11.3031 -      val elements = List.mapPartial (fn (arg, result) =>
 11.3032 -        case result of
 11.3033 -          Leaf [fmTrue, (* fmFalse *) _] =>
 11.3034 -          if Prop_Logic.eval assignment fmTrue then
 11.3035 -            SOME (print ctxt model T1 arg assignment)
 11.3036 -          else (* if Prop_Logic.eval assignment fmFalse then *)
 11.3037 -            NONE
 11.3038 -        | _ =>
 11.3039 -          raise REFUTE ("set_printer",
 11.3040 -            "illegal interpretation for a Boolean value"))
 11.3041 -        (constants ~~ results)
 11.3042 -      (* Term.typ *)
 11.3043 -      val HOLogic_setT1     = HOLogic.mk_setT T1
 11.3044 -      (* Term.term *)
 11.3045 -      val HOLogic_empty_set = Const (@{const_abbrev Set.empty}, HOLogic_setT1)
 11.3046 -      val HOLogic_insert    =
 11.3047 -        Const (@{const_name insert}, T1 --> HOLogic_setT1 --> HOLogic_setT1)
 11.3048 -    in
 11.3049 -      SOME (Library.foldl (fn (acc, elem) => HOLogic_insert $ elem $ acc)
 11.3050 -        (HOLogic_empty_set, elements))
 11.3051 -    end
 11.3052 -  | _ =>
 11.3053 -    NONE);
 11.3054 -
 11.3055 -fun IDT_printer ctxt model T intr assignment =
 11.3056 -  let
 11.3057 -    val thy = Proof_Context.theory_of ctxt
 11.3058 -  in
 11.3059 -    (case T of
 11.3060 -      Type (s, Ts) =>
 11.3061 -        (case Datatype.get_info thy s of
 11.3062 -          SOME info =>  (* inductive datatype *)
 11.3063 -            let
 11.3064 -              val (typs, _)           = model
 11.3065 -              val index               = #index info
 11.3066 -              val descr               = #descr info
 11.3067 -              val (_, dtyps, constrs) = the (AList.lookup (op =) descr index)
 11.3068 -              val typ_assoc           = dtyps ~~ Ts
 11.3069 -              (* sanity check: every element in 'dtyps' must be a 'DtTFree' *)
 11.3070 -              val _ =
 11.3071 -                if Library.exists (fn d =>
 11.3072 -                  case d of Datatype.DtTFree _ => false | _ => true) dtyps
 11.3073 -                then
 11.3074 -                  raise REFUTE ("IDT_printer", "datatype argument (for type " ^
 11.3075 -                    Syntax.string_of_typ ctxt (Type (s, Ts)) ^ ") is not a variable")
 11.3076 -                else ()
 11.3077 -              (* the index of the element in the datatype *)
 11.3078 -              val element =
 11.3079 -                (case intr of
 11.3080 -                  Leaf xs => find_index (Prop_Logic.eval assignment) xs
 11.3081 -                | Node _  => raise REFUTE ("IDT_printer",
 11.3082 -                  "interpretation is not a leaf"))
 11.3083 -            in
 11.3084 -              if element < 0 then
 11.3085 -                SOME (Const (@{const_name undefined}, Type (s, Ts)))
 11.3086 -              else
 11.3087 -                let
 11.3088 -                  (* takes a datatype constructor, and if for some arguments this  *)
 11.3089 -                  (* constructor generates the datatype's element that is given by *)
 11.3090 -                  (* 'element', returns the constructor (as a term) as well as the *)
 11.3091 -                  (* indices of the arguments                                      *)
 11.3092 -                  fun get_constr_args (cname, cargs) =
 11.3093 -                    let
 11.3094 -                      val cTerm      = Const (cname,
 11.3095 -                        map (typ_of_dtyp descr typ_assoc) cargs ---> Type (s, Ts))
 11.3096 -                      val (iC, _, _) = interpret ctxt (typs, []) {maxvars=0,
 11.3097 -                        def_eq=false, next_idx=1, bounds=[], wellformed=True} cTerm
 11.3098 -                      (* interpretation -> int list option *)
 11.3099 -                      fun get_args (Leaf xs) =
 11.3100 -                            if find_index (fn x => x = True) xs = element then
 11.3101 -                              SOME []
 11.3102 -                            else
 11.3103 -                              NONE
 11.3104 -                        | get_args (Node xs) =
 11.3105 -                            let
 11.3106 -                              (* interpretation * int -> int list option *)
 11.3107 -                              fun search ([], _) =
 11.3108 -                                NONE
 11.3109 -                                | search (x::xs, n) =
 11.3110 -                                (case get_args x of
 11.3111 -                                  SOME result => SOME (n::result)
 11.3112 -                                | NONE        => search (xs, n+1))
 11.3113 -                            in
 11.3114 -                              search (xs, 0)
 11.3115 -                            end
 11.3116 -                    in
 11.3117 -                      Option.map (fn args => (cTerm, cargs, args)) (get_args iC)
 11.3118 -                    end
 11.3119 -                  val (cTerm, cargs, args) =
 11.3120 -                    (* we could speed things up by computing the correct          *)
 11.3121 -                    (* constructor directly (rather than testing all              *)
 11.3122 -                    (* constructors), based on the order in which constructors    *)
 11.3123 -                    (* generate elements of datatypes; the current implementation *)
 11.3124 -                    (* of 'IDT_printer' however is independent of the internals   *)
 11.3125 -                    (* of 'IDT_constructor_interpreter'                           *)
 11.3126 -                    (case get_first get_constr_args constrs of
 11.3127 -                      SOME x => x
 11.3128 -                    | NONE   => raise REFUTE ("IDT_printer",
 11.3129 -                      "no matching constructor found for element " ^
 11.3130 -                      string_of_int element))
 11.3131 -                  val argsTerms = map (fn (d, n) =>
 11.3132 -                    let
 11.3133 -                      val dT = typ_of_dtyp descr typ_assoc d
 11.3134 -                      (* we only need the n-th element of this list, so there   *)
 11.3135 -                      (* might be a more efficient implementation that does not *)
 11.3136 -                      (* generate all constants                                 *)
 11.3137 -                      val consts = make_constants ctxt (typs, []) dT
 11.3138 -                    in
 11.3139 -                      print ctxt (typs, []) dT (nth consts n) assignment
 11.3140 -                    end) (cargs ~~ args)
 11.3141 -                in
 11.3142 -                  SOME (list_comb (cTerm, argsTerms))
 11.3143 -                end
 11.3144 -            end
 11.3145 -        | NONE =>  (* not an inductive datatype *)
 11.3146 -            NONE)
 11.3147 -    | _ =>  (* a (free or schematic) type variable *)
 11.3148 -        NONE)
 11.3149 -  end;
 11.3150 -
 11.3151 -
 11.3152 -(* ------------------------------------------------------------------------- *)
 11.3153 -(* use 'setup Refute.setup' in an Isabelle theory to initialize the 'Refute' *)
 11.3154 -(* structure                                                                 *)
 11.3155 -(* ------------------------------------------------------------------------- *)
 11.3156 -
 11.3157 -(* ------------------------------------------------------------------------- *)
 11.3158 -(* Note: the interpreters and printers are used in reverse order; however,   *)
 11.3159 -(*       an interpreter that can handle non-atomic terms ends up being       *)
 11.3160 -(*       applied before the 'stlc_interpreter' breaks the term apart into    *)
 11.3161 -(*       subterms that are then passed to other interpreters!                *)
 11.3162 -(* ------------------------------------------------------------------------- *)
 11.3163 -
 11.3164 -val setup =
 11.3165 -   add_interpreter "stlc"    stlc_interpreter #>
 11.3166 -   add_interpreter "Pure"    Pure_interpreter #>
 11.3167 -   add_interpreter "HOLogic" HOLogic_interpreter #>
 11.3168 -   add_interpreter "set"     set_interpreter #>
 11.3169 -   add_interpreter "IDT"             IDT_interpreter #>
 11.3170 -   add_interpreter "IDT_constructor" IDT_constructor_interpreter #>
 11.3171 -   add_interpreter "IDT_recursion"   IDT_recursion_interpreter #>
 11.3172 -   add_interpreter "Finite_Set.card"    Finite_Set_card_interpreter #>
 11.3173 -   add_interpreter "Finite_Set.finite"  Finite_Set_finite_interpreter #>
 11.3174 -   add_interpreter "Nat_Orderings.less" Nat_less_interpreter #>
 11.3175 -   add_interpreter "Nat_HOL.plus"       Nat_plus_interpreter #>
 11.3176 -   add_interpreter "Nat_HOL.minus"      Nat_minus_interpreter #>
 11.3177 -   add_interpreter "Nat_HOL.times"      Nat_times_interpreter #>
 11.3178 -   add_interpreter "List.append" List_append_interpreter #>
 11.3179 -(* UNSOUND
 11.3180 -   add_interpreter "lfp" lfp_interpreter #>
 11.3181 -   add_interpreter "gfp" gfp_interpreter #>
 11.3182 -*)
 11.3183 -   add_interpreter "Product_Type.fst" Product_Type_fst_interpreter #>
 11.3184 -   add_interpreter "Product_Type.snd" Product_Type_snd_interpreter #>
 11.3185 -   add_printer "stlc" stlc_printer #>
 11.3186 -   add_printer "set" set_printer #>
 11.3187 -   add_printer "IDT"  IDT_printer;
 11.3188 -
 11.3189 -
 11.3190 -
 11.3191 -(** outer syntax commands 'refute' and 'refute_params' **)
 11.3192 -
 11.3193 -(* argument parsing *)
 11.3194 -
 11.3195 -(*optional list of arguments of the form [name1=value1, name2=value2, ...]*)
 11.3196 -
 11.3197 -val scan_parm = Parse.name -- (Scan.optional (@{keyword "="} |-- Parse.name) "true")
 11.3198 -val scan_parms = Scan.optional (@{keyword "["} |-- Parse.list scan_parm --| @{keyword "]"}) [];
 11.3199 -
 11.3200 -
 11.3201 -(* 'refute' command *)
 11.3202 -
 11.3203 -val _ =
 11.3204 -  Outer_Syntax.improper_command @{command_spec "refute"}
 11.3205 -    "try to find a model that refutes a given subgoal"
 11.3206 -    (scan_parms -- Scan.optional Parse.nat 1 >>
 11.3207 -      (fn (parms, i) =>
 11.3208 -        Toplevel.keep (fn state =>
 11.3209 -          let
 11.3210 -            val ctxt = Toplevel.context_of state;
 11.3211 -            val {goal = st, ...} = Proof.raw_goal (Toplevel.proof_of state);
 11.3212 -          in refute_goal ctxt parms st i; () end)));
 11.3213 -
 11.3214 -
 11.3215 -(* 'refute_params' command *)
 11.3216 -
 11.3217 -val _ =
 11.3218 -  Outer_Syntax.command @{command_spec "refute_params"}
 11.3219 -    "show/store default parameters for the 'refute' command"
 11.3220 -    (scan_parms >> (fn parms =>
 11.3221 -      Toplevel.theory (fn thy =>
 11.3222 -        let
 11.3223 -          val thy' = fold set_default_param parms thy;
 11.3224 -          val output =
 11.3225 -            (case get_default_params (Proof_Context.init_global thy') of
 11.3226 -              [] => "none"
 11.3227 -            | new_defaults => cat_lines (map (fn (x, y) => x ^ "=" ^ y) new_defaults));
 11.3228 -          val _ = writeln ("Default parameters for 'refute':\n" ^ output);
 11.3229 -        in thy' end)));
 11.3230 -
 11.3231 -end;
 11.3232 -