moved Nunchaku to Main; the goal is to move Nitpick out in the next 1-2 years
authorblanchet
Fri Sep 08 00:01:36 2017 +0200 (20 months ago)
changeset 666141f1c5d85d232
parent 66613 db3969568560
child 66615 7706577cd10e
moved Nunchaku to Main; the goal is to move Nitpick out in the next 1-2 years
NEWS
src/HOL/Main.thy
src/HOL/Nunchaku.thy
src/HOL/Nunchaku/Nunchaku.thy
src/HOL/Nunchaku/Tools/nunchaku.ML
src/HOL/Nunchaku/Tools/nunchaku_collect.ML
src/HOL/Nunchaku/Tools/nunchaku_commands.ML
src/HOL/Nunchaku/Tools/nunchaku_display.ML
src/HOL/Nunchaku/Tools/nunchaku_model.ML
src/HOL/Nunchaku/Tools/nunchaku_problem.ML
src/HOL/Nunchaku/Tools/nunchaku_reconstruct.ML
src/HOL/Nunchaku/Tools/nunchaku_tool.ML
src/HOL/Nunchaku/Tools/nunchaku_translate.ML
src/HOL/Nunchaku/Tools/nunchaku_util.ML
src/HOL/Tools/Nunchaku/nunchaku.ML
src/HOL/Tools/Nunchaku/nunchaku_collect.ML
src/HOL/Tools/Nunchaku/nunchaku_commands.ML
src/HOL/Tools/Nunchaku/nunchaku_display.ML
src/HOL/Tools/Nunchaku/nunchaku_model.ML
src/HOL/Tools/Nunchaku/nunchaku_problem.ML
src/HOL/Tools/Nunchaku/nunchaku_reconstruct.ML
src/HOL/Tools/Nunchaku/nunchaku_tool.ML
src/HOL/Tools/Nunchaku/nunchaku_translate.ML
src/HOL/Tools/Nunchaku/nunchaku_util.ML
     1.1 --- a/NEWS	Thu Sep 07 23:13:15 2017 +0200
     1.2 +++ b/NEWS	Fri Sep 08 00:01:36 2017 +0200
     1.3 @@ -134,6 +134,8 @@
     1.4  
     1.5  *** HOL ***
     1.6  
     1.7 +* The Nunchaku model finder is now part of "Main".
     1.8 +
     1.9  * SMT module:
    1.10    - A new option, 'smt_nat_as_int', has been added to translate 'nat' to
    1.11      'int' and benefit from the SMT solver's theory reasoning. It is
    1.12 @@ -569,7 +571,7 @@
    1.13  quantifier-free propositional logic with linear real arithmetic
    1.14  including min/max/abs. See HOL/ex/Argo_Examples.thy for examples.
    1.15  
    1.16 -* The new "nunchaku" program integrates the Nunchaku model finder. The
    1.17 +* The new "nunchaku" command integrates the Nunchaku model finder. The
    1.18  tool is experimental. See ~~/src/HOL/Nunchaku/Nunchaku.thy for details.
    1.19  
    1.20  * Metis: The problem encoding has changed very slightly. This might
     2.1 --- a/src/HOL/Main.thy	Thu Sep 07 23:13:15 2017 +0200
     2.2 +++ b/src/HOL/Main.thy	Fri Sep 08 00:01:36 2017 +0200
     2.3 @@ -6,7 +6,7 @@
     2.4  \<close>
     2.5  
     2.6  theory Main
     2.7 -imports Predicate_Compile Quickcheck_Narrowing Extraction Nitpick BNF_Greatest_Fixpoint Filter Conditionally_Complete_Lattices Binomial GCD
     2.8 +imports Predicate_Compile Quickcheck_Narrowing Extraction Nunchaku BNF_Greatest_Fixpoint Filter Conditionally_Complete_Lattices Binomial GCD
     2.9  begin
    2.10  
    2.11  text \<open>
     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/src/HOL/Nunchaku.thy	Fri Sep 08 00:01:36 2017 +0200
     3.3 @@ -0,0 +1,45 @@
     3.4 +(*  Title:      HOL/Nunchaku.thy
     3.5 +    Author:     Jasmin Blanchette, VU Amsterdam
     3.6 +    Copyright   2015, 2016, 2017
     3.7 +
     3.8 +Nunchaku: Yet another counterexample generator for Isabelle/HOL.
     3.9 +
    3.10 +Nunchaku relies on an external program of the same name. The sources are
    3.11 +available at
    3.12 +
    3.13 +    https://github.com/nunchaku-inria
    3.14 +
    3.15 +The "$NUNCHAKU_HOME" environment variable must be set to the absolute path to
    3.16 +the directory containing the "nunchaku" executable. The Isabelle components
    3.17 +for CVC4 and Kodkodi are necessary to use these backend solvers.
    3.18 +*)
    3.19 +
    3.20 +theory Nunchaku
    3.21 +imports Nitpick
    3.22 +keywords
    3.23 +  "nunchaku" :: diag and
    3.24 +  "nunchaku_params" :: thy_decl
    3.25 +begin
    3.26 +
    3.27 +consts unreachable :: 'a
    3.28 +
    3.29 +definition The_unsafe :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" where
    3.30 +  "The_unsafe = The"
    3.31 +
    3.32 +definition rmember :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" where
    3.33 +  "rmember A x \<longleftrightarrow> x \<in> A"
    3.34 +
    3.35 +ML_file "Tools/Nunchaku/nunchaku_util.ML"
    3.36 +ML_file "Tools/Nunchaku/nunchaku_collect.ML"
    3.37 +ML_file "Tools/Nunchaku/nunchaku_problem.ML"
    3.38 +ML_file "Tools/Nunchaku/nunchaku_translate.ML"
    3.39 +ML_file "Tools/Nunchaku/nunchaku_model.ML"
    3.40 +ML_file "Tools/Nunchaku/nunchaku_reconstruct.ML"
    3.41 +ML_file "Tools/Nunchaku/nunchaku_display.ML"
    3.42 +ML_file "Tools/Nunchaku/nunchaku_tool.ML"
    3.43 +ML_file "Tools/Nunchaku/nunchaku.ML"
    3.44 +ML_file "Tools/Nunchaku/nunchaku_commands.ML"
    3.45 +
    3.46 +hide_const (open) unreachable The_unsafe rmember
    3.47 +
    3.48 +end
     4.1 --- a/src/HOL/Nunchaku/Nunchaku.thy	Thu Sep 07 23:13:15 2017 +0200
     4.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.3 @@ -1,45 +0,0 @@
     4.4 -(*  Title:      HOL/Nunchaku/Nunchaku.thy
     4.5 -    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
     4.6 -    Copyright   2015, 2016
     4.7 -
     4.8 -Nunchaku: Yet another counterexample generator for Isabelle/HOL.
     4.9 -
    4.10 -Nunchaku relies on an external program of the same name. The program is still
    4.11 -being actively developed. The sources are available at
    4.12 -
    4.13 -    https://github.com/nunchaku-inria
    4.14 -
    4.15 -The "$NUNCHAKU_HOME" environment variable must be set to the absolute path to
    4.16 -the directory containing the "nunchaku" executable. The Isabelle components
    4.17 -for CVC4 and Kodkodi are necessary to use these backend solvers.
    4.18 -*)
    4.19 -
    4.20 -theory Nunchaku
    4.21 -imports Main
    4.22 -keywords
    4.23 -  "nunchaku" :: diag and
    4.24 -  "nunchaku_params" :: thy_decl
    4.25 -begin
    4.26 -
    4.27 -consts unreachable :: 'a
    4.28 -
    4.29 -definition The_unsafe :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" where
    4.30 -  "The_unsafe = The"
    4.31 -
    4.32 -definition rmember :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" where
    4.33 -  "rmember A x \<longleftrightarrow> x \<in> A"
    4.34 -
    4.35 -ML_file "Tools/nunchaku_util.ML"
    4.36 -ML_file "Tools/nunchaku_collect.ML"
    4.37 -ML_file "Tools/nunchaku_problem.ML"
    4.38 -ML_file "Tools/nunchaku_translate.ML"
    4.39 -ML_file "Tools/nunchaku_model.ML"
    4.40 -ML_file "Tools/nunchaku_reconstruct.ML"
    4.41 -ML_file "Tools/nunchaku_display.ML"
    4.42 -ML_file "Tools/nunchaku_tool.ML"
    4.43 -ML_file "Tools/nunchaku.ML"
    4.44 -ML_file "Tools/nunchaku_commands.ML"
    4.45 -
    4.46 -hide_const (open) unreachable The_unsafe rmember
    4.47 -
    4.48 -end
     5.1 --- a/src/HOL/Nunchaku/Tools/nunchaku.ML	Thu Sep 07 23:13:15 2017 +0200
     5.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.3 @@ -1,327 +0,0 @@
     5.4 -(*  Title:      HOL/Nunchaku/Tools/nunchaku.ML
     5.5 -    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
     5.6 -    Copyright   2015, 2016
     5.7 -
     5.8 -The core of the Nunchaku integration in Isabelle.
     5.9 -*)
    5.10 -
    5.11 -signature NUNCHAKU =
    5.12 -sig
    5.13 -  type isa_model = Nunchaku_Reconstruct.isa_model
    5.14 -
    5.15 -  datatype mode = Auto_Try | Try | Normal
    5.16 -
    5.17 -  type mode_of_operation_params =
    5.18 -    {solvers: string list,
    5.19 -     falsify: bool,
    5.20 -     assms: bool,
    5.21 -     spy: bool,
    5.22 -     overlord: bool,
    5.23 -     expect: string}
    5.24 -
    5.25 -  type scope_of_search_params =
    5.26 -    {wfs: ((string * typ) option * bool option) list,
    5.27 -     whacks: (term option * bool) list,
    5.28 -     cards: (typ option * (int option * int option)) list,
    5.29 -     monos: (typ option * bool option) list}
    5.30 -
    5.31 -  type output_format_params =
    5.32 -    {verbose: bool,
    5.33 -     debug: bool,
    5.34 -     max_potential: int,
    5.35 -     max_genuine: int,
    5.36 -     evals: term list,
    5.37 -     atomss: (typ option * string list) list}
    5.38 -
    5.39 -  type optimization_params =
    5.40 -    {specialize: bool,
    5.41 -     multithread: bool}
    5.42 -
    5.43 -  type timeout_params =
    5.44 -    {timeout: Time.time,
    5.45 -     wf_timeout: Time.time}
    5.46 -
    5.47 -  type params =
    5.48 -    {mode_of_operation_params: mode_of_operation_params,
    5.49 -     scope_of_search_params: scope_of_search_params,
    5.50 -     output_format_params: output_format_params,
    5.51 -     optimization_params: optimization_params,
    5.52 -     timeout_params: timeout_params}
    5.53 -
    5.54 -  val genuineN: string
    5.55 -  val quasi_genuineN: string
    5.56 -  val potentialN: string
    5.57 -  val noneN: string
    5.58 -  val unknownN: string
    5.59 -  val no_nunchakuN: string
    5.60 -
    5.61 -  val run_chaku_on_prop: Proof.state -> params -> mode -> int -> term list -> term ->
    5.62 -    string * isa_model option
    5.63 -  val run_chaku_on_subgoal: Proof.state -> params -> mode -> int -> string * isa_model option
    5.64 -end;
    5.65 -
    5.66 -structure Nunchaku : NUNCHAKU =
    5.67 -struct
    5.68 -
    5.69 -open Nunchaku_Util;
    5.70 -open Nunchaku_Collect;
    5.71 -open Nunchaku_Problem;
    5.72 -open Nunchaku_Translate;
    5.73 -open Nunchaku_Model;
    5.74 -open Nunchaku_Reconstruct;
    5.75 -open Nunchaku_Display;
    5.76 -open Nunchaku_Tool;
    5.77 -
    5.78 -datatype mode = Auto_Try | Try | Normal;
    5.79 -
    5.80 -type mode_of_operation_params =
    5.81 -  {solvers: string list,
    5.82 -   falsify: bool,
    5.83 -   assms: bool,
    5.84 -   spy: bool,
    5.85 -   overlord: bool,
    5.86 -   expect: string};
    5.87 -
    5.88 -type scope_of_search_params =
    5.89 -  {wfs: ((string * typ) option * bool option) list,
    5.90 -   whacks: (term option * bool) list,
    5.91 -   cards: (typ option * (int option * int option)) list,
    5.92 -   monos: (typ option * bool option) list};
    5.93 -
    5.94 -type output_format_params =
    5.95 -  {verbose: bool,
    5.96 -   debug: bool,
    5.97 -   max_potential: int,
    5.98 -   max_genuine: int,
    5.99 -   evals: term list,
   5.100 -   atomss: (typ option * string list) list};
   5.101 -
   5.102 -type optimization_params =
   5.103 -  {specialize: bool,
   5.104 -   multithread: bool};
   5.105 -
   5.106 -type timeout_params =
   5.107 -  {timeout: Time.time,
   5.108 -   wf_timeout: Time.time};
   5.109 -
   5.110 -type params =
   5.111 -  {mode_of_operation_params: mode_of_operation_params,
   5.112 -   scope_of_search_params: scope_of_search_params,
   5.113 -   output_format_params: output_format_params,
   5.114 -   optimization_params: optimization_params,
   5.115 -   timeout_params: timeout_params};
   5.116 -
   5.117 -val genuineN = "genuine";
   5.118 -val quasi_genuineN = "quasi_genuine";
   5.119 -val potentialN = "potential";
   5.120 -val noneN = "none";
   5.121 -val unknownN = "unknown";
   5.122 -
   5.123 -val no_nunchakuN = "no_nunchaku";
   5.124 -
   5.125 -fun str_of_mode Auto_Try = "Auto_Try"
   5.126 -  | str_of_mode Try = "Try"
   5.127 -  | str_of_mode Normal = "Normal";
   5.128 -
   5.129 -fun none_true assigns = forall (curry (op <>) (SOME true) o snd) assigns;
   5.130 -
   5.131 -fun has_lonely_bool_var (@{const Pure.conjunction} $ (@{const Trueprop} $ Free _) $ _) = true
   5.132 -  | has_lonely_bool_var _ = false;
   5.133 -
   5.134 -val syntactic_sorts =
   5.135 -  @{sort "{default,zero,one,plus,minus,uminus,times,inverse,abs,sgn,ord,equal}"} @ @{sort numeral};
   5.136 -
   5.137 -fun has_tfree_syntactic_sort (TFree (_, S as _ :: _)) = subset (op =) (S, syntactic_sorts)
   5.138 -  | has_tfree_syntactic_sort _ = false;
   5.139 -
   5.140 -val has_syntactic_sorts = exists_type (exists_subtype has_tfree_syntactic_sort);
   5.141 -
   5.142 -(* Give the soft timeout a chance. *)
   5.143 -val timeout_slack = seconds 1.0;
   5.144 -
   5.145 -fun run_chaku_on_prop state
   5.146 -    ({mode_of_operation_params = {solvers, falsify, assms, spy, overlord, expect},
   5.147 -      scope_of_search_params = {wfs, whacks, cards, monos},
   5.148 -      output_format_params = {verbose, debug, evals, atomss, ...},
   5.149 -      optimization_params = {specialize, ...},
   5.150 -      timeout_params = {timeout, wf_timeout}})
   5.151 -    mode i all_assms subgoal =
   5.152 -  let
   5.153 -    val ctxt = Proof.context_of state;
   5.154 -
   5.155 -    val timer = Timer.startRealTimer ()
   5.156 -
   5.157 -    val print = writeln;
   5.158 -    val print_n = if mode = Normal then writeln else K ();
   5.159 -    fun print_v f = if verbose then writeln (f ()) else ();
   5.160 -    fun print_d f = if debug then writeln (f ()) else ();
   5.161 -
   5.162 -    val das_wort_Model = if falsify then "Countermodel" else "Model";
   5.163 -    val das_wort_model = if falsify then "countermodel" else "model";
   5.164 -
   5.165 -    val tool_params =
   5.166 -      {solvers = solvers, overlord = overlord, debug = debug, specialize = specialize,
   5.167 -       timeout = timeout};
   5.168 -
   5.169 -    fun run () =
   5.170 -      let
   5.171 -        val outcome as (outcome_code, _) =
   5.172 -          let
   5.173 -            val (poly_axioms, isa_problem as {sound, complete, ...}) =
   5.174 -              isa_problem_of_subgoal ctxt falsify wfs whacks cards debug wf_timeout evals
   5.175 -                (if assms then all_assms else []) subgoal;
   5.176 -            val _ = print_d (fn () => "*** Isabelle problem ***\n" ^
   5.177 -              str_of_isa_problem ctxt isa_problem);
   5.178 -            val ugly_nun_problem = nun_problem_of_isa ctxt isa_problem;
   5.179 -            val _ = print_d (fn () => "*** Ugly Nunchaku problem ***\n" ^
   5.180 -              str_of_nun_problem ugly_nun_problem);
   5.181 -            val (nice_nun_problem, pool) = nice_nun_problem ugly_nun_problem;
   5.182 -            val _ = print_d (fn () => "*** Nice Nunchaku problem ***\n" ^
   5.183 -              str_of_nun_problem nice_nun_problem);
   5.184 -
   5.185 -            fun print_any_hints () =
   5.186 -              if has_lonely_bool_var subgoal then
   5.187 -                print "Hint: Maybe you forgot a colon after the lemma's name?"
   5.188 -              else if has_syntactic_sorts subgoal then
   5.189 -                print "Hint: Maybe you forgot a type constraint?"
   5.190 -              else
   5.191 -                ();
   5.192 -
   5.193 -            fun get_isa_model_opt output =
   5.194 -              let
   5.195 -                val nice_nun_model = nun_model_of_str output;
   5.196 -                val _ = print_d (fn () => "*** Nice Nunchaku model ***\n" ^
   5.197 -                  str_of_nun_model nice_nun_model);
   5.198 -                val ugly_nun_model = ugly_nun_model pool nice_nun_model;
   5.199 -                val _ = print_d (fn () => "*** Ugly Nunchaku model ***\n" ^
   5.200 -                  str_of_nun_model ugly_nun_model);
   5.201 -
   5.202 -                val pat_completes = pat_completes_of_isa_problem isa_problem;
   5.203 -                val isa_model = isa_model_of_nun ctxt pat_completes atomss ugly_nun_model;
   5.204 -                val _ = print_d (fn () => "*** Isabelle model ***\n" ^
   5.205 -                  str_of_isa_model ctxt isa_model);
   5.206 -              in
   5.207 -                isa_model
   5.208 -              end;
   5.209 -
   5.210 -            fun isa_model_opt output =
   5.211 -              if debug then SOME (get_isa_model_opt output) else try get_isa_model_opt output;
   5.212 -
   5.213 -            val model_str = isa_model_opt #> pretty_of_isa_model_opt ctxt #> Pretty.string_of;
   5.214 -
   5.215 -            fun unsat_means_theorem () =
   5.216 -              null whacks andalso null cards andalso null monos;
   5.217 -
   5.218 -            fun unknown () =
   5.219 -              (print_n ("No " ^ das_wort_model ^ " can be found\n\
   5.220 -                 \The problem lies outside Nunchaku's fragment, or the Nunchaku backends are not \
   5.221 -                 \installed properly");
   5.222 -               (unknownN, NONE));
   5.223 -
   5.224 -            fun unsat_or_unknown complete =
   5.225 -              if complete then
   5.226 -                (print_n ("No " ^ das_wort_model ^ " exists" ^
   5.227 -                   (if falsify andalso unsat_means_theorem () then "\nThe goal is a theorem"
   5.228 -                    else ""));
   5.229 -                 (noneN, NONE))
   5.230 -              else
   5.231 -                unknown ();
   5.232 -
   5.233 -            fun sat_or_maybe_sat sound output =
   5.234 -              let val header = if sound then das_wort_Model else "Potential " ^ das_wort_model in
   5.235 -                (case (null poly_axioms, none_true wfs) of
   5.236 -                  (true, true) =>
   5.237 -                  (print (header ^ ":\n" ^
   5.238 -                     model_str output); print_any_hints ();
   5.239 -                   (genuineN, isa_model_opt output))
   5.240 -                | (no_poly, no_wf) =>
   5.241 -                  let
   5.242 -                    val ignorings = []
   5.243 -                      |> not no_poly ? cons "polymorphic axioms"
   5.244 -                      |> not no_wf ? cons "unchecked well-foundedness";
   5.245 -                  in
   5.246 -                    (print (header ^ " (ignoring " ^ space_implode " and " ignorings ^ "):\n" ^
   5.247 -                       model_str output ^
   5.248 -                       (if no_poly then
   5.249 -                          ""
   5.250 -                        else
   5.251 -                          "\nIgnored axioms:\n" ^
   5.252 -                          cat_lines (map (prefix "  " o Syntax.string_of_term ctxt) poly_axioms)));
   5.253 -                     print_any_hints ();
   5.254 -                     (quasi_genuineN, isa_model_opt output))
   5.255 -                  end)
   5.256 -              end;
   5.257 -          in
   5.258 -            (case solve_nun_problem tool_params nice_nun_problem of
   5.259 -              Unsat => unsat_or_unknown complete
   5.260 -            | Sat (output, _) => sat_or_maybe_sat sound output
   5.261 -            | Unknown NONE => unknown ()
   5.262 -            | Unknown (SOME (output, _)) => sat_or_maybe_sat false output
   5.263 -            | Timeout => (print_n "Time out"; (unknownN, NONE))
   5.264 -            | Nunchaku_Var_Not_Set =>
   5.265 -              (print_n ("Variable $" ^ nunchaku_home_env_var ^ " not set"); (unknownN, NONE))
   5.266 -            | Nunchaku_Cannot_Execute =>
   5.267 -              (print_n "External tool \"nunchaku\" cannot execute"; (unknownN, NONE))
   5.268 -            | Nunchaku_Not_Found =>
   5.269 -              (print_n "External tool \"nunchaku\" not found"; (unknownN, NONE))
   5.270 -            | CVC4_Cannot_Execute =>
   5.271 -              (print_n "External tool \"cvc4\" cannot execute"; (unknownN, NONE))
   5.272 -            | CVC4_Not_Found => (print_n "External tool \"cvc4\" not found"; (unknownN, NONE))
   5.273 -            | Unknown_Error (code, msg) =>
   5.274 -              (print_n ("Unknown error: " ^ msg ^
   5.275 -                 (if code = 0 then "" else " (code " ^ string_of_int code ^ ")"));
   5.276 -               (unknownN, NONE)))
   5.277 -          end
   5.278 -          handle
   5.279 -            CYCLIC_DEPS () =>
   5.280 -            (print_n "Cyclic dependencies (or bug in Nunchaku)"; (unknownN, NONE))
   5.281 -          | TOO_DEEP_DEPS () =>
   5.282 -            (print_n "Too deep dependencies (or bug in Nunchaku)"; (unknownN, NONE))
   5.283 -          | TOO_META t =>
   5.284 -            (print_n ("Formula too meta for Nunchaku:\n" ^ Syntax.string_of_term ctxt t);
   5.285 -             (unknownN, NONE))
   5.286 -          | UNEXPECTED_POLYMORPHISM t =>
   5.287 -            (print_n ("Unexpected polymorphism in term\n" ^ Syntax.string_of_term ctxt t);
   5.288 -             (unknownN, NONE))
   5.289 -          | UNEXPECTED_VAR t =>
   5.290 -            (print_n ("Unexpected schematic variables in term\n" ^ Syntax.string_of_term ctxt t);
   5.291 -             (unknownN, NONE))
   5.292 -          | UNSUPPORTED_FUNC t =>
   5.293 -            (print_n ("Unsupported low-level constant in problem: " ^ Syntax.string_of_term ctxt t);
   5.294 -             (unknownN, NONE));
   5.295 -      in
   5.296 -        if expect = "" orelse outcome_code = expect then outcome
   5.297 -        else error ("Unexpected outcome: " ^ quote outcome_code)
   5.298 -      end;
   5.299 -
   5.300 -    val _ = spying spy (fn () => (state, i, "starting " ^ str_of_mode mode ^ " mode"));
   5.301 -
   5.302 -    val outcome as (outcome_code, _) =
   5.303 -      Timeout.apply (Time.+ (timeout, timeout_slack)) run ()
   5.304 -      handle Timeout.TIMEOUT _ => (print_n "Time out"; (unknownN, NONE));
   5.305 -
   5.306 -    val _ = print_v (fn () => "Total time: " ^ string_of_time (Timer.checkRealTimer timer));
   5.307 -
   5.308 -    val _ = spying spy (fn () => (state, i, "outcome: " ^ outcome_code));
   5.309 -  in
   5.310 -    if expect = "" orelse outcome_code = expect then outcome
   5.311 -    else error ("Unexpected outcome: " ^ quote outcome_code)
   5.312 -  end;
   5.313 -
   5.314 -fun run_chaku_on_subgoal state params mode i =
   5.315 -  let
   5.316 -    val ctxt = Proof.context_of state;
   5.317 -    val goal = Thm.prop_of (#goal (Proof.raw_goal state));
   5.318 -  in
   5.319 -    if Logic.count_prems goal = 0 then
   5.320 -      (writeln "No subgoal!"; (noneN, NONE))
   5.321 -    else
   5.322 -      let
   5.323 -        val subgoal = fst (Logic.goal_params goal i);
   5.324 -        val all_assms = map Thm.term_of (Assumption.all_assms_of ctxt);
   5.325 -      in
   5.326 -        run_chaku_on_prop state params mode i all_assms subgoal
   5.327 -      end
   5.328 -  end;
   5.329 -
   5.330 -end;
     6.1 --- a/src/HOL/Nunchaku/Tools/nunchaku_collect.ML	Thu Sep 07 23:13:15 2017 +0200
     6.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.3 @@ -1,1119 +0,0 @@
     6.4 -(*  Title:      HOL/Nunchaku/Tools/nunchaku_collect.ML
     6.5 -    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
     6.6 -    Copyright   2015, 2016
     6.7 -
     6.8 -Collecting of Isabelle/HOL definitions etc. for Nunchaku.
     6.9 -*)
    6.10 -
    6.11 -signature NUNCHAKU_COLLECT =
    6.12 -sig
    6.13 -  val dest_co_datatype_case: Proof.context -> string * typ -> (string * typ) list
    6.14 -
    6.15 -  type isa_type_spec =
    6.16 -    {abs_typ: typ,
    6.17 -     rep_typ: typ,
    6.18 -     wrt: term,
    6.19 -     abs: term,
    6.20 -     rep: term}
    6.21 -
    6.22 -  type isa_co_data_spec =
    6.23 -    {typ: typ,
    6.24 -     ctrs: term list}
    6.25 -
    6.26 -  type isa_const_spec =
    6.27 -    {const: term,
    6.28 -     props: term list}
    6.29 -
    6.30 -  type isa_rec_spec =
    6.31 -    {const: term,
    6.32 -     props: term list,
    6.33 -     pat_complete: bool}
    6.34 -
    6.35 -  type isa_consts_spec =
    6.36 -    {consts: term list,
    6.37 -     props: term list}
    6.38 -
    6.39 -  datatype isa_command =
    6.40 -    ITVal of typ * (int option * int option)
    6.41 -  | ITypedef of isa_type_spec
    6.42 -  | IQuotient of isa_type_spec
    6.43 -  | ICoData of BNF_Util.fp_kind * isa_co_data_spec list
    6.44 -  | IVal of term
    6.45 -  | ICoPred of BNF_Util.fp_kind * bool * isa_const_spec list
    6.46 -  | IRec of isa_rec_spec list
    6.47 -  | ISpec of isa_consts_spec
    6.48 -  | IAxiom of term
    6.49 -  | IGoal of term
    6.50 -  | IEval of term
    6.51 -
    6.52 -  type isa_problem =
    6.53 -    {commandss: isa_command list list,
    6.54 -     sound: bool,
    6.55 -     complete: bool}
    6.56 -
    6.57 -  exception CYCLIC_DEPS of unit
    6.58 -  exception TOO_DEEP_DEPS of unit
    6.59 -  exception TOO_META of term
    6.60 -  exception UNEXPECTED_POLYMORPHISM of term
    6.61 -  exception UNEXPECTED_VAR of term
    6.62 -  exception UNSUPPORTED_FUNC of term
    6.63 -
    6.64 -  val isa_problem_of_subgoal: Proof.context -> bool -> ((string * typ) option * bool option) list ->
    6.65 -    (term option * bool) list -> (typ option * (int option * int option)) list -> bool ->
    6.66 -    Time.time -> term list -> term list -> term -> term list * isa_problem
    6.67 -  val pat_completes_of_isa_problem: isa_problem -> term list
    6.68 -  val str_of_isa_problem: Proof.context -> isa_problem -> string
    6.69 -end;
    6.70 -
    6.71 -structure Nunchaku_Collect : NUNCHAKU_COLLECT =
    6.72 -struct
    6.73 -
    6.74 -open Nunchaku_Util;
    6.75 -
    6.76 -type isa_type_spec =
    6.77 -  {abs_typ: typ,
    6.78 -   rep_typ: typ,
    6.79 -   wrt: term,
    6.80 -   abs: term,
    6.81 -   rep: term};
    6.82 -
    6.83 -type isa_co_data_spec =
    6.84 -  {typ: typ,
    6.85 -   ctrs: term list};
    6.86 -
    6.87 -type isa_const_spec =
    6.88 -  {const: term,
    6.89 -   props: term list};
    6.90 -
    6.91 -type isa_rec_spec =
    6.92 -  {const: term,
    6.93 -   props: term list,
    6.94 -   pat_complete: bool};
    6.95 -
    6.96 -type isa_consts_spec =
    6.97 -  {consts: term list,
    6.98 -   props: term list};
    6.99 -
   6.100 -datatype isa_command =
   6.101 -  ITVal of typ * (int option * int option)
   6.102 -| ITypedef of isa_type_spec
   6.103 -| IQuotient of isa_type_spec
   6.104 -| ICoData of BNF_Util.fp_kind * isa_co_data_spec list
   6.105 -| IVal of term
   6.106 -| ICoPred of BNF_Util.fp_kind * bool * isa_const_spec list
   6.107 -| IRec of isa_rec_spec list
   6.108 -| ISpec of isa_consts_spec
   6.109 -| IAxiom of term
   6.110 -| IGoal of term
   6.111 -| IEval of term;
   6.112 -
   6.113 -type isa_problem =
   6.114 -  {commandss: isa_command list list,
   6.115 -   sound: bool,
   6.116 -   complete: bool};
   6.117 -
   6.118 -exception CYCLIC_DEPS of unit;
   6.119 -exception TOO_DEEP_DEPS of unit;
   6.120 -exception TOO_META of term;
   6.121 -exception UNEXPECTED_POLYMORPHISM of term;
   6.122 -exception UNEXPECTED_VAR of term;
   6.123 -exception UNSUPPORTED_FUNC of term;
   6.124 -
   6.125 -fun str_of_and_list str_of_elem =
   6.126 -  map str_of_elem #> space_implode ("\nand ");
   6.127 -
   6.128 -val key_of_typ =
   6.129 -  let
   6.130 -    fun key_of (Type (s, [])) = s
   6.131 -      | key_of (Type (s, Ts)) = s ^ "(" ^ commas (map key_of Ts) ^ ")"
   6.132 -      | key_of (TFree (s, _)) = s;
   6.133 -  in
   6.134 -    prefix "y" o key_of
   6.135 -  end;
   6.136 -
   6.137 -fun key_of_const ctxt =
   6.138 -  let
   6.139 -    val thy = Proof_Context.theory_of ctxt;
   6.140 -
   6.141 -    fun key_of (Const (x as (s, _))) =
   6.142 -        (case Sign.const_typargs thy x of
   6.143 -          [] => s
   6.144 -        | Ts => s ^ "(" ^ commas (map key_of_typ Ts) ^ ")")
   6.145 -      | key_of (Free (s, _)) = s;
   6.146 -  in
   6.147 -    prefix "t" o key_of
   6.148 -  end;
   6.149 -
   6.150 -val add_type_keys = fold_subtypes (insert (op =) o key_of_typ);
   6.151 -
   6.152 -fun add_aterm_keys ctxt t =
   6.153 -  if is_Const t orelse is_Free t then insert (op =) (key_of_const ctxt t) else I;
   6.154 -
   6.155 -fun add_keys ctxt t =
   6.156 -  fold_aterms (add_aterm_keys ctxt) t
   6.157 -  #> fold_types add_type_keys t;
   6.158 -
   6.159 -fun close_form except t =
   6.160 -  fold (fn ((s, i), T) => fn t' =>
   6.161 -      HOLogic.all_const T $ Abs (s, T, abstract_over (Var ((s, i), T), t')))
   6.162 -    (Term.add_vars t [] |> subtract (op =) except) t;
   6.163 -
   6.164 -(* "imp_conjL[symmetric]" is important for inductive predicates with multiple assumptions. *)
   6.165 -val basic_defs =
   6.166 -  @{thms Ball_def[abs_def] Bex_def[abs_def] case_bool_if Ex1_def[abs_def]
   6.167 -    imp_conjL[symmetric, abs_def] Let_def[abs_def] rmember_def[symmetric, abs_def]};
   6.168 -
   6.169 -fun unfold_basic_def ctxt =
   6.170 -  let val thy = Proof_Context.theory_of ctxt in
   6.171 -    Pattern.rewrite_term thy (map (Logic.dest_equals o Thm.prop_of) basic_defs) []
   6.172 -  end;
   6.173 -
   6.174 -val has_polymorphism = exists_type (exists_subtype is_TVar);
   6.175 -
   6.176 -fun whack_term thy whacks =
   6.177 -  let
   6.178 -    fun whk t =
   6.179 -      if triple_lookup (term_match thy o swap) whacks t = SOME true then
   6.180 -        Const (@{const_name unreachable}, fastype_of t)
   6.181 -      else
   6.182 -        (case t of
   6.183 -          u $ v => whk u $ whk v
   6.184 -        | Abs (s, T, u) => Abs (s, T, whk u)
   6.185 -        | _ => t);
   6.186 -  in
   6.187 -    whk
   6.188 -  end;
   6.189 -
   6.190 -fun preprocess_term_basic falsify ctxt whacks t =
   6.191 -  let val thy = Proof_Context.theory_of ctxt in
   6.192 -    if has_polymorphism t then
   6.193 -      raise UNEXPECTED_POLYMORPHISM t
   6.194 -    else
   6.195 -      t
   6.196 -      |> attach_typeS
   6.197 -      |> whack_term thy whacks
   6.198 -      |> Object_Logic.atomize_term ctxt
   6.199 -      |> tap (fn t' => fastype_of t' <> @{typ prop} orelse raise TOO_META t)
   6.200 -      |> falsify ? HOLogic.mk_not
   6.201 -      |> unfold_basic_def ctxt
   6.202 -  end;
   6.203 -
   6.204 -val check_closed = tap (fn t => null (Term.add_vars t []) orelse raise UNEXPECTED_VAR t);
   6.205 -
   6.206 -val preprocess_prop = close_form [] oooo preprocess_term_basic;
   6.207 -val preprocess_closed_term = check_closed ooo preprocess_term_basic false;
   6.208 -
   6.209 -val is_type_builtin = member (op =) [@{type_name bool}, @{type_name fun}];
   6.210 -
   6.211 -val is_const_builtin =
   6.212 -  member (op =) [@{const_name All}, @{const_name conj}, @{const_name disj}, @{const_name Eps},
   6.213 -    @{const_name HOL.eq}, @{const_name Ex}, @{const_name False}, @{const_name If},
   6.214 -    @{const_name implies}, @{const_name Not}, @{const_name The}, @{const_name The_unsafe},
   6.215 -    @{const_name True}];
   6.216 -
   6.217 -datatype type_classification = Builtin | TVal | Typedef | Quotient | Co_Datatype;
   6.218 -
   6.219 -fun classify_type_name ctxt T_name =
   6.220 -  if is_type_builtin T_name then
   6.221 -    Builtin
   6.222 -  else if T_name = @{type_name itself} then
   6.223 -    Co_Datatype
   6.224 -  else
   6.225 -    (case BNF_FP_Def_Sugar.fp_sugar_of ctxt T_name of
   6.226 -      SOME _ => Co_Datatype
   6.227 -    | NONE =>
   6.228 -      (case Ctr_Sugar.ctr_sugar_of ctxt T_name of
   6.229 -        SOME _ => Co_Datatype
   6.230 -      | NONE =>
   6.231 -        (case Quotient_Info.lookup_quotients ctxt T_name of
   6.232 -          SOME _ => Quotient
   6.233 -        | NONE =>
   6.234 -          if T_name = @{type_name set} then
   6.235 -            Typedef
   6.236 -          else
   6.237 -            (case Typedef.get_info ctxt T_name of
   6.238 -              _ :: _ => Typedef
   6.239 -            | [] => TVal))));
   6.240 -
   6.241 -fun fp_kind_of_ctr_sugar_kind Ctr_Sugar.Codatatype = BNF_Util.Greatest_FP
   6.242 -  | fp_kind_of_ctr_sugar_kind _ = BNF_Util.Least_FP;
   6.243 -
   6.244 -fun mutual_co_datatypes_of ctxt (T_name, Ts) =
   6.245 -  (if T_name = @{type_name itself} then
   6.246 -     (BNF_Util.Least_FP, [@{typ "'a itself"}], [[@{const Pure.type ('a)}]])
   6.247 -   else
   6.248 -     let
   6.249 -       val (fp, ctr_sugars) =
   6.250 -         (case BNF_FP_Def_Sugar.fp_sugar_of ctxt T_name of
   6.251 -           SOME (fp_sugar as {fp, fp_res = {Ts, ...}, ...}) =>
   6.252 -           (fp,
   6.253 -            (case Ts of
   6.254 -              [_] => [fp_sugar]
   6.255 -            | _ => map (the o BNF_FP_Def_Sugar.fp_sugar_of ctxt o fst o dest_Type) Ts)
   6.256 -            |> map (#ctr_sugar o #fp_ctr_sugar))
   6.257 -         | NONE =>
   6.258 -           (case Ctr_Sugar.ctr_sugar_of ctxt T_name of
   6.259 -             SOME (ctr_sugar as {kind, ...}) =>
   6.260 -             (* Any freely constructed type that is not a codatatype is considered a datatype. This
   6.261 -                is sound (but incomplete) for model finding. *)
   6.262 -             (fp_kind_of_ctr_sugar_kind kind, [ctr_sugar])));
   6.263 -     in
   6.264 -       (fp, map #T ctr_sugars, map #ctrs ctr_sugars)
   6.265 -     end)
   6.266 -  |> @{apply 3(2)} (map ((fn Type (s, _) => Type (s, Ts))))
   6.267 -  |> @{apply 3(3)} (map (map (Ctr_Sugar.mk_ctr Ts)));
   6.268 -
   6.269 -fun typedef_of ctxt whacks T_name =
   6.270 -  if T_name = @{type_name set} then
   6.271 -    let
   6.272 -      val A = Logic.varifyT_global @{typ 'a};
   6.273 -      val absT = Type (@{type_name set}, [A]);
   6.274 -      val repT = A --> HOLogic.boolT;
   6.275 -      val pred = K (Abs (Name.uu, repT, @{const True}));
   6.276 -      val abs = Const (@{const_name Collect}, repT --> absT);
   6.277 -      val rep = Const (@{const_name rmember}, absT --> repT);
   6.278 -    in
   6.279 -      (absT, repT, pred, abs, rep)
   6.280 -    end
   6.281 -  else
   6.282 -    (case Typedef.get_info ctxt T_name of
   6.283 -      (* When several entries are returned, it shouldn't matter much which one we take (according to
   6.284 -         Florian Haftmann). The "Logic.varifyT_global" calls are a workaround because these types'
   6.285 -         variables sometimes clash with locally fixed type variables. *)
   6.286 -      ({abs_type, rep_type, Abs_name, Rep_name, ...}, {Rep, ...}) :: _ =>
   6.287 -      let
   6.288 -        val absT = Logic.varifyT_global abs_type;
   6.289 -        val repT = Logic.varifyT_global rep_type;
   6.290 -        val set0 = Thm.prop_of Rep
   6.291 -          |> HOLogic.dest_Trueprop
   6.292 -          |> HOLogic.dest_mem
   6.293 -          |> snd;
   6.294 -        val pred0 = Abs (Name.uu, repT, HOLogic.mk_mem (Bound 0, set0));
   6.295 -        fun pred () = preprocess_prop false ctxt whacks pred0;
   6.296 -        val abs = Const (Abs_name, repT --> absT);
   6.297 -        val rep = Const (Rep_name, absT --> repT);
   6.298 -      in
   6.299 -        (absT, repT, pred, abs, rep)
   6.300 -      end);
   6.301 -
   6.302 -fun quotient_of ctxt whacks T_name =
   6.303 -  (case Quotient_Info.lookup_quotients ctxt T_name of
   6.304 -    SOME {equiv_rel = equiv_rel0, qtyp, rtyp, quot_thm, ...} =>
   6.305 -    let
   6.306 -      val _ $ (_ $ _ $ abs $ rep) = Thm.prop_of quot_thm;
   6.307 -      fun equiv_rel () = preprocess_prop false ctxt whacks equiv_rel0;
   6.308 -    in
   6.309 -      (qtyp, rtyp, equiv_rel, abs, rep)
   6.310 -    end);
   6.311 -
   6.312 -fun is_co_datatype_ctr ctxt (s, T) =
   6.313 -  (case body_type T of
   6.314 -    Type (fpT_name, Ts) =>
   6.315 -    classify_type_name ctxt fpT_name = Co_Datatype andalso
   6.316 -    let
   6.317 -      val ctrs =
   6.318 -        if fpT_name = @{type_name itself} then
   6.319 -          [Const (@{const_name Pure.type}, @{typ "'a itself"})]
   6.320 -        else
   6.321 -          (case BNF_FP_Def_Sugar.fp_sugar_of ctxt fpT_name of
   6.322 -            SOME {fp_ctr_sugar = {ctr_sugar = {ctrs, ...}, ...}, ...} => ctrs
   6.323 -          | NONE =>
   6.324 -            (case Ctr_Sugar.ctr_sugar_of ctxt fpT_name of
   6.325 -              SOME {ctrs, ...} => ctrs
   6.326 -            | _ => []));
   6.327 -
   6.328 -      fun is_right_ctr (t' as Const (s', _)) =
   6.329 -        s = s' andalso fastype_of (Ctr_Sugar.mk_ctr Ts t') = T;
   6.330 -    in
   6.331 -      exists is_right_ctr ctrs
   6.332 -    end
   6.333 -  | _  => false);
   6.334 -
   6.335 -fun dest_co_datatype_case ctxt (s, T) =
   6.336 -  let val thy = Proof_Context.theory_of ctxt in
   6.337 -    (case strip_fun_type (Sign.the_const_type thy s) of
   6.338 -      (gen_branch_Ts, gen_body_fun_T) =>
   6.339 -      (case gen_body_fun_T of
   6.340 -        Type (@{type_name fun}, [Type (fpT_name, _), _]) =>
   6.341 -        if classify_type_name ctxt fpT_name = Co_Datatype then
   6.342 -          let
   6.343 -            val Type (_, fpTs) = domain_type (funpow (length gen_branch_Ts) range_type T);
   6.344 -            val (ctrs0, Const (case_name, _)) =
   6.345 -              (case BNF_FP_Def_Sugar.fp_sugar_of ctxt fpT_name of
   6.346 -                SOME {fp_ctr_sugar = {ctr_sugar = {ctrs, casex, ...}, ...}, ...} => (ctrs, casex)
   6.347 -              | NONE =>
   6.348 -                (case Ctr_Sugar.ctr_sugar_of ctxt fpT_name of
   6.349 -                  SOME {ctrs, casex, ...} => (ctrs, casex)));
   6.350 -          in
   6.351 -            if s = case_name then map (dest_Const o Ctr_Sugar.mk_ctr fpTs) ctrs0
   6.352 -            else raise Fail "non-case"
   6.353 -          end
   6.354 -        else
   6.355 -          raise Fail "non-case"))
   6.356 -  end;
   6.357 -
   6.358 -val is_co_datatype_case = can o dest_co_datatype_case;
   6.359 -
   6.360 -fun is_quotient_abs ctxt whacks (s, T) =
   6.361 -  (case T of
   6.362 -    Type (@{type_name fun}, [_, Type (absT_name, _)]) =>
   6.363 -    classify_type_name ctxt absT_name = Quotient andalso
   6.364 -    (case quotient_of ctxt whacks absT_name of
   6.365 -      (_, _, _, Const (s', _), _) => s' = s)
   6.366 -  | _ => false);
   6.367 -
   6.368 -fun is_quotient_rep ctxt whacks (s, T) =
   6.369 -  (case T of
   6.370 -    Type (@{type_name fun}, [Type (absT_name, _), _]) =>
   6.371 -    classify_type_name ctxt absT_name = Quotient andalso
   6.372 -    (case quotient_of ctxt whacks absT_name of
   6.373 -      (_, _, _, _, Const (s', _)) => s' = s)
   6.374 -  | _ => false);
   6.375 -
   6.376 -fun is_maybe_typedef_abs ctxt whacks absT_name s =
   6.377 -  if absT_name = @{type_name set} then
   6.378 -    s = @{const_name Collect}
   6.379 -  else
   6.380 -    (case try (typedef_of ctxt whacks) absT_name of
   6.381 -      SOME (_, _, _, Const (s', _), _) => s' = s
   6.382 -    | NONE => false);
   6.383 -
   6.384 -fun is_maybe_typedef_rep ctxt whacks absT_name s =
   6.385 -  if absT_name = @{type_name set} then
   6.386 -    s = @{const_name rmember}
   6.387 -  else
   6.388 -    (case try (typedef_of ctxt whacks) absT_name of
   6.389 -      SOME (_, _, _, _, Const (s', _)) => s' = s
   6.390 -    | NONE => false);
   6.391 -
   6.392 -fun is_typedef_abs ctxt whacks (s, T) =
   6.393 -  (case T of
   6.394 -    Type (@{type_name fun}, [_, Type (absT_name, _)]) =>
   6.395 -    classify_type_name ctxt absT_name = Typedef andalso
   6.396 -    is_maybe_typedef_abs ctxt whacks absT_name s
   6.397 -  | _ => false);
   6.398 -
   6.399 -fun is_typedef_rep ctxt whacks (s, T) =
   6.400 -  (case T of
   6.401 -    Type (@{type_name fun}, [Type (absT_name, _), _]) =>
   6.402 -    classify_type_name ctxt absT_name = Typedef andalso
   6.403 -    is_maybe_typedef_rep ctxt whacks absT_name s
   6.404 -  | _ => false);
   6.405 -
   6.406 -fun is_stale_typedef_abs ctxt whacks (s, T) =
   6.407 -  (case T of
   6.408 -    Type (@{type_name fun}, [_, Type (absT_name, _)]) =>
   6.409 -    classify_type_name ctxt absT_name <> Typedef andalso
   6.410 -    is_maybe_typedef_abs ctxt whacks absT_name s
   6.411 -  | _ => false);
   6.412 -
   6.413 -fun is_stale_typedef_rep ctxt whacks (s, T) =
   6.414 -  (case T of
   6.415 -    Type (@{type_name fun}, [Type (absT_name, _), _]) =>
   6.416 -    classify_type_name ctxt absT_name <> Typedef andalso
   6.417 -    is_maybe_typedef_rep ctxt whacks absT_name s
   6.418 -  | _ => false);
   6.419 -
   6.420 -fun instantiate_constant_types_in_term ctxt csts target =
   6.421 -  let
   6.422 -    val thy = Proof_Context.theory_of ctxt;
   6.423 -
   6.424 -    fun try_const _ _ (res as SOME _) = res
   6.425 -      | try_const (s', T') cst NONE =
   6.426 -        (case cst of
   6.427 -          Const (s, T) =>
   6.428 -          if s = s' then
   6.429 -            SOME (Sign.typ_match thy (T', T) Vartab.empty)
   6.430 -            handle Type.TYPE_MATCH => NONE
   6.431 -          else
   6.432 -            NONE
   6.433 -        | _ => NONE);
   6.434 -
   6.435 -    fun subst_for (Const x) = fold (try_const x) csts NONE
   6.436 -      | subst_for (t as Free _) = if member (op aconv) csts t then SOME Vartab.empty else NONE
   6.437 -      | subst_for (t1 $ t2) = (case subst_for t1 of SOME subst => SOME subst | NONE => subst_for t2)
   6.438 -      | subst_for (Abs (_, _, t')) = subst_for t'
   6.439 -      | subst_for _ = NONE;
   6.440 -  in
   6.441 -    (case subst_for target of
   6.442 -      SOME subst => Envir.subst_term_types subst target
   6.443 -    | NONE => raise Type.TYPE_MATCH)
   6.444 -  end;
   6.445 -
   6.446 -datatype card = One | Fin | Fin_or_Inf | Inf
   6.447 -
   6.448 -(* Similar to "ATP_Util.tiny_card_of_type". *)
   6.449 -fun card_of_type ctxt =
   6.450 -  let
   6.451 -    fun max_card Inf _ = Inf
   6.452 -      | max_card _ Inf = Inf
   6.453 -      | max_card Fin_or_Inf _ = Fin_or_Inf
   6.454 -      | max_card _ Fin_or_Inf = Fin_or_Inf
   6.455 -      | max_card Fin _ = Fin
   6.456 -      | max_card _ Fin = Fin
   6.457 -      | max_card One One = One;
   6.458 -
   6.459 -    fun card_of avoid T =
   6.460 -      if member (op =) avoid T then
   6.461 -        Inf
   6.462 -      else
   6.463 -        (case T of
   6.464 -          TFree _ => Fin_or_Inf
   6.465 -        | TVar _ => Inf
   6.466 -        | Type (@{type_name fun}, [T1, T2]) =>
   6.467 -          (case (card_of avoid T1, card_of avoid T2) of
   6.468 -            (_, One) => One
   6.469 -          | (k1, k2) => max_card k1 k2)
   6.470 -        | Type (@{type_name prod}, [T1, T2]) =>
   6.471 -          (case (card_of avoid T1, card_of avoid T2) of
   6.472 -            (k1, k2) => max_card k1 k2)
   6.473 -        | Type (@{type_name set}, [T']) => card_of avoid (T' --> HOLogic.boolT)
   6.474 -        | Type (T_name, Ts) =>
   6.475 -          (case try (mutual_co_datatypes_of ctxt) (T_name, Ts) of
   6.476 -            NONE => Inf
   6.477 -          | SOME (_, fpTs, ctrss) =>
   6.478 -            (case ctrss of [[_]] => One | _ => Fin)
   6.479 -            |> fold (fold (fold (max_card o card_of (fpTs @ avoid)) o binder_types o fastype_of))
   6.480 -              ctrss));
   6.481 -  in
   6.482 -    card_of []
   6.483 -  end;
   6.484 -
   6.485 -fun int_of_classif Spec_Rules.Equational = 1
   6.486 -  | int_of_classif Spec_Rules.Inductive = 2
   6.487 -  | int_of_classif Spec_Rules.Co_Inductive = 3
   6.488 -  | int_of_classif Spec_Rules.Unknown = 4;
   6.489 -
   6.490 -val classif_ord = int_ord o apply2 int_of_classif;
   6.491 -
   6.492 -fun spec_rules_of ctxt (x as (s, T)) =
   6.493 -  let
   6.494 -    val thy = Proof_Context.theory_of ctxt;
   6.495 -
   6.496 -    fun subst_of t0 =
   6.497 -      try (Sign.typ_match thy (fastype_of t0, T)) Vartab.empty;
   6.498 -
   6.499 -    fun process_spec _ (res as SOME _) = res
   6.500 -      | process_spec (classif, (ts0, ths as _ :: _)) NONE =
   6.501 -        (case get_first subst_of ts0 of
   6.502 -          SOME subst =>
   6.503 -          (let
   6.504 -             val ts = map (Envir.subst_term_types subst) ts0;
   6.505 -             val poly_props = map Thm.prop_of ths;
   6.506 -             val props = map (instantiate_constant_types_in_term ctxt ts) poly_props;
   6.507 -           in
   6.508 -             if exists (exists (exists_type (exists_subtype is_TVar))) [ts, props] then NONE
   6.509 -             else SOME (classif, ts, props, poly_props)
   6.510 -           end
   6.511 -           handle Type.TYPE_MATCH => NONE)
   6.512 -        | NONE => NONE)
   6.513 -      | process_spec _ NONE = NONE;
   6.514 -
   6.515 -    fun spec_rules () =
   6.516 -      Spec_Rules.retrieve ctxt (Const x)
   6.517 -      |> sort (classif_ord o apply2 fst);
   6.518 -
   6.519 -    val specs =
   6.520 -      if s = @{const_name The} then
   6.521 -        [(Spec_Rules.Unknown, ([Logic.varify_global @{term The}], [@{thm theI_unique}]))]
   6.522 -      else if s = @{const_name finite} then
   6.523 -        let val card = card_of_type ctxt T in
   6.524 -          if card = Inf orelse card = Fin_or_Inf then
   6.525 -            spec_rules ()
   6.526 -          else
   6.527 -            [(Spec_Rules.Equational, ([Logic.varify_global @{term finite}],
   6.528 -               [Skip_Proof.make_thm thy (Logic.varify_global @{prop "finite A = True"})]))]
   6.529 -        end
   6.530 -      else
   6.531 -        spec_rules ();
   6.532 -  in
   6.533 -    fold process_spec specs NONE
   6.534 -  end;
   6.535 -
   6.536 -fun lhs_of_equation (Const (@{const_name Pure.eq}, _) $ t $ _) = t
   6.537 -  | lhs_of_equation (@{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ t $ _)) = t;
   6.538 -
   6.539 -fun specialize_definition_type thy x def0 =
   6.540 -  let
   6.541 -    val def = specialize_type thy x def0;
   6.542 -    val lhs = lhs_of_equation def;
   6.543 -  in
   6.544 -    if exists_Const (curry (op =) x) lhs then def else raise Fail "cannot specialize"
   6.545 -  end;
   6.546 -
   6.547 -fun definition_of thy (x as (s, _)) =
   6.548 -  Defs.specifications_of (Theory.defs_of thy) (Defs.Const, s)
   6.549 -  |> map_filter #def
   6.550 -  |> map_filter (try (specialize_definition_type thy x o Thm.prop_of o Thm.axiom thy))
   6.551 -  |> try hd;
   6.552 -
   6.553 -fun is_builtin_theory thy_id =
   6.554 -  Context.subthy_id (thy_id, Context.theory_id @{theory Hilbert_Choice});
   6.555 -
   6.556 -val orphan_axioms_of =
   6.557 -  Spec_Rules.get
   6.558 -  #> filter (curry (op =) Spec_Rules.Unknown o fst)
   6.559 -  #> map snd
   6.560 -  #> filter (null o fst)
   6.561 -  #> maps snd
   6.562 -  #> filter_out (is_builtin_theory o Thm.theory_id)
   6.563 -  #> map Thm.prop_of;
   6.564 -
   6.565 -fun keys_of _ (ITVal (T, _)) = [key_of_typ T]
   6.566 -  | keys_of _ (ITypedef {abs_typ, ...}) = [key_of_typ abs_typ]
   6.567 -  | keys_of _ (IQuotient {abs_typ, ...}) = [key_of_typ abs_typ]
   6.568 -  | keys_of _ (ICoData (_, specs)) = map (key_of_typ o #typ) specs
   6.569 -  | keys_of ctxt (IVal const) = [key_of_const ctxt const]
   6.570 -  | keys_of ctxt (ICoPred (_, _, specs)) = map (key_of_const ctxt o #const) specs
   6.571 -  | keys_of ctxt (IRec specs) = map (key_of_const ctxt o #const) specs
   6.572 -  | keys_of ctxt (ISpec {consts, ...}) = map (key_of_const ctxt) consts
   6.573 -  | keys_of _ (IAxiom _) = []
   6.574 -  | keys_of _ (IGoal _) = []
   6.575 -  | keys_of _ (IEval _) = [];
   6.576 -
   6.577 -fun co_data_spec_deps_of ctxt ({ctrs, ...} : isa_co_data_spec) =
   6.578 -  fold (add_keys ctxt) ctrs [];
   6.579 -fun const_spec_deps_of ctxt consts props =
   6.580 -  fold (add_keys ctxt) props [] |> subtract (op =) (map (key_of_const ctxt) consts);
   6.581 -fun consts_spec_deps_of ctxt {consts, props} =
   6.582 -  fold (add_keys ctxt) props [] |> subtract (op =) (map (key_of_const ctxt) consts);
   6.583 -
   6.584 -fun deps_of _ (ITVal _) = []
   6.585 -  | deps_of ctxt (ITypedef {wrt, ...}) = add_keys ctxt wrt []
   6.586 -  | deps_of ctxt (IQuotient {wrt, ...}) = add_keys ctxt wrt []
   6.587 -  | deps_of ctxt (ICoData (_, specs)) = maps (co_data_spec_deps_of ctxt) specs
   6.588 -  | deps_of _ (IVal const) = add_type_keys (fastype_of const) []
   6.589 -  | deps_of ctxt (ICoPred (_, _, specs)) =
   6.590 -    maps (const_spec_deps_of ctxt (map #const specs) o #props) specs
   6.591 -  | deps_of ctxt (IRec specs) = maps (const_spec_deps_of ctxt (map #const specs) o #props) specs
   6.592 -  | deps_of ctxt (ISpec spec) = consts_spec_deps_of ctxt spec
   6.593 -  | deps_of ctxt (IAxiom prop) = add_keys ctxt prop []
   6.594 -  | deps_of ctxt (IGoal prop) = add_keys ctxt prop []
   6.595 -  | deps_of ctxt (IEval t) = add_keys ctxt t [];
   6.596 -
   6.597 -fun consts_of_rec_or_spec (IRec specs) = map #const specs
   6.598 -  | consts_of_rec_or_spec (ISpec {consts, ...}) = consts;
   6.599 -
   6.600 -fun props_of_rec_or_spec (IRec specs) = maps #props specs
   6.601 -  | props_of_rec_or_spec (ISpec {props, ...}) = props;
   6.602 -
   6.603 -fun merge_two_rec_or_spec cmd cmd' =
   6.604 -  ISpec {consts = consts_of_rec_or_spec cmd @ consts_of_rec_or_spec cmd',
   6.605 -    props = props_of_rec_or_spec cmd @ props_of_rec_or_spec cmd'};
   6.606 -
   6.607 -fun merge_two (ICoData (fp, specs)) (ICoData (fp', specs'), complete) =
   6.608 -    (ICoData (BNF_Util.case_fp fp fp fp', specs @ specs'), complete andalso fp = fp')
   6.609 -  | merge_two (IRec specs) (IRec specs', complete) = (IRec (specs @ specs'), complete)
   6.610 -  | merge_two (cmd as IRec _) (cmd' as ISpec _, complete) =
   6.611 -    (merge_two_rec_or_spec cmd cmd', complete)
   6.612 -  | merge_two (cmd as ISpec _) (cmd' as IRec _, complete) =
   6.613 -    (merge_two_rec_or_spec cmd cmd', complete)
   6.614 -  | merge_two (cmd as ISpec _) (cmd' as ISpec _, complete) =
   6.615 -    (merge_two_rec_or_spec cmd cmd', complete)
   6.616 -  | merge_two _ _ = raise CYCLIC_DEPS ();
   6.617 -
   6.618 -fun sort_isa_commands_topologically ctxt cmds =
   6.619 -  let
   6.620 -    fun normal_pairs [] = []
   6.621 -      | normal_pairs (all as normal :: _) = map (rpair normal) all;
   6.622 -
   6.623 -    fun add_node [] _ = I
   6.624 -      | add_node (normal :: _) cmd = Graph.new_node (normal, cmd);
   6.625 -
   6.626 -    fun merge_scc (cmd :: cmds) complete = fold merge_two cmds (cmd, complete);
   6.627 -
   6.628 -    fun sort_problem (cmds, complete) =
   6.629 -      let
   6.630 -        val keyss = map (keys_of ctxt) cmds;
   6.631 -        val normal_keys = Symtab.make (maps normal_pairs keyss);
   6.632 -        val normalize = Symtab.lookup normal_keys;
   6.633 -
   6.634 -        fun add_deps [] _ = I
   6.635 -          | add_deps (normal :: _) cmd =
   6.636 -            let
   6.637 -              val deps = deps_of ctxt cmd
   6.638 -                |> map_filter normalize
   6.639 -                |> remove (op =) normal;
   6.640 -            in
   6.641 -              fold (fn dep => Graph.add_edge (dep, normal)) deps
   6.642 -            end;
   6.643 -
   6.644 -        val cmd_of_key = the o AList.lookup (op =) (map hd keyss ~~ cmds);
   6.645 -
   6.646 -        val G = Graph.empty
   6.647 -          |> fold2 add_node keyss cmds
   6.648 -          |> fold2 add_deps keyss cmds;
   6.649 -
   6.650 -        val cmd_sccs = rev (Graph.strong_conn G)
   6.651 -          |> map (map cmd_of_key);
   6.652 -      in
   6.653 -        if exists (can (fn _ :: _ :: _ => ())) cmd_sccs then
   6.654 -          sort_problem (fold_map merge_scc cmd_sccs complete)
   6.655 -        else
   6.656 -          (Graph.schedule (K snd) G, complete)
   6.657 -      end;
   6.658 -
   6.659 -    val typedecls = filter (can (fn ITVal _ => ())) cmds;
   6.660 -    val (mixed, complete) =
   6.661 -      (filter (can (fn ITypedef _ => () | IQuotient _ => () | ICoData _ => () | IVal _ => ()
   6.662 -         | ICoPred _ => () | IRec _ => () | ISpec _ => ())) cmds, true)
   6.663 -      |> sort_problem;
   6.664 -    val axioms = filter (can (fn IAxiom _ => ())) cmds;
   6.665 -    val goals = filter (can (fn IGoal _ => ())) cmds;
   6.666 -    val evals = filter (can (fn IEval _ => ())) cmds;
   6.667 -  in
   6.668 -    (typedecls @ mixed @ axioms @ goals @ evals, complete)
   6.669 -  end;
   6.670 -
   6.671 -fun group_of (ITVal _) = 1
   6.672 -  | group_of (ITypedef _) = 2
   6.673 -  | group_of (IQuotient _) = 3
   6.674 -  | group_of (ICoData _) = 4
   6.675 -  | group_of (IVal _) = 5
   6.676 -  | group_of (ICoPred _) = 6
   6.677 -  | group_of (IRec _) = 7
   6.678 -  | group_of (ISpec _) = 8
   6.679 -  | group_of (IAxiom _) = 9
   6.680 -  | group_of (IGoal _) = 10
   6.681 -  | group_of (IEval _) = 11;
   6.682 -
   6.683 -fun group_isa_commands [] = []
   6.684 -  | group_isa_commands [cmd] = [[cmd]]
   6.685 -  | group_isa_commands (cmd :: cmd' :: cmds) =
   6.686 -    let val (group :: groups) = group_isa_commands (cmd' :: cmds) in
   6.687 -      if group_of cmd = group_of cmd' then
   6.688 -        (cmd :: group) :: groups
   6.689 -      else
   6.690 -        [cmd] :: (group :: groups)
   6.691 -    end;
   6.692 -
   6.693 -fun defined_by (Const (@{const_name All}, _) $ t) = defined_by t
   6.694 -  | defined_by (Abs (_, _, t)) = defined_by t
   6.695 -  | defined_by (@{const implies} $ _ $ u) = defined_by u
   6.696 -  | defined_by (Const (@{const_name HOL.eq}, _) $ t $ _) = head_of t
   6.697 -  | defined_by t = head_of t;
   6.698 -
   6.699 -fun partition_props [_] props = SOME [props]
   6.700 -  | partition_props consts props =
   6.701 -    let
   6.702 -      val propss = map (fn const => filter (fn prop => defined_by prop aconv const) props) consts;
   6.703 -    in
   6.704 -      if eq_set (op aconv) (props, flat propss) andalso forall (not o null) propss then SOME propss
   6.705 -      else NONE
   6.706 -    end;
   6.707 -
   6.708 -fun hol_concl_head (Const (@{const_name All}, _) $ Abs (_, _, t)) = hol_concl_head t
   6.709 -  | hol_concl_head (Const (@{const_name implies}, _) $ _ $ t) = hol_concl_head t
   6.710 -  | hol_concl_head (t $ _) = hol_concl_head t
   6.711 -  | hol_concl_head t = t;
   6.712 -
   6.713 -fun is_inductive_set_intro t =
   6.714 -  (case hol_concl_head t of
   6.715 -    Const (@{const_name rmember}, _) => true
   6.716 -  | _ => false);
   6.717 -
   6.718 -exception NO_TRIPLE of unit;
   6.719 -
   6.720 -fun triple_for_intro_rule ctxt x rule =
   6.721 -  let
   6.722 -    val (prems, concl) = Logic.strip_horn rule
   6.723 -      |>> map (Object_Logic.atomize_term ctxt)
   6.724 -      ||> Object_Logic.atomize_term ctxt;
   6.725 -
   6.726 -    val (mains, sides) = List.partition (exists_Const (curry (op =) x)) prems;
   6.727 -
   6.728 -    val is_right_head = curry (op aconv) (Const x) o head_of;
   6.729 -  in
   6.730 -    if forall is_right_head mains then (sides, mains, concl) else raise NO_TRIPLE ()
   6.731 -  end;
   6.732 -
   6.733 -val tuple_for_args = HOLogic.mk_tuple o snd o strip_comb;
   6.734 -
   6.735 -fun wf_constraint_for rel sides concl mains =
   6.736 -  HOLogic.mk_mem (HOLogic.mk_prod (apply2 tuple_for_args (mains, concl)), Var rel)
   6.737 -  |> fold (curry HOLogic.mk_imp) sides
   6.738 -  |> close_form [rel];
   6.739 -
   6.740 -fun wf_constraint_for_triple rel (sides, mains, concl) =
   6.741 -  map (wf_constraint_for rel sides concl) mains
   6.742 -  |> foldr1 HOLogic.mk_conj;
   6.743 -
   6.744 -fun terminates_by ctxt timeout goal tac =
   6.745 -  can (SINGLE (Classical.safe_tac ctxt) #> the
   6.746 -    #> SINGLE (DETERM_TIMEOUT timeout (tac ctxt (auto_tac ctxt))) #> the
   6.747 -    #> Goal.finish ctxt) goal;
   6.748 -
   6.749 -val max_cached_wfs = 50;
   6.750 -val cached_timeout = Synchronized.var "Nunchaku_Collect.cached_timeout" Time.zeroTime;
   6.751 -val cached_wf_props = Synchronized.var "Nunchaku_Collect.cached_wf_props" ([] : (term * bool) list);
   6.752 -
   6.753 -val termination_tacs = [Lexicographic_Order.lex_order_tac true, ScnpReconstruct.sizechange_tac];
   6.754 -
   6.755 -fun is_wellfounded_inductive_predicate ctxt wfs debug wf_timeout const intros =
   6.756 -  let
   6.757 -    val thy = Proof_Context.theory_of ctxt;
   6.758 -
   6.759 -    val Const (x as (_, T)) = head_of (HOLogic.dest_Trueprop (Logic.strip_imp_concl (hd intros)));
   6.760 -  in
   6.761 -    (case triple_lookup (const_match thy o swap) wfs (dest_Const const) of
   6.762 -      SOME (SOME wf) => wf
   6.763 -    | _ =>
   6.764 -      (case map (triple_for_intro_rule ctxt x) intros |> filter_out (null o #2) of
   6.765 -        [] => true
   6.766 -      | triples =>
   6.767 -        let
   6.768 -          val binders_T = HOLogic.mk_tupleT (binder_types T);
   6.769 -          val rel_T = HOLogic.mk_setT (HOLogic.mk_prodT (binders_T, binders_T));
   6.770 -          val j = fold (Integer.max o maxidx_of_term) intros 0 + 1;
   6.771 -          val rel = (("R", j), rel_T);
   6.772 -          val prop =
   6.773 -            Const (@{const_name wf}, rel_T --> HOLogic.boolT) $ Var rel ::
   6.774 -            map (wf_constraint_for_triple rel) triples
   6.775 -            |> foldr1 HOLogic.mk_conj
   6.776 -            |> HOLogic.mk_Trueprop;
   6.777 -        in
   6.778 -          if debug then writeln ("Wellfoundedness goal: " ^ Syntax.string_of_term ctxt prop)
   6.779 -          else ();
   6.780 -          if wf_timeout = Synchronized.value cached_timeout andalso
   6.781 -             length (Synchronized.value cached_wf_props) < max_cached_wfs then
   6.782 -            ()
   6.783 -          else
   6.784 -            (Synchronized.change cached_wf_props (K []);
   6.785 -             Synchronized.change cached_timeout (K wf_timeout));
   6.786 -          (case AList.lookup (op =) (Synchronized.value cached_wf_props) prop of
   6.787 -            SOME wf => wf
   6.788 -          | NONE =>
   6.789 -            let
   6.790 -              val goal = Goal.init (Thm.cterm_of ctxt prop);
   6.791 -              val wf = exists (terminates_by ctxt wf_timeout goal) termination_tacs;
   6.792 -            in
   6.793 -              Synchronized.change cached_wf_props (cons (prop, wf)); wf
   6.794 -            end)
   6.795 -        end)
   6.796 -      handle
   6.797 -        List.Empty => false
   6.798 -      | NO_TRIPLE () => false)
   6.799 -  end;
   6.800 -
   6.801 -datatype lhs_pat =
   6.802 -  Only_Vars
   6.803 -| Prim_Pattern of string
   6.804 -| Any_Pattern;
   6.805 -
   6.806 -fun is_likely_pat_complete ctxt props =
   6.807 -  let
   6.808 -    val is_Var_or_Bound = is_Var orf is_Bound;
   6.809 -
   6.810 -    fun lhs_pat_of t =
   6.811 -      (case t of
   6.812 -        Const (@{const_name All}, _) $ Abs (_, _, t) => lhs_pat_of t
   6.813 -      | Const (@{const_name HOL.eq}, _) $ u $ _ =>
   6.814 -        (case filter_out is_Var_or_Bound (snd (strip_comb u)) of
   6.815 -          [] => Only_Vars
   6.816 -        | [v] =>
   6.817 -          (case strip_comb v of
   6.818 -            (cst as Const (_, T), args) =>
   6.819 -            (case body_type T of
   6.820 -              Type (T_name, _) =>
   6.821 -              if can (Ctr_Sugar.dest_ctr ctxt T_name) cst andalso forall is_Var_or_Bound args then
   6.822 -                Prim_Pattern T_name
   6.823 -              else
   6.824 -                Any_Pattern
   6.825 -            | _ => Any_Pattern)
   6.826 -          | _ => Any_Pattern)
   6.827 -        | _ => Any_Pattern)
   6.828 -      | _ => Any_Pattern);
   6.829 -  in
   6.830 -    (case map lhs_pat_of props of
   6.831 -      [] => false
   6.832 -    | pats as Prim_Pattern T_name :: _ =>
   6.833 -      forall (can (fn Prim_Pattern _ => ())) pats andalso
   6.834 -      length pats = length (#ctrs (the (Ctr_Sugar.ctr_sugar_of ctxt T_name)))
   6.835 -    | pats => forall (curry (op =) Only_Vars) pats)
   6.836 -  end;
   6.837 -
   6.838 -(* Prevents divergence in case of cyclic or infinite axiom dependencies. *)
   6.839 -val axioms_max_depth = 255
   6.840 -
   6.841 -fun isa_problem_of_subgoal ctxt falsify wfs whacks cards debug wf_timeout evals0 some_assms0
   6.842 -    subgoal0 =
   6.843 -  let
   6.844 -    val thy = Proof_Context.theory_of ctxt;
   6.845 -
   6.846 -    fun card_of T =
   6.847 -      (case triple_lookup (typ_match thy o swap) cards T of
   6.848 -        NONE => (NONE, NONE)
   6.849 -      | SOME (c1, c2) => (if c1 = SOME 1 then NONE else c1, c2));
   6.850 -
   6.851 -    fun axioms_of_class class =
   6.852 -      #axioms (Axclass.get_info thy class)
   6.853 -      handle ERROR _ => [];
   6.854 -
   6.855 -    fun monomorphize_class_axiom T t =
   6.856 -      (case Term.add_tvars t [] of
   6.857 -        [] => t
   6.858 -      | [(x, S)] => Envir.subst_term_types (Vartab.make [(x, (S, T))]) t);
   6.859 -
   6.860 -    fun consider_sort depth T S (seens as (seenS, seenT, seen), problem) =
   6.861 -      if member (op =) seenS S then
   6.862 -        (seens, problem)
   6.863 -      else if depth > axioms_max_depth then
   6.864 -        raise TOO_DEEP_DEPS ()
   6.865 -      else
   6.866 -        let
   6.867 -          val seenS = S :: seenS;
   6.868 -          val seens = (seenS, seenT, seen);
   6.869 -
   6.870 -          val supers = Sign.complete_sort thy S;
   6.871 -          val axioms0 = maps (map Thm.prop_of o axioms_of_class) supers;
   6.872 -          val axioms = map (preprocess_prop false ctxt whacks o monomorphize_class_axiom T) axioms0;
   6.873 -        in
   6.874 -          (seens, map IAxiom axioms @ problem)
   6.875 -          |> fold (consider_term (depth + 1)) axioms
   6.876 -        end
   6.877 -    and consider_type depth T =
   6.878 -      (case T of
   6.879 -        Type (s, Ts) =>
   6.880 -        if is_type_builtin s then fold (consider_type depth) Ts
   6.881 -        else consider_non_builtin_type depth T
   6.882 -      | _ => consider_non_builtin_type depth T)
   6.883 -    and consider_non_builtin_type depth T (seens as (seenS, seenT, seen), problem) =
   6.884 -      if member (op =) seenT T then
   6.885 -        (seens, problem)
   6.886 -      else
   6.887 -        let
   6.888 -          val seenT = T :: seenT;
   6.889 -          val seens = (seenS, seenT, seen);
   6.890 -
   6.891 -          fun consider_typedef_or_quotient itypedef_or_quotient tuple_of s =
   6.892 -            let
   6.893 -              val (T0, repT0, wrt0, abs0, rep0) = tuple_of ctxt whacks s;
   6.894 -              val tyenv = Sign.typ_match thy (T0, T) Vartab.empty;
   6.895 -              val substT = Envir.subst_type tyenv;
   6.896 -              val subst = Envir.subst_term_types tyenv;
   6.897 -              val repT = substT repT0;
   6.898 -              val wrt = subst (wrt0 ());
   6.899 -              val abs = subst abs0;
   6.900 -              val rep = subst rep0;
   6.901 -            in
   6.902 -              apsnd (cons (itypedef_or_quotient {abs_typ = T, rep_typ = repT, wrt = wrt, abs = abs,
   6.903 -                rep = rep}))
   6.904 -              #> consider_term (depth + 1) wrt
   6.905 -            end;
   6.906 -        in
   6.907 -          (seens, problem)
   6.908 -          |> (case T of
   6.909 -               TFree (_, S) =>
   6.910 -               apsnd (cons (ITVal (T, card_of T)))
   6.911 -               #> consider_sort depth T S
   6.912 -             | TVar (_, S) => consider_sort depth T S
   6.913 -             | Type (s, Ts) =>
   6.914 -               fold (consider_type depth) Ts
   6.915 -               #> (case classify_type_name ctxt s of
   6.916 -                    Co_Datatype =>
   6.917 -                    let
   6.918 -                      val (fp, fpTs, ctrss) = mutual_co_datatypes_of ctxt (s, Ts);
   6.919 -                      val specs = map2 (fn T => fn ctrs => {typ = T, ctrs = ctrs}) fpTs ctrss;
   6.920 -                    in
   6.921 -                      (fn ((seenS, seenT, seen), problem) =>
   6.922 -                          ((seenS, union (op =) fpTs seenT, seen), ICoData (fp, specs) :: problem))
   6.923 -                      #> fold (fold (consider_type (depth + 1) o fastype_of)) ctrss
   6.924 -                    end
   6.925 -                  | Typedef => consider_typedef_or_quotient ITypedef typedef_of s
   6.926 -                  | Quotient => consider_typedef_or_quotient IQuotient quotient_of s
   6.927 -                  | TVal => apsnd (cons (ITVal (T, card_of T)))))
   6.928 -        end
   6.929 -    and consider_term depth t =
   6.930 -      (case t of
   6.931 -        t1 $ t2 => fold (consider_term depth) [t1, t2]
   6.932 -      | Var (_, T) => consider_type depth T
   6.933 -      | Bound _ => I
   6.934 -      | Abs (_, T, t') =>
   6.935 -        consider_term depth t'
   6.936 -        #> consider_type depth T
   6.937 -      | _ => (fn (seens as (seenS, seenT, seen), problem) =>
   6.938 -          if member (op aconv) seen t then
   6.939 -            (seens, problem)
   6.940 -          else if depth > axioms_max_depth then
   6.941 -            raise TOO_DEEP_DEPS ()
   6.942 -          else
   6.943 -            let
   6.944 -              val seen = t :: seen;
   6.945 -              val seens = (seenS, seenT, seen);
   6.946 -            in
   6.947 -              (case t of
   6.948 -                Const (x as (s, T)) =>
   6.949 -                (if is_const_builtin s orelse is_co_datatype_ctr ctxt x orelse
   6.950 -                    is_co_datatype_case ctxt x orelse is_quotient_abs ctxt whacks x orelse
   6.951 -                    is_quotient_rep ctxt whacks x orelse is_typedef_abs ctxt whacks x orelse
   6.952 -                    is_typedef_rep ctxt whacks x then
   6.953 -                   (seens, problem)
   6.954 -                 else if is_stale_typedef_abs ctxt whacks x orelse
   6.955 -                     is_stale_typedef_rep ctxt whacks x then
   6.956 -                   raise UNSUPPORTED_FUNC t
   6.957 -                 else
   6.958 -                   (case spec_rules_of ctxt x of
   6.959 -                     SOME (classif, consts, props0, poly_props) =>
   6.960 -                     let
   6.961 -                       val props = map (preprocess_prop false ctxt whacks) props0;
   6.962 -
   6.963 -                       fun def_or_spec () =
   6.964 -                         (case definition_of thy x of
   6.965 -                           SOME eq0 =>
   6.966 -                           let val eq = preprocess_prop false ctxt whacks eq0 in
   6.967 -                             ([eq], [IRec [{const = t, props = [eq], pat_complete = true}]])
   6.968 -                           end
   6.969 -                         | NONE => (props, [ISpec {consts = consts, props = props}]));
   6.970 -
   6.971 -                       val (props', cmds) =
   6.972 -                         if null props then
   6.973 -                           ([], map IVal consts)
   6.974 -                         else if classif = Spec_Rules.Equational then
   6.975 -                           (case partition_props consts props of
   6.976 -                             SOME propss =>
   6.977 -                             (props,
   6.978 -                              [IRec (map2 (fn const => fn props =>
   6.979 -                                   {const = const, props = props,
   6.980 -                                    pat_complete = is_likely_pat_complete ctxt props})
   6.981 -                                 consts propss)])
   6.982 -                           | NONE => def_or_spec ())
   6.983 -                         else if member (op =) [Spec_Rules.Inductive, Spec_Rules.Co_Inductive]
   6.984 -                             classif then
   6.985 -                           if is_inductive_set_intro (hd props) then
   6.986 -                             def_or_spec ()
   6.987 -                           else
   6.988 -                             (case partition_props consts props of
   6.989 -                               SOME propss =>
   6.990 -                               (props,
   6.991 -                                [ICoPred (if classif = Spec_Rules.Inductive then BNF_Util.Least_FP
   6.992 -                                   else BNF_Util.Greatest_FP,
   6.993 -                                 length consts = 1 andalso
   6.994 -                                 is_wellfounded_inductive_predicate ctxt wfs debug wf_timeout
   6.995 -                                   (the_single consts) poly_props,
   6.996 -                                 map2 (fn const => fn props => {const = const, props = props})
   6.997 -                                   consts propss)])
   6.998 -                             | NONE => def_or_spec ())
   6.999 -                         else
  6.1000 -                           def_or_spec ();
  6.1001 -                     in
  6.1002 -                       ((seenS, seenT, union (op aconv) consts seen), cmds @ problem)
  6.1003 -                       |> fold (consider_term (depth + 1)) props'
  6.1004 -                     end
  6.1005 -                   | NONE =>
  6.1006 -                     (case definition_of thy x of
  6.1007 -                       SOME eq0 =>
  6.1008 -                       let val eq = preprocess_prop false ctxt whacks eq0 in
  6.1009 -                         (seens, IRec [{const = t, props = [eq], pat_complete = true}] :: problem)
  6.1010 -                         |> consider_term (depth + 1) eq
  6.1011 -                       end
  6.1012 -                     | NONE => (seens, IVal t :: problem))))
  6.1013 -                |> consider_type depth T
  6.1014 -              | Free (_, T) =>
  6.1015 -                (seens, IVal t :: problem)
  6.1016 -                |> consider_type depth T)
  6.1017 -            end));
  6.1018 -
  6.1019 -    val (poly_axioms, mono_axioms0) = orphan_axioms_of ctxt
  6.1020 -      |> List.partition has_polymorphism;
  6.1021 -
  6.1022 -    fun implicit_evals_of pol (@{const Not} $ t) = implicit_evals_of (not pol) t
  6.1023 -      | implicit_evals_of pol (@{const implies} $ t $ u) =
  6.1024 -        (case implicit_evals_of pol u of
  6.1025 -          [] => implicit_evals_of (not pol) t
  6.1026 -        | ts => ts)
  6.1027 -      | implicit_evals_of pol (@{const conj} $ t $ u) =
  6.1028 -        union (op aconv) (implicit_evals_of pol t) (implicit_evals_of pol u)
  6.1029 -      | implicit_evals_of pol (@{const disj} $ t $ u) =
  6.1030 -        union (op aconv) (implicit_evals_of pol t) (implicit_evals_of pol u)
  6.1031 -      | implicit_evals_of false (Const (@{const_name HOL.eq}, _) $ t $ u) =
  6.1032 -        distinct (op aconv) [t, u]
  6.1033 -      | implicit_evals_of true (Const (@{const_name HOL.eq}, _) $ t $ _) = [t]
  6.1034 -      | implicit_evals_of _ _ = [];
  6.1035 -
  6.1036 -    val mono_axioms_and_some_assms =
  6.1037 -      map (preprocess_prop false ctxt whacks) (mono_axioms0 @ some_assms0);
  6.1038 -    val subgoal = preprocess_prop falsify ctxt whacks subgoal0;
  6.1039 -    val implicit_evals = implicit_evals_of true subgoal;
  6.1040 -    val evals = map (preprocess_closed_term ctxt whacks) evals0;
  6.1041 -    val seens = ([], [], []);
  6.1042 -
  6.1043 -    val (commandss, complete) =
  6.1044 -      (seens,
  6.1045 -       map IAxiom mono_axioms_and_some_assms @ [IGoal subgoal] @ map IEval (implicit_evals @ evals))
  6.1046 -      |> fold (consider_term 0) (subgoal :: evals @ mono_axioms_and_some_assms)
  6.1047 -      |> snd
  6.1048 -      |> rev (* prettier *)
  6.1049 -      |> sort_isa_commands_topologically ctxt
  6.1050 -      |>> group_isa_commands;
  6.1051 -  in
  6.1052 -    (poly_axioms, {commandss = commandss, sound = true, complete = complete})
  6.1053 -  end;
  6.1054 -
  6.1055 -fun add_pat_complete_of_command cmd =
  6.1056 -  (case cmd of
  6.1057 -    ICoPred (_, _, specs) => union (op =) (map #const specs)
  6.1058 -  | IRec specs =>
  6.1059 -    union (op =) (map_filter (try (fn {const, pat_complete = true, ...} => const)) specs)
  6.1060 -  | _ => I);
  6.1061 -
  6.1062 -fun pat_completes_of_isa_problem {commandss, ...} =
  6.1063 -  fold (fold add_pat_complete_of_command) commandss [];
  6.1064 -
  6.1065 -fun str_of_isa_term_with_type ctxt t =
  6.1066 -  Syntax.string_of_term ctxt t ^ " : " ^ Syntax.string_of_typ ctxt (fastype_of t);
  6.1067 -
  6.1068 -fun is_triv_wrt (Abs (_, _, body)) = is_triv_wrt body
  6.1069 -  | is_triv_wrt @{const True} = true
  6.1070 -  | is_triv_wrt _ = false;
  6.1071 -
  6.1072 -fun str_of_isa_type_spec ctxt {abs_typ, rep_typ, wrt, abs, rep} =
  6.1073 -  Syntax.string_of_typ ctxt abs_typ ^ " := " ^ Syntax.string_of_typ ctxt rep_typ ^
  6.1074 -  (if is_triv_wrt wrt then "" else "\n  wrt " ^ Syntax.string_of_term ctxt wrt) ^
  6.1075 -  "\n  abstract " ^ Syntax.string_of_term ctxt abs ^
  6.1076 -  "\n  concrete " ^ Syntax.string_of_term ctxt rep;
  6.1077 -
  6.1078 -fun str_of_isa_co_data_spec ctxt {typ, ctrs} =
  6.1079 -  Syntax.string_of_typ ctxt typ ^ " :=\n  " ^
  6.1080 -  space_implode "\n| " (map (str_of_isa_term_with_type ctxt) ctrs);
  6.1081 -
  6.1082 -fun str_of_isa_const_spec ctxt {const, props} =
  6.1083 -  str_of_isa_term_with_type ctxt const ^ " :=\n  " ^
  6.1084 -  space_implode ";\n  " (map (Syntax.string_of_term ctxt) props);
  6.1085 -
  6.1086 -fun str_of_isa_rec_spec ctxt {const, props, pat_complete} =
  6.1087 -  str_of_isa_term_with_type ctxt const ^ (if pat_complete then " [pat_complete]" else "") ^
  6.1088 -  " :=\n " ^ space_implode ";\n " (map (Syntax.string_of_term ctxt) props);
  6.1089 -
  6.1090 -fun str_of_isa_consts_spec ctxt {consts, props} =
  6.1091 -  space_implode " and\n     " (map (str_of_isa_term_with_type ctxt) consts) ^ " :=\n  " ^
  6.1092 -  space_implode ";\n  " (map (Syntax.string_of_term ctxt) props);
  6.1093 -
  6.1094 -fun str_of_isa_card NONE = ""
  6.1095 -  | str_of_isa_card (SOME k) = signed_string_of_int k;
  6.1096 -
  6.1097 -fun str_of_isa_cards_suffix (NONE, NONE) = ""
  6.1098 -  | str_of_isa_cards_suffix (c1, c2) = " " ^ str_of_isa_card c1 ^ "-" ^ str_of_isa_card c2;
  6.1099 -
  6.1100 -fun str_of_isa_command ctxt (ITVal (T, cards)) =
  6.1101 -    "type " ^ Syntax.string_of_typ ctxt T ^ str_of_isa_cards_suffix cards
  6.1102 -  | str_of_isa_command ctxt (ITypedef spec) = "typedef " ^ str_of_isa_type_spec ctxt spec
  6.1103 -  | str_of_isa_command ctxt (IQuotient spec) = "quotient " ^ str_of_isa_type_spec ctxt spec
  6.1104 -  | str_of_isa_command ctxt (ICoData (fp, specs)) =
  6.1105 -    BNF_Util.case_fp fp "data" "codata" ^ " " ^ str_of_and_list (str_of_isa_co_data_spec ctxt) specs
  6.1106 -  | str_of_isa_command ctxt (IVal t) = "val " ^ str_of_isa_term_with_type ctxt t
  6.1107 -  | str_of_isa_command ctxt (ICoPred (fp, wf, specs)) =
  6.1108 -    BNF_Util.case_fp fp "pred" "copred" ^ " " ^ (if wf then "[wf] " else "") ^
  6.1109 -    str_of_and_list (str_of_isa_const_spec ctxt) specs
  6.1110 -  | str_of_isa_command ctxt (IRec specs) = "rec " ^ str_of_and_list (str_of_isa_rec_spec ctxt) specs
  6.1111 -  | str_of_isa_command ctxt (ISpec spec) = "spec " ^ str_of_isa_consts_spec ctxt spec
  6.1112 -  | str_of_isa_command ctxt (IAxiom prop) = "axiom " ^ Syntax.string_of_term ctxt prop
  6.1113 -  | str_of_isa_command ctxt (IGoal prop) = "goal " ^ Syntax.string_of_term ctxt prop
  6.1114 -  | str_of_isa_command ctxt (IEval t) = "eval " ^ Syntax.string_of_term ctxt t;
  6.1115 -
  6.1116 -fun str_of_isa_problem ctxt {commandss, sound, complete} =
  6.1117 -  map (cat_lines o map (suffix "." o str_of_isa_command ctxt)) commandss
  6.1118 -  |> space_implode "\n\n" |> suffix "\n"
  6.1119 -  |> prefix ("# " ^ (if sound then "sound" else "unsound") ^ "\n")
  6.1120 -  |> prefix ("# " ^ (if complete then "complete" else "incomplete") ^ "\n");
  6.1121 -
  6.1122 -end;
     7.1 --- a/src/HOL/Nunchaku/Tools/nunchaku_commands.ML	Thu Sep 07 23:13:15 2017 +0200
     7.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.3 @@ -1,265 +0,0 @@
     7.4 -(*  Title:      HOL/Nunchaku/Tools/nunchaku_commands.ML
     7.5 -    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
     7.6 -    Copyright   2015, 2016
     7.7 -
     7.8 -Adds the "nunchaku" and "nunchaku_params" commands to Isabelle/Isar's outer syntax.
     7.9 -*)
    7.10 -
    7.11 -signature NUNCHAKU_COMMANDS =
    7.12 -sig
    7.13 -  type params = Nunchaku.params
    7.14 -
    7.15 -  val default_params: theory -> (string * string) list -> params
    7.16 -end;
    7.17 -
    7.18 -structure Nunchaku_Commands : NUNCHAKU_COMMANDS =
    7.19 -struct
    7.20 -
    7.21 -open Nunchaku_Util;
    7.22 -open Nunchaku;
    7.23 -
    7.24 -type raw_param = string * string list;
    7.25 -
    7.26 -val default_default_params =
    7.27 -  [("assms", "true"),
    7.28 -   ("debug", "false"),
    7.29 -   ("falsify", "true"),
    7.30 -   ("max_genuine", "1"),
    7.31 -   ("max_potential", "1"),
    7.32 -   ("overlord", "false"),
    7.33 -   ("solvers", "cvc4 kodkod paradox smbc"),
    7.34 -   ("specialize", "true"),
    7.35 -   ("spy", "false"),
    7.36 -   ("timeout", "30"),
    7.37 -   ("verbose", "false"),
    7.38 -   ("wf_timeout", "0.5")];
    7.39 -
    7.40 -val negated_params =
    7.41 -  [("dont_whack", "whack"),
    7.42 -   ("dont_specialize", "specialize"),
    7.43 -   ("dont_spy", "spy"),
    7.44 -   ("no_assms", "assms"),
    7.45 -   ("no_debug", "debug"),
    7.46 -   ("no_overlord", "overlord"),
    7.47 -   ("non_mono", "mono"),
    7.48 -   ("non_wf", "wf"),
    7.49 -   ("quiet", "verbose"),
    7.50 -   ("satisfy", "falsify")];
    7.51 -
    7.52 -fun is_known_raw_param s =
    7.53 -  AList.defined (op =) default_default_params s orelse
    7.54 -  AList.defined (op =) negated_params s orelse
    7.55 -  member (op =) ["atoms", "card", "eval", "expect"] s orelse
    7.56 -  exists (fn p => String.isPrefix (p ^ " ") s)
    7.57 -    ["atoms", "card", "dont_whack", "mono", "non_mono", "non_wf", "wf", "whack"];
    7.58 -
    7.59 -fun check_raw_param (s, _) =
    7.60 -  if is_known_raw_param s then () else error ("Unknown parameter: " ^ quote s);
    7.61 -
    7.62 -fun unnegate_param_name name =
    7.63 -  (case AList.lookup (op =) negated_params name of
    7.64 -    NONE =>
    7.65 -    if String.isPrefix "dont_" name then SOME (unprefix "dont_" name)
    7.66 -    else if String.isPrefix "non_" name then SOME (unprefix "non_" name)
    7.67 -    else NONE
    7.68 -  | some_name => some_name);
    7.69 -
    7.70 -fun normalize_raw_param (name, value) =
    7.71 -  (case unnegate_param_name name of
    7.72 -    SOME name' =>
    7.73 -    [(name',
    7.74 -      (case value of
    7.75 -        ["false"] => ["true"]
    7.76 -      | ["true"] => ["false"]
    7.77 -      | [] => ["false"]
    7.78 -      | _ => value))]
    7.79 -  | NONE => [(name, value)]);
    7.80 -
    7.81 -structure Data = Theory_Data
    7.82 -(
    7.83 -  type T = raw_param list
    7.84 -  val empty = default_default_params |> map (apsnd single)
    7.85 -  val extend = I
    7.86 -  fun merge data = AList.merge (op =) (K true) data
    7.87 -);
    7.88 -
    7.89 -val set_default_raw_param = Data.map o fold (AList.update (op =)) o normalize_raw_param;
    7.90 -val default_raw_params = Data.get;
    7.91 -
    7.92 -fun is_punctuation s = (s = "," orelse s = "-");
    7.93 -
    7.94 -fun stringify_raw_param_value [] = ""
    7.95 -  | stringify_raw_param_value [s] = s
    7.96 -  | stringify_raw_param_value (s1 :: s2 :: ss) =
    7.97 -    s1 ^ (if is_punctuation s1 orelse is_punctuation s2 then "" else " ") ^
    7.98 -    stringify_raw_param_value (s2 :: ss);
    7.99 -
   7.100 -fun extract_params ctxt mode default_params override_params =
   7.101 -  let
   7.102 -    val override_params = maps normalize_raw_param override_params;
   7.103 -    val raw_params = rev override_params @ rev default_params;
   7.104 -    val raw_lookup = AList.lookup (op =) raw_params;
   7.105 -    val lookup = Option.map stringify_raw_param_value o raw_lookup;
   7.106 -    val lookup_string = the_default "" o lookup;
   7.107 -    val lookup_strings = these o Option.map (space_explode " ") o lookup;
   7.108 -
   7.109 -    fun general_lookup_bool option default_value name =
   7.110 -      (case lookup name of
   7.111 -        SOME s => parse_bool_option option name s
   7.112 -      | NONE => default_value);
   7.113 -
   7.114 -    val lookup_bool = the o general_lookup_bool false (SOME false);
   7.115 -
   7.116 -    fun lookup_int name =
   7.117 -      (case lookup name of
   7.118 -        SOME s =>
   7.119 -        (case Int.fromString s of
   7.120 -          SOME i => i
   7.121 -        | NONE => error ("Parameter " ^ quote name ^ " must be assigned an integer value"))
   7.122 -      | NONE => 0);
   7.123 -
   7.124 -    fun int_range_from_string name s =
   7.125 -      (case space_explode "-" s of
   7.126 -         [s] => (s, s)
   7.127 -       | [s1, s2] => (s1, s2)
   7.128 -       | _ => error ("Parameter " ^ quote name ^ " must be assigned a range of integers"))
   7.129 -      |> apply2 Int.fromString;
   7.130 -
   7.131 -    fun lookup_assigns read pre of_str =
   7.132 -      (case lookup pre of
   7.133 -        SOME s => [(NONE, of_str s)]
   7.134 -      | NONE => []) @
   7.135 -      map (fn (name, value) => (SOME (read (String.extract (name, size pre + 1, NONE))),
   7.136 -          of_str (stringify_raw_param_value value)))
   7.137 -        (filter (String.isPrefix (pre ^ " ") o fst) raw_params);
   7.138 -
   7.139 -    fun lookup_int_range_assigns read pre =
   7.140 -      lookup_assigns read pre (int_range_from_string pre);
   7.141 -
   7.142 -    fun lookup_bool_assigns read pre =
   7.143 -      lookup_assigns read pre (the o parse_bool_option false pre);
   7.144 -
   7.145 -    fun lookup_bool_option_assigns read pre =
   7.146 -      lookup_assigns read pre (parse_bool_option true pre);
   7.147 -
   7.148 -    fun lookup_strings_assigns read pre =
   7.149 -      lookup_assigns read pre (space_explode " ");
   7.150 -
   7.151 -    fun lookup_time name =
   7.152 -      (case lookup name of
   7.153 -        SOME s => parse_time name s
   7.154 -      | NONE => Time.zeroTime);
   7.155 -
   7.156 -    val read_type_polymorphic =
   7.157 -      Syntax.read_typ ctxt #> Logic.mk_type
   7.158 -      #> singleton (Variable.polymorphic ctxt) #> Logic.dest_type;
   7.159 -    val read_term_polymorphic =
   7.160 -      Syntax.read_term ctxt #> singleton (Variable.polymorphic ctxt);
   7.161 -    val lookup_term_list_option_polymorphic =
   7.162 -      AList.lookup (op =) raw_params #> Option.map (map read_term_polymorphic);
   7.163 -
   7.164 -    fun read_const_polymorphic s =
   7.165 -      (case read_term_polymorphic s of
   7.166 -        Const x => x
   7.167 -      | t => error ("Not a constant: " ^ Syntax.string_of_term ctxt t));
   7.168 -
   7.169 -    val solvers = lookup_strings "solvers";
   7.170 -    val falsify = lookup_bool "falsify";
   7.171 -    val assms = lookup_bool "assms";
   7.172 -    val spy = getenv "NUNCHAKU_SPY" = "yes" orelse lookup_bool "spy";
   7.173 -    val overlord = lookup_bool "overlord";
   7.174 -    val expect = lookup_string "expect";
   7.175 -
   7.176 -    val wfs = lookup_bool_option_assigns read_const_polymorphic "wf";
   7.177 -    val whacks = lookup_bool_assigns read_term_polymorphic "whack";
   7.178 -    val cards = lookup_int_range_assigns read_type_polymorphic "card";
   7.179 -    val monos = lookup_bool_option_assigns read_type_polymorphic "mono";
   7.180 -
   7.181 -    val debug = (mode <> Auto_Try andalso lookup_bool "debug");
   7.182 -    val verbose = debug orelse (mode <> Auto_Try andalso lookup_bool "verbose");
   7.183 -    val max_potential = if mode = Normal then Int.max (0, lookup_int "max_potential") else 0;
   7.184 -    val max_genuine = Int.max (0, lookup_int "max_genuine");
   7.185 -    val evals = these (lookup_term_list_option_polymorphic "eval");
   7.186 -    val atomss = lookup_strings_assigns read_type_polymorphic "atoms";
   7.187 -
   7.188 -    val specialize = lookup_bool "specialize";
   7.189 -    val multithread = mode = Normal andalso lookup_bool "multithread";
   7.190 -
   7.191 -    val timeout = lookup_time "timeout";
   7.192 -    val wf_timeout = lookup_time "wf_timeout";
   7.193 -
   7.194 -    val mode_of_operation_params =
   7.195 -      {solvers = solvers, falsify = falsify, assms = assms, spy = spy, overlord = overlord,
   7.196 -       expect = expect};
   7.197 -
   7.198 -    val scope_of_search_params =
   7.199 -      {wfs = wfs, whacks = whacks, cards = cards, monos = monos};
   7.200 -
   7.201 -    val output_format_params =
   7.202 -      {verbose = verbose, debug = debug, max_potential = max_potential, max_genuine = max_genuine,
   7.203 -       evals = evals, atomss = atomss};
   7.204 -
   7.205 -    val optimization_params =
   7.206 -      {specialize = specialize, multithread = multithread};
   7.207 -
   7.208 -    val timeout_params =
   7.209 -      {timeout = timeout, wf_timeout = wf_timeout};
   7.210 -  in
   7.211 -    {mode_of_operation_params = mode_of_operation_params,
   7.212 -     scope_of_search_params = scope_of_search_params,
   7.213 -     output_format_params = output_format_params,
   7.214 -     optimization_params = optimization_params,
   7.215 -     timeout_params = timeout_params}
   7.216 -  end;
   7.217 -
   7.218 -fun default_params thy =
   7.219 -  extract_params (Proof_Context.init_global thy) Normal (default_raw_params thy)
   7.220 -  o map (apsnd single);
   7.221 -
   7.222 -val parse_key = Scan.repeat1 Parse.embedded >> space_implode " ";
   7.223 -val parse_value =
   7.224 -  Scan.repeat1 (Parse.minus >> single
   7.225 -    || Scan.repeat1 (Scan.unless Parse.minus (Parse.name || Parse.float_number))
   7.226 -    || @{keyword ","} |-- Parse.number >> prefix "," >> single)
   7.227 -  >> flat;
   7.228 -val parse_param = parse_key -- Scan.optional (@{keyword "="} |-- parse_value) [];
   7.229 -val parse_params = Scan.optional (@{keyword "["} |-- Parse.list parse_param --| @{keyword "]"}) [];
   7.230 -
   7.231 -fun run_chaku override_params mode i state0 =
   7.232 -  let
   7.233 -    val state = Proof.map_contexts (Try0.silence_methods false) state0;
   7.234 -    val thy = Proof.theory_of state;
   7.235 -    val ctxt = Proof.context_of state;
   7.236 -    val _ = List.app check_raw_param override_params;
   7.237 -    val params = extract_params ctxt mode (default_raw_params thy) override_params;
   7.238 -  in
   7.239 -    (if mode = Auto_Try then perhaps o try else fn f => fn x => f x)
   7.240 -      (fn _ => run_chaku_on_subgoal state params mode i) (unknownN, NONE)
   7.241 -    |> `(fn (outcome_code, _) => outcome_code = genuineN)
   7.242 -  end;
   7.243 -
   7.244 -fun string_for_raw_param (name, value) =
   7.245 -  name ^ " = " ^ stringify_raw_param_value value;
   7.246 -
   7.247 -fun nunchaku_params_trans params =
   7.248 -  Toplevel.theory (fold set_default_raw_param params
   7.249 -    #> tap (fn thy =>
   7.250 -      let val params = rev (default_raw_params thy) in
   7.251 -        List.app check_raw_param params;
   7.252 -        writeln ("Default parameters for Nunchaku:\n" ^
   7.253 -          (params |> map string_for_raw_param |> sort_strings |> cat_lines))
   7.254 -      end));
   7.255 -
   7.256 -val _ =
   7.257 -  Outer_Syntax.command @{command_keyword nunchaku}
   7.258 -    "try to find a countermodel using Nunchaku"
   7.259 -    (parse_params -- Scan.optional Parse.nat 1 >> (fn (params, i) =>
   7.260 -       Toplevel.keep_proof (fn state =>
   7.261 -         ignore (run_chaku params Normal i (Toplevel.proof_of state)))));
   7.262 -
   7.263 -val _ =
   7.264 -  Outer_Syntax.command @{command_keyword nunchaku_params}
   7.265 -    "set and display the default parameters for Nunchaku"
   7.266 -    (parse_params #>> nunchaku_params_trans);
   7.267 -
   7.268 -end;
     8.1 --- a/src/HOL/Nunchaku/Tools/nunchaku_display.ML	Thu Sep 07 23:13:15 2017 +0200
     8.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.3 @@ -1,91 +0,0 @@
     8.4 -(*  Title:      HOL/Nunchaku/Tools/nunchaku_display.ML
     8.5 -    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
     8.6 -    Copyright   2015, 2016
     8.7 -
     8.8 -Pretty printing of Isabelle/HOL models for Nunchaku.
     8.9 -*)
    8.10 -
    8.11 -signature NUNCHAKU_DISPLAY =
    8.12 -sig
    8.13 -  type isa_model = Nunchaku_Reconstruct.isa_model
    8.14 -
    8.15 -  val pretty_of_isa_model_opt: Proof.context -> isa_model option -> Pretty.T
    8.16 -end;
    8.17 -
    8.18 -structure Nunchaku_Display : NUNCHAKU_DISPLAY =
    8.19 -struct
    8.20 -
    8.21 -open Nunchaku_Util;
    8.22 -open Nunchaku_Reconstruct;
    8.23 -
    8.24 -val indent_size = 2;
    8.25 -
    8.26 -val pretty_indent = Pretty.indent indent_size;
    8.27 -
    8.28 -fun sorting_str_of_typ (TFree (s, _)) = "a" ^ s
    8.29 -  | sorting_str_of_typ (Type (s, Ts)) = "b" ^ s ^ space_implode " " (map sorting_str_of_typ Ts)
    8.30 -  | sorting_str_of_typ (TVar _) = "X";
    8.31 -
    8.32 -fun sorting_str_of_term (Const (s, T)) = "b" ^ s ^ sorting_str_of_typ T
    8.33 -  | sorting_str_of_term (Free (s, _)) = "a" ^ s
    8.34 -  | sorting_str_of_term (t $ u) = sorting_str_of_term t ^ " " ^ sorting_str_of_term u
    8.35 -  | sorting_str_of_term (Abs (_, T, t)) = "c" ^ sorting_str_of_typ T ^ " " ^ sorting_str_of_term t
    8.36 -  | sorting_str_of_term _ = "X";
    8.37 -
    8.38 -fun pretty_of_isa_model_opt _ NONE =
    8.39 -    pretty_indent (Pretty.str "Model unavailable (internal error)")
    8.40 -  | pretty_of_isa_model_opt ctxt0
    8.41 -      (SOME {type_model, free_model, pat_complete_model, pat_incomplete_model, skolem_model}) =
    8.42 -    let
    8.43 -      val ctxt = ctxt0 |> Config.put show_question_marks false;
    8.44 -
    8.45 -      val pat_incomplete_model' = pat_incomplete_model
    8.46 -        |> filter_out (can (fn Const (@{const_name unreachable}, _) => ()) o fst);
    8.47 -
    8.48 -      fun pretty_of_typ_entry (T, atoms) =
    8.49 -        Pretty.block (Pretty.breaks [Syntax.pretty_typ ctxt T, Pretty.str "=",
    8.50 -           Pretty.enum "," "{" "}" (map (Syntax.pretty_term ctxt) atoms)]);
    8.51 -
    8.52 -      fun pretty_of_term_entry (t, value) =
    8.53 -        let
    8.54 -          val no_types_ctxt = ctxt |> Config.put show_types false;
    8.55 -          val schematic_ctxt = ctxt |> Proof_Context.set_mode Proof_Context.mode_schematic;
    8.56 -
    8.57 -          val show_types = Config.get ctxt show_types;
    8.58 -          val value' = value |> perhaps (try (Syntax.check_term schematic_ctxt));
    8.59 -          val T = fastype_of t;
    8.60 -          val T' = if T = dummyT then try fastype_of value' |> the_default T else T;
    8.61 -          val t' = t |> show_types ? Type.constraint T';
    8.62 -        in
    8.63 -          Pretty.block (Pretty.breaks
    8.64 -            [Syntax.pretty_term ctxt t'
    8.65 -             |> (show_types andalso T' <> dummyT) ? (single #> Pretty.enclose "(" ")"),
    8.66 -             Pretty.str "=", Syntax.pretty_term no_types_ctxt value'])
    8.67 -        end;
    8.68 -
    8.69 -      fun chunks_of_entries sorting_str_of pretty_of title entries =
    8.70 -        if not (null entries) then
    8.71 -          (if title = "" then [] else [Pretty.str (title ^ plural_s_for_list entries ^ ":")]) @
    8.72 -          map (pretty_indent o pretty_of) (sort_by (sorting_str_of o fst) entries)
    8.73 -        else
    8.74 -          [];
    8.75 -
    8.76 -      val chunks =
    8.77 -        (if null free_model then
    8.78 -           [pretty_indent (Pretty.str "No free variables")]
    8.79 -         else
    8.80 -           chunks_of_entries sorting_str_of_term pretty_of_term_entry "" free_model) @
    8.81 -        chunks_of_entries sorting_str_of_term pretty_of_term_entry "Skolem constant" skolem_model @
    8.82 -        chunks_of_entries sorting_str_of_term pretty_of_term_entry "Underspecified constant"
    8.83 -          pat_incomplete_model' @
    8.84 -        (if Config.get ctxt show_consts then
    8.85 -           chunks_of_entries sorting_str_of_term pretty_of_term_entry "Fully specified constant"
    8.86 -             pat_complete_model
    8.87 -         else
    8.88 -           []) @
    8.89 -        chunks_of_entries sorting_str_of_typ pretty_of_typ_entry "Type" type_model;
    8.90 -    in
    8.91 -      Pretty.chunks chunks
    8.92 -    end;
    8.93 -
    8.94 -end;
     9.1 --- a/src/HOL/Nunchaku/Tools/nunchaku_model.ML	Thu Sep 07 23:13:15 2017 +0200
     9.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3 @@ -1,284 +0,0 @@
     9.4 -(*  Title:      HOL/Nunchaku/Tools/nunchaku_model.ML
     9.5 -    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
     9.6 -    Copyright   2015, 2016
     9.7 -
     9.8 -Abstract syntax tree for Nunchaku models.
     9.9 -*)
    9.10 -
    9.11 -signature NUNCHAKU_MODEL =
    9.12 -sig
    9.13 -  type ident = Nunchaku_Problem.ident
    9.14 -  type ty = Nunchaku_Problem.ty
    9.15 -  type tm = Nunchaku_Problem.tm
    9.16 -  type name_pool = Nunchaku_Problem.name_pool
    9.17 -
    9.18 -  type ty_entry = ty * tm list
    9.19 -  type tm_entry = tm * tm
    9.20 -
    9.21 -  type nun_model =
    9.22 -    {type_model: ty_entry list,
    9.23 -     const_model: tm_entry list,
    9.24 -     skolem_model: tm_entry list}
    9.25 -
    9.26 -  val str_of_nun_model: nun_model -> string
    9.27 -
    9.28 -  val allocate_ugly: name_pool -> string * string -> string * name_pool
    9.29 -
    9.30 -  val ugly_nun_model: name_pool -> nun_model -> nun_model
    9.31 -
    9.32 -  datatype token =
    9.33 -    Ident of ident
    9.34 -  | Symbol of ident
    9.35 -  | Atom of ident * int
    9.36 -  | End_of_Stream
    9.37 -
    9.38 -  val parse_tok: ''a -> ''a list -> ''a * ''a list
    9.39 -  val parse_ident: token list -> ident * token list
    9.40 -  val parse_id: ident -> token list -> token * token list
    9.41 -  val parse_sym: ident -> token list -> token * token list
    9.42 -  val parse_atom: token list -> (ident * int) * token list
    9.43 -  val nun_model_of_str: string -> nun_model
    9.44 -end;
    9.45 -
    9.46 -structure Nunchaku_Model : NUNCHAKU_MODEL =
    9.47 -struct
    9.48 -
    9.49 -open Nunchaku_Problem;
    9.50 -
    9.51 -type ty_entry = ty * tm list;
    9.52 -type tm_entry = tm * tm;
    9.53 -
    9.54 -type nun_model =
    9.55 -  {type_model: ty_entry list,
    9.56 -   const_model: tm_entry list,
    9.57 -   skolem_model: tm_entry list};
    9.58 -
    9.59 -val nun_SAT = str_of_ident "SAT";
    9.60 -
    9.61 -fun str_of_ty_entry (ty, tms) =
    9.62 -  "type " ^ str_of_ty ty ^ " := {" ^ commas (map str_of_tm tms) ^ "}.";
    9.63 -
    9.64 -fun str_of_tm_entry (tm, value) =
    9.65 -  "val " ^ str_of_tm tm ^ " := " ^ str_of_tm value ^ ".";
    9.66 -
    9.67 -fun str_of_nun_model {type_model, const_model, skolem_model} =
    9.68 -  map str_of_ty_entry type_model @ "" :: map str_of_tm_entry const_model @ "" ::
    9.69 -  map str_of_tm_entry skolem_model
    9.70 -  |> cat_lines;
    9.71 -
    9.72 -fun fold_map_ty_entry_idents f (ty, atoms) =
    9.73 -  fold_map_ty_idents f ty
    9.74 -  ##>> fold_map (fold_map_tm_idents f) atoms;
    9.75 -
    9.76 -fun fold_map_tm_entry_idents f (tm, value) =
    9.77 -  fold_map_tm_idents f tm
    9.78 -  ##>> fold_map_tm_idents f value;
    9.79 -
    9.80 -fun fold_map_nun_model_idents f {type_model, const_model, skolem_model} =
    9.81 -  fold_map (fold_map_ty_entry_idents f) type_model
    9.82 -  ##>> fold_map (fold_map_tm_entry_idents f) const_model
    9.83 -  ##>> fold_map (fold_map_tm_entry_idents f) skolem_model
    9.84 -  #>> (fn ((type_model, const_model), skolem_model) =>
    9.85 -    {type_model = type_model, const_model = const_model, skolem_model = skolem_model});
    9.86 -
    9.87 -fun swap_name_pool ({nice_of_ugly, ugly_of_nice} : name_pool) =
    9.88 -  {nice_of_ugly = ugly_of_nice, ugly_of_nice = nice_of_ugly};
    9.89 -
    9.90 -fun allocate_ugly pool (nice, ugly_sugg) =
    9.91 -  allocate_nice (swap_name_pool pool) (nice, ugly_sugg) ||> swap_name_pool;
    9.92 -
    9.93 -fun ugly_ident nice (pool as {ugly_of_nice, ...}) =
    9.94 -  (case Symtab.lookup ugly_of_nice nice of
    9.95 -    NONE => allocate_ugly pool (nice, nice)
    9.96 -  | SOME ugly => (ugly, pool));
    9.97 -
    9.98 -fun ugly_nun_model pool model =
    9.99 -  fst (fold_map_nun_model_idents ugly_ident model pool);
   9.100 -
   9.101 -datatype token =
   9.102 -  Ident of ident
   9.103 -| Symbol of ident
   9.104 -| Atom of ident * int
   9.105 -| End_of_Stream;
   9.106 -
   9.107 -val rev_str = String.implode o rev o String.explode;
   9.108 -
   9.109 -fun atom_of_str s =
   9.110 -  (case first_field "_" (rev_str s) of
   9.111 -    SOME (rev_suf, rev_pre) =>
   9.112 -    let
   9.113 -      val pre = rev_str rev_pre;
   9.114 -      val suf = rev_str rev_suf;
   9.115 -    in
   9.116 -      (case Int.fromString suf of
   9.117 -        SOME j => Atom (ident_of_str pre, j)
   9.118 -      | NONE => raise Fail "ill-formed atom")
   9.119 -    end
   9.120 -  | NONE => raise Fail "ill-formed atom");
   9.121 -
   9.122 -fun is_alnum_etc_char c = Char.isAlphaNum c orelse c = #"_" orelse c = #"/";
   9.123 -
   9.124 -val multi_ids =
   9.125 -  [nun_arrow, nun_assign, nun_conj, nun_disj, nun_implies, nun_unparsable, nun_irrelevant];
   9.126 -
   9.127 -val nun_anon_fun_prefix_exploded = String.explode nun_anon_fun_prefix;
   9.128 -val [nun_dollar_char] = String.explode nun_dollar;
   9.129 -
   9.130 -fun next_token [] = (End_of_Stream, [])
   9.131 -  | next_token (c :: cs) =
   9.132 -    if Char.isSpace c then
   9.133 -      next_token cs
   9.134 -    else if c = nun_dollar_char then
   9.135 -      let val n = find_index (not o is_alnum_etc_char) cs in
   9.136 -        (if n = ~1 then (cs, []) else chop n cs)
   9.137 -        |>> (String.implode
   9.138 -          #> (if is_prefix (op =) nun_anon_fun_prefix_exploded cs then ident_of_str #> Ident
   9.139 -            else atom_of_str))
   9.140 -      end
   9.141 -    else if is_alnum_etc_char c then
   9.142 -      let val n = find_index (not o is_alnum_etc_char) cs in
   9.143 -        (if n = ~1 then (cs, []) else chop n cs)
   9.144 -        |>> (cons c #> String.implode #> ident_of_str #> Ident)
   9.145 -      end
   9.146 -    else
   9.147 -      let
   9.148 -        fun next_multi id =
   9.149 -          let
   9.150 -            val s = str_of_ident id;
   9.151 -            val n = String.size s - 1;
   9.152 -          in
   9.153 -            if c = String.sub (s, 0) andalso
   9.154 -               is_prefix (op =) (String.explode (String.substring (s, 1, n))) cs then
   9.155 -              SOME (Symbol id, drop n cs)
   9.156 -            else
   9.157 -              NONE
   9.158 -          end;
   9.159 -      in
   9.160 -        (case get_first next_multi multi_ids of
   9.161 -          SOME res => res
   9.162 -        | NONE => (Symbol (ident_of_str (String.str c)), cs))
   9.163 -      end;
   9.164 -
   9.165 -val tokenize =
   9.166 -  let
   9.167 -    fun toks cs =
   9.168 -      (case next_token cs of
   9.169 -        (End_of_Stream, []) => []
   9.170 -      | (tok, cs') => tok :: toks cs');
   9.171 -  in
   9.172 -    toks o String.explode
   9.173 -  end;
   9.174 -
   9.175 -fun parse_enum sep scan = scan ::: Scan.repeat (sep |-- scan);
   9.176 -
   9.177 -fun parse_tok tok = Scan.one (curry (op =) tok);
   9.178 -
   9.179 -val parse_ident = Scan.some (try (fn Ident id => id));
   9.180 -val parse_id = parse_tok o Ident;
   9.181 -val parse_sym = parse_tok o Symbol;
   9.182 -val parse_atom = Scan.some (try (fn Atom id_j => id_j));
   9.183 -
   9.184 -val confusing_ids = [nun_else, nun_then, nun_with];
   9.185 -
   9.186 -val parse_confusing_id = Scan.one (fn Ident id => member (op =) confusing_ids id | _ => false);
   9.187 -
   9.188 -fun parse_ty toks =
   9.189 -  (parse_ty_arg -- Scan.option (parse_sym nun_arrow -- parse_ty)
   9.190 -   >> (fn (ty, NONE) => ty
   9.191 -     | (lhs, SOME (Symbol id, rhs)) => NType (id, [lhs, rhs]))) toks
   9.192 -and parse_ty_arg toks =
   9.193 -  (parse_ident >> (rpair [] #> NType)
   9.194 -   || parse_sym nun_lparen |-- parse_ty --| parse_sym nun_rparen) toks;
   9.195 -
   9.196 -val parse_choice_or_unique =
   9.197 -  (parse_tok (Ident nun_choice) || parse_tok (Ident nun_unique)
   9.198 -   || parse_tok (Ident nun_unique_unsafe))
   9.199 -  -- parse_ty_arg
   9.200 -  >> (fn (Ident id, ty) => NConst (id, [ty], mk_arrows_ty ([ty, prop_ty], ty)));
   9.201 -
   9.202 -fun parse_tm toks =
   9.203 -  (parse_id nun_lambda |-- Scan.repeat parse_arg --| parse_sym nun_dot -- parse_tm >> nabss
   9.204 -  || parse_id nun_mu |-- parse_arg --| parse_sym nun_dot -- parse_tm
   9.205 -     >> (fn (var, body) =>
   9.206 -       let val ty = safe_ty_of body in
   9.207 -         NApp (NConst (nun_mu, [ty], mk_arrow_ty (mk_arrow_ty (ty, ty), ty)), NAbs (var, body))
   9.208 -       end)
   9.209 -   || parse_id nun_if |-- parse_tm --| parse_id nun_then -- parse_tm --| parse_id nun_else
   9.210 -       -- parse_tm
   9.211 -     >> (fn ((cond, th), el) =>
   9.212 -       let val ty = safe_ty_of th in
   9.213 -         napps (NConst (nun_if, [ty], mk_arrows_ty ([prop_ty, ty, ty], ty)), [cond, th, el])
   9.214 -       end)
   9.215 -   || parse_implies) toks
   9.216 -and parse_implies toks =
   9.217 -  (parse_disj -- Scan.option (parse_sym nun_implies -- parse_implies)
   9.218 -   >> (fn (tm, NONE) => tm
   9.219 -     | (lhs, SOME (Symbol id, rhs)) => napps (NConst (id, [], dummy_ty), [lhs, rhs]))) toks
   9.220 -and parse_disj toks =
   9.221 -  (parse_conj -- Scan.option (parse_sym nun_disj -- parse_disj)
   9.222 -   >> (fn (tm, NONE) => tm
   9.223 -     | (lhs, SOME (Symbol id, rhs)) => napps (NConst (id, [], dummy_ty), [lhs, rhs]))) toks
   9.224 -and parse_conj toks =
   9.225 -  (parse_equals -- Scan.option (parse_sym nun_conj -- parse_conj)
   9.226 -   >> (fn (tm, NONE) => tm
   9.227 -     | (lhs, SOME (Symbol id, rhs)) => napps (NConst (id, [], dummy_ty), [lhs, rhs]))) toks
   9.228 -and parse_equals toks =
   9.229 -  (parse_comb -- Scan.option (parse_sym nun_equals -- parse_comb)
   9.230 -   >> (fn (tm, NONE) => tm
   9.231 -     | (lhs, SOME (Symbol id, rhs)) => napps (NConst (id, [], dummy_ty), [lhs, rhs]))) toks
   9.232 -and parse_comb toks =
   9.233 -  (parse_arg -- Scan.repeat (Scan.unless parse_confusing_id parse_arg) >> napps) toks
   9.234 -and parse_arg toks =
   9.235 -  (parse_choice_or_unique
   9.236 -   || parse_ident >> (fn id => NConst (id, [], dummy_ty))
   9.237 -   || parse_sym nun_irrelevant
   9.238 -      |-- Scan.option (parse_sym nun_lparen |-- parse_tm --| parse_sym nun_rparen) (* FIXME *)
   9.239 -     >> (fn _ => NConst (nun_irrelevant, [], dummy_ty))
   9.240 -   || parse_sym nun_unparsable |-- parse_ty >> (fn ty => NConst (nun_unparsable, [], ty))
   9.241 -   || parse_sym nun_lparen |-- parse_tm -- Scan.option (parse_sym nun_colon |-- parse_ty)
   9.242 -      --| parse_sym nun_rparen
   9.243 -     >> (fn (NConst (id, [], _), SOME ty) => NConst (id, [], ty)
   9.244 -       | (tm, _) => tm)
   9.245 -   || parse_atom >> (fn (id, j) => NAtom (j, NType (id, [])))) toks;
   9.246 -
   9.247 -val parse_witness_name =
   9.248 -  parse_ident >> (fn id => NConst (hd (space_explode "/" id), [], dummy_ty));
   9.249 -
   9.250 -val parse_witness =
   9.251 -  parse_id nun__witness_of |-- parse_sym nun_lparen |-- (parse_id nun_forall || parse_id nun_exists)
   9.252 -  |-- Scan.option (parse_sym nun_lparen) |-- parse_witness_name
   9.253 -  --| Scan.repeat (Scan.one (curry (op <>) (Symbol nun_assign)));
   9.254 -
   9.255 -datatype entry =
   9.256 -  Type_Entry of ty_entry
   9.257 -| Skolem_Entry of tm_entry
   9.258 -| Const_Entry of tm_entry;
   9.259 -
   9.260 -val parse_entry =
   9.261 -  (parse_id nun_type |-- parse_ty --| parse_sym nun_assign --| parse_sym nun_lbrace --
   9.262 -       parse_enum (parse_sym nun_comma) parse_tm --| parse_sym nun_rbrace
   9.263 -     >> Type_Entry
   9.264 -   || parse_id nun_val |-- parse_witness --| parse_sym nun_assign -- parse_tm >> Skolem_Entry
   9.265 -   || parse_id nun_val |-- parse_tm --| parse_sym nun_assign -- parse_tm >> Const_Entry)
   9.266 -  --| parse_sym nun_dot;
   9.267 -
   9.268 -val parse_model =
   9.269 -  parse_id nun_SAT |-- parse_sym nun_colon |-- parse_sym nun_lbrace |-- Scan.repeat parse_entry
   9.270 -  --| parse_sym nun_rbrace;
   9.271 -
   9.272 -fun add_entry entry ({type_model, const_model, skolem_model} : nun_model) =
   9.273 -  (case entry of
   9.274 -    Type_Entry e =>
   9.275 -    {type_model = e :: type_model, const_model = const_model, skolem_model = skolem_model}
   9.276 -  | Skolem_Entry e =>
   9.277 -    {type_model = type_model, const_model = const_model, skolem_model = e :: skolem_model}
   9.278 -  | Const_Entry e =>
   9.279 -    {type_model = type_model, const_model = e :: const_model, skolem_model = skolem_model});
   9.280 -
   9.281 -fun nun_model_of_str str =
   9.282 -  let val (entries, _) = parse_model (tokenize str) in
   9.283 -    {type_model = [], const_model = [], skolem_model = []}
   9.284 -    |> fold_rev add_entry entries
   9.285 -  end;
   9.286 -
   9.287 -end;
    10.1 --- a/src/HOL/Nunchaku/Tools/nunchaku_problem.ML	Thu Sep 07 23:13:15 2017 +0200
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,799 +0,0 @@
    10.4 -(*  Title:      HOL/Nunchaku/Tools/nunchaku_problem.ML
    10.5 -    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    10.6 -    Copyright   2015, 2016
    10.7 -
    10.8 -Abstract syntax tree for Nunchaku problems.
    10.9 -*)
   10.10 -
   10.11 -signature NUNCHAKU_PROBLEM =
   10.12 -sig
   10.13 -  eqtype ident
   10.14 -
   10.15 -  datatype ty =
   10.16 -    NType of ident * ty list
   10.17 -
   10.18 -  datatype tm =
   10.19 -    NAtom of int * ty
   10.20 -  | NConst of ident * ty list * ty
   10.21 -  | NAbs of tm * tm
   10.22 -  | NMatch of tm * (ident * tm list * tm) list
   10.23 -  | NApp of tm * tm
   10.24 -
   10.25 -  type nun_copy_spec =
   10.26 -    {abs_ty: ty,
   10.27 -     rep_ty: ty,
   10.28 -     subset: tm option,
   10.29 -     quotient: tm option,
   10.30 -     abs: tm,
   10.31 -     rep: tm}
   10.32 -
   10.33 -  type nun_ctr_spec =
   10.34 -    {ctr: tm,
   10.35 -     arg_tys: ty list}
   10.36 -
   10.37 -  type nun_co_data_spec =
   10.38 -    {ty: ty,
   10.39 -     ctrs: nun_ctr_spec list}
   10.40 -
   10.41 -  type nun_const_spec =
   10.42 -    {const: tm,
   10.43 -     props: tm list}
   10.44 -
   10.45 -  type nun_consts_spec =
   10.46 -    {consts: tm list,
   10.47 -     props: tm list}
   10.48 -
   10.49 -  datatype nun_command =
   10.50 -    NTVal of ty * (int option * int option)
   10.51 -  | NCopy of nun_copy_spec
   10.52 -  | NData of nun_co_data_spec list
   10.53 -  | NCodata of nun_co_data_spec list
   10.54 -  | NVal of tm * ty
   10.55 -  | NPred of bool * nun_const_spec list
   10.56 -  | NCopred of nun_const_spec list
   10.57 -  | NRec of nun_const_spec list
   10.58 -  | NSpec of nun_consts_spec
   10.59 -  | NAxiom of tm
   10.60 -  | NGoal of tm
   10.61 -  | NEval of tm
   10.62 -
   10.63 -  type nun_problem =
   10.64 -    {commandss: nun_command list list,
   10.65 -     sound: bool,
   10.66 -     complete: bool}
   10.67 -
   10.68 -  type name_pool =
   10.69 -    {nice_of_ugly: string Symtab.table,
   10.70 -     ugly_of_nice: string Symtab.table}
   10.71 -
   10.72 -  val nun_abstract: string
   10.73 -  val nun_and: string
   10.74 -  val nun_anon_fun_prefix: string
   10.75 -  val nun_arrow: string
   10.76 -  val nun_asserting: string
   10.77 -  val nun_assign: string
   10.78 -  val nun_at: string
   10.79 -  val nun_axiom: string
   10.80 -  val nun_bar: string
   10.81 -  val nun_choice: string
   10.82 -  val nun_codata: string
   10.83 -  val nun_colon: string
   10.84 -  val nun_comma: string
   10.85 -  val nun_concrete: string
   10.86 -  val nun_conj: string
   10.87 -  val nun_copred: string
   10.88 -  val nun_copy: string
   10.89 -  val nun_data: string
   10.90 -  val nun_disj: string
   10.91 -  val nun_dollar: string
   10.92 -  val nun_dot: string
   10.93 -  val nun_dummy: string
   10.94 -  val nun_else: string
   10.95 -  val nun_end: string
   10.96 -  val nun_equals: string
   10.97 -  val nun_eval: string
   10.98 -  val nun_exists: string
   10.99 -  val nun_false: string
  10.100 -  val nun_forall: string
  10.101 -  val nun_goal: string
  10.102 -  val nun_hash: string
  10.103 -  val nun_if: string
  10.104 -  val nun_implies: string
  10.105 -  val nun_irrelevant: string
  10.106 -  val nun_lambda: string
  10.107 -  val nun_lbrace: string
  10.108 -  val nun_lbracket: string
  10.109 -  val nun_lparen: string
  10.110 -  val nun_match: string
  10.111 -  val nun_mu: string
  10.112 -  val nun_not: string
  10.113 -  val nun_partial_quotient: string
  10.114 -  val nun_pred: string
  10.115 -  val nun_prop: string
  10.116 -  val nun_quotient: string
  10.117 -  val nun_rbrace: string
  10.118 -  val nun_rbracket: string
  10.119 -  val nun_rec: string
  10.120 -  val nun_rparen: string
  10.121 -  val nun_semicolon: string
  10.122 -  val nun_spec: string
  10.123 -  val nun_subset: string
  10.124 -  val nun_then: string
  10.125 -  val nun_true: string
  10.126 -  val nun_type: string
  10.127 -  val nun_unparsable: string
  10.128 -  val nun_unique: string
  10.129 -  val nun_unique_unsafe: string
  10.130 -  val nun_val: string
  10.131 -  val nun_wf: string
  10.132 -  val nun_with: string
  10.133 -  val nun__witness_of: string
  10.134 -
  10.135 -  val ident_of_str: string -> ident
  10.136 -  val str_of_ident: ident -> string
  10.137 -  val encode_args: string list -> string
  10.138 -  val nun_const_of_str: string list -> string -> ident
  10.139 -  val nun_tconst_of_str: string list -> string -> ident
  10.140 -  val nun_free_of_str: string -> ident
  10.141 -  val nun_tfree_of_str: string -> ident
  10.142 -  val nun_var_of_str: string -> ident
  10.143 -  val str_of_nun_const: ident -> string list * string
  10.144 -  val str_of_nun_tconst: ident -> string list * string
  10.145 -  val str_of_nun_free: ident -> string
  10.146 -  val str_of_nun_tfree: ident -> string
  10.147 -  val str_of_nun_var: ident -> string
  10.148 -
  10.149 -  val dummy_ty: ty
  10.150 -  val prop_ty: ty
  10.151 -  val mk_arrow_ty: ty * ty -> ty
  10.152 -  val mk_arrows_ty: ty list * ty -> ty
  10.153 -  val nabss: tm list * tm -> tm
  10.154 -  val napps: tm * tm list -> tm
  10.155 -
  10.156 -  val ty_of: tm -> ty
  10.157 -  val safe_ty_of: tm -> ty
  10.158 -
  10.159 -  val fold_map_ty_idents: (string -> 'a -> string * 'a) -> ty -> 'a -> ty * 'a
  10.160 -  val fold_map_tm_idents: (string -> 'a -> string * 'a) -> tm -> 'a -> tm * 'a
  10.161 -  val fold_map_nun_command_idents: (string -> 'a -> string * 'a) -> nun_command -> 'a ->
  10.162 -    nun_command * 'a
  10.163 -  val fold_map_nun_problem_idents: (string -> 'a -> string * 'a) -> nun_problem -> 'a ->
  10.164 -    nun_problem * 'a
  10.165 -
  10.166 -  val allocate_nice: name_pool -> string * string -> string * name_pool
  10.167 -
  10.168 -  val rcomb_tms: tm list -> tm -> tm
  10.169 -  val abs_tms: tm list -> tm -> tm
  10.170 -  val beta_reduce_tm: tm -> tm
  10.171 -  val eta_expandN_tm: int -> tm -> tm
  10.172 -  val eta_expand_builtin_tm: tm -> tm
  10.173 -
  10.174 -  val str_of_ty: ty -> string
  10.175 -  val str_of_tm: tm -> string
  10.176 -  val str_of_tmty: tm -> string
  10.177 -
  10.178 -  val nice_nun_problem: nun_problem -> nun_problem * name_pool
  10.179 -  val str_of_nun_problem: nun_problem -> string
  10.180 -end;
  10.181 -
  10.182 -structure Nunchaku_Problem : NUNCHAKU_PROBLEM =
  10.183 -struct
  10.184 -
  10.185 -open Nunchaku_Util;
  10.186 -
  10.187 -type ident = string;
  10.188 -
  10.189 -datatype ty =
  10.190 -  NType of ident * ty list;
  10.191 -
  10.192 -datatype tm =
  10.193 -  NAtom of int * ty
  10.194 -| NConst of ident * ty list * ty
  10.195 -| NAbs of tm * tm
  10.196 -| NMatch of tm * (ident * tm list * tm) list
  10.197 -| NApp of tm * tm;
  10.198 -
  10.199 -type nun_copy_spec =
  10.200 -  {abs_ty: ty,
  10.201 -   rep_ty: ty,
  10.202 -   subset: tm option,
  10.203 -   quotient: tm option,
  10.204 -   abs: tm,
  10.205 -   rep: tm};
  10.206 -
  10.207 -type nun_ctr_spec =
  10.208 -  {ctr: tm,
  10.209 -   arg_tys: ty list};
  10.210 -
  10.211 -type nun_co_data_spec =
  10.212 -  {ty: ty,
  10.213 -   ctrs: nun_ctr_spec list};
  10.214 -
  10.215 -type nun_const_spec =
  10.216 -  {const: tm,
  10.217 -   props: tm list};
  10.218 -
  10.219 -type nun_consts_spec =
  10.220 -  {consts: tm list,
  10.221 -   props: tm list};
  10.222 -
  10.223 -datatype nun_command =
  10.224 -  NTVal of ty * (int option * int option)
  10.225 -| NCopy of nun_copy_spec
  10.226 -| NData of nun_co_data_spec list
  10.227 -| NCodata of nun_co_data_spec list
  10.228 -| NVal of tm * ty
  10.229 -| NPred of bool * nun_const_spec list
  10.230 -| NCopred of nun_const_spec list
  10.231 -| NRec of nun_const_spec list
  10.232 -| NSpec of nun_consts_spec
  10.233 -| NAxiom of tm
  10.234 -| NGoal of tm
  10.235 -| NEval of tm;
  10.236 -
  10.237 -type nun_problem =
  10.238 -  {commandss: nun_command list list,
  10.239 -   sound: bool,
  10.240 -   complete: bool};
  10.241 -
  10.242 -type name_pool =
  10.243 -  {nice_of_ugly: string Symtab.table,
  10.244 -   ugly_of_nice: string Symtab.table};
  10.245 -
  10.246 -val nun_abstract = "abstract";
  10.247 -val nun_and = "and";
  10.248 -val nun_anon_fun_prefix = "anon_fun_";
  10.249 -val nun_arrow = "->";
  10.250 -val nun_asserting = "asserting";
  10.251 -val nun_assign = ":=";
  10.252 -val nun_at = "@";
  10.253 -val nun_axiom = "axiom";
  10.254 -val nun_bar = "|";
  10.255 -val nun_choice = "choice";
  10.256 -val nun_codata = "codata";
  10.257 -val nun_colon = ":";
  10.258 -val nun_comma = ",";
  10.259 -val nun_concrete = "concrete";
  10.260 -val nun_conj = "&&";
  10.261 -val nun_copred = "copred";
  10.262 -val nun_copy = "copy";
  10.263 -val nun_data = "data";
  10.264 -val nun_disj = "||";
  10.265 -val nun_dollar = "$";
  10.266 -val nun_dot = ".";
  10.267 -val nun_dummy = "_";
  10.268 -val nun_else = "else";
  10.269 -val nun_end = "end";
  10.270 -val nun_equals = "=";
  10.271 -val nun_eval = "eval";
  10.272 -val nun_exists = "exists";
  10.273 -val nun_false = "false";
  10.274 -val nun_forall = "forall";
  10.275 -val nun_goal = "goal";
  10.276 -val nun_hash = "#";
  10.277 -val nun_if = "if";
  10.278 -val nun_implies = "=>";
  10.279 -val nun_irrelevant = "?__";
  10.280 -val nun_lambda = "fun";
  10.281 -val nun_lbrace = "{";
  10.282 -val nun_lbracket = "[";
  10.283 -val nun_lparen = "(";
  10.284 -val nun_match = "match";
  10.285 -val nun_mu = "mu";
  10.286 -val nun_not = "~";
  10.287 -val nun_partial_quotient = "partial_quotient";
  10.288 -val nun_pred = "pred";
  10.289 -val nun_prop = "prop";
  10.290 -val nun_quotient = "quotient";
  10.291 -val nun_rbrace = "}";
  10.292 -val nun_rbracket = "]";
  10.293 -val nun_rec = "rec";
  10.294 -val nun_rparen = ")";
  10.295 -val nun_semicolon = ";";
  10.296 -val nun_spec = "spec";
  10.297 -val nun_subset = "subset";
  10.298 -val nun_then = "then";
  10.299 -val nun_true = "true";
  10.300 -val nun_type = "type";
  10.301 -val nun_unique = "unique";
  10.302 -val nun_unique_unsafe = "unique_unsafe";
  10.303 -val nun_unparsable = "?__unparsable";
  10.304 -val nun_val = "val";
  10.305 -val nun_wf = "wf";
  10.306 -val nun_with = "with";
  10.307 -val nun__witness_of = "_witness_of";
  10.308 -
  10.309 -val nun_parens = enclose nun_lparen nun_rparen;
  10.310 -
  10.311 -fun nun_parens_if_space s = s |> String.isSubstring " " s ? nun_parens;
  10.312 -
  10.313 -fun str_of_nun_arg_list str_of_arg =
  10.314 -  map (prefix " " o nun_parens_if_space o str_of_arg) #> space_implode "";
  10.315 -
  10.316 -fun str_of_nun_and_list str_of_elem =
  10.317 -  map str_of_elem #> space_implode ("\n" ^ nun_and ^ " ");
  10.318 -
  10.319 -val is_nun_const_quantifier = member (op =) [nun_forall, nun_exists];
  10.320 -val is_nun_const_connective = member (op =) [nun_conj, nun_disj, nun_implies];
  10.321 -
  10.322 -val nun_builtin_arity =
  10.323 -  [(nun_asserting, 2),
  10.324 -   (nun_conj, 2),
  10.325 -   (nun_disj, 2),
  10.326 -   (nun_equals, 2),
  10.327 -   (nun_exists, 1),
  10.328 -   (nun_false, 0),
  10.329 -   (nun_forall, 1),
  10.330 -   (nun_if, 3),
  10.331 -   (nun_implies, 2),
  10.332 -   (nun_not, 1),
  10.333 -   (nun_true, 0)];
  10.334 -
  10.335 -val arity_of_nun_builtin = AList.lookup (op =) nun_builtin_arity #> the_default 0;
  10.336 -
  10.337 -val nun_const_prefix = "c.";
  10.338 -val nun_free_prefix = "f.";
  10.339 -val nun_var_prefix = "v.";
  10.340 -val nun_tconst_prefix = "C.";
  10.341 -val nun_tfree_prefix = "F.";
  10.342 -val nun_custom_id_suffix = "_";
  10.343 -
  10.344 -val ident_of_str = I : string -> ident;
  10.345 -val str_of_ident = I : ident -> string;
  10.346 -
  10.347 -val encode_args = enclose "(" ")" o commas;
  10.348 -
  10.349 -fun decode_args s =
  10.350 -  let
  10.351 -    fun delta #"(" = 1
  10.352 -      | delta #")" = ~1
  10.353 -      | delta _ = 0;
  10.354 -
  10.355 -    fun dec 0 (#"(" :: #")" :: cs) _ = ([], String.implode cs)
  10.356 -      | dec 0 (#"(" :: cs) [] = dec 1 cs [[]]
  10.357 -      | dec 0 cs _ = ([], String.implode cs)
  10.358 -      | dec _ [] _ = raise Fail ("ill-formed arguments in " ^ quote s)
  10.359 -      | dec 1 (#")" :: cs) args = (rev (map (String.implode o rev) args), String.implode cs)
  10.360 -      | dec 1 (#"," :: cs) args = dec 1 cs ([] :: args)
  10.361 -      | dec n (c :: cs) (arg :: args) = dec (n + delta c) cs ((c :: arg) :: args);
  10.362 -  in
  10.363 -    dec 0 (String.explode s) []
  10.364 -  end;
  10.365 -
  10.366 -fun nun_const_of_str args =
  10.367 -  suffix nun_custom_id_suffix #> prefix nun_const_prefix #> prefix (encode_args args);
  10.368 -fun nun_tconst_of_str args =
  10.369 -  suffix nun_custom_id_suffix #> prefix nun_tconst_prefix #> prefix (encode_args args);
  10.370 -
  10.371 -val nun_free_of_str = suffix nun_custom_id_suffix #> prefix nun_free_prefix;
  10.372 -val nun_tfree_of_str = suffix nun_custom_id_suffix #> prefix nun_tfree_prefix;
  10.373 -val nun_var_of_str = suffix nun_custom_id_suffix #> prefix nun_var_prefix;
  10.374 -val str_of_nun_const = decode_args ##> unprefix nun_const_prefix ##> unsuffix nun_custom_id_suffix;
  10.375 -val str_of_nun_tconst = decode_args ##> unprefix nun_tconst_prefix ##> unsuffix nun_custom_id_suffix;
  10.376 -val str_of_nun_free = unprefix nun_free_prefix #> unsuffix nun_custom_id_suffix;
  10.377 -val str_of_nun_tfree = unprefix nun_tfree_prefix #> unsuffix nun_custom_id_suffix;
  10.378 -val str_of_nun_var = unprefix nun_var_prefix #> unsuffix nun_custom_id_suffix;
  10.379 -
  10.380 -fun index_name s 0 = s
  10.381 -  | index_name s j =
  10.382 -    let
  10.383 -      val n = size s;
  10.384 -      val m = n - 1;
  10.385 -    in
  10.386 -      String.substring (s, 0, m) ^ string_of_int j ^ String.substring (s, m, n - m)
  10.387 -    end;
  10.388 -
  10.389 -val dummy_ty = NType (nun_dummy, []);
  10.390 -val prop_ty = NType (nun_prop, []);
  10.391 -
  10.392 -fun mk_arrow_ty (dom, ran) = NType (nun_arrow, [dom, ran]);
  10.393 -val mk_arrows_ty = Library.foldr mk_arrow_ty;
  10.394 -
  10.395 -val nabss = Library.foldr NAbs;
  10.396 -val napps = Library.foldl NApp;
  10.397 -
  10.398 -fun domain_ty (NType (_, [ty, _])) = ty
  10.399 -  | domain_ty ty = ty;
  10.400 -
  10.401 -fun range_ty (NType (_, [_, ty])) = ty
  10.402 -  | range_ty ty = ty;
  10.403 -
  10.404 -fun domain_tys 0 _ = []
  10.405 -  | domain_tys n ty = domain_ty ty :: domain_tys (n - 1) (range_ty ty);
  10.406 -
  10.407 -fun ty_of (NAtom (_, ty)) = ty
  10.408 -  | ty_of (NConst (_, _, ty)) = ty
  10.409 -  | ty_of (NAbs (var, body)) = mk_arrow_ty (ty_of var, ty_of body)
  10.410 -  | ty_of (NMatch (_, (_, _, body1) :: _)) = ty_of body1
  10.411 -  | ty_of (NApp (const, _)) = range_ty (ty_of const);
  10.412 -
  10.413 -val safe_ty_of = try ty_of #> the_default dummy_ty;
  10.414 -
  10.415 -fun strip_nun_binders binder (app as NApp (NConst (id, _, _), NAbs (var, body))) =
  10.416 -    if id = binder then
  10.417 -      strip_nun_binders binder body
  10.418 -      |>> cons var
  10.419 -    else
  10.420 -      ([], app)
  10.421 -  | strip_nun_binders _ tm = ([], tm);
  10.422 -
  10.423 -fun fold_map_option _ NONE = pair NONE
  10.424 -  | fold_map_option f (SOME x) = f x #>> SOME;
  10.425 -
  10.426 -fun fold_map_ty_idents f (NType (id, tys)) =
  10.427 -    f id
  10.428 -    ##>> fold_map (fold_map_ty_idents f) tys
  10.429 -    #>> NType;
  10.430 -
  10.431 -fun fold_map_match_branch_idents f (id, vars, body) =
  10.432 -    f id
  10.433 -    ##>> fold_map (fold_map_tm_idents f) vars
  10.434 -    ##>> fold_map_tm_idents f body
  10.435 -    #>> Scan.triple1
  10.436 -and fold_map_tm_idents f (NAtom (j, ty)) =
  10.437 -    fold_map_ty_idents f ty
  10.438 -    #>> curry NAtom j
  10.439 -  | fold_map_tm_idents f (NConst (id, tys, ty)) =
  10.440 -    f id
  10.441 -    ##>> fold_map (fold_map_ty_idents f) tys
  10.442 -    ##>> fold_map_ty_idents f ty
  10.443 -    #>> (Scan.triple1 #> NConst)
  10.444 -  | fold_map_tm_idents f (NAbs (var, body)) =
  10.445 -    fold_map_tm_idents f var
  10.446 -    ##>> fold_map_tm_idents f body
  10.447 -    #>> NAbs
  10.448 -  | fold_map_tm_idents f (NMatch (obj, branches)) =
  10.449 -    fold_map_tm_idents f obj
  10.450 -    ##>> fold_map (fold_map_match_branch_idents f) branches
  10.451 -    #>> NMatch
  10.452 -  | fold_map_tm_idents f (NApp (const, arg)) =
  10.453 -    fold_map_tm_idents f const
  10.454 -    ##>> fold_map_tm_idents f arg
  10.455 -    #>> NApp;
  10.456 -
  10.457 -fun fold_map_nun_copy_spec_idents f {abs_ty, rep_ty, subset, quotient, abs, rep} =
  10.458 -  fold_map_ty_idents f abs_ty
  10.459 -  ##>> fold_map_ty_idents f rep_ty
  10.460 -  ##>> fold_map_option (fold_map_tm_idents f) subset
  10.461 -  ##>> fold_map_option (fold_map_tm_idents f) quotient
  10.462 -  ##>> fold_map_tm_idents f abs
  10.463 -  ##>> fold_map_tm_idents f rep
  10.464 -  #>> (fn (((((abs_ty, rep_ty), subset), quotient), abs), rep) =>
  10.465 -    {abs_ty = abs_ty, rep_ty = rep_ty, subset = subset, quotient = quotient, abs = abs, rep = rep});
  10.466 -
  10.467 -fun fold_map_nun_ctr_spec_idents f {ctr, arg_tys} =
  10.468 -  fold_map_tm_idents f ctr
  10.469 -  ##>> fold_map (fold_map_ty_idents f) arg_tys
  10.470 -  #>> (fn (ctr, arg_tys) => {ctr = ctr, arg_tys = arg_tys});
  10.471 -
  10.472 -fun fold_map_nun_co_data_spec_idents f {ty, ctrs} =
  10.473 -  fold_map_ty_idents f ty
  10.474 -  ##>> fold_map (fold_map_nun_ctr_spec_idents f) ctrs
  10.475 -  #>> (fn (ty, ctrs) => {ty = ty, ctrs = ctrs});
  10.476 -
  10.477 -fun fold_map_nun_const_spec_idents f {const, props} =
  10.478 -  fold_map_tm_idents f const
  10.479 -  ##>> fold_map (fold_map_tm_idents f) props
  10.480 -  #>> (fn (const, props) => {const = const, props = props});
  10.481 -
  10.482 -fun fold_map_nun_consts_spec_idents f {consts, props} =
  10.483 -  fold_map (fold_map_tm_idents f) consts
  10.484 -  ##>> fold_map (fold_map_tm_idents f) props
  10.485 -  #>> (fn (consts, props) => {consts = consts, props = props});
  10.486 -
  10.487 -fun fold_map_nun_command_idents f (NTVal (ty, cards)) =
  10.488 -    fold_map_ty_idents f ty
  10.489 -    #>> (rpair cards #> NTVal)
  10.490 -  | fold_map_nun_command_idents f (NCopy spec) =
  10.491 -    fold_map_nun_copy_spec_idents f spec
  10.492 -    #>> NCopy
  10.493 -  | fold_map_nun_command_idents f (NData specs) =
  10.494 -    fold_map (fold_map_nun_co_data_spec_idents f) specs
  10.495 -    #>> NData
  10.496 -  | fold_map_nun_command_idents f (NCodata specs) =
  10.497 -    fold_map (fold_map_nun_co_data_spec_idents f) specs
  10.498 -    #>> NCodata
  10.499 -  | fold_map_nun_command_idents f (NVal (tm, ty)) =
  10.500 -    fold_map_tm_idents f tm
  10.501 -    ##>> fold_map_ty_idents f ty
  10.502 -    #>> NVal
  10.503 -  | fold_map_nun_command_idents f (NPred (wf, specs)) =
  10.504 -    fold_map (fold_map_nun_const_spec_idents f) specs
  10.505 -    #>> curry NPred wf
  10.506 -  | fold_map_nun_command_idents f (NCopred specs) =
  10.507 -    fold_map (fold_map_nun_const_spec_idents f) specs
  10.508 -    #>> NCopred
  10.509 -  | fold_map_nun_command_idents f (NRec specs) =
  10.510 -    fold_map (fold_map_nun_const_spec_idents f) specs
  10.511 -    #>> NRec
  10.512 -  | fold_map_nun_command_idents f (NSpec spec) =
  10.513 -    fold_map_nun_consts_spec_idents f spec
  10.514 -    #>> NSpec
  10.515 -  | fold_map_nun_command_idents f (NAxiom tm) =
  10.516 -    fold_map_tm_idents f tm
  10.517 -    #>> NAxiom
  10.518 -  | fold_map_nun_command_idents f (NGoal tm) =
  10.519 -    fold_map_tm_idents f tm
  10.520 -    #>> NGoal
  10.521 -  | fold_map_nun_command_idents f (NEval tm) =
  10.522 -    fold_map_tm_idents f tm
  10.523 -    #>> NEval;
  10.524 -
  10.525 -fun fold_map_nun_problem_idents f ({commandss, sound, complete} : nun_problem) =
  10.526 -  fold_map (fold_map (fold_map_nun_command_idents f)) commandss
  10.527 -  #>> (fn commandss' => {commandss = commandss', sound = sound, complete = complete});
  10.528 -
  10.529 -fun dest_rassoc_args oper arg0 rest =
  10.530 -  (case rest of
  10.531 -    NApp (NApp (oper', arg1), rest') =>
  10.532 -    if oper' = oper then arg0 :: dest_rassoc_args oper arg1 rest' else [arg0, rest]
  10.533 -  | _ => [arg0, rest]);
  10.534 -
  10.535 -fun replace_tm from to =
  10.536 -  let
  10.537 -    (* This code assumes all enclosing binders bind distinct variables and bound variables are
  10.538 -       distinct from any other variables. *)
  10.539 -    fun repl_br (id, vars, body) = (id, map repl vars, repl body)
  10.540 -    and repl (NApp (const, arg)) = NApp (repl const, repl arg)
  10.541 -      | repl (NAbs (var, body)) = NAbs (var, repl body)
  10.542 -      | repl (NMatch (obj, branches)) = NMatch (repl obj, map repl_br branches)
  10.543 -      | repl tm = if tm = from then to else tm;
  10.544 -  in
  10.545 -    repl
  10.546 -  end;
  10.547 -
  10.548 -val rcomb_tms = fold (fn arg => fn func => NApp (func, arg));
  10.549 -val abs_tms = fold_rev (curry NAbs);
  10.550 -
  10.551 -fun fresh_var_names_wrt_tm n tm =
  10.552 -  let
  10.553 -    fun max_var_br (_, vars, body) = fold max_var (body :: vars)
  10.554 -    and max_var (NAtom _) = I
  10.555 -      | max_var (NConst (id, _, _)) =
  10.556 -        (fn max => if String.isPrefix nun_var_prefix id andalso size id > size max then id else max)
  10.557 -      | max_var (NApp (func, arg)) = fold max_var [func, arg]
  10.558 -      | max_var (NAbs (var, body)) = fold max_var [var, body]
  10.559 -      | max_var (NMatch (obj, branches)) = max_var obj #> fold max_var_br branches;
  10.560 -
  10.561 -    val dummy_name = nun_var_of_str Name.uu;
  10.562 -    val max_name = max_var tm dummy_name;
  10.563 -  in
  10.564 -    map (index_name max_name) (1 upto n)
  10.565 -  end;
  10.566 -
  10.567 -fun beta_reduce_tm (NApp (NAbs (var, body), arg)) = beta_reduce_tm (replace_tm var arg body)
  10.568 -  | beta_reduce_tm (NApp (const, arg)) =
  10.569 -    (case beta_reduce_tm const of
  10.570 -      const' as NAbs _ => beta_reduce_tm (NApp (const', arg))
  10.571 -    | const' => NApp (const', beta_reduce_tm arg))
  10.572 -  | beta_reduce_tm (NAbs (var, body)) = NAbs (var, beta_reduce_tm body)
  10.573 -  | beta_reduce_tm (NMatch (obj, branches)) =
  10.574 -    NMatch (beta_reduce_tm obj, map (@{apply 3(3)} beta_reduce_tm) branches)
  10.575 -  | beta_reduce_tm tm = tm;
  10.576 -
  10.577 -fun eta_expandN_tm 0 tm = tm
  10.578 -  | eta_expandN_tm n tm =
  10.579 -    let
  10.580 -      val var_names = fresh_var_names_wrt_tm n tm;
  10.581 -      val arg_tys = domain_tys n (ty_of tm);
  10.582 -      val vars = map2 (fn id => fn ty => NConst (id, [], ty)) var_names arg_tys;
  10.583 -    in
  10.584 -      abs_tms vars (rcomb_tms vars tm)
  10.585 -    end;
  10.586 -
  10.587 -val eta_expand_builtin_tm =
  10.588 -  let
  10.589 -    fun expand_quant_arg (NAbs (var, body)) = NAbs (var, expand_quant_arg body)
  10.590 -      | expand_quant_arg (NMatch (obj, branches)) =
  10.591 -        NMatch (obj, map (@{apply 3(3)} expand_quant_arg) branches)
  10.592 -      | expand_quant_arg (tm as NApp (_, NAbs _)) = tm
  10.593 -      | expand_quant_arg (NApp (quant, arg)) = NApp (quant, eta_expandN_tm 1 arg)
  10.594 -      | expand_quant_arg tm = tm;
  10.595 -
  10.596 -    fun expand args (NApp (func, arg)) = expand (expand [] arg :: args) func
  10.597 -      | expand args (func as NConst (id, _, _)) =
  10.598 -        let val missing = Int.max (0, arity_of_nun_builtin id - length args) in
  10.599 -          rcomb_tms args func
  10.600 -          |> eta_expandN_tm missing
  10.601 -          |> is_nun_const_quantifier id ? expand_quant_arg
  10.602 -        end
  10.603 -      | expand args (func as NAtom _) = rcomb_tms args func
  10.604 -      | expand args (NAbs (var, body)) = rcomb_tms args (NAbs (var, expand [] body))
  10.605 -      | expand args (NMatch (obj, branches)) =
  10.606 -        rcomb_tms args (NMatch (obj, map (@{apply 3(3)} (expand [])) branches));
  10.607 -  in
  10.608 -    expand []
  10.609 -  end;
  10.610 -
  10.611 -val str_of_ty =
  10.612 -  let
  10.613 -    fun str_of maybe_parens (NType (id, tys)) =
  10.614 -      if id = nun_arrow then
  10.615 -        (case tys of
  10.616 -          [ty, ty'] => maybe_parens (str_of nun_parens ty ^ " " ^ nun_arrow ^ " " ^ str_of I ty'))
  10.617 -      else
  10.618 -        id ^ str_of_nun_arg_list (str_of I) tys
  10.619 -  in
  10.620 -    str_of I
  10.621 -  end;
  10.622 -
  10.623 -val (str_of_tmty, str_of_tm) =
  10.624 -  let
  10.625 -    fun is_triv_head (NConst (id, _, _)) = (arity_of_nun_builtin id = 0)
  10.626 -      | is_triv_head (NAtom _) = true
  10.627 -      | is_triv_head (NApp (const, _)) = is_triv_head const
  10.628 -      | is_triv_head (NAbs _) = false
  10.629 -      | is_triv_head (NMatch _) = false;
  10.630 -
  10.631 -    fun str_of_at_const id tys =
  10.632 -      nun_at ^ str_of_ident id ^ str_of_nun_arg_list str_of_ty tys;
  10.633 -
  10.634 -    fun str_of_app ty_opt const arg =
  10.635 -      let
  10.636 -        val ty_opt' =
  10.637 -          try (Option.map (fn ty => mk_arrow_ty (ty_of arg, ty))) ty_opt
  10.638 -          |> the_default NONE;
  10.639 -      in
  10.640 -        (str_of ty_opt' const |> (case const of NAbs _ => nun_parens | _ => I)) ^
  10.641 -        str_of_nun_arg_list (str_of NONE) [arg]
  10.642 -      end
  10.643 -    and str_of_br ty_opt (id, vars, body) =
  10.644 -      " " ^ nun_bar ^ " " ^ id ^ space_implode "" (map (prefix " " o str_of NONE) vars) ^ " " ^
  10.645 -      nun_arrow ^ " " ^ str_of ty_opt body
  10.646 -    and str_of_tmty tm =
  10.647 -      let val ty = ty_of tm in
  10.648 -        str_of (SOME ty) tm ^ " " ^ nun_colon ^ " " ^ str_of_ty ty
  10.649 -      end
  10.650 -    and str_of _ (NAtom (j, _)) = nun_dollar ^ string_of_int j
  10.651 -      | str_of _ (NConst (id, [], _)) = str_of_ident id
  10.652 -      | str_of (SOME ty0) (NConst (id, tys, ty)) =
  10.653 -        if ty = ty0 then str_of_ident id else str_of_at_const id tys
  10.654 -      | str_of _ (NConst (id, tys, _)) = str_of_at_const id tys
  10.655 -      | str_of ty_opt (NAbs (var, body)) =
  10.656 -        nun_lambda ^ " " ^
  10.657 -        (case ty_opt of
  10.658 -          SOME ty => str_of (SOME (domain_ty ty))
  10.659 -        | NONE => nun_parens o str_of_tmty) var ^
  10.660 -        nun_dot ^ " " ^ str_of (Option.map range_ty ty_opt) body
  10.661 -      | str_of ty_opt (NMatch (obj, branches)) =
  10.662 -        nun_match ^ " " ^ str_of NONE obj ^ " " ^ nun_with ^ " " ^
  10.663 -        space_implode "" (map (str_of_br ty_opt) branches) ^ " " ^ nun_end
  10.664 -      | str_of ty_opt (app as NApp (func, argN)) =
  10.665 -        (case (func, argN) of
  10.666 -          (NApp (oper as NConst (id, _, _), arg1), arg2) =>
  10.667 -          if id = nun_asserting then
  10.668 -            str_of ty_opt arg1 ^ " " ^ nun_asserting ^ " " ^ str_of (SOME prop_ty) arg2
  10.669 -            |> nun_parens
  10.670 -          else if id = nun_equals then
  10.671 -            (str_of NONE arg1 |> not (is_triv_head arg1) ? nun_parens) ^ " " ^ id ^ " " ^
  10.672 -            (str_of (try ty_of arg2) arg2 |> not (is_triv_head arg2) ? nun_parens)
  10.673 -          else if is_nun_const_connective id then
  10.674 -            let val args = dest_rassoc_args oper arg1 arg2 in
  10.675 -              space_implode (" " ^ id ^ " ")
  10.676 -                (map (fn arg => str_of NONE arg |> not (is_triv_head arg) ? nun_parens) args)
  10.677 -            end
  10.678 -          else
  10.679 -            str_of_app ty_opt func argN
  10.680 -        | (NApp (NApp (NConst (id, _, _), arg1), arg2), arg3) =>
  10.681 -          if id = nun_if then
  10.682 -            nun_if ^ " " ^ str_of NONE arg1 ^ " " ^ nun_then ^ " " ^ str_of NONE arg2 ^ " " ^
  10.683 -            nun_else ^ " " ^ str_of NONE arg3
  10.684 -            |> nun_parens
  10.685 -          else
  10.686 -            str_of_app ty_opt func argN
  10.687 -        | (NConst (id, _, _), NAbs _) =>
  10.688 -          if is_nun_const_quantifier id then
  10.689 -            let val (vars, body) = strip_nun_binders id app in
  10.690 -              id ^ " " ^ space_implode " " (map (nun_parens o str_of_tmty) vars) ^ nun_dot ^ " " ^
  10.691 -              str_of NONE body
  10.692 -            end
  10.693 -          else
  10.694 -            str_of_app ty_opt func argN
  10.695 -        | _ => str_of_app ty_opt func argN);
  10.696 -  in
  10.697 -    (str_of_tmty, str_of NONE)
  10.698 -  end;
  10.699 -
  10.700 -val empty_name_pool = {nice_of_ugly = Symtab.empty, ugly_of_nice = Symtab.empty};
  10.701 -
  10.702 -val nice_of_ugly_suggestion =
  10.703 -  unascii_of #> Long_Name.base_name #> ascii_of #> unsuffix nun_custom_id_suffix
  10.704 -  #> (fn s => if s = "" orelse not (Char.isAlpha (String.sub (s, 0))) then "x" ^ s else s);
  10.705 -
  10.706 -fun allocate_nice ({nice_of_ugly, ugly_of_nice} : name_pool) (ugly, nice_sugg0) =
  10.707 -  let
  10.708 -    fun alloc j =
  10.709 -      let val nice_sugg = index_name nice_sugg0 j in
  10.710 -        (case Symtab.lookup ugly_of_nice nice_sugg of
  10.711 -          NONE =>
  10.712 -          (nice_sugg,
  10.713 -           {nice_of_ugly = Symtab.update_new (ugly, nice_sugg) nice_of_ugly,
  10.714 -            ugly_of_nice = Symtab.update_new (nice_sugg, ugly) ugly_of_nice})
  10.715 -        | SOME _ => alloc (j + 1))
  10.716 -      end;
  10.717 -  in
  10.718 -    alloc 0
  10.719 -  end;
  10.720 -
  10.721 -fun nice_ident ugly (pool as {nice_of_ugly, ...}) =
  10.722 -  if String.isSuffix nun_custom_id_suffix ugly then
  10.723 -    (case Symtab.lookup nice_of_ugly ugly of
  10.724 -      NONE => allocate_nice pool (ugly, nice_of_ugly_suggestion ugly)
  10.725 -    | SOME nice => (nice, pool))
  10.726 -  else
  10.727 -    (ugly, pool);
  10.728 -
  10.729 -fun nice_nun_problem problem =
  10.730 -  fold_map_nun_problem_idents nice_ident problem empty_name_pool;
  10.731 -
  10.732 -fun str_of_tval (NType (id, tys)) =
  10.733 -  str_of_ident id ^ " " ^ nun_colon ^ " " ^
  10.734 -  fold (K (prefix (nun_type ^ " " ^ nun_arrow ^ " "))) tys nun_type;
  10.735 -
  10.736 -fun is_triv_subset (NAbs (_, body)) = is_triv_subset body
  10.737 -  | is_triv_subset (NConst (id, _, _)) = (id = nun_true)
  10.738 -  | is_triv_subset _ = false;
  10.739 -
  10.740 -fun str_of_nun_copy_spec {abs_ty, rep_ty, subset, quotient, abs, rep} =
  10.741 -  str_of_ty abs_ty ^ " " ^ nun_assign ^ " " ^ str_of_ty rep_ty ^
  10.742 -  (case subset of
  10.743 -    NONE => ""
  10.744 -  | SOME s => if is_triv_subset s then "" else "\n  " ^ nun_subset ^ " " ^ str_of_tm s) ^
  10.745 -  (* TODO: use nun_quotient when possible *)
  10.746 -  (case quotient of
  10.747 -    NONE => ""
  10.748 -  | SOME q => "\n  " ^ nun_partial_quotient ^ " " ^ str_of_tm q) ^
  10.749 -  "\n  " ^ nun_abstract ^ " " ^ str_of_tm abs ^ "\n  " ^ nun_concrete ^ " " ^ str_of_tm rep;
  10.750 -
  10.751 -fun str_of_nun_ctr_spec {ctr, arg_tys} =
  10.752 -  str_of_tm ctr ^ str_of_nun_arg_list str_of_ty arg_tys;
  10.753 -
  10.754 -fun str_of_nun_co_data_spec {ty, ctrs} =
  10.755 -  str_of_ty ty ^ " " ^ nun_assign ^ "\n  " ^
  10.756 -  space_implode ("\n" ^ nun_bar ^ " ") (map str_of_nun_ctr_spec ctrs);
  10.757 -
  10.758 -fun str_of_nun_const_spec {const, props} =
  10.759 -  str_of_tmty const ^ " " ^ nun_assign ^ "\n  " ^
  10.760 -  space_implode (nun_semicolon ^ "\n  ") (map str_of_tm props);
  10.761 -
  10.762 -fun str_of_nun_consts_spec {consts, props} =
  10.763 -  space_implode (" " ^ nun_and ^ "\n     ") (map str_of_tmty consts) ^ " " ^ nun_assign ^ "\n  " ^
  10.764 -  space_implode (nun_semicolon ^ "\n  ") (map str_of_tm props);
  10.765 -
  10.766 -fun str_of_nun_cards_suffix (NONE, NONE) = ""
  10.767 -  | str_of_nun_cards_suffix (c1, c2) =
  10.768 -    let
  10.769 -      val s1 = Option.map (prefix "min_card " o signed_string_of_int) c1;
  10.770 -      val s2 = Option.map (prefix "max_card " o signed_string_of_int) c2;
  10.771 -    in
  10.772 -      enclose " [" "]" (space_implode ", " (map_filter I [s1, s2]))
  10.773 -    end;
  10.774 -
  10.775 -fun str_of_nun_command (NTVal (ty, cards)) =
  10.776 -    nun_val ^ " " ^ str_of_tval ty ^ str_of_nun_cards_suffix cards
  10.777 -  | str_of_nun_command (NCopy spec) = nun_copy ^ " " ^ str_of_nun_copy_spec spec
  10.778 -  | str_of_nun_command (NData specs) =
  10.779 -    nun_data ^ " " ^ str_of_nun_and_list str_of_nun_co_data_spec specs
  10.780 -  | str_of_nun_command (NCodata specs) =
  10.781 -    nun_codata ^ " " ^ str_of_nun_and_list str_of_nun_co_data_spec specs
  10.782 -  | str_of_nun_command (NVal (tm, ty)) =
  10.783 -    nun_val ^ " " ^ str_of_tm tm ^ " " ^ nun_colon ^ " " ^ str_of_ty ty
  10.784 -  | str_of_nun_command (NPred (wf, specs)) =
  10.785 -    nun_pred ^ " " ^ (if wf then nun_lbracket ^ nun_wf ^ nun_rbracket ^ " " else "") ^
  10.786 -    str_of_nun_and_list str_of_nun_const_spec specs
  10.787 -  | str_of_nun_command (NCopred specs) =
  10.788 -    nun_copred ^ " " ^ str_of_nun_and_list str_of_nun_const_spec specs
  10.789 -  | str_of_nun_command (NRec specs) =
  10.790 -    nun_rec ^ " " ^ str_of_nun_and_list str_of_nun_const_spec specs
  10.791 -  | str_of_nun_command (NSpec spec) = nun_spec ^ " " ^ str_of_nun_consts_spec spec
  10.792 -  | str_of_nun_command (NAxiom tm) = nun_axiom ^ " " ^ str_of_tm tm
  10.793 -  | str_of_nun_command (NGoal tm) = nun_goal ^ " " ^ str_of_tm tm
  10.794 -  | str_of_nun_command (NEval tm) = nun_hash ^ " " ^ nun_eval ^ " " ^ str_of_tm tm;
  10.795 -
  10.796 -fun str_of_nun_problem {commandss, sound, complete} =
  10.797 -  map (cat_lines o map (suffix nun_dot o str_of_nun_command)) commandss
  10.798 -  |> space_implode "\n\n" |> suffix "\n"
  10.799 -  |> prefix (nun_hash ^ " " ^ (if sound then "sound" else "unsound") ^ "\n")
  10.800 -  |> prefix (nun_hash ^ " " ^ (if complete then "complete" else "incomplete") ^ "\n");
  10.801 -
  10.802 -end;
    11.1 --- a/src/HOL/Nunchaku/Tools/nunchaku_reconstruct.ML	Thu Sep 07 23:13:15 2017 +0200
    11.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.3 @@ -1,244 +0,0 @@
    11.4 -(*  Title:      HOL/Nunchaku/Tools/nunchaku_reconstruct.ML
    11.5 -    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    11.6 -    Copyright   2015, 2016
    11.7 -
    11.8 -Reconstruction of Nunchaku models in Isabelle/HOL.
    11.9 -*)
   11.10 -
   11.11 -signature NUNCHAKU_RECONSTRUCT =
   11.12 -sig
   11.13 -  type nun_model = Nunchaku_Model.nun_model
   11.14 -
   11.15 -  type typ_entry = typ * term list
   11.16 -  type term_entry = term * term
   11.17 -
   11.18 -  type isa_model =
   11.19 -    {type_model: typ_entry list,
   11.20 -     free_model: term_entry list,
   11.21 -     pat_complete_model: term_entry list,
   11.22 -     pat_incomplete_model: term_entry list,
   11.23 -     skolem_model: term_entry list}
   11.24 -
   11.25 -  val str_of_isa_model: Proof.context -> isa_model -> string
   11.26 -
   11.27 -  val isa_model_of_nun: Proof.context -> term list -> (typ option * string list) list ->
   11.28 -    nun_model -> isa_model
   11.29 -end;
   11.30 -
   11.31 -structure Nunchaku_Reconstruct : NUNCHAKU_RECONSTRUCT =
   11.32 -struct
   11.33 -
   11.34 -open Nunchaku_Util;
   11.35 -open Nunchaku_Problem;
   11.36 -open Nunchaku_Translate;
   11.37 -open Nunchaku_Model;
   11.38 -
   11.39 -type typ_entry = typ * term list;
   11.40 -type term_entry = term * term;
   11.41 -
   11.42 -type isa_model =
   11.43 -  {type_model: typ_entry list,
   11.44 -   free_model: term_entry list,
   11.45 -   pat_complete_model: term_entry list,
   11.46 -   pat_incomplete_model: term_entry list,
   11.47 -   skolem_model: term_entry list};
   11.48 -
   11.49 -val anonymousN = "anonymous";
   11.50 -val irrelevantN = "irrelevant";
   11.51 -val unparsableN = "unparsable";
   11.52 -
   11.53 -val nun_arrow_exploded = String.explode nun_arrow;
   11.54 -
   11.55 -val is_ty_meta = member (op =) (String.explode "()->,");
   11.56 -
   11.57 -fun next_token_lowlevel [] = (End_of_Stream, [])
   11.58 -  | next_token_lowlevel (c :: cs) =
   11.59 -    if Char.isSpace c then
   11.60 -      next_token_lowlevel cs
   11.61 -    else if not (is_ty_meta c) then
   11.62 -      let val n = find_index (Char.isSpace orf is_ty_meta) cs in
   11.63 -        (if n = ~1 then (cs, []) else chop n cs)
   11.64 -        |>> (cons c #> String.implode #> ident_of_str #> Ident)
   11.65 -      end
   11.66 -    else if is_prefix (op =) nun_arrow_exploded (c :: cs) then
   11.67 -      (Ident nun_arrow, tl cs)
   11.68 -    else
   11.69 -      (Symbol (String.str c), cs);
   11.70 -
   11.71 -val tokenize_lowlevel =
   11.72 -  let
   11.73 -    fun toks cs =
   11.74 -      (case next_token_lowlevel cs of
   11.75 -        (End_of_Stream, []) => []
   11.76 -      | (tok, cs') => tok :: toks cs');
   11.77 -  in
   11.78 -    toks o String.explode
   11.79 -  end;
   11.80 -
   11.81 -fun parse_lowlevel_ty tok =
   11.82 -  (Scan.optional
   11.83 -     (parse_sym "(" |-- Scan.repeat (parse_lowlevel_ty --| Scan.option (parse_sym ",")) --|
   11.84 -      parse_sym ")")
   11.85 -     []
   11.86 -   -- parse_ident >> (swap #> NType)) tok;
   11.87 -
   11.88 -val ty_of_lowlevel_str = fst o parse_lowlevel_ty o tokenize_lowlevel;
   11.89 -
   11.90 -fun ident_of_const (NConst (id, _, _)) = id
   11.91 -  | ident_of_const _ = nun_dummy;
   11.92 -
   11.93 -fun str_of_typ_entry ctxt (T, ts) =
   11.94 -  "type " ^ Syntax.string_of_typ ctxt T  ^
   11.95 -  " := {" ^ commas (map (Syntax.string_of_term ctxt) ts) ^ "}.";
   11.96 -
   11.97 -fun str_of_term_entry ctxt (tm, value) =
   11.98 -  "val " ^ Syntax.string_of_term ctxt tm ^ " := " ^ Syntax.string_of_term ctxt value ^ ".";
   11.99 -
  11.100 -fun str_of_isa_model ctxt
  11.101 -    {type_model, free_model, pat_complete_model, pat_incomplete_model, skolem_model} =
  11.102 -  map (str_of_typ_entry ctxt) type_model @ "" ::
  11.103 -  map (str_of_term_entry ctxt) free_model @ "" ::
  11.104 -  map (str_of_term_entry ctxt) pat_complete_model @ "" ::
  11.105 -  map (str_of_term_entry ctxt) pat_incomplete_model @ "" ::
  11.106 -  map (str_of_term_entry ctxt) skolem_model
  11.107 -  |> cat_lines;
  11.108 -
  11.109 -fun typ_of_nun ctxt =
  11.110 -  let
  11.111 -    fun typ_of (NType (id, tys)) =
  11.112 -      let val Ts = map typ_of tys in
  11.113 -        if id = nun_dummy then
  11.114 -          dummyT
  11.115 -        else if id = nun_prop then
  11.116 -          @{typ bool}
  11.117 -        else if id = nun_arrow then
  11.118 -          Type (@{type_name fun}, Ts)
  11.119 -        else
  11.120 -          (case try str_of_nun_tconst id of
  11.121 -            SOME (args, s) =>
  11.122 -            let val tys' = map ty_of_lowlevel_str args in
  11.123 -              Type (s, map typ_of (tys' @ tys))
  11.124 -            end
  11.125 -          | NONE =>
  11.126 -            (case try str_of_nun_tfree id of
  11.127 -              SOME s => TFree (Proof_Context.check_tfree ctxt (flip_quote s, dummyS))
  11.128 -            | NONE => raise Fail ("unknown type constructor: " ^ quote (str_of_ident id))))
  11.129 -      end;
  11.130 -  in
  11.131 -    typ_of
  11.132 -  end;
  11.133 -
  11.134 -fun one_letter_of s =
  11.135 -  let val c = String.sub (Long_Name.base_name s, 0) in
  11.136 -    String.str (if Char.isAlpha c then c else #"x")
  11.137 -  end;
  11.138 -
  11.139 -fun base_of_typ (Type (s, _)) = s
  11.140 -  | base_of_typ (TFree (s, _)) = flip_quote s
  11.141 -  | base_of_typ (TVar ((s, _), _)) = flip_quote s;
  11.142 -
  11.143 -fun term_of_nun ctxt atomss =
  11.144 -  let
  11.145 -    val thy = Proof_Context.theory_of ctxt;
  11.146 -
  11.147 -    val typ_of = typ_of_nun ctxt;
  11.148 -
  11.149 -    fun nth_atom T j =
  11.150 -      let val ss = these (triple_lookup (typ_match thy) atomss T) in
  11.151 -        if j >= 0 andalso j < length ss then nth ss j
  11.152 -        else one_letter_of (base_of_typ T) ^ nat_subscript (j + 1)
  11.153 -      end;
  11.154 -
  11.155 -    fun term_of _ (NAtom (j, ty)) =
  11.156 -        let val T = typ_of ty in Var ((nth_atom T j, 0), T) end
  11.157 -      | term_of bounds (NConst (id, tys0, ty)) =
  11.158 -        if id = nun_conj then
  11.159 -          HOLogic.conj
  11.160 -        else if id = nun_disj then
  11.161 -          HOLogic.disj
  11.162 -        else if id = nun_choice then
  11.163 -          Const (@{const_name Eps}, typ_of ty)
  11.164 -        else if id = nun_equals then
  11.165 -          Const (@{const_name HOL.eq}, typ_of ty)
  11.166 -        else if id = nun_false then
  11.167 -          @{const False}
  11.168 -        else if id = nun_if then
  11.169 -          Const (@{const_name If}, typ_of ty)
  11.170 -        else if id = nun_implies then
  11.171 -          @{term implies}
  11.172 -        else if id = nun_unique then
  11.173 -          Const (@{const_name The}, typ_of ty)
  11.174 -        else if id = nun_unique_unsafe then
  11.175 -          Const (@{const_name The_unsafe}, typ_of ty)
  11.176 -        else if id = nun_true then
  11.177 -          @{const True}
  11.178 -        else if String.isPrefix nun_anon_fun_prefix id then
  11.179 -          let val j = Int.fromString (unprefix nun_anon_fun_prefix id) |> the_default ~1 in
  11.180 -            Var ((anonymousN ^ nat_subscript (j + 1), 0), typ_of ty)
  11.181 -          end
  11.182 -        else if id = nun_irrelevant then
  11.183 -          (* FIXME: get bounds from Nunchaku *)
  11.184 -          list_comb (Var ((irrelevantN, 0), map (typ_of o safe_ty_of) bounds ---> typ_of ty),
  11.185 -            map Bound (length bounds - 1 downto 0))
  11.186 -        else if id = nun_unparsable then
  11.187 -          (* FIXME: get bounds from Nunchaku *)
  11.188 -          list_comb (Var ((unparsableN, 0), typ_of ty), map Bound (length bounds - 1 downto 0))
  11.189 -        else
  11.190 -          (case try str_of_nun_const id of
  11.191 -            SOME (args, s) =>
  11.192 -            let val tys = map ty_of_lowlevel_str args in
  11.193 -              Sign.mk_const thy (s, map typ_of (tys @ tys0))
  11.194 -            end
  11.195 -          | NONE =>
  11.196 -            (case try str_of_nun_free id of
  11.197 -              SOME s => Free (s, typ_of ty)
  11.198 -            | NONE =>
  11.199 -              (case try str_of_nun_var id of
  11.200 -                SOME s => Var ((s, 0), typ_of ty)
  11.201 -              | NONE =>
  11.202 -                (case find_index (fn bound => ident_of_const bound = id) bounds of
  11.203 -                  ~1 => Var ((str_of_ident id, 0), typ_of ty) (* shouldn't happen? *)
  11.204 -                | j => Bound j))))
  11.205 -      | term_of bounds (NAbs (var, body)) =
  11.206 -        let val T = typ_of (safe_ty_of var) in
  11.207 -          Abs (one_letter_of (base_of_typ T), T, term_of (var :: bounds) body)
  11.208 -        end
  11.209 -      | term_of bounds (NApp (func, arg)) =
  11.210 -        let
  11.211 -          fun same () = term_of bounds func $ term_of bounds arg;
  11.212 -        in
  11.213 -          (case (func, arg) of
  11.214 -            (NConst (id, _, _), NAbs _) =>
  11.215 -            if id = nun_mu then
  11.216 -              let val Abs (s, T, body) = term_of bounds arg in
  11.217 -                Const (@{const_name The}, (T --> HOLogic.boolT) --> T)
  11.218 -                $ Abs (s, T, HOLogic.eq_const T $ Bound 0 $ body)
  11.219 -              end
  11.220 -            else
  11.221 -              same ()
  11.222 -          | _ => same ())
  11.223 -        end
  11.224 -      | term_of _ (NMatch _) = raise Fail "unexpected match";
  11.225 -  in
  11.226 -    term_of []
  11.227 -  end;
  11.228 -
  11.229 -fun isa_typ_entry_of_nun ctxt atomss (ty, atoms) =
  11.230 -  (typ_of_nun ctxt ty, map (term_of_nun ctxt atomss) atoms);
  11.231 -
  11.232 -fun isa_term_entry_of_nun ctxt atomss (tm, value) =
  11.233 -  (term_of_nun ctxt atomss tm, term_of_nun ctxt atomss value);
  11.234 -
  11.235 -fun isa_model_of_nun ctxt pat_completes atomss {type_model, const_model, skolem_model} =
  11.236 -  let
  11.237 -    val free_and_const_model = map (isa_term_entry_of_nun ctxt atomss) const_model;
  11.238 -    val (free_model, (pat_complete_model, pat_incomplete_model)) =
  11.239 -      List.partition (is_Free o fst) free_and_const_model
  11.240 -      ||> List.partition (member (op aconv) pat_completes o fst);
  11.241 -  in
  11.242 -    {type_model = map (isa_typ_entry_of_nun ctxt atomss) type_model, free_model = free_model,
  11.243 -     pat_complete_model = pat_complete_model, pat_incomplete_model = pat_incomplete_model,
  11.244 -     skolem_model = map (isa_term_entry_of_nun ctxt atomss) skolem_model}
  11.245 -  end;
  11.246 -
  11.247 -end;
    12.1 --- a/src/HOL/Nunchaku/Tools/nunchaku_tool.ML	Thu Sep 07 23:13:15 2017 +0200
    12.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.3 @@ -1,141 +0,0 @@
    12.4 -(*  Title:      HOL/Nunchaku/Tools/nunchaku_tool.ML
    12.5 -    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    12.6 -    Copyright   2015, 2016
    12.7 -
    12.8 -Interface to the external "nunchaku" tool.
    12.9 -*)
   12.10 -
   12.11 -signature NUNCHAKU_TOOL =
   12.12 -sig
   12.13 -  type ty = Nunchaku_Problem.ty
   12.14 -  type tm = Nunchaku_Problem.tm
   12.15 -  type nun_problem = Nunchaku_Problem.nun_problem
   12.16 -
   12.17 -  type tool_params =
   12.18 -    {solvers: string list,
   12.19 -     overlord: bool,
   12.20 -     debug: bool,
   12.21 -     specialize: bool,
   12.22 -     timeout: Time.time}
   12.23 -
   12.24 -  type nun_solution =
   12.25 -    {tys: (ty * tm list) list,
   12.26 -     tms: (tm * tm) list}
   12.27 -
   12.28 -  datatype nun_outcome =
   12.29 -    Unsat
   12.30 -  | Sat of string * nun_solution
   12.31 -  | Unknown of (string * nun_solution) option
   12.32 -  | Timeout
   12.33 -  | Nunchaku_Var_Not_Set
   12.34 -  | Nunchaku_Cannot_Execute
   12.35 -  | Nunchaku_Not_Found
   12.36 -  | CVC4_Cannot_Execute
   12.37 -  | CVC4_Not_Found
   12.38 -  | Unknown_Error of int * string
   12.39 -
   12.40 -  val nunchaku_home_env_var: string
   12.41 -
   12.42 -  val solve_nun_problem: tool_params -> nun_problem -> nun_outcome
   12.43 -end;
   12.44 -
   12.45 -structure Nunchaku_Tool : NUNCHAKU_TOOL =
   12.46 -struct
   12.47 -
   12.48 -open Nunchaku_Util;
   12.49 -open Nunchaku_Problem;
   12.50 -
   12.51 -type tool_params =
   12.52 -  {solvers: string list,
   12.53 -   overlord: bool,
   12.54 -   debug: bool,
   12.55 -   specialize: bool,
   12.56 -   timeout: Time.time};
   12.57 -
   12.58 -type nun_solution =
   12.59 -  {tys: (ty * tm list) list,
   12.60 -   tms: (tm * tm) list};
   12.61 -
   12.62 -datatype nun_outcome =
   12.63 -  Unsat
   12.64 -| Sat of string * nun_solution
   12.65 -| Unknown of (string * nun_solution) option
   12.66 -| Timeout
   12.67 -| Nunchaku_Var_Not_Set
   12.68 -| Nunchaku_Cannot_Execute
   12.69 -| Nunchaku_Not_Found
   12.70 -| CVC4_Cannot_Execute
   12.71 -| CVC4_Not_Found
   12.72 -| Unknown_Error of int * string;
   12.73 -
   12.74 -fun bash_output_error s =
   12.75 -  let val {out, err, rc, ...} = Bash.process s in
   12.76 -    ((out, err), rc)
   12.77 -  end;
   12.78 -
   12.79 -val nunchaku_home_env_var = "NUNCHAKU_HOME";
   12.80 -
   12.81 -val cached_outcome = Synchronized.var "Nunchaku_Tool.cached_outcome"
   12.82 -  (NONE : ((string list * nun_problem) * nun_outcome) option);
   12.83 -
   12.84 -fun uncached_solve_nun_problem ({solvers, overlord, specialize, timeout, ...} : tool_params)
   12.85 -    (problem as {sound, complete, ...}) =
   12.86 -  with_tmp_or_overlord_file overlord "nunchaku" "nun" (fn prob_path =>
   12.87 -    if getenv nunchaku_home_env_var = "" then
   12.88 -      Nunchaku_Var_Not_Set
   12.89 -    else
   12.90 -      let
   12.91 -        val bash_cmd =
   12.92 -          "PATH=\"$CVC4_HOME:$KODKODI/bin:$PATH\" \"$" ^
   12.93 -          nunchaku_home_env_var ^ "\"/nunchaku --skolems-in-model --no-color " ^
   12.94 -          (if specialize then "" else "--no-specialize ") ^
   12.95 -          "--solvers \"" ^ Bash_Syntax.string (space_implode " " solvers) ^ "\" " ^
   12.96 -          "--timeout " ^ string_of_int (Time.toSeconds timeout) ^ " " ^
   12.97 -          File.bash_path prob_path;
   12.98 -        val comments =
   12.99 -          [bash_cmd, "This file was generated by Isabelle (most likely Nunchaku)", timestamp ()];
  12.100 -        val prob_str = cat_lines (map (prefix "# ") comments) ^ "\n\n" ^ str_of_nun_problem problem;
  12.101 -        val _ = File.write prob_path prob_str;
  12.102 -        val ((output, error), code) = bash_output_error bash_cmd;
  12.103 -      in
  12.104 -        if String.isPrefix "SAT" output then
  12.105 -          (if sound then Sat else Unknown o SOME) (output, {tys = [], tms = []})
  12.106 -        else if String.isPrefix "UNSAT" output then
  12.107 -          if complete then Unsat else Unknown NONE
  12.108 -        else if String.isSubstring "TIMEOUT" output
  12.109 -            (* FIXME: temporary *)
  12.110 -            orelse String.isSubstring "kodkod failed (errcode 152)" error then
  12.111 -          Timeout
  12.112 -        else if String.isPrefix "UNKNOWN" output then
  12.113 -          Unknown NONE
  12.114 -        else if code = 126 then
  12.115 -          Nunchaku_Cannot_Execute
  12.116 -        else if code = 127 then
  12.117 -          Nunchaku_Not_Found
  12.118 -        else
  12.119 -          Unknown_Error (code,
  12.120 -            simplify_spaces (elide_string 1000 (if error <> "" then error else output)))
  12.121 -      end);
  12.122 -
  12.123 -fun solve_nun_problem (params as {solvers, overlord, debug, ...}) problem =
  12.124 -  let val key = (solvers, problem) in
  12.125 -    (case (overlord orelse debug,
  12.126 -        AList.lookup (op =) (the_list (Synchronized.value cached_outcome)) key) of
  12.127 -      (false, SOME outcome) => outcome
  12.128 -    | _ =>
  12.129 -      let
  12.130 -        val outcome = uncached_solve_nun_problem params problem;
  12.131 -
  12.132 -        fun update_cache () =
  12.133 -          Synchronized.change cached_outcome (K (SOME (key, outcome)));
  12.134 -      in
  12.135 -        (case outcome of
  12.136 -          Unsat => update_cache ()
  12.137 -        | Sat _ => update_cache ()
  12.138 -        | Unknown _ => update_cache ()
  12.139 -        | _ => ());
  12.140 -        outcome
  12.141 -      end)
  12.142 -  end;
  12.143 -
  12.144 -end;
    13.1 --- a/src/HOL/Nunchaku/Tools/nunchaku_translate.ML	Thu Sep 07 23:13:15 2017 +0200
    13.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.3 @@ -1,193 +0,0 @@
    13.4 -(*  Title:      HOL/Nunchaku/Tools/nunchaku_translate.ML
    13.5 -    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    13.6 -    Copyright   2015, 2016
    13.7 -
    13.8 -Translation of Isabelle/HOL problems to Nunchaku.
    13.9 -*)
   13.10 -
   13.11 -signature NUNCHAKU_TRANSLATE =
   13.12 -sig
   13.13 -  type isa_problem = Nunchaku_Collect.isa_problem
   13.14 -  type ty = Nunchaku_Problem.ty
   13.15 -  type nun_problem = Nunchaku_Problem.nun_problem
   13.16 -
   13.17 -  val flip_quote: string -> string
   13.18 -  val lowlevel_str_of_ty: ty -> string
   13.19 -
   13.20 -  val nun_problem_of_isa: Proof.context -> isa_problem -> nun_problem
   13.21 -end;
   13.22 -
   13.23 -structure Nunchaku_Translate : NUNCHAKU_TRANSLATE =
   13.24 -struct
   13.25 -
   13.26 -open Nunchaku_Util;
   13.27 -open Nunchaku_Collect;
   13.28 -open Nunchaku_Problem;
   13.29 -
   13.30 -fun flip_quote s =
   13.31 -  (case try (unprefix "'") s of
   13.32 -    SOME s' => s'
   13.33 -  | NONE => prefix "'" s);
   13.34 -
   13.35 -fun lowlevel_str_of_ty (NType (id, tys)) =
   13.36 -  (if null tys then "" else encode_args (map lowlevel_str_of_ty tys)) ^ id;
   13.37 -
   13.38 -fun strip_nun_abs 0 tm = ([], tm)
   13.39 -  | strip_nun_abs n (NAbs (var, body)) =
   13.40 -    strip_nun_abs (n - 1) body
   13.41 -    |>> cons var;
   13.42 -
   13.43 -val strip_nun_comb =
   13.44 -  let
   13.45 -    fun strip args (NApp (func, arg)) = strip (arg :: args) func
   13.46 -      | strip args tm = (tm, args);
   13.47 -  in
   13.48 -    strip []
   13.49 -  end;
   13.50 -
   13.51 -fun ty_of_isa (Type (s, Ts)) =
   13.52 -    let val tys = map ty_of_isa Ts in
   13.53 -      (case s of
   13.54 -        @{type_name bool} => prop_ty
   13.55 -      | @{type_name fun} => NType (nun_arrow, tys)
   13.56 -      | _ =>
   13.57 -        let
   13.58 -          val args = map lowlevel_str_of_ty tys;
   13.59 -          val id = nun_tconst_of_str args s;
   13.60 -        in
   13.61 -          NType (id, [])
   13.62 -        end)
   13.63 -    end
   13.64 -  | ty_of_isa (TFree (s, _)) = NType (nun_tfree_of_str (flip_quote s), [])
   13.65 -  | ty_of_isa (TVar _) = raise Fail "unexpected TVar";
   13.66 -
   13.67 -fun gen_tm_of_isa in_prop ctxt t =
   13.68 -  let
   13.69 -    val thy = Proof_Context.theory_of ctxt;
   13.70 -
   13.71 -    fun id_of_const (x as (s, _)) =
   13.72 -      let val args = map (lowlevel_str_of_ty o ty_of_isa) (Sign.const_typargs thy x) in
   13.73 -        nun_const_of_str args s
   13.74 -      end;
   13.75 -
   13.76 -    fun tm_of_branch ctr_id var_count f_arg_tm =
   13.77 -      let val (vars, body) = strip_nun_abs var_count f_arg_tm in
   13.78 -        (ctr_id, vars, body)
   13.79 -      end;
   13.80 -
   13.81 -    fun tm_of bounds (Const (x as (s, T))) =
   13.82 -        (case try (dest_co_datatype_case ctxt) x of
   13.83 -          SOME ctrs =>
   13.84 -          let
   13.85 -            val num_f_args = length ctrs;
   13.86 -            val min_args = num_f_args + 1;
   13.87 -            val var_counts = map (num_binder_types o snd) ctrs;
   13.88 -
   13.89 -            val dummy_free = Free (Name.uu, T);
   13.90 -            val tm = tm_of bounds dummy_free;
   13.91 -            val tm' = eta_expandN_tm min_args tm;
   13.92 -            val (vars, body) = strip_nun_abs min_args tm';
   13.93 -            val (_, (f_args, obj :: other_args)) = strip_nun_comb body ||> chop num_f_args;
   13.94 -            val f_args' = map2 eta_expandN_tm var_counts f_args;
   13.95 -
   13.96 -            val ctr_ids = map id_of_const ctrs;
   13.97 -          in
   13.98 -            NMatch (obj, @{map 3} tm_of_branch ctr_ids var_counts f_args')
   13.99 -            |> rcomb_tms other_args
  13.100 -            |> abs_tms vars
  13.101 -          end
  13.102 -        | NONE =>
  13.103 -          if s = @{const_name unreachable} andalso in_prop then
  13.104 -            let val ty = ty_of_isa T in
  13.105 -              napps (NConst (nun_asserting, [ty], mk_arrows_ty ([ty, prop_ty], ty)),
  13.106 -                [NConst (id_of_const x, [], ty), NConst (nun_false, [], prop_ty)])
  13.107 -            end
  13.108 -          else
  13.109 -            let
  13.110 -              val id =
  13.111 -                (case s of
  13.112 -                  @{const_name All} => nun_forall
  13.113 -                | @{const_name conj} => nun_conj
  13.114 -                | @{const_name disj} => nun_disj
  13.115 -                | @{const_name HOL.eq} => nun_equals
  13.116 -                | @{const_name Eps} => nun_choice
  13.117 -                | @{const_name Ex} => nun_exists
  13.118 -                | @{const_name False} => nun_false
  13.119 -                | @{const_name If} => nun_if
  13.120 -                | @{const_name implies} => nun_implies
  13.121 -                | @{const_name Not} => nun_not
  13.122 -                | @{const_name The} => nun_unique
  13.123 -                | @{const_name The_unsafe} => nun_unique_unsafe
  13.124 -                | @{const_name True} => nun_true
  13.125 -                | _ => id_of_const x);
  13.126 -            in
  13.127 -              NConst (id, [], ty_of_isa T)
  13.128 -            end)
  13.129 -      | tm_of _ (Free (s, T)) = NConst (nun_free_of_str s, [], ty_of_isa T)
  13.130 -      | tm_of _ (Var ((s, _), T)) = NConst (nun_var_of_str s, [], ty_of_isa T)
  13.131 -      | tm_of bounds (Abs (s, T, t)) =
  13.132 -        let
  13.133 -          val (s', bounds') = Name.variant s bounds;
  13.134 -          val x = Var ((s', 0), T);
  13.135 -        in
  13.136 -          NAbs (tm_of bounds' x, tm_of bounds' (subst_bound (x, t)))
  13.137 -        end
  13.138 -      | tm_of bounds (t $ u) = NApp (tm_of bounds t, tm_of bounds u)
  13.139 -      | tm_of _ (Bound _) = raise Fail "unexpected Bound";
  13.140 -  in
  13.141 -    t
  13.142 -    |> tm_of Name.context
  13.143 -    |> beta_reduce_tm
  13.144 -    |> eta_expand_builtin_tm
  13.145 -  end;
  13.146 -
  13.147 -val tm_of_isa = gen_tm_of_isa false;
  13.148 -val prop_of_isa = gen_tm_of_isa true;
  13.149 -
  13.150 -fun nun_copy_spec_of_isa_typedef ctxt {abs_typ, rep_typ, wrt, abs, rep} =
  13.151 -  {abs_ty = ty_of_isa abs_typ, rep_ty = ty_of_isa rep_typ, subset = SOME (tm_of_isa ctxt wrt),
  13.152 -   quotient = NONE, abs = tm_of_isa ctxt abs, rep = tm_of_isa ctxt rep};
  13.153 -
  13.154 -fun nun_copy_spec_of_isa_quotient ctxt {abs_typ, rep_typ, wrt, abs, rep} =
  13.155 -  {abs_ty = ty_of_isa abs_typ, rep_ty = ty_of_isa rep_typ, subset = NONE,
  13.156 -   quotient = SOME (tm_of_isa ctxt wrt), abs = tm_of_isa ctxt abs, rep = tm_of_isa ctxt rep};
  13.157 -
  13.158 -fun nun_ctr_of_isa ctxt ctr =
  13.159 -  {ctr = tm_of_isa ctxt ctr, arg_tys = map ty_of_isa (binder_types (fastype_of ctr))};
  13.160 -
  13.161 -fun nun_co_data_spec_of_isa ctxt {typ, ctrs} =
  13.162 -  {ty = ty_of_isa typ, ctrs = map (nun_ctr_of_isa ctxt) ctrs};
  13.163 -
  13.164 -fun nun_const_spec_of_isa ctxt {const, props} =
  13.165 -  {const = tm_of_isa ctxt const, props = map (prop_of_isa ctxt) props};
  13.166 -
  13.167 -fun nun_rec_spec_of_isa ctxt {const, props, ...} =
  13.168 -  {const = tm_of_isa ctxt const, props = map (prop_of_isa ctxt) props};
  13.169 -
  13.170 -fun nun_consts_spec_of_isa ctxt {consts, props} =
  13.171 -  {consts = map (tm_of_isa ctxt) consts, props = map (prop_of_isa ctxt) props};
  13.172 -
  13.173 -fun nun_problem_of_isa ctxt {commandss, sound, complete} =
  13.174 -  let
  13.175 -    fun cmd_of cmd =
  13.176 -      (case cmd of
  13.177 -        ITVal (T, cards) => NTVal (ty_of_isa T, cards)
  13.178 -      | ITypedef spec => NCopy (nun_copy_spec_of_isa_typedef ctxt spec)
  13.179 -      | IQuotient spec => NCopy (nun_copy_spec_of_isa_quotient ctxt spec)
  13.180 -      | ICoData (fp, specs) =>
  13.181 -        BNF_Util.case_fp fp NData NCodata (map (nun_co_data_spec_of_isa ctxt) specs)
  13.182 -      | IVal t => NVal (tm_of_isa ctxt t, ty_of_isa (fastype_of t))
  13.183 -      | ICoPred (fp, wf, specs) =>
  13.184 -        (if wf then curry NPred true
  13.185 -         else if fp = BNF_Util.Least_FP then curry NPred false
  13.186 -         else NCopred) (map (nun_const_spec_of_isa ctxt) specs)
  13.187 -      | IRec specs => NRec (map (nun_rec_spec_of_isa ctxt) specs)
  13.188 -      | ISpec spec => NSpec (nun_consts_spec_of_isa ctxt spec)
  13.189 -      | IAxiom prop => NAxiom (prop_of_isa ctxt prop)
  13.190 -      | IGoal prop => NGoal (prop_of_isa ctxt prop)
  13.191 -      | IEval t => NEval (tm_of_isa ctxt t));
  13.192 -  in
  13.193 -    {commandss = map (map cmd_of) commandss, sound = sound, complete = complete}
  13.194 -  end;
  13.195 -
  13.196 -end;
    14.1 --- a/src/HOL/Nunchaku/Tools/nunchaku_util.ML	Thu Sep 07 23:13:15 2017 +0200
    14.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.3 @@ -1,95 +0,0 @@
    14.4 -(*  Title:      HOL/Nunchaku/Tools/nunchaku_util.ML
    14.5 -    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    14.6 -    Copyright   2015, 2016
    14.7 -
    14.8 -General-purpose functions used by Nunchaku.
    14.9 -*)
   14.10 -
   14.11 -signature NUNCHAKU_UTIL =
   14.12 -sig
   14.13 -  val elide_string: int -> string -> string
   14.14 -  val nat_subscript: int -> string
   14.15 -  val timestamp: unit -> string
   14.16 -  val parse_bool_option: bool -> string -> string -> bool option
   14.17 -  val parse_time: string -> string -> Time.time
   14.18 -  val string_of_time: Time.time -> string
   14.19 -  val simplify_spaces: string -> string
   14.20 -  val ascii_of: string -> string
   14.21 -  val unascii_of: string -> string
   14.22 -  val double_lookup: ('a * 'a -> bool) -> ('a option * 'b) list -> 'a -> 'b option
   14.23 -  val triple_lookup: (''a * ''a -> bool) -> (''a option * 'b) list -> ''a -> 'b option
   14.24 -  val plural_s_for_list: 'a list -> string
   14.25 -  val with_overlord_file: string -> string -> (Path.T -> 'a) -> 'a
   14.26 -  val with_tmp_or_overlord_file: bool -> string -> string -> (Path.T -> 'a) -> 'a
   14.27 -  val num_binder_types: typ -> int
   14.28 -  val strip_fun_type: typ -> typ list * typ
   14.29 -  val attach_typeS: term -> term
   14.30 -  val specialize_type: theory -> string * typ -> term -> term
   14.31 -  val typ_match: theory -> typ * typ -> bool
   14.32 -  val term_match: theory -> term * term -> bool
   14.33 -  val const_match: theory -> (string * typ) * (string * typ) -> bool
   14.34 -  val DETERM_TIMEOUT: Time.time -> tactic -> tactic
   14.35 -  val spying: bool -> (unit -> Proof.state * int * string) -> unit
   14.36 -end;
   14.37 -
   14.38 -structure Nunchaku_Util : NUNCHAKU_UTIL =
   14.39 -struct
   14.40 -
   14.41 -val elide_string = ATP_Util.elide_string;
   14.42 -val nat_subscript = Nitpick_Util.nat_subscript;
   14.43 -val timestamp = ATP_Util.timestamp;
   14.44 -
   14.45 -val parse_bool_option = Sledgehammer_Util.parse_bool_option;
   14.46 -val parse_time = Sledgehammer_Util.parse_time;
   14.47 -val string_of_time = ATP_Util.string_of_time;
   14.48 -val simplify_spaces = Sledgehammer_Util.simplify_spaces;
   14.49 -val ascii_of = ATP_Problem_Generate.ascii_of;
   14.50 -val unascii_of = ATP_Problem_Generate.unascii_of;
   14.51 -val double_lookup = Nitpick_Util.double_lookup;
   14.52 -val triple_lookup = Nitpick_Util.triple_lookup;
   14.53 -val plural_s_for_list = Nitpick_Util.plural_s_for_list;
   14.54 -
   14.55 -fun with_overlord_file name ext f =
   14.56 -  f (Path.explode ("$ISABELLE_HOME_USER/" ^ name ^ "." ^ ext));
   14.57 -
   14.58 -fun with_tmp_or_overlord_file overlord =
   14.59 -  if overlord then with_overlord_file else Isabelle_System.with_tmp_file;
   14.60 -
   14.61 -val num_binder_types = BNF_Util.num_binder_types
   14.62 -val strip_fun_type = BNF_Util.strip_fun_type;
   14.63 -
   14.64 -(* Clone from "HOL/Tools/inductive_realizer.ML". *)
   14.65 -val attach_typeS =
   14.66 -  map_types (map_atyps
   14.67 -    (fn TFree (s, []) => TFree (s, @{sort type})
   14.68 -      | TVar (ixn, []) => TVar (ixn, @{sort type})
   14.69 -      | T => T));
   14.70 -
   14.71 -val specialize_type = ATP_Util.specialize_type;
   14.72 -
   14.73 -fun typ_match thy TU = can (Sign.typ_match thy TU) Vartab.empty;
   14.74 -fun term_match thy tu = can (Pattern.match thy tu) (Vartab.empty, Vartab.empty);
   14.75 -fun const_match thy = term_match thy o apply2 Const;
   14.76 -
   14.77 -val DETERM_TIMEOUT = Nitpick_Util.DETERM_TIMEOUT;
   14.78 -
   14.79 -val spying_version = "a"
   14.80 -
   14.81 -val hackish_string_of_term = Sledgehammer_Util.hackish_string_of_term;
   14.82 -
   14.83 -fun spying spy f =
   14.84 -  if spy then
   14.85 -    let
   14.86 -      val (state, i, message) = f ();
   14.87 -      val ctxt = Proof.context_of state;
   14.88 -      val goal = Logic.get_goal (Thm.prop_of (#goal (Proof.goal state))) i;
   14.89 -      val hash =
   14.90 -        String.substring (SHA1.rep (SHA1.digest (hackish_string_of_term ctxt goal)), 0, 12);
   14.91 -    in
   14.92 -      File.append (Path.explode "$ISABELLE_HOME_USER/spy_nunchaku")
   14.93 -        (spying_version ^ " " ^ timestamp () ^ ": " ^ hash ^ ": " ^ message ^ "\n")
   14.94 -    end
   14.95 -  else
   14.96 -    ();
   14.97 -
   14.98 -end;
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/src/HOL/Tools/Nunchaku/nunchaku.ML	Fri Sep 08 00:01:36 2017 +0200
    15.3 @@ -0,0 +1,327 @@
    15.4 +(*  Title:      HOL/Nunchaku/Tools/nunchaku.ML
    15.5 +    Author:     Jasmin Blanchette, VU Amsterdam
    15.6 +    Copyright   2015, 2016, 2017
    15.7 +
    15.8 +The core of the Nunchaku integration in Isabelle.
    15.9 +*)
   15.10 +
   15.11 +signature NUNCHAKU =
   15.12 +sig
   15.13 +  type isa_model = Nunchaku_Reconstruct.isa_model
   15.14 +
   15.15 +  datatype mode = Auto_Try | Try | Normal
   15.16 +
   15.17 +  type mode_of_operation_params =
   15.18 +    {solvers: string list,
   15.19 +     falsify: bool,
   15.20 +     assms: bool,
   15.21 +     spy: bool,
   15.22 +     overlord: bool,
   15.23 +     expect: string}
   15.24 +
   15.25 +  type scope_of_search_params =
   15.26 +    {wfs: ((string * typ) option * bool option) list,
   15.27 +     whacks: (term option * bool) list,
   15.28 +     cards: (typ option * (int option * int option)) list,
   15.29 +     monos: (typ option * bool option) list}
   15.30 +
   15.31 +  type output_format_params =
   15.32 +    {verbose: bool,
   15.33 +     debug: bool,
   15.34 +     max_potential: int,
   15.35 +     max_genuine: int,
   15.36 +     evals: term list,
   15.37 +     atomss: (typ option * string list) list}
   15.38 +
   15.39 +  type optimization_params =
   15.40 +    {specialize: bool,
   15.41 +     multithread: bool}
   15.42 +
   15.43 +  type timeout_params =
   15.44 +    {timeout: Time.time,
   15.45 +     wf_timeout: Time.time}
   15.46 +
   15.47 +  type params =
   15.48 +    {mode_of_operation_params: mode_of_operation_params,
   15.49 +     scope_of_search_params: scope_of_search_params,
   15.50 +     output_format_params: output_format_params,
   15.51 +     optimization_params: optimization_params,
   15.52 +     timeout_params: timeout_params}
   15.53 +
   15.54 +  val genuineN: string
   15.55 +  val quasi_genuineN: string
   15.56 +  val potentialN: string
   15.57 +  val noneN: string
   15.58 +  val unknownN: string
   15.59 +  val no_nunchakuN: string
   15.60 +
   15.61 +  val run_chaku_on_prop: Proof.state -> params -> mode -> int -> term list -> term ->
   15.62 +    string * isa_model option
   15.63 +  val run_chaku_on_subgoal: Proof.state -> params -> mode -> int -> string * isa_model option
   15.64 +end;
   15.65 +
   15.66 +structure Nunchaku : NUNCHAKU =
   15.67 +struct
   15.68 +
   15.69 +open Nunchaku_Util;
   15.70 +open Nunchaku_Collect;
   15.71 +open Nunchaku_Problem;
   15.72 +open Nunchaku_Translate;
   15.73 +open Nunchaku_Model;
   15.74 +open Nunchaku_Reconstruct;
   15.75 +open Nunchaku_Display;
   15.76 +open Nunchaku_Tool;
   15.77 +
   15.78 +datatype mode = Auto_Try | Try | Normal;
   15.79 +
   15.80 +type mode_of_operation_params =
   15.81 +  {solvers: string list,
   15.82 +   falsify: bool,
   15.83 +   assms: bool,
   15.84 +   spy: bool,
   15.85 +   overlord: bool,
   15.86 +   expect: string};
   15.87 +
   15.88 +type scope_of_search_params =
   15.89 +  {wfs: ((string * typ) option * bool option) list,
   15.90 +   whacks: (term option * bool) list,
   15.91 +   cards: (typ option * (int option * int option)) list,
   15.92 +   monos: (typ option * bool option) list};
   15.93 +
   15.94 +type output_format_params =
   15.95 +  {verbose: bool,
   15.96 +   debug: bool,
   15.97 +   max_potential: int,
   15.98 +   max_genuine: int,
   15.99 +   evals: term list,
  15.100 +   atomss: (typ option * string list) list};
  15.101 +
  15.102 +type optimization_params =
  15.103 +  {specialize: bool,
  15.104 +   multithread: bool};
  15.105 +
  15.106 +type timeout_params =
  15.107 +  {timeout: Time.time,
  15.108 +   wf_timeout: Time.time};
  15.109 +
  15.110 +type params =
  15.111 +  {mode_of_operation_params: mode_of_operation_params,
  15.112 +   scope_of_search_params: scope_of_search_params,
  15.113 +   output_format_params: output_format_params,
  15.114 +   optimization_params: optimization_params,
  15.115 +   timeout_params: timeout_params};
  15.116 +
  15.117 +val genuineN = "genuine";
  15.118 +val quasi_genuineN = "quasi_genuine";
  15.119 +val potentialN = "potential";
  15.120 +val noneN = "none";
  15.121 +val unknownN = "unknown";
  15.122 +
  15.123 +val no_nunchakuN = "no_nunchaku";
  15.124 +
  15.125 +fun str_of_mode Auto_Try = "Auto_Try"
  15.126 +  | str_of_mode Try = "Try"
  15.127 +  | str_of_mode Normal = "Normal";
  15.128 +
  15.129 +fun none_true assigns = forall (curry (op <>) (SOME true) o snd) assigns;
  15.130 +
  15.131 +fun has_lonely_bool_var (@{const Pure.conjunction} $ (@{const Trueprop} $ Free _) $ _) = true
  15.132 +  | has_lonely_bool_var _ = false;
  15.133 +
  15.134 +val syntactic_sorts =
  15.135 +  @{sort "{default,zero,one,plus,minus,uminus,times,inverse,abs,sgn,ord,equal}"} @ @{sort numeral};
  15.136 +
  15.137 +fun has_tfree_syntactic_sort (TFree (_, S as _ :: _)) = subset (op =) (S, syntactic_sorts)
  15.138 +  | has_tfree_syntactic_sort _ = false;
  15.139 +
  15.140 +val has_syntactic_sorts = exists_type (exists_subtype has_tfree_syntactic_sort);
  15.141 +
  15.142 +(* Give the soft timeout a chance. *)
  15.143 +val timeout_slack = seconds 1.0;
  15.144 +
  15.145 +fun run_chaku_on_prop state
  15.146 +    ({mode_of_operation_params = {solvers, falsify, assms, spy, overlord, expect},
  15.147 +      scope_of_search_params = {wfs, whacks, cards, monos},
  15.148 +      output_format_params = {verbose, debug, evals, atomss, ...},
  15.149 +      optimization_params = {specialize, ...},
  15.150 +      timeout_params = {timeout, wf_timeout}})
  15.151 +    mode i all_assms subgoal =
  15.152 +  let
  15.153 +    val ctxt = Proof.context_of state;
  15.154 +
  15.155 +    val timer = Timer.startRealTimer ()
  15.156 +
  15.157 +    val print = writeln;
  15.158 +    val print_n = if mode = Normal then writeln else K ();
  15.159 +    fun print_v f = if verbose then writeln (f ()) else ();
  15.160 +    fun print_d f = if debug then writeln (f ()) else ();
  15.161 +
  15.162 +    val das_wort_Model = if falsify then "Countermodel" else "Model";
  15.163 +    val das_wort_model = if falsify then "countermodel" else "model";
  15.164 +
  15.165 +    val tool_params =
  15.166 +      {solvers = solvers, overlord = overlord, debug = debug, specialize = specialize,
  15.167 +       timeout = timeout};
  15.168 +
  15.169 +    fun run () =
  15.170 +      let
  15.171 +        val outcome as (outcome_code, _) =
  15.172 +          let
  15.173 +            val (poly_axioms, isa_problem as {sound, complete, ...}) =
  15.174 +              isa_problem_of_subgoal ctxt falsify wfs whacks cards debug wf_timeout evals
  15.175 +                (if assms then all_assms else []) subgoal;
  15.176 +            val _ = print_d (fn () => "*** Isabelle problem ***\n" ^
  15.177 +              str_of_isa_problem ctxt isa_problem);
  15.178 +            val ugly_nun_problem = nun_problem_of_isa ctxt isa_problem;
  15.179 +            val _ = print_d (fn () => "*** Ugly Nunchaku problem ***\n" ^
  15.180 +              str_of_nun_problem ugly_nun_problem);
  15.181 +            val (nice_nun_problem, pool) = nice_nun_problem ugly_nun_problem;
  15.182 +            val _ = print_d (fn () => "*** Nice Nunchaku problem ***\n" ^
  15.183 +              str_of_nun_problem nice_nun_problem);
  15.184 +
  15.185 +            fun print_any_hints () =
  15.186 +              if has_lonely_bool_var subgoal then
  15.187 +                print "Hint: Maybe you forgot a colon after the lemma's name?"
  15.188 +              else if has_syntactic_sorts subgoal then
  15.189 +                print "Hint: Maybe you forgot a type constraint?"
  15.190 +              else
  15.191 +                ();
  15.192 +
  15.193 +            fun get_isa_model_opt output =
  15.194 +              let
  15.195 +                val nice_nun_model = nun_model_of_str output;
  15.196 +                val _ = print_d (fn () => "*** Nice Nunchaku model ***\n" ^
  15.197 +                  str_of_nun_model nice_nun_model);
  15.198 +                val ugly_nun_model = ugly_nun_model pool nice_nun_model;
  15.199 +                val _ = print_d (fn () => "*** Ugly Nunchaku model ***\n" ^
  15.200 +                  str_of_nun_model ugly_nun_model);
  15.201 +
  15.202 +                val pat_completes = pat_completes_of_isa_problem isa_problem;
  15.203 +                val isa_model = isa_model_of_nun ctxt pat_completes atomss ugly_nun_model;
  15.204 +                val _ = print_d (fn () => "*** Isabelle model ***\n" ^
  15.205 +                  str_of_isa_model ctxt isa_model);
  15.206 +              in
  15.207 +                isa_model
  15.208 +              end;
  15.209 +
  15.210 +            fun isa_model_opt output =
  15.211 +              if debug then SOME (get_isa_model_opt output) else try get_isa_model_opt output;
  15.212 +
  15.213 +            val model_str = isa_model_opt #> pretty_of_isa_model_opt ctxt #> Pretty.string_of;
  15.214 +
  15.215 +            fun unsat_means_theorem () =
  15.216 +              null whacks andalso null cards andalso null monos;
  15.217 +
  15.218 +            fun unknown () =
  15.219 +              (print_n ("No " ^ das_wort_model ^ " can be found\n\
  15.220 +                 \The problem lies outside Nunchaku's fragment, or the Nunchaku backends are not \
  15.221 +                 \installed properly");
  15.222 +               (unknownN, NONE));
  15.223 +
  15.224 +            fun unsat_or_unknown complete =
  15.225 +              if complete then
  15.226 +                (print_n ("No " ^ das_wort_model ^ " exists" ^
  15.227 +                   (if falsify andalso unsat_means_theorem () then "\nThe goal is a theorem"
  15.228 +                    else ""));
  15.229 +                 (noneN, NONE))
  15.230 +              else
  15.231 +                unknown ();
  15.232 +
  15.233 +            fun sat_or_maybe_sat sound output =
  15.234 +              let val header = if sound then das_wort_Model else "Potential " ^ das_wort_model in
  15.235 +                (case (null poly_axioms, none_true wfs) of
  15.236 +                  (true, true) =>
  15.237 +                  (print (header ^ ":\n" ^
  15.238 +                     model_str output); print_any_hints ();
  15.239 +                   (genuineN, isa_model_opt output))
  15.240 +                | (no_poly, no_wf) =>
  15.241 +                  let
  15.242 +                    val ignorings = []
  15.243 +                      |> not no_poly ? cons "polymorphic axioms"
  15.244 +                      |> not no_wf ? cons "unchecked well-foundedness";
  15.245 +                  in
  15.246 +                    (print (header ^ " (ignoring " ^ space_implode " and " ignorings ^ "):\n" ^
  15.247 +                       model_str output ^
  15.248 +                       (if no_poly then
  15.249 +                          ""
  15.250 +                        else
  15.251 +                          "\nIgnored axioms:\n" ^
  15.252 +                          cat_lines (map (prefix "  " o Syntax.string_of_term ctxt) poly_axioms)));
  15.253 +                     print_any_hints ();
  15.254 +                     (quasi_genuineN, isa_model_opt output))
  15.255 +                  end)
  15.256 +              end;
  15.257 +          in
  15.258 +            (case solve_nun_problem tool_params nice_nun_problem of
  15.259 +              Unsat => unsat_or_unknown complete
  15.260 +            | Sat (output, _) => sat_or_maybe_sat sound output
  15.261 +            | Unknown NONE => unknown ()
  15.262 +            | Unknown (SOME (output, _)) => sat_or_maybe_sat false output
  15.263 +            | Timeout => (print_n "Time out"; (unknownN, NONE))
  15.264 +            | Nunchaku_Var_Not_Set =>
  15.265 +              (print_n ("Variable $" ^ nunchaku_home_env_var ^ " not set"); (unknownN, NONE))
  15.266 +            | Nunchaku_Cannot_Execute =>
  15.267 +              (print_n "External tool \"nunchaku\" cannot execute"; (unknownN, NONE))
  15.268 +            | Nunchaku_Not_Found =>
  15.269 +              (print_n "External tool \"nunchaku\" not found"; (unknownN, NONE))
  15.270 +            | CVC4_Cannot_Execute =>
  15.271 +              (print_n "External tool \"cvc4\" cannot execute"; (unknownN, NONE))
  15.272 +            | CVC4_Not_Found => (print_n "External tool \"cvc4\" not found"; (unknownN, NONE))
  15.273 +            | Unknown_Error (code, msg) =>
  15.274 +              (print_n ("Unknown error: " ^ msg ^
  15.275 +                 (if code = 0 then "" else " (code " ^ string_of_int code ^ ")"));
  15.276 +               (unknownN, NONE)))
  15.277 +          end
  15.278 +          handle
  15.279 +            CYCLIC_DEPS () =>
  15.280 +            (print_n "Cyclic dependencies (or bug in Nunchaku)"; (unknownN, NONE))
  15.281 +          | TOO_DEEP_DEPS () =>
  15.282 +            (print_n "Too deep dependencies (or bug in Nunchaku)"; (unknownN, NONE))
  15.283 +          | TOO_META t =>
  15.284 +            (print_n ("Formula too meta for Nunchaku:\n" ^ Syntax.string_of_term ctxt t);
  15.285 +             (unknownN, NONE))
  15.286 +          | UNEXPECTED_POLYMORPHISM t =>
  15.287 +            (print_n ("Unexpected polymorphism in term\n" ^ Syntax.string_of_term ctxt t);
  15.288 +             (unknownN, NONE))
  15.289 +          | UNEXPECTED_VAR t =>
  15.290 +            (print_n ("Unexpected schematic variables in term\n" ^ Syntax.string_of_term ctxt t);
  15.291 +             (unknownN, NONE))
  15.292 +          | UNSUPPORTED_FUNC t =>
  15.293 +            (print_n ("Unsupported low-level constant in problem: " ^ Syntax.string_of_term ctxt t);
  15.294 +             (unknownN, NONE));
  15.295 +      in
  15.296 +        if expect = "" orelse outcome_code = expect then outcome
  15.297 +        else error ("Unexpected outcome: " ^ quote outcome_code)
  15.298 +      end;
  15.299 +
  15.300 +    val _ = spying spy (fn () => (state, i, "starting " ^ str_of_mode mode ^ " mode"));
  15.301 +
  15.302 +    val outcome as (outcome_code, _) =
  15.303 +      Timeout.apply (Time.+ (timeout, timeout_slack)) run ()
  15.304 +      handle Timeout.TIMEOUT _ => (print_n "Time out"; (unknownN, NONE));
  15.305 +
  15.306 +    val _ = print_v (fn () => "Total time: " ^ string_of_time (Timer.checkRealTimer timer));
  15.307 +
  15.308 +    val _ = spying spy (fn () => (state, i, "outcome: " ^ outcome_code));
  15.309 +  in
  15.310 +    if expect = "" orelse outcome_code = expect then outcome
  15.311 +    else error ("Unexpected outcome: " ^ quote outcome_code)
  15.312 +  end;
  15.313 +
  15.314 +fun run_chaku_on_subgoal state params mode i =
  15.315 +  let
  15.316 +    val ctxt = Proof.context_of state;
  15.317 +    val goal = Thm.prop_of (#goal (Proof.raw_goal state));
  15.318 +  in
  15.319 +    if Logic.count_prems goal = 0 then
  15.320 +      (writeln "No subgoal!"; (noneN, NONE))
  15.321 +    else
  15.322 +      let
  15.323 +        val subgoal = fst (Logic.goal_params goal i);
  15.324 +        val all_assms = map Thm.term_of (Assumption.all_assms_of ctxt);
  15.325 +      in
  15.326 +        run_chaku_on_prop state params mode i all_assms subgoal
  15.327 +      end
  15.328 +  end;
  15.329 +
  15.330 +end;
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/HOL/Tools/Nunchaku/nunchaku_collect.ML	Fri Sep 08 00:01:36 2017 +0200
    16.3 @@ -0,0 +1,1119 @@
    16.4 +(*  Title:      HOL/Nunchaku/Tools/nunchaku_collect.ML
    16.5 +    Author:     Jasmin Blanchette, VU Amsterdam
    16.6 +    Copyright   2015, 2016, 2017
    16.7 +
    16.8 +Collecting of Isabelle/HOL definitions etc. for Nunchaku.
    16.9 +*)
   16.10 +
   16.11 +signature NUNCHAKU_COLLECT =
   16.12 +sig
   16.13 +  val dest_co_datatype_case: Proof.context -> string * typ -> (string * typ) list
   16.14 +
   16.15 +  type isa_type_spec =
   16.16 +    {abs_typ: typ,
   16.17 +     rep_typ: typ,
   16.18 +     wrt: term,
   16.19 +     abs: term,
   16.20 +     rep: term}
   16.21 +
   16.22 +  type isa_co_data_spec =
   16.23 +    {typ: typ,
   16.24 +     ctrs: term list}
   16.25 +
   16.26 +  type isa_const_spec =
   16.27 +    {const: term,
   16.28 +     props: term list}
   16.29 +
   16.30 +  type isa_rec_spec =
   16.31 +    {const: term,
   16.32 +     props: term list,
   16.33 +     pat_complete: bool}
   16.34 +
   16.35 +  type isa_consts_spec =
   16.36 +    {consts: term list,
   16.37 +     props: term list}
   16.38 +
   16.39 +  datatype isa_command =
   16.40 +    ITVal of typ * (int option * int option)
   16.41 +  | ITypedef of isa_type_spec
   16.42 +  | IQuotient of isa_type_spec
   16.43 +  | ICoData of BNF_Util.fp_kind * isa_co_data_spec list
   16.44 +  | IVal of term
   16.45 +  | ICoPred of BNF_Util.fp_kind * bool * isa_const_spec list
   16.46 +  | IRec of isa_rec_spec list
   16.47 +  | ISpec of isa_consts_spec
   16.48 +  | IAxiom of term
   16.49 +  | IGoal of term
   16.50 +  | IEval of term
   16.51 +
   16.52 +  type isa_problem =
   16.53 +    {commandss: isa_command list list,
   16.54 +     sound: bool,
   16.55 +     complete: bool}
   16.56 +
   16.57 +  exception CYCLIC_DEPS of unit
   16.58 +  exception TOO_DEEP_DEPS of unit
   16.59 +  exception TOO_META of term
   16.60 +  exception UNEXPECTED_POLYMORPHISM of term
   16.61 +  exception UNEXPECTED_VAR of term
   16.62 +  exception UNSUPPORTED_FUNC of term
   16.63 +
   16.64 +  val isa_problem_of_subgoal: Proof.context -> bool -> ((string * typ) option * bool option) list ->
   16.65 +    (term option * bool) list -> (typ option * (int option * int option)) list -> bool ->
   16.66 +    Time.time -> term list -> term list -> term -> term list * isa_problem
   16.67 +  val pat_completes_of_isa_problem: isa_problem -> term list
   16.68 +  val str_of_isa_problem: Proof.context -> isa_problem -> string
   16.69 +end;
   16.70 +
   16.71 +structure Nunchaku_Collect : NUNCHAKU_COLLECT =
   16.72 +struct
   16.73 +
   16.74 +open Nunchaku_Util;
   16.75 +
   16.76 +type isa_type_spec =
   16.77 +  {abs_typ: typ,
   16.78 +   rep_typ: typ,
   16.79 +   wrt: term,
   16.80 +   abs: term,
   16.81 +   rep: term};
   16.82 +
   16.83 +type isa_co_data_spec =
   16.84 +  {typ: typ,
   16.85 +   ctrs: term list};
   16.86 +
   16.87 +type isa_const_spec =
   16.88 +  {const: term,
   16.89 +   props: term list};
   16.90 +
   16.91 +type isa_rec_spec =
   16.92 +  {const: term,
   16.93 +   props: term list,
   16.94 +   pat_complete: bool};
   16.95 +
   16.96 +type isa_consts_spec =
   16.97 +  {consts: term list,
   16.98 +   props: term list};
   16.99 +
  16.100 +datatype isa_command =
  16.101 +  ITVal of typ * (int option * int option)
  16.102 +| ITypedef of isa_type_spec
  16.103 +| IQuotient of isa_type_spec
  16.104 +| ICoData of BNF_Util.fp_kind * isa_co_data_spec list
  16.105 +| IVal of term
  16.106 +| ICoPred of BNF_Util.fp_kind * bool * isa_const_spec list
  16.107 +| IRec of isa_rec_spec list
  16.108 +| ISpec of isa_consts_spec
  16.109 +| IAxiom of term
  16.110 +| IGoal of term
  16.111 +| IEval of term;
  16.112 +
  16.113 +type isa_problem =
  16.114 +  {commandss: isa_command list list,
  16.115 +   sound: bool,
  16.116 +   complete: bool};
  16.117 +
  16.118 +exception CYCLIC_DEPS of unit;
  16.119 +exception TOO_DEEP_DEPS of unit;
  16.120 +exception TOO_META of term;
  16.121 +exception UNEXPECTED_POLYMORPHISM of term;
  16.122 +exception UNEXPECTED_VAR of term;
  16.123 +exception UNSUPPORTED_FUNC of term;
  16.124 +
  16.125 +fun str_of_and_list str_of_elem =
  16.126 +  map str_of_elem #> space_implode ("\nand ");
  16.127 +
  16.128 +val key_of_typ =
  16.129 +  let
  16.130 +    fun key_of (Type (s, [])) = s
  16.131 +      | key_of (Type (s, Ts)) = s ^ "(" ^ commas (map key_of Ts) ^ ")"
  16.132 +      | key_of (TFree (s, _)) = s;
  16.133 +  in
  16.134 +    prefix "y" o key_of
  16.135 +  end;
  16.136 +
  16.137 +fun key_of_const ctxt =
  16.138 +  let
  16.139 +    val thy = Proof_Context.theory_of ctxt;
  16.140 +
  16.141 +    fun key_of (Const (x as (s, _))) =
  16.142 +        (case Sign.const_typargs thy x of
  16.143 +          [] => s
  16.144 +        | Ts => s ^ "(" ^ commas (map key_of_typ Ts) ^ ")")
  16.145 +      | key_of (Free (s, _)) = s;
  16.146 +  in
  16.147 +    prefix "t" o key_of
  16.148 +  end;
  16.149 +
  16.150 +val add_type_keys = fold_subtypes (insert (op =) o key_of_typ);
  16.151 +
  16.152 +fun add_aterm_keys ctxt t =
  16.153 +  if is_Const t orelse is_Free t then insert (op =) (key_of_const ctxt t) else I;
  16.154 +
  16.155 +fun add_keys ctxt t =
  16.156 +  fold_aterms (add_aterm_keys ctxt) t
  16.157 +  #> fold_types add_type_keys t;
  16.158 +
  16.159 +fun close_form except t =
  16.160 +  fold (fn ((s, i), T) => fn t' =>
  16.161 +      HOLogic.all_const T $ Abs (s, T, abstract_over (Var ((s, i), T), t')))
  16.162 +    (Term.add_vars t [] |> subtract (op =) except) t;
  16.163 +
  16.164 +(* "imp_conjL[symmetric]" is important for inductive predicates with multiple assumptions. *)
  16.165 +val basic_defs =
  16.166 +  @{thms Ball_def[abs_def] Bex_def[abs_def] case_bool_if Ex1_def[abs_def]
  16.167 +    imp_conjL[symmetric, abs_def] Let_def[abs_def] rmember_def[symmetric, abs_def]};
  16.168 +
  16.169 +fun unfold_basic_def ctxt =
  16.170 +  let val thy = Proof_Context.theory_of ctxt in
  16.171 +    Pattern.rewrite_term thy (map (Logic.dest_equals o Thm.prop_of) basic_defs) []
  16.172 +  end;
  16.173 +
  16.174 +val has_polymorphism = exists_type (exists_subtype is_TVar);
  16.175 +
  16.176 +fun whack_term thy whacks =
  16.177 +  let
  16.178 +    fun whk t =
  16.179 +      if triple_lookup (term_match thy o swap) whacks t = SOME true then
  16.180 +        Const (@{const_name unreachable}, fastype_of t)
  16.181 +      else
  16.182 +        (case t of
  16.183 +          u $ v => whk u $ whk v
  16.184 +        | Abs (s, T, u) => Abs (s, T, whk u)
  16.185 +        | _ => t);
  16.186 +  in
  16.187 +    whk
  16.188 +  end;
  16.189 +
  16.190 +fun preprocess_term_basic falsify ctxt whacks t =
  16.191 +  let val thy = Proof_Context.theory_of ctxt in
  16.192 +    if has_polymorphism t then
  16.193 +      raise UNEXPECTED_POLYMORPHISM t
  16.194 +    else
  16.195 +      t
  16.196 +      |> attach_typeS
  16.197 +      |> whack_term thy whacks
  16.198 +      |> Object_Logic.atomize_term ctxt
  16.199 +      |> tap (fn t' => fastype_of t' <> @{typ prop} orelse raise TOO_META t)
  16.200 +      |> falsify ? HOLogic.mk_not
  16.201 +      |> unfold_basic_def ctxt
  16.202 +  end;
  16.203 +
  16.204 +val check_closed = tap (fn t => null (Term.add_vars t []) orelse raise UNEXPECTED_VAR t);
  16.205 +
  16.206 +val preprocess_prop = close_form [] oooo preprocess_term_basic;
  16.207 +val preprocess_closed_term = check_closed ooo preprocess_term_basic false;
  16.208 +
  16.209 +val is_type_builtin = member (op =) [@{type_name bool}, @{type_name fun}];
  16.210 +
  16.211 +val is_const_builtin =
  16.212 +  member (op =) [@{const_name All}, @{const_name conj}, @{const_name disj}, @{const_name Eps},
  16.213 +    @{const_name HOL.eq}, @{const_name Ex}, @{const_name False}, @{const_name If},
  16.214 +    @{const_name implies}, @{const_name Not}, @{const_name The}, @{const_name The_unsafe},
  16.215 +    @{const_name True}];
  16.216 +
  16.217 +datatype type_classification = Builtin | TVal | Typedef | Quotient | Co_Datatype;
  16.218 +
  16.219 +fun classify_type_name ctxt T_name =
  16.220 +  if is_type_builtin T_name then
  16.221 +    Builtin
  16.222 +  else if T_name = @{type_name itself} then
  16.223 +    Co_Datatype
  16.224 +  else
  16.225 +    (case BNF_FP_Def_Sugar.fp_sugar_of ctxt T_name of
  16.226 +      SOME _ => Co_Datatype
  16.227 +    | NONE =>
  16.228 +      (case Ctr_Sugar.ctr_sugar_of ctxt T_name of
  16.229 +        SOME _ => Co_Datatype
  16.230 +      | NONE =>
  16.231 +        (case Quotient_Info.lookup_quotients ctxt T_name of
  16.232 +          SOME _ => Quotient
  16.233 +        | NONE =>
  16.234 +          if T_name = @{type_name set} then
  16.235 +            Typedef
  16.236 +          else
  16.237 +            (case Typedef.get_info ctxt T_name of
  16.238 +              _ :: _ => Typedef
  16.239 +            | [] => TVal))));
  16.240 +
  16.241 +fun fp_kind_of_ctr_sugar_kind Ctr_Sugar.Codatatype = BNF_Util.Greatest_FP
  16.242 +  | fp_kind_of_ctr_sugar_kind _ = BNF_Util.Least_FP;
  16.243 +
  16.244 +fun mutual_co_datatypes_of ctxt (T_name, Ts) =
  16.245 +  (if T_name = @{type_name itself} then
  16.246 +     (BNF_Util.Least_FP, [@{typ "'a itself"}], [[@{const Pure.type ('a)}]])
  16.247 +   else
  16.248 +     let
  16.249 +       val (fp, ctr_sugars) =
  16.250 +         (case BNF_FP_Def_Sugar.fp_sugar_of ctxt T_name of
  16.251 +           SOME (fp_sugar as {fp, fp_res = {Ts, ...}, ...}) =>
  16.252 +           (fp,
  16.253 +            (case Ts of
  16.254 +              [_] => [fp_sugar]
  16.255 +            | _ => map (the o BNF_FP_Def_Sugar.fp_sugar_of ctxt o fst o dest_Type) Ts)
  16.256 +            |> map (#ctr_sugar o #fp_ctr_sugar))
  16.257 +         | NONE =>
  16.258 +           (case Ctr_Sugar.ctr_sugar_of ctxt T_name of
  16.259 +             SOME (ctr_sugar as {kind, ...}) =>
  16.260 +             (* Any freely constructed type that is not a codatatype is considered a datatype. This
  16.261 +                is sound (but incomplete) for model finding. *)
  16.262 +             (fp_kind_of_ctr_sugar_kind kind, [ctr_sugar])));
  16.263 +     in
  16.264 +       (fp, map #T ctr_sugars, map #ctrs ctr_sugars)
  16.265 +     end)
  16.266 +  |> @{apply 3(2)} (map ((fn Type (s, _) => Type (s, Ts))))
  16.267 +  |> @{apply 3(3)} (map (map (Ctr_Sugar.mk_ctr Ts)));
  16.268 +
  16.269 +fun typedef_of ctxt whacks T_name =
  16.270 +  if T_name = @{type_name set} then
  16.271 +    let
  16.272 +      val A = Logic.varifyT_global @{typ 'a};
  16.273 +      val absT = Type (@{type_name set}, [A]);
  16.274 +      val repT = A --> HOLogic.boolT;
  16.275 +      val pred = K (Abs (Name.uu, repT, @{const True}));
  16.276 +      val abs = Const (@{const_name Collect}, repT --> absT);
  16.277 +      val rep = Const (@{const_name rmember}, absT --> repT);
  16.278 +    in
  16.279 +      (absT, repT, pred, abs, rep)
  16.280 +    end
  16.281 +  else
  16.282 +    (case Typedef.get_info ctxt T_name of
  16.283 +      (* When several entries are returned, it shouldn't matter much which one we take (according to
  16.284 +         Florian Haftmann). The "Logic.varifyT_global" calls are a workaround because these types'
  16.285 +         variables sometimes clash with locally fixed type variables. *)
  16.286 +      ({abs_type, rep_type, Abs_name, Rep_name, ...}, {Rep, ...}) :: _ =>
  16.287 +      let
  16.288 +        val absT = Logic.varifyT_global abs_type;
  16.289 +        val repT = Logic.varifyT_global rep_type;
  16.290 +        val set0 = Thm.prop_of Rep
  16.291 +          |> HOLogic.dest_Trueprop
  16.292 +          |> HOLogic.dest_mem
  16.293 +          |> snd;
  16.294 +        val pred0 = Abs (Name.uu, repT, HOLogic.mk_mem (Bound 0, set0));
  16.295 +        fun pred () = preprocess_prop false ctxt whacks pred0;
  16.296 +        val abs = Const (Abs_name, repT --> absT);
  16.297 +        val rep = Const (Rep_name, absT --> repT);
  16.298 +      in
  16.299 +        (absT, repT, pred, abs, rep)
  16.300 +      end);
  16.301 +
  16.302 +fun quotient_of ctxt whacks T_name =
  16.303 +  (case Quotient_Info.lookup_quotients ctxt T_name of
  16.304 +    SOME {equiv_rel = equiv_rel0, qtyp, rtyp, quot_thm, ...} =>
  16.305 +    let
  16.306 +      val _ $ (_ $ _ $ abs $ rep) = Thm.prop_of quot_thm;
  16.307 +      fun equiv_rel () = preprocess_prop false ctxt whacks equiv_rel0;
  16.308 +    in
  16.309 +      (qtyp, rtyp, equiv_rel, abs, rep)
  16.310 +    end);
  16.311 +
  16.312 +fun is_co_datatype_ctr ctxt (s, T) =
  16.313 +  (case body_type T of
  16.314 +    Type (fpT_name, Ts) =>
  16.315 +    classify_type_name ctxt fpT_name = Co_Datatype andalso
  16.316 +    let
  16.317 +      val ctrs =
  16.318 +        if fpT_name = @{type_name itself} then
  16.319 +          [Const (@{const_name Pure.type}, @{typ "'a itself"})]
  16.320 +        else
  16.321 +          (case BNF_FP_Def_Sugar.fp_sugar_of ctxt fpT_name of
  16.322 +            SOME {fp_ctr_sugar = {ctr_sugar = {ctrs, ...}, ...}, ...} => ctrs
  16.323 +          | NONE =>
  16.324 +            (case Ctr_Sugar.ctr_sugar_of ctxt fpT_name of
  16.325 +              SOME {ctrs, ...} => ctrs
  16.326 +            | _ => []));
  16.327 +
  16.328 +      fun is_right_ctr (t' as Const (s', _)) =
  16.329 +        s = s' andalso fastype_of (Ctr_Sugar.mk_ctr Ts t') = T;
  16.330 +    in
  16.331 +      exists is_right_ctr ctrs
  16.332 +    end
  16.333 +  | _  => false);
  16.334 +
  16.335 +fun dest_co_datatype_case ctxt (s, T) =
  16.336 +  let val thy = Proof_Context.theory_of ctxt in
  16.337 +    (case strip_fun_type (Sign.the_const_type thy s) of
  16.338 +      (gen_branch_Ts, gen_body_fun_T) =>
  16.339 +      (case gen_body_fun_T of
  16.340 +        Type (@{type_name fun}, [Type (fpT_name, _), _]) =>
  16.341 +        if classify_type_name ctxt fpT_name = Co_Datatype then
  16.342 +          let
  16.343 +            val Type (_, fpTs) = domain_type (funpow (length gen_branch_Ts) range_type T);
  16.344 +            val (ctrs0, Const (case_name, _)) =
  16.345 +              (case BNF_FP_Def_Sugar.fp_sugar_of ctxt fpT_name of
  16.346 +                SOME {fp_ctr_sugar = {ctr_sugar = {ctrs, casex, ...}, ...}, ...} => (ctrs, casex)
  16.347 +              | NONE =>
  16.348 +                (case Ctr_Sugar.ctr_sugar_of ctxt fpT_name of
  16.349 +                  SOME {ctrs, casex, ...} => (ctrs, casex)));
  16.350 +          in
  16.351 +            if s = case_name then map (dest_Const o Ctr_Sugar.mk_ctr fpTs) ctrs0
  16.352 +            else raise Fail "non-case"
  16.353 +          end
  16.354 +        else
  16.355 +          raise Fail "non-case"))
  16.356 +  end;
  16.357 +
  16.358 +val is_co_datatype_case = can o dest_co_datatype_case;
  16.359 +
  16.360 +fun is_quotient_abs ctxt whacks (s, T) =
  16.361 +  (case T of
  16.362 +    Type (@{type_name fun}, [_, Type (absT_name, _)]) =>
  16.363 +    classify_type_name ctxt absT_name = Quotient andalso
  16.364 +    (case quotient_of ctxt whacks absT_name of
  16.365 +      (_, _, _, Const (s', _), _) => s' = s)
  16.366 +  | _ => false);
  16.367 +
  16.368 +fun is_quotient_rep ctxt whacks (s, T) =
  16.369 +  (case T of
  16.370 +    Type (@{type_name fun}, [Type (absT_name, _), _]) =>
  16.371 +    classify_type_name ctxt absT_name = Quotient andalso
  16.372 +    (case quotient_of ctxt whacks absT_name of
  16.373 +      (_, _, _, _, Const (s', _)) => s' = s)
  16.374 +  | _ => false);
  16.375 +
  16.376 +fun is_maybe_typedef_abs ctxt whacks absT_name s =
  16.377 +  if absT_name = @{type_name set} then
  16.378 +    s = @{const_name Collect}
  16.379 +  else
  16.380 +    (case try (typedef_of ctxt whacks) absT_name of
  16.381 +      SOME (_, _, _, Const (s', _), _) => s' = s
  16.382 +    | NONE => false);
  16.383 +
  16.384 +fun is_maybe_typedef_rep ctxt whacks absT_name s =
  16.385 +  if absT_name = @{type_name set} then
  16.386 +    s = @{const_name rmember}
  16.387 +  else
  16.388 +    (case try (typedef_of ctxt whacks) absT_name of
  16.389 +      SOME (_, _, _, _, Const (s', _)) => s' = s
  16.390 +    | NONE => false);
  16.391 +
  16.392 +fun is_typedef_abs ctxt whacks (s, T) =
  16.393 +  (case T of
  16.394 +    Type (@{type_name fun}, [_, Type (absT_name, _)]) =>
  16.395 +    classify_type_name ctxt absT_name = Typedef andalso
  16.396 +    is_maybe_typedef_abs ctxt whacks absT_name s
  16.397 +  | _ => false);
  16.398 +
  16.399 +fun is_typedef_rep ctxt whacks (s, T) =
  16.400 +  (case T of
  16.401 +    Type (@{type_name fun}, [Type (absT_name, _), _]) =>
  16.402 +    classify_type_name ctxt absT_name = Typedef andalso
  16.403 +    is_maybe_typedef_rep ctxt whacks absT_name s
  16.404 +  | _ => false);
  16.405 +
  16.406 +fun is_stale_typedef_abs ctxt whacks (s, T) =
  16.407 +  (case T of
  16.408 +    Type (@{type_name fun}, [_, Type (absT_name, _)]) =>
  16.409 +    classify_type_name ctxt absT_name <> Typedef andalso
  16.410 +    is_maybe_typedef_abs ctxt whacks absT_name s
  16.411 +  | _ => false);
  16.412 +
  16.413 +fun is_stale_typedef_rep ctxt whacks (s, T) =
  16.414 +  (case T of
  16.415 +    Type (@{type_name fun}, [Type (absT_name, _), _]) =>
  16.416 +    classify_type_name ctxt absT_name <> Typedef andalso
  16.417 +    is_maybe_typedef_rep ctxt whacks absT_name s
  16.418 +  | _ => false);
  16.419 +
  16.420 +fun instantiate_constant_types_in_term ctxt csts target =
  16.421 +  let
  16.422 +    val thy = Proof_Context.theory_of ctxt;
  16.423 +
  16.424 +    fun try_const _ _ (res as SOME _) = res
  16.425 +      | try_const (s', T') cst NONE =
  16.426 +        (case cst of
  16.427 +          Const (s, T) =>
  16.428 +          if s = s' then
  16.429 +            SOME (Sign.typ_match thy (T', T) Vartab.empty)
  16.430 +            handle Type.TYPE_MATCH => NONE
  16.431 +          else
  16.432 +            NONE
  16.433 +        | _ => NONE);
  16.434 +
  16.435 +    fun subst_for (Const x) = fold (try_const x) csts NONE
  16.436 +      | subst_for (t as Free _) = if member (op aconv) csts t then SOME Vartab.empty else NONE
  16.437 +      | subst_for (t1 $ t2) = (case subst_for t1 of SOME subst => SOME subst | NONE => subst_for t2)
  16.438 +      | subst_for (Abs (_, _, t')) = subst_for t'
  16.439 +      | subst_for _ = NONE;
  16.440 +  in
  16.441 +    (case subst_for target of
  16.442 +      SOME subst => Envir.subst_term_types subst target
  16.443 +    | NONE => raise Type.TYPE_MATCH)
  16.444 +  end;
  16.445 +
  16.446 +datatype card = One | Fin | Fin_or_Inf | Inf
  16.447 +
  16.448 +(* Similar to "ATP_Util.tiny_card_of_type". *)
  16.449 +fun card_of_type ctxt =
  16.450 +  let
  16.451 +    fun max_card Inf _ = Inf
  16.452 +      | max_card _ Inf = Inf
  16.453 +      | max_card Fin_or_Inf _ = Fin_or_Inf
  16.454 +      | max_card _ Fin_or_Inf = Fin_or_Inf
  16.455 +      | max_card Fin _ = Fin
  16.456 +      | max_card _ Fin = Fin
  16.457 +      | max_card One One = One;
  16.458 +
  16.459 +    fun card_of avoid T =
  16.460 +      if member (op =) avoid T then
  16.461 +        Inf
  16.462 +      else
  16.463 +        (case T of
  16.464 +          TFree _ => Fin_or_Inf
  16.465 +        | TVar _ => Inf
  16.466 +        | Type (@{type_name fun}, [T1, T2]) =>
  16.467 +          (case (card_of avoid T1, card_of avoid T2) of
  16.468 +            (_, One) => One
  16.469 +          | (k1, k2) => max_card k1 k2)
  16.470 +        | Type (@{type_name prod}, [T1, T2]) =>
  16.471 +          (case (card_of avoid T1, card_of avoid T2) of
  16.472 +            (k1, k2) => max_card k1 k2)
  16.473 +        | Type (@{type_name set}, [T']) => card_of avoid (T' --> HOLogic.boolT)
  16.474 +        | Type (T_name, Ts) =>
  16.475 +          (case try (mutual_co_datatypes_of ctxt) (T_name, Ts) of
  16.476 +            NONE => Inf
  16.477 +          | SOME (_, fpTs, ctrss) =>
  16.478 +            (case ctrss of [[_]] => One | _ => Fin)
  16.479 +            |> fold (fold (fold (max_card o card_of (fpTs @ avoid)) o binder_types o fastype_of))
  16.480 +              ctrss));
  16.481 +  in
  16.482 +    card_of []
  16.483 +  end;
  16.484 +
  16.485 +fun int_of_classif Spec_Rules.Equational = 1
  16.486 +  | int_of_classif Spec_Rules.Inductive = 2
  16.487 +  | int_of_classif Spec_Rules.Co_Inductive = 3
  16.488 +  | int_of_classif Spec_Rules.Unknown = 4;
  16.489 +
  16.490 +val classif_ord = int_ord o apply2 int_of_classif;
  16.491 +
  16.492 +fun spec_rules_of ctxt (x as (s, T)) =
  16.493 +  let
  16.494 +    val thy = Proof_Context.theory_of ctxt;
  16.495 +
  16.496 +    fun subst_of t0 =
  16.497 +      try (Sign.typ_match thy (fastype_of t0, T)) Vartab.empty;
  16.498 +
  16.499 +    fun process_spec _ (res as SOME _) = res
  16.500 +      | process_spec (classif, (ts0, ths as _ :: _)) NONE =
  16.501 +        (case get_first subst_of ts0 of
  16.502 +          SOME subst =>
  16.503 +          (let
  16.504 +             val ts = map (Envir.subst_term_types subst) ts0;
  16.505 +             val poly_props = map Thm.prop_of ths;
  16.506 +             val props = map (instantiate_constant_types_in_term ctxt ts) poly_props;
  16.507 +           in
  16.508 +             if exists (exists (exists_type (exists_subtype is_TVar))) [ts, props] then NONE
  16.509 +             else SOME (classif, ts, props, poly_props)
  16.510 +           end
  16.511 +           handle Type.TYPE_MATCH => NONE)
  16.512 +        | NONE => NONE)
  16.513 +      | process_spec _ NONE = NONE;
  16.514 +
  16.515 +    fun spec_rules () =
  16.516 +      Spec_Rules.retrieve ctxt (Const x)
  16.517 +      |> sort (classif_ord o apply2 fst);
  16.518 +
  16.519 +    val specs =
  16.520 +      if s = @{const_name The} then
  16.521 +        [(Spec_Rules.Unknown, ([Logic.varify_global @{term The}], [@{thm theI_unique}]))]
  16.522 +      else if s = @{const_name finite} then
  16.523 +        let val card = card_of_type ctxt T in
  16.524 +          if card = Inf orelse card = Fin_or_Inf then
  16.525 +            spec_rules ()
  16.526 +          else
  16.527 +            [(Spec_Rules.Equational, ([Logic.varify_global @{term finite}],
  16.528 +               [Skip_Proof.make_thm thy (Logic.varify_global @{prop "finite A = True"})]))]
  16.529 +        end
  16.530 +      else
  16.531 +        spec_rules ();
  16.532 +  in
  16.533 +    fold process_spec specs NONE
  16.534 +  end;
  16.535 +
  16.536 +fun lhs_of_equation (Const (@{const_name Pure.eq}, _) $ t $ _) = t
  16.537 +  | lhs_of_equation (@{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ t $ _)) = t;
  16.538 +
  16.539 +fun specialize_definition_type thy x def0 =
  16.540 +  let
  16.541 +    val def = specialize_type thy x def0;
  16.542 +    val lhs = lhs_of_equation def;
  16.543 +  in
  16.544 +    if exists_Const (curry (op =) x) lhs then def else raise Fail "cannot specialize"
  16.545 +  end;
  16.546 +
  16.547 +fun definition_of thy (x as (s, _)) =
  16.548 +  Defs.specifications_of (Theory.defs_of thy) (Defs.Const, s)
  16.549 +  |> map_filter #def
  16.550 +  |> map_filter (try (specialize_definition_type thy x o Thm.prop_of o Thm.axiom thy))
  16.551 +  |> try hd;
  16.552 +
  16.553 +fun is_builtin_theory thy_id =
  16.554 +  Context.subthy_id (thy_id, Context.theory_id @{theory Hilbert_Choice});
  16.555 +
  16.556 +val orphan_axioms_of =
  16.557 +  Spec_Rules.get
  16.558 +  #> filter (curry (op =) Spec_Rules.Unknown o fst)
  16.559 +  #> map snd
  16.560 +  #> filter (null o fst)
  16.561 +  #> maps snd
  16.562 +  #> filter_out (is_builtin_theory o Thm.theory_id)
  16.563 +  #> map Thm.prop_of;
  16.564 +
  16.565 +fun keys_of _ (ITVal (T, _)) = [key_of_typ T]
  16.566 +  | keys_of _ (ITypedef {abs_typ, ...}) = [key_of_typ abs_typ]
  16.567 +  | keys_of _ (IQuotient {abs_typ, ...}) = [key_of_typ abs_typ]
  16.568 +  | keys_of _ (ICoData (_, specs)) = map (key_of_typ o #typ) specs
  16.569 +  | keys_of ctxt (IVal const) = [key_of_const ctxt const]
  16.570 +  | keys_of ctxt (ICoPred (_, _, specs)) = map (key_of_const ctxt o #const) specs
  16.571 +  | keys_of ctxt (IRec specs) = map (key_of_const ctxt o #const) specs
  16.572 +  | keys_of ctxt (ISpec {consts, ...}) = map (key_of_const ctxt) consts
  16.573 +  | keys_of _ (IAxiom _) = []
  16.574 +  | keys_of _ (IGoal _) = []
  16.575 +  | keys_of _ (IEval _) = [];
  16.576 +
  16.577 +fun co_data_spec_deps_of ctxt ({ctrs, ...} : isa_co_data_spec) =
  16.578 +  fold (add_keys ctxt) ctrs [];
  16.579 +fun const_spec_deps_of ctxt consts props =
  16.580 +  fold (add_keys ctxt) props [] |> subtract (op =) (map (key_of_const ctxt) consts);
  16.581 +fun consts_spec_deps_of ctxt {consts, props} =
  16.582 +  fold (add_keys ctxt) props [] |> subtract (op =) (map (key_of_const ctxt) consts);
  16.583 +
  16.584 +fun deps_of _ (ITVal _) = []
  16.585 +  | deps_of ctxt (ITypedef {wrt, ...}) = add_keys ctxt wrt []
  16.586 +  | deps_of ctxt (IQuotient {wrt, ...}) = add_keys ctxt wrt []
  16.587 +  | deps_of ctxt (ICoData (_, specs)) = maps (co_data_spec_deps_of ctxt) specs
  16.588 +  | deps_of _ (IVal const) = add_type_keys (fastype_of const) []
  16.589 +  | deps_of ctxt (ICoPred (_, _, specs)) =
  16.590 +    maps (const_spec_deps_of ctxt (map #const specs) o #props) specs
  16.591 +  | deps_of ctxt (IRec specs) = maps (const_spec_deps_of ctxt (map #const specs) o #props) specs
  16.592 +  | deps_of ctxt (ISpec spec) = consts_spec_deps_of ctxt spec
  16.593 +  | deps_of ctxt (IAxiom prop) = add_keys ctxt prop []
  16.594 +  | deps_of ctxt (IGoal prop) = add_keys ctxt prop []
  16.595 +  | deps_of ctxt (IEval t) = add_keys ctxt t [];
  16.596 +
  16.597 +fun consts_of_rec_or_spec (IRec specs) = map #const specs
  16.598 +  | consts_of_rec_or_spec (ISpec {consts, ...}) = consts;
  16.599 +
  16.600 +fun props_of_rec_or_spec (IRec specs) = maps #props specs
  16.601 +  | props_of_rec_or_spec (ISpec {props, ...}) = props;
  16.602 +
  16.603 +fun merge_two_rec_or_spec cmd cmd' =
  16.604 +  ISpec {consts = consts_of_rec_or_spec cmd @ consts_of_rec_or_spec cmd',
  16.605 +    props = props_of_rec_or_spec cmd @ props_of_rec_or_spec cmd'};
  16.606 +
  16.607 +fun merge_two (ICoData (fp, specs)) (ICoData (fp', specs'), complete) =
  16.608 +    (ICoData (BNF_Util.case_fp fp fp fp', specs @ specs'), complete andalso fp = fp')
  16.609 +  | merge_two (IRec specs) (IRec specs', complete) = (IRec (specs @ specs'), complete)
  16.610 +  | merge_two (cmd as IRec _) (cmd' as ISpec _, complete) =
  16.611 +    (merge_two_rec_or_spec cmd cmd', complete)
  16.612 +  | merge_two (cmd as ISpec _) (cmd' as IRec _, complete) =
  16.613 +    (merge_two_rec_or_spec cmd cmd', complete)
  16.614 +  | merge_two (cmd as ISpec _) (cmd' as ISpec _, complete) =
  16.615 +    (merge_two_rec_or_spec cmd cmd', complete)
  16.616 +  | merge_two _ _ = raise CYCLIC_DEPS ();
  16.617 +
  16.618 +fun sort_isa_commands_topologically ctxt cmds =
  16.619 +  let
  16.620 +    fun normal_pairs [] = []
  16.621 +      | normal_pairs (all as normal :: _) = map (rpair normal) all;
  16.622 +
  16.623 +    fun add_node [] _ = I
  16.624 +      | add_node (normal :: _) cmd = Graph.new_node (normal, cmd);
  16.625 +
  16.626 +    fun merge_scc (cmd :: cmds) complete = fold merge_two cmds (cmd, complete);
  16.627 +
  16.628 +    fun sort_problem (cmds, complete) =
  16.629 +      let
  16.630 +        val keyss = map (keys_of ctxt) cmds;
  16.631 +        val normal_keys = Symtab.make (maps normal_pairs keyss);
  16.632 +        val normalize = Symtab.lookup normal_keys;
  16.633 +
  16.634 +        fun add_deps [] _ = I
  16.635 +          | add_deps (normal :: _) cmd =
  16.636 +            let
  16.637 +              val deps = deps_of ctxt cmd
  16.638 +                |> map_filter normalize
  16.639 +                |> remove (op =) normal;
  16.640 +            in
  16.641 +              fold (fn dep => Graph.add_edge (dep, normal)) deps
  16.642 +            end;
  16.643 +
  16.644 +        val cmd_of_key = the o AList.lookup (op =) (map hd keyss ~~ cmds);
  16.645 +
  16.646 +        val G = Graph.empty
  16.647 +          |> fold2 add_node keyss cmds
  16.648 +          |> fold2 add_deps keyss cmds;
  16.649 +
  16.650 +        val cmd_sccs = rev (Graph.strong_conn G)
  16.651 +          |> map (map cmd_of_key);
  16.652 +      in
  16.653 +        if exists (can (fn _ :: _ :: _ => ())) cmd_sccs then
  16.654 +          sort_problem (fold_map merge_scc cmd_sccs complete)
  16.655 +        else
  16.656 +          (Graph.schedule (K snd) G, complete)
  16.657 +      end;
  16.658 +
  16.659 +    val typedecls = filter (can (fn ITVal _ => ())) cmds;
  16.660 +    val (mixed, complete) =
  16.661 +      (filter (can (fn ITypedef _ => () | IQuotient _ => () | ICoData _ => () | IVal _ => ()
  16.662 +         | ICoPred _ => () | IRec _ => () | ISpec _ => ())) cmds, true)
  16.663 +      |> sort_problem;
  16.664 +    val axioms = filter (can (fn IAxiom _ => ())) cmds;
  16.665 +    val goals = filter (can (fn IGoal _ => ())) cmds;
  16.666 +    val evals = filter (can (fn IEval _ => ())) cmds;
  16.667 +  in
  16.668 +    (typedecls @ mixed @ axioms @ goals @ evals, complete)
  16.669 +  end;
  16.670 +
  16.671 +fun group_of (ITVal _) = 1
  16.672 +  | group_of (ITypedef _) = 2
  16.673 +  | group_of (IQuotient _) = 3
  16.674 +  | group_of (ICoData _) = 4
  16.675 +  | group_of (IVal _) = 5
  16.676 +  | group_of (ICoPred _) = 6
  16.677 +  | group_of (IRec _) = 7
  16.678 +  | group_of (ISpec _) = 8
  16.679 +  | group_of (IAxiom _) = 9
  16.680 +  | group_of (IGoal _) = 10
  16.681 +  | group_of (IEval _) = 11;
  16.682 +
  16.683 +fun group_isa_commands [] = []
  16.684 +  | group_isa_commands [cmd] = [[cmd]]
  16.685 +  | group_isa_commands (cmd :: cmd' :: cmds) =
  16.686 +    let val (group :: groups) = group_isa_commands (cmd' :: cmds) in
  16.687 +      if group_of cmd = group_of cmd' then
  16.688 +        (cmd :: group) :: groups
  16.689 +      else
  16.690 +        [cmd] :: (group :: groups)
  16.691 +    end;
  16.692 +
  16.693 +fun defined_by (Const (@{const_name All}, _) $ t) = defined_by t
  16.694 +  | defined_by (Abs (_, _, t)) = defined_by t
  16.695 +  | defined_by (@{const implies} $ _ $ u) = defined_by u
  16.696 +  | defined_by (Const (@{const_name HOL.eq}, _) $ t $ _) = head_of t
  16.697 +  | defined_by t = head_of t;
  16.698 +
  16.699 +fun partition_props [_] props = SOME [props]
  16.700 +  | partition_props consts props =
  16.701 +    let
  16.702 +      val propss = map (fn const => filter (fn prop => defined_by prop aconv const) props) consts;
  16.703 +    in
  16.704 +      if eq_set (op aconv) (props, flat propss) andalso forall (not o null) propss then SOME propss
  16.705 +      else NONE
  16.706 +    end;
  16.707 +
  16.708 +fun hol_concl_head (Const (@{const_name All}, _) $ Abs (_, _, t)) = hol_concl_head t
  16.709 +  | hol_concl_head (Const (@{const_name implies}, _) $ _ $ t) = hol_concl_head t
  16.710 +  | hol_concl_head (t $ _) = hol_concl_head t
  16.711 +  | hol_concl_head t = t;
  16.712 +
  16.713 +fun is_inductive_set_intro t =
  16.714 +  (case hol_concl_head t of
  16.715 +    Const (@{const_name rmember}, _) => true
  16.716 +  | _ => false);
  16.717 +
  16.718 +exception NO_TRIPLE of unit;
  16.719 +
  16.720 +fun triple_for_intro_rule ctxt x rule =
  16.721 +  let
  16.722 +    val (prems, concl) = Logic.strip_horn rule
  16.723 +      |>> map (Object_Logic.atomize_term ctxt)
  16.724 +      ||> Object_Logic.atomize_term ctxt;
  16.725 +
  16.726 +    val (mains, sides) = List.partition (exists_Const (curry (op =) x)) prems;
  16.727 +
  16.728 +    val is_right_head = curry (op aconv) (Const x) o head_of;
  16.729 +  in
  16.730 +    if forall is_right_head mains then (sides, mains, concl) else raise NO_TRIPLE ()
  16.731 +  end;
  16.732 +
  16.733 +val tuple_for_args = HOLogic.mk_tuple o snd o strip_comb;
  16.734 +
  16.735 +fun wf_constraint_for rel sides concl mains =
  16.736 +  HOLogic.mk_mem (HOLogic.mk_prod (apply2 tuple_for_args (mains, concl)), Var rel)
  16.737 +  |> fold (curry HOLogic.mk_imp) sides
  16.738 +  |> close_form [rel];
  16.739 +
  16.740 +fun wf_constraint_for_triple rel (sides, mains, concl) =
  16.741 +  map (wf_constraint_for rel sides concl) mains
  16.742 +  |> foldr1 HOLogic.mk_conj;
  16.743 +
  16.744 +fun terminates_by ctxt timeout goal tac =
  16.745 +  can (SINGLE (Classical.safe_tac ctxt) #> the
  16.746 +    #> SINGLE (DETERM_TIMEOUT timeout (tac ctxt (auto_tac ctxt))) #> the
  16.747 +    #> Goal.finish ctxt) goal;
  16.748 +
  16.749 +val max_cached_wfs = 50;
  16.750 +val cached_timeout = Synchronized.var "Nunchaku_Collect.cached_timeout" Time.zeroTime;
  16.751 +val cached_wf_props = Synchronized.var "Nunchaku_Collect.cached_wf_props" ([] : (term * bool) list);
  16.752 +
  16.753 +val termination_tacs = [Lexicographic_Order.lex_order_tac true, ScnpReconstruct.sizechange_tac];
  16.754 +
  16.755 +fun is_wellfounded_inductive_predicate ctxt wfs debug wf_timeout const intros =
  16.756 +  let
  16.757 +    val thy = Proof_Context.theory_of ctxt;
  16.758 +
  16.759 +    val Const (x as (_, T)) = head_of (HOLogic.dest_Trueprop (Logic.strip_imp_concl (hd intros)));
  16.760 +  in
  16.761 +    (case triple_lookup (const_match thy o swap) wfs (dest_Const const) of
  16.762 +      SOME (SOME wf) => wf
  16.763 +    | _ =>
  16.764 +      (case map (triple_for_intro_rule ctxt x) intros |> filter_out (null o #2) of
  16.765 +        [] => true
  16.766 +      | triples =>
  16.767 +        let
  16.768 +          val binders_T = HOLogic.mk_tupleT (binder_types T);
  16.769 +          val rel_T = HOLogic.mk_setT (HOLogic.mk_prodT (binders_T, binders_T));
  16.770 +          val j = fold (Integer.max o maxidx_of_term) intros 0 + 1;
  16.771 +          val rel = (("R", j), rel_T);
  16.772 +          val prop =
  16.773 +            Const (@{const_name wf}, rel_T --> HOLogic.boolT) $ Var rel ::
  16.774 +            map (wf_constraint_for_triple rel) triples
  16.775 +            |> foldr1 HOLogic.mk_conj
  16.776 +            |> HOLogic.mk_Trueprop;
  16.777 +        in
  16.778 +          if debug then writeln ("Wellfoundedness goal: " ^ Syntax.string_of_term ctxt prop)
  16.779 +          else ();
  16.780 +          if wf_timeout = Synchronized.value cached_timeout andalso
  16.781 +             length (Synchronized.value cached_wf_props) < max_cached_wfs then
  16.782 +            ()
  16.783 +          else
  16.784 +            (Synchronized.change cached_wf_props (K []);
  16.785 +             Synchronized.change cached_timeout (K wf_timeout));
  16.786 +          (case AList.lookup (op =) (Synchronized.value cached_wf_props) prop of
  16.787 +            SOME wf => wf
  16.788 +          | NONE =>
  16.789 +            let
  16.790 +              val goal = Goal.init (Thm.cterm_of ctxt prop);
  16.791 +              val wf = exists (terminates_by ctxt wf_timeout goal) termination_tacs;
  16.792 +            in
  16.793 +              Synchronized.change cached_wf_props (cons (prop, wf)); wf
  16.794 +            end)
  16.795 +        end)
  16.796 +      handle
  16.797 +        List.Empty => false
  16.798 +      | NO_TRIPLE () => false)
  16.799 +  end;
  16.800 +
  16.801 +datatype lhs_pat =
  16.802 +  Only_Vars
  16.803 +| Prim_Pattern of string
  16.804 +| Any_Pattern;
  16.805 +
  16.806 +fun is_likely_pat_complete ctxt props =
  16.807 +  let
  16.808 +    val is_Var_or_Bound = is_Var orf is_Bound;
  16.809 +
  16.810 +    fun lhs_pat_of t =
  16.811 +      (case t of
  16.812 +        Const (@{const_name All}, _) $ Abs (_, _, t) => lhs_pat_of t
  16.813 +      | Const (@{const_name HOL.eq}, _) $ u $ _ =>
  16.814 +        (case filter_out is_Var_or_Bound (snd (strip_comb u)) of
  16.815 +          [] => Only_Vars
  16.816 +        | [v] =>
  16.817 +          (case strip_comb v of
  16.818 +            (cst as Const (_, T), args) =>
  16.819 +            (case body_type T of
  16.820 +              Type (T_name, _) =>
  16.821 +              if can (Ctr_Sugar.dest_ctr ctxt T_name) cst andalso forall is_Var_or_Bound args then
  16.822 +                Prim_Pattern T_name
  16.823 +              else
  16.824 +                Any_Pattern
  16.825 +            | _ => Any_Pattern)
  16.826 +          | _ => Any_Pattern)
  16.827 +        | _ => Any_Pattern)
  16.828 +      | _ => Any_Pattern);
  16.829 +  in
  16.830 +    (case map lhs_pat_of props of
  16.831 +      [] => false
  16.832 +    | pats as Prim_Pattern T_name :: _ =>
  16.833 +      forall (can (fn Prim_Pattern _ => ())) pats andalso
  16.834 +      length pats = length (#ctrs (the (Ctr_Sugar.ctr_sugar_of ctxt T_name)))
  16.835 +    | pats => forall (curry (op =) Only_Vars) pats)
  16.836 +  end;
  16.837 +
  16.838 +(* Prevents divergence in case of cyclic or infinite axiom dependencies. *)
  16.839 +val axioms_max_depth = 255
  16.840 +
  16.841 +fun isa_problem_of_subgoal ctxt falsify wfs whacks cards debug wf_timeout evals0 some_assms0
  16.842 +    subgoal0 =
  16.843 +  let
  16.844 +    val thy = Proof_Context.theory_of ctxt;
  16.845 +
  16.846 +    fun card_of T =
  16.847 +      (case triple_lookup (typ_match thy o swap) cards T of
  16.848 +        NONE => (NONE, NONE)
  16.849 +      | SOME (c1, c2) => (if c1 = SOME 1 then NONE else c1, c2));
  16.850 +
  16.851 +    fun axioms_of_class class =
  16.852 +      #axioms (Axclass.get_info thy class)
  16.853 +      handle ERROR _ => [];
  16.854 +
  16.855 +    fun monomorphize_class_axiom T t =
  16.856 +      (case Term.add_tvars t [] of
  16.857 +        [] => t
  16.858 +      | [(x, S)] => Envir.subst_term_types (Vartab.make [(x, (S, T))]) t);
  16.859 +
  16.860 +    fun consider_sort depth T S (seens as (seenS, seenT, seen), problem) =
  16.861 +      if member (op =) seenS S then
  16.862 +        (seens, problem)
  16.863 +      else if depth > axioms_max_depth then
  16.864 +        raise TOO_DEEP_DEPS ()
  16.865 +      else
  16.866 +        let
  16.867 +          val seenS = S :: seenS;
  16.868 +          val seens = (seenS, seenT, seen);
  16.869 +
  16.870 +          val supers = Sign.complete_sort thy S;
  16.871 +          val axioms0 = maps (map Thm.prop_of o axioms_of_class) supers;
  16.872 +          val axioms = map (preprocess_prop false ctxt whacks o monomorphize_class_axiom T) axioms0;
  16.873 +        in
  16.874 +          (seens, map IAxiom axioms @ problem)
  16.875 +          |> fold (consider_term (depth + 1)) axioms
  16.876 +        end
  16.877 +    and consider_type depth T =
  16.878 +      (case T of
  16.879 +        Type (s, Ts) =>
  16.880 +        if is_type_builtin s then fold (consider_type depth) Ts
  16.881 +        else consider_non_builtin_type depth T
  16.882 +      | _ => consider_non_builtin_type depth T)
  16.883 +    and consider_non_builtin_type depth T (seens as (seenS, seenT, seen), problem) =
  16.884 +      if member (op =) seenT T then
  16.885 +        (seens, problem)
  16.886 +      else
  16.887 +        let
  16.888 +          val seenT = T :: seenT;
  16.889 +          val seens = (seenS, seenT, seen);
  16.890 +
  16.891 +          fun consider_typedef_or_quotient itypedef_or_quotient tuple_of s =
  16.892 +            let
  16.893 +              val (T0, repT0, wrt0, abs0, rep0) = tuple_of ctxt whacks s;
  16.894 +              val tyenv = Sign.typ_match thy (T0, T) Vartab.empty;
  16.895 +              val substT = Envir.subst_type tyenv;
  16.896 +              val subst = Envir.subst_term_types tyenv;
  16.897 +              val repT = substT repT0;
  16.898 +              val wrt = subst (wrt0 ());
  16.899 +              val abs = subst abs0;
  16.900 +              val rep = subst rep0;
  16.901 +            in
  16.902 +              apsnd (cons (itypedef_or_quotient {abs_typ = T, rep_typ = repT, wrt = wrt, abs = abs,
  16.903 +                rep = rep}))
  16.904 +              #> consider_term (depth + 1) wrt
  16.905 +            end;
  16.906 +        in
  16.907 +          (seens, problem)
  16.908 +          |> (case T of
  16.909 +               TFree (_, S) =>
  16.910 +               apsnd (cons (ITVal (T, card_of T)))
  16.911 +               #> consider_sort depth T S
  16.912 +             | TVar (_, S) => consider_sort depth T S
  16.913 +             | Type (s, Ts) =>
  16.914 +               fold (consider_type depth) Ts
  16.915 +               #> (case classify_type_name ctxt s of
  16.916 +                    Co_Datatype =>
  16.917 +                    let
  16.918 +                      val (fp, fpTs, ctrss) = mutual_co_datatypes_of ctxt (s, Ts);
  16.919 +                      val specs = map2 (fn T => fn ctrs => {typ = T, ctrs = ctrs}) fpTs ctrss;
  16.920 +                    in
  16.921 +                      (fn ((seenS, seenT, seen), problem) =>
  16.922 +                          ((seenS, union (op =) fpTs seenT, seen), ICoData (fp, specs) :: problem))
  16.923 +                      #> fold (fold (consider_type (depth + 1) o fastype_of)) ctrss
  16.924 +                    end
  16.925 +                  | Typedef => consider_typedef_or_quotient ITypedef typedef_of s
  16.926 +                  | Quotient => consider_typedef_or_quotient IQuotient quotient_of s
  16.927 +                  | TVal => apsnd (cons (ITVal (T, card_of T)))))
  16.928 +        end
  16.929 +    and consider_term depth t =
  16.930 +      (case t of
  16.931 +        t1 $ t2 => fold (consider_term depth) [t1, t2]
  16.932 +      | Var (_, T) => consider_type depth T
  16.933 +      | Bound _ => I
  16.934 +      | Abs (_, T, t') =>
  16.935 +        consider_term depth t'
  16.936 +        #> consider_type depth T
  16.937 +      | _ => (fn (seens as (seenS, seenT, seen), problem) =>
  16.938 +          if member (op aconv) seen t then
  16.939 +            (seens, problem)
  16.940 +          else if depth > axioms_max_depth then
  16.941 +            raise TOO_DEEP_DEPS ()
  16.942 +          else
  16.943 +            let
  16.944 +              val seen = t :: seen;
  16.945 +              val seens = (seenS, seenT, seen);
  16.946 +            in
  16.947 +              (case t of
  16.948 +                Const (x as (s, T)) =>
  16.949 +                (if is_const_builtin s orelse is_co_datatype_ctr ctxt x orelse
  16.950 +                    is_co_datatype_case ctxt x orelse is_quotient_abs ctxt whacks x orelse
  16.951 +                    is_quotient_rep ctxt whacks x orelse is_typedef_abs ctxt whacks x orelse
  16.952 +                    is_typedef_rep ctxt whacks x then
  16.953 +                   (seens, problem)
  16.954 +                 else if is_stale_typedef_abs ctxt whacks x orelse
  16.955 +                     is_stale_typedef_rep ctxt whacks x then
  16.956 +                   raise UNSUPPORTED_FUNC t
  16.957 +                 else
  16.958 +                   (case spec_rules_of ctxt x of
  16.959 +                     SOME (classif, consts, props0, poly_props) =>
  16.960 +                     let
  16.961 +                       val props = map (preprocess_prop false ctxt whacks) props0;
  16.962 +
  16.963 +                       fun def_or_spec () =
  16.964 +                         (case definition_of thy x of
  16.965 +                           SOME eq0 =>
  16.966 +                           let val eq = preprocess_prop false ctxt whacks eq0 in
  16.967 +                             ([eq], [IRec [{const = t, props = [eq], pat_complete = true}]])
  16.968 +                           end
  16.969 +                         | NONE => (props, [ISpec {consts = consts, props = props}]));
  16.970 +
  16.971 +                       val (props', cmds) =
  16.972 +                         if null props then
  16.973 +                           ([], map IVal consts)
  16.974 +                         else if classif = Spec_Rules.Equational then
  16.975 +                           (case partition_props consts props of
  16.976 +                             SOME propss =>
  16.977 +                             (props,
  16.978 +                              [IRec (map2 (fn const => fn props =>
  16.979 +                                   {const = const, props = props,
  16.980 +                                    pat_complete = is_likely_pat_complete ctxt props})
  16.981 +                                 consts propss)])
  16.982 +                           | NONE => def_or_spec ())
  16.983 +                         else if member (op =) [Spec_Rules.Inductive, Spec_Rules.Co_Inductive]
  16.984 +                             classif then
  16.985 +                           if is_inductive_set_intro (hd props) then
  16.986 +                             def_or_spec ()
  16.987 +                           else
  16.988 +                             (case partition_props consts props of
  16.989 +                               SOME propss =>
  16.990 +                               (props,
  16.991 +                                [ICoPred (if classif = Spec_Rules.Inductive then BNF_Util.Least_FP
  16.992 +                                   else BNF_Util.Greatest_FP,
  16.993 +                                 length consts = 1 andalso
  16.994 +                                 is_wellfounded_inductive_predicate ctxt wfs debug wf_timeout
  16.995 +                                   (the_single consts) poly_props,
  16.996 +                                 map2 (fn const => fn props => {const = const, props = props})
  16.997 +                                   consts propss)])
  16.998 +                             | NONE => def_or_spec ())
  16.999 +                         else
 16.1000 +                           def_or_spec ();
 16.1001 +                     in
 16.1002 +                       ((seenS, seenT, union (op aconv) consts seen), cmds @ problem)
 16.1003 +                       |> fold (consider_term (depth + 1)) props'
 16.1004 +                     end
 16.1005 +                   | NONE =>
 16.1006 +                     (case definition_of thy x of
 16.1007 +                       SOME eq0 =>
 16.1008 +                       let val eq = preprocess_prop false ctxt whacks eq0 in
 16.1009 +                         (seens, IRec [{const = t, props = [eq], pat_complete = true}] :: problem)
 16.1010 +                         |> consider_term (depth + 1) eq
 16.1011 +                       end
 16.1012 +                     | NONE => (seens, IVal t :: problem))))
 16.1013 +                |> consider_type depth T
 16.1014 +              | Free (_, T) =>
 16.1015 +                (seens, IVal t :: problem)
 16.1016 +                |> consider_type depth T)
 16.1017 +            end));
 16.1018 +
 16.1019 +    val (poly_axioms, mono_axioms0) = orphan_axioms_of ctxt
 16.1020 +      |> List.partition has_polymorphism;
 16.1021 +
 16.1022 +    fun implicit_evals_of pol (@{const Not} $ t) = implicit_evals_of (not pol) t
 16.1023 +      | implicit_evals_of pol (@{const implies} $ t $ u) =
 16.1024 +        (case implicit_evals_of pol u of
 16.1025 +          [] => implicit_evals_of (not pol) t
 16.1026 +        | ts => ts)
 16.1027 +      | implicit_evals_of pol (@{const conj} $ t $ u) =
 16.1028 +        union (op aconv) (implicit_evals_of pol t) (implicit_evals_of pol u)
 16.1029 +      | implicit_evals_of pol (@{const disj} $ t $ u) =
 16.1030 +        union (op aconv) (implicit_evals_of pol t) (implicit_evals_of pol u)
 16.1031 +      | implicit_evals_of false (Const (@{const_name HOL.eq}, _) $ t $ u) =
 16.1032 +        distinct (op aconv) [t, u]
 16.1033 +      | implicit_evals_of true (Const (@{const_name HOL.eq}, _) $ t $ _) = [t]
 16.1034 +      | implicit_evals_of _ _ = [];
 16.1035 +
 16.1036 +    val mono_axioms_and_some_assms =
 16.1037 +      map (preprocess_prop false ctxt whacks) (mono_axioms0 @ some_assms0);
 16.1038 +    val subgoal = preprocess_prop falsify ctxt whacks subgoal0;
 16.1039 +    val implicit_evals = implicit_evals_of true subgoal;
 16.1040 +    val evals = map (preprocess_closed_term ctxt whacks) evals0;
 16.1041 +    val seens = ([], [], []);
 16.1042 +
 16.1043 +    val (commandss, complete) =
 16.1044 +      (seens,
 16.1045 +       map IAxiom mono_axioms_and_some_assms @ [IGoal subgoal] @ map IEval (implicit_evals @ evals))
 16.1046 +      |> fold (consider_term 0) (subgoal :: evals @ mono_axioms_and_some_assms)
 16.1047 +      |> snd
 16.1048 +      |> rev (* prettier *)
 16.1049 +      |> sort_isa_commands_topologically ctxt
 16.1050 +      |>> group_isa_commands;
 16.1051 +  in
 16.1052 +    (poly_axioms, {commandss = commandss, sound = true, complete = complete})
 16.1053 +  end;
 16.1054 +
 16.1055 +fun add_pat_complete_of_command cmd =
 16.1056 +  (case cmd of
 16.1057 +    ICoPred (_, _, specs) => union (op =) (map #const specs)
 16.1058 +  | IRec specs =>
 16.1059 +    union (op =) (map_filter (try (fn {const, pat_complete = true, ...} => const)) specs)
 16.1060 +  | _ => I);
 16.1061 +
 16.1062 +fun pat_completes_of_isa_problem {commandss, ...} =
 16.1063 +  fold (fold add_pat_complete_of_command) commandss [];
 16.1064 +
 16.1065 +fun str_of_isa_term_with_type ctxt t =
 16.1066 +  Syntax.string_of_term ctxt t ^ " : " ^ Syntax.string_of_typ ctxt (fastype_of t);
 16.1067 +
 16.1068 +fun is_triv_wrt (Abs (_, _, body)) = is_triv_wrt body
 16.1069 +  | is_triv_wrt @{const True} = true
 16.1070 +  | is_triv_wrt _ = false;
 16.1071 +
 16.1072 +fun str_of_isa_type_spec ctxt {abs_typ, rep_typ, wrt, abs, rep} =
 16.1073 +  Syntax.string_of_typ ctxt abs_typ ^ " := " ^ Syntax.string_of_typ ctxt rep_typ ^
 16.1074 +  (if is_triv_wrt wrt then "" else "\n  wrt " ^ Syntax.string_of_term ctxt wrt) ^
 16.1075 +  "\n  abstract " ^ Syntax.string_of_term ctxt abs ^
 16.1076 +  "\n  concrete " ^ Syntax.string_of_term ctxt rep;
 16.1077 +
 16.1078 +fun str_of_isa_co_data_spec ctxt {typ, ctrs} =
 16.1079 +  Syntax.string_of_typ ctxt typ ^ " :=\n  " ^
 16.1080 +  space_implode "\n| " (map (str_of_isa_term_with_type ctxt) ctrs);
 16.1081 +
 16.1082 +fun str_of_isa_const_spec ctxt {const, props} =
 16.1083 +  str_of_isa_term_with_type ctxt const ^ " :=\n  " ^
 16.1084 +  space_implode ";\n  " (map (Syntax.string_of_term ctxt) props);
 16.1085 +
 16.1086 +fun str_of_isa_rec_spec ctxt {const, props, pat_complete} =
 16.1087 +  str_of_isa_term_with_type ctxt const ^ (if pat_complete then " [pat_complete]" else "") ^
 16.1088 +  " :=\n " ^ space_implode ";\n " (map (Syntax.string_of_term ctxt) props);
 16.1089 +
 16.1090 +fun str_of_isa_consts_spec ctxt {consts, props} =
 16.1091 +  space_implode " and\n     " (map (str_of_isa_term_with_type ctxt) consts) ^ " :=\n  " ^
 16.1092 +  space_implode ";\n  " (map (Syntax.string_of_term ctxt) props);
 16.1093 +
 16.1094 +fun str_of_isa_card NONE = ""
 16.1095 +  | str_of_isa_card (SOME k) = signed_string_of_int k;
 16.1096 +
 16.1097 +fun str_of_isa_cards_suffix (NONE, NONE) = ""
 16.1098 +  | str_of_isa_cards_suffix (c1, c2) = " " ^ str_of_isa_card c1 ^ "-" ^ str_of_isa_card c2;
 16.1099 +
 16.1100 +fun str_of_isa_command ctxt (ITVal (T, cards)) =
 16.1101 +    "type " ^ Syntax.string_of_typ ctxt T ^ str_of_isa_cards_suffix cards
 16.1102 +  | str_of_isa_command ctxt (ITypedef spec) = "typedef " ^ str_of_isa_type_spec ctxt spec
 16.1103 +  | str_of_isa_command ctxt (IQuotient spec) = "quotient " ^ str_of_isa_type_spec ctxt spec
 16.1104 +  | str_of_isa_command ctxt (ICoData (fp, specs)) =
 16.1105 +    BNF_Util.case_fp fp "data" "codata" ^ " " ^ str_of_and_list (str_of_isa_co_data_spec ctxt) specs
 16.1106 +  | str_of_isa_command ctxt (IVal t) = "val " ^ str_of_isa_term_with_type ctxt t
 16.1107 +  | str_of_isa_command ctxt (ICoPred (fp, wf, specs)) =
 16.1108 +    BNF_Util.case_fp fp "pred" "copred" ^ " " ^ (if wf then "[wf] " else "") ^
 16.1109 +    str_of_and_list (str_of_isa_const_spec ctxt) specs
 16.1110 +  | str_of_isa_command ctxt (IRec specs) = "rec " ^ str_of_and_list (str_of_isa_rec_spec ctxt) specs
 16.1111 +  | str_of_isa_command ctxt (ISpec spec) = "spec " ^ str_of_isa_consts_spec ctxt spec
 16.1112 +  | str_of_isa_command ctxt (IAxiom prop) = "axiom " ^ Syntax.string_of_term ctxt prop
 16.1113 +  | str_of_isa_command ctxt (IGoal prop) = "goal " ^ Syntax.string_of_term ctxt prop
 16.1114 +  | str_of_isa_command ctxt (IEval t) = "eval " ^ Syntax.string_of_term ctxt t;
 16.1115 +
 16.1116 +fun str_of_isa_problem ctxt {commandss, sound, complete} =
 16.1117 +  map (cat_lines o map (suffix "." o str_of_isa_command ctxt)) commandss
 16.1118 +  |> space_implode "\n\n" |> suffix "\n"
 16.1119 +  |> prefix ("# " ^ (if sound then "sound" else "unsound") ^ "\n")
 16.1120 +  |> prefix ("# " ^ (if complete then "complete" else "incomplete") ^ "\n");
 16.1121 +
 16.1122 +end;
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/HOL/Tools/Nunchaku/nunchaku_commands.ML	Fri Sep 08 00:01:36 2017 +0200
    17.3 @@ -0,0 +1,265 @@
    17.4 +(*  Title:      HOL/Nunchaku/Tools/nunchaku_commands.ML
    17.5 +    Author:     Jasmin Blanchette, VU Amsterdam
    17.6 +    Copyright   2015, 2016, 2017
    17.7 +
    17.8 +Adds the "nunchaku" and "nunchaku_params" commands to Isabelle/Isar's outer syntax.
    17.9 +*)
   17.10 +
   17.11 +signature NUNCHAKU_COMMANDS =
   17.12 +sig
   17.13 +  type params = Nunchaku.params
   17.14 +
   17.15 +  val default_params: theory -> (string * string) list -> params
   17.16 +end;
   17.17 +
   17.18 +structure Nunchaku_Commands : NUNCHAKU_COMMANDS =
   17.19 +struct
   17.20 +
   17.21 +open Nunchaku_Util;
   17.22 +open Nunchaku;
   17.23 +
   17.24 +type raw_param = string * string list;
   17.25 +
   17.26 +val default_default_params =
   17.27 +  [("assms", "true"),
   17.28 +   ("debug", "false"),
   17.29 +   ("falsify", "true"),
   17.30 +   ("max_genuine", "1"),
   17.31 +   ("max_potential", "1"),
   17.32 +   ("overlord", "false"),
   17.33 +   ("solvers", "cvc4 kodkod paradox smbc"),
   17.34 +   ("specialize", "true"),
   17.35 +   ("spy", "false"),
   17.36 +   ("timeout", "30"),
   17.37 +   ("verbose", "false"),
   17.38 +   ("wf_timeout", "0.5")];
   17.39 +
   17.40 +val negated_params =
   17.41 +  [("dont_whack", "whack"),
   17.42 +   ("dont_specialize", "specialize"),
   17.43 +   ("dont_spy", "spy"),
   17.44 +   ("no_assms", "assms"),
   17.45 +   ("no_debug", "debug"),
   17.46 +   ("no_overlord", "overlord"),
   17.47 +   ("non_mono", "mono"),
   17.48 +   ("non_wf", "wf"),
   17.49 +   ("quiet", "verbose"),
   17.50 +   ("satisfy", "falsify")];
   17.51 +
   17.52 +fun is_known_raw_param s =
   17.53 +  AList.defined (op =) default_default_params s orelse
   17.54 +  AList.defined (op =) negated_params s orelse
   17.55 +  member (op =) ["atoms", "card", "eval", "expect"] s orelse
   17.56 +  exists (fn p => String.isPrefix (p ^ " ") s)
   17.57 +    ["atoms", "card", "dont_whack", "mono", "non_mono", "non_wf", "wf", "whack"];
   17.58 +
   17.59 +fun check_raw_param (s, _) =
   17.60 +  if is_known_raw_param s then () else error ("Unknown parameter: " ^ quote s);
   17.61 +
   17.62 +fun unnegate_param_name name =
   17.63 +  (case AList.lookup (op =) negated_params name of
   17.64 +    NONE =>
   17.65 +    if String.isPrefix "dont_" name then SOME (unprefix "dont_" name)
   17.66 +    else if String.isPrefix "non_" name then SOME (unprefix "non_" name)
   17.67 +    else NONE
   17.68 +  | some_name => some_name);
   17.69 +
   17.70 +fun normalize_raw_param (name, value) =
   17.71 +  (case unnegate_param_name name of
   17.72 +    SOME name' =>
   17.73 +    [(name',
   17.74 +      (case value of
   17.75 +        ["false"] => ["true"]
   17.76 +      | ["true"] => ["false"]
   17.77 +      | [] => ["false"]
   17.78 +      | _ => value))]
   17.79 +  | NONE => [(name, value)]);
   17.80 +
   17.81 +structure Data = Theory_Data
   17.82 +(
   17.83 +  type T = raw_param list
   17.84 +  val empty = default_default_params |> map (apsnd single)
   17.85 +  val extend = I
   17.86 +  fun merge data = AList.merge (op =) (K true) data
   17.87 +);
   17.88 +
   17.89 +val set_default_raw_param = Data.map o fold (AList.update (op =)) o normalize_raw_param;
   17.90 +val default_raw_params = Data.get;
   17.91 +
   17.92 +fun is_punctuation s = (s = "," orelse s = "-");
   17.93 +
   17.94 +fun stringify_raw_param_value [] = ""
   17.95 +  | stringify_raw_param_value [s] = s
   17.96 +  | stringify_raw_param_value (s1 :: s2 :: ss) =
   17.97 +    s1 ^ (if is_punctuation s1 orelse is_punctuation s2 then "" else " ") ^
   17.98 +    stringify_raw_param_value (s2 :: ss);
   17.99 +
  17.100 +fun extract_params ctxt mode default_params override_params =
  17.101 +  let
  17.102 +    val override_params = maps normalize_raw_param override_params;
  17.103 +    val raw_params = rev override_params @ rev default_params;
  17.104 +    val raw_lookup = AList.lookup (op =) raw_params;
  17.105 +    val lookup = Option.map stringify_raw_param_value o raw_lookup;
  17.106 +    val lookup_string = the_default "" o lookup;
  17.107 +    val lookup_strings = these o Option.map (space_explode " ") o lookup;
  17.108 +
  17.109 +    fun general_lookup_bool option default_value name =
  17.110 +      (case lookup name of
  17.111 +        SOME s => parse_bool_option option name s
  17.112 +      | NONE => default_value);
  17.113 +
  17.114 +    val lookup_bool = the o general_lookup_bool false (SOME false);
  17.115 +
  17.116 +    fun lookup_int name =
  17.117 +      (case lookup name of
  17.118 +        SOME s =>
  17.119 +        (case Int.fromString s of
  17.120 +          SOME i => i
  17.121 +        | NONE => error ("Parameter " ^ quote name ^ " must be assigned an integer value"))
  17.122 +      | NONE => 0);
  17.123 +
  17.124 +    fun int_range_from_string name s =
  17.125 +      (case space_explode "-" s of
  17.126 +         [s] => (s, s)
  17.127 +       | [s1, s2] => (s1, s2)
  17.128 +       | _ => error ("Parameter " ^ quote name ^ " must be assigned a range of integers"))
  17.129 +      |> apply2 Int.fromString;
  17.130 +
  17.131 +    fun lookup_assigns read pre of_str =
  17.132 +      (case lookup pre of
  17.133 +        SOME s => [(NONE, of_str s)]
  17.134 +      | NONE => []) @
  17.135 +      map (fn (name, value) => (SOME (read (String.extract (name, size pre + 1, NONE))),
  17.136 +          of_str (stringify_raw_param_value value)))
  17.137 +        (filter (String.isPrefix (pre ^ " ") o fst) raw_params);
  17.138 +
  17.139 +    fun lookup_int_range_assigns read pre =
  17.140 +      lookup_assigns read pre (int_range_from_string pre);
  17.141 +
  17.142 +    fun lookup_bool_assigns read pre =
  17.143 +      lookup_assigns read pre (the o parse_bool_option false pre);
  17.144 +
  17.145 +    fun lookup_bool_option_assigns read pre =
  17.146 +      lookup_assigns read pre (parse_bool_option true pre);
  17.147 +
  17.148 +    fun lookup_strings_assigns read pre =
  17.149 +      lookup_assigns read pre (space_explode " ");
  17.150 +
  17.151 +    fun lookup_time name =
  17.152 +      (case lookup name of
  17.153 +        SOME s => parse_time name s
  17.154 +      | NONE => Time.zeroTime);
  17.155 +
  17.156 +    val read_type_polymorphic =
  17.157 +      Syntax.read_typ ctxt #> Logic.mk_type
  17.158 +      #> singleton (Variable.polymorphic ctxt) #> Logic.dest_type;
  17.159 +    val read_term_polymorphic =
  17.160 +      Syntax.read_term ctxt #> singleton (Variable.polymorphic ctxt);
  17.161 +    val lookup_term_list_option_polymorphic =
  17.162 +      AList.lookup (op =) raw_params #> Option.map (map read_term_polymorphic);
  17.163 +
  17.164 +    fun read_const_polymorphic s =
  17.165 +      (case read_term_polymorphic s of
  17.166 +        Const x => x
  17.167 +      | t => error ("Not a constant: " ^ Syntax.string_of_term ctxt t));
  17.168 +
  17.169 +    val solvers = lookup_strings "solvers";
  17.170 +    val falsify = lookup_bool "falsify";
  17.171 +    val assms = lookup_bool "assms";
  17.172 +    val spy = getenv "NUNCHAKU_SPY" = "yes" orelse lookup_bool "spy";
  17.173 +    val overlord = lookup_bool "overlord";
  17.174 +    val expect = lookup_string "expect";
  17.175 +
  17.176 +    val wfs = lookup_bool_option_assigns read_const_polymorphic "wf";
  17.177 +    val whacks = lookup_bool_assigns read_term_polymorphic "whack";
  17.178 +    val cards = lookup_int_range_assigns read_type_polymorphic "card";
  17.179 +    val monos = lookup_bool_option_assigns read_type_polymorphic "mono";
  17.180 +
  17.181 +    val debug = (mode <> Auto_Try andalso lookup_bool "debug");
  17.182 +    val verbose = debug orelse (mode <> Auto_Try andalso lookup_bool "verbose");
  17.183 +    val max_potential = if mode = Normal then Int.max (0, lookup_int "max_potential") else 0;
  17.184 +    val max_genuine = Int.max (0, lookup_int "max_genuine");
  17.185 +    val evals = these (lookup_term_list_option_polymorphic "eval");
  17.186 +    val atomss = lookup_strings_assigns read_type_polymorphic "atoms";
  17.187 +
  17.188 +    val specialize = lookup_bool "specialize";
  17.189 +    val multithread = mode = Normal andalso lookup_bool "multithread";
  17.190 +
  17.191 +    val timeout = lookup_time "timeout";
  17.192 +    val wf_timeout = lookup_time "wf_timeout";
  17.193 +
  17.194 +    val mode_of_operation_params =
  17.195 +      {solvers = solvers, falsify = falsify, assms = assms, spy = spy, overlord = overlord,
  17.196 +       expect = expect};
  17.197 +
  17.198 +    val scope_of_search_params =
  17.199 +      {wfs = wfs, whacks = whacks, cards = cards, monos = monos};
  17.200 +
  17.201 +    val output_format_params =
  17.202 +      {verbose = verbose, debug = debug, max_potential = max_potential, max_genuine = max_genuine,
  17.203 +       evals = evals, atomss = atomss};
  17.204 +
  17.205 +    val optimization_params =
  17.206 +      {specialize = specialize, multithread = multithread};
  17.207 +
  17.208 +    val timeout_params =
  17.209 +      {timeout = timeout, wf_timeout = wf_timeout};
  17.210 +  in
  17.211 +    {mode_of_operation_params = mode_of_operation_params,
  17.212 +     scope_of_search_params = scope_of_search_params,
  17.213 +     output_format_params = output_format_params,
  17.214 +     optimization_params = optimization_params,
  17.215 +     timeout_params = timeout_params}
  17.216 +  end;
  17.217 +
  17.218 +fun default_params thy =
  17.219 +  extract_params (Proof_Context.init_global thy) Normal (default_raw_params thy)
  17.220 +  o map (apsnd single);
  17.221 +
  17.222 +val parse_key = Scan.repeat1 Parse.embedded >> space_implode " ";
  17.223 +val parse_value =
  17.224 +  Scan.repeat1 (Parse.minus >> single
  17.225 +    || Scan.repeat1 (Scan.unless Parse.minus (Parse.name || Parse.float_number))
  17.226 +    || @{keyword ","} |-- Parse.number >> prefix "," >> single)
  17.227 +  >> flat;
  17.228 +val parse_param = parse_key -- Scan.optional (@{keyword "="} |-- parse_value) [];
  17.229 +val parse_params = Scan.optional (@{keyword "["} |-- Parse.list parse_param --| @{keyword "]"}) [];
  17.230 +
  17.231 +fun run_chaku override_params mode i state0 =
  17.232 +  let
  17.233 +    val state = Proof.map_contexts (Try0.silence_methods false) state0;
  17.234 +    val thy = Proof.theory_of state;
  17.235 +    val ctxt = Proof.context_of state;
  17.236 +    val _ = List.app check_raw_param override_params;
  17.237 +    val params = extract_params ctxt mode (default_raw_params thy) override_params;
  17.238 +  in
  17.239 +    (if mode = Auto_Try then perhaps o try else fn f => fn x => f x)
  17.240 +      (fn _ => run_chaku_on_subgoal state params mode i) (unknownN, NONE)
  17.241 +    |> `(fn (outcome_code, _) => outcome_code = genuineN)
  17.242 +  end;
  17.243 +
  17.244 +fun string_for_raw_param (name, value) =
  17.245 +  name ^ " = " ^ stringify_raw_param_value value;
  17.246 +
  17.247 +fun nunchaku_params_trans params =
  17.248 +  Toplevel.theory (fold set_default_raw_param params
  17.249 +    #> tap (fn thy =>
  17.250 +      let val params = rev (default_raw_params thy) in
  17.251 +        List.app check_raw_param params;
  17.252 +        writeln ("Default parameters for Nunchaku:\n" ^
  17.253 +          (params |> map string_for_raw_param |> sort_strings |> cat_lines))
  17.254 +      end));
  17.255 +
  17.256 +val _ =
  17.257 +  Outer_Syntax.command @{command_keyword nunchaku}
  17.258 +    "try to find a countermodel using Nunchaku"
  17.259 +    (parse_params -- Scan.optional Parse.nat 1 >> (fn (params, i) =>
  17.260 +       Toplevel.keep_proof (fn state =>
  17.261 +         ignore (run_chaku params Normal i (Toplevel.proof_of state)))));
  17.262 +
  17.263 +val _ =
  17.264 +  Outer_Syntax.command @{command_keyword nunchaku_params}
  17.265 +    "set and display the default parameters for Nunchaku"
  17.266 +    (parse_params #>> nunchaku_params_trans);
  17.267 +
  17.268 +end;
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/HOL/Tools/Nunchaku/nunchaku_display.ML	Fri Sep 08 00:01:36 2017 +0200
    18.3 @@ -0,0 +1,91 @@
    18.4 +(*  Title:      HOL/Nunchaku/Tools/nunchaku_display.ML
    18.5 +    Author:     Jasmin Blanchette, VU Amsterdam
    18.6 +    Copyright   2015, 2016, 2017
    18.7 +
    18.8 +Pretty printing of Isabelle/HOL models for Nunchaku.
    18.9 +*)
   18.10 +
   18.11 +signature NUNCHAKU_DISPLAY =
   18.12 +sig
   18.13 +  type isa_model = Nunchaku_Reconstruct.isa_model
   18.14 +
   18.15 +  val pretty_of_isa_model_opt: Proof.context -> isa_model option -> Pretty.T
   18.16 +end;
   18.17 +
   18.18 +structure Nunchaku_Display : NUNCHAKU_DISPLAY =
   18.19 +struct
   18.20 +
   18.21 +open Nunchaku_Util;
   18.22 +open Nunchaku_Reconstruct;
   18.23 +
   18.24 +val indent_size = 2;
   18.25 +
   18.26 +val pretty_indent = Pretty.indent indent_size;
   18.27 +
   18.28 +fun sorting_str_of_typ (TFree (s, _)) = "a" ^ s
   18.29 +  | sorting_str_of_typ (Type (s, Ts)) = "b" ^ s ^ space_implode " " (map sorting_str_of_typ Ts)
   18.30 +  | sorting_str_of_typ (TVar _) = "X";
   18.31 +
   18.32 +fun sorting_str_of_term (Const (s, T)) = "b" ^ s ^ sorting_str_of_typ T
   18.33 +  | sorting_str_of_term (Free (s, _)) = "a" ^ s
   18.34 +  | sorting_str_of_term (t $ u) = sorting_str_of_term t ^ " " ^ sorting_str_of_term u
   18.35 +  | sorting_str_of_term (Abs (_, T, t)) = "c" ^ sorting_str_of_typ T ^ " " ^ sorting_str_of_term t
   18.36 +  | sorting_str_of_term _ = "X";
   18.37 +
   18.38 +fun pretty_of_isa_model_opt _ NONE =
   18.39 +    pretty_indent (Pretty.str "Model unavailable (internal error)")
   18.40 +  | pretty_of_isa_model_opt ctxt0
   18.41 +      (SOME {type_model, free_model, pat_complete_model, pat_incomplete_model, skolem_model}) =
   18.42 +    let
   18.43 +      val ctxt = ctxt0 |> Config.put show_question_marks false;
   18.44 +
   18.45 +      val pat_incomplete_model' = pat_incomplete_model
   18.46 +        |> filter_out (can (fn Const (@{const_name unreachable}, _) => ()) o fst);
   18.47 +
   18.48 +      fun pretty_of_typ_entry (T, atoms) =
   18.49 +        Pretty.block (Pretty.breaks [Syntax.pretty_typ ctxt T, Pretty.str "=",
   18.50 +           Pretty.enum "," "{" "}" (map (Syntax.pretty_term ctxt) atoms)]);
   18.51 +
   18.52 +      fun pretty_of_term_entry (t, value) =
   18.53 +        let
   18.54 +          val no_types_ctxt = ctxt |> Config.put show_types false;
   18.55 +          val schematic_ctxt = ctxt |> Proof_Context.set_mode Proof_Context.mode_schematic;
   18.56 +
   18.57 +          val show_types = Config.get ctxt show_types;
   18.58 +          val value' = value |> perhaps (try (Syntax.check_term schematic_ctxt));
   18.59 +          val T = fastype_of t;
   18.60 +          val T' = if T = dummyT then try fastype_of value' |> the_default T else T;
   18.61 +          val t' = t |> show_types ? Type.constraint T';
   18.62 +        in
   18.63 +          Pretty.block (Pretty.breaks
   18.64 +            [Syntax.pretty_term ctxt t'
   18.65 +             |> (show_types andalso T' <> dummyT) ? (single #> Pretty.enclose "(" ")"),
   18.66 +             Pretty.str "=", Syntax.pretty_term no_types_ctxt value'])
   18.67 +        end;
   18.68 +
   18.69 +      fun chunks_of_entries sorting_str_of pretty_of title entries =
   18.70 +        if not (null entries) then
   18.71 +          (if title = "" then [] else [Pretty.str (title ^ plural_s_for_list entries ^ ":")]) @
   18.72 +          map (pretty_indent o pretty_of) (sort_by (sorting_str_of o fst) entries)
   18.73 +        else
   18.74 +          [];
   18.75 +
   18.76 +      val chunks =
   18.77 +        (if null free_model then
   18.78 +           [pretty_indent (Pretty.str "No free variables")]
   18.79 +         else
   18.80 +           chunks_of_entries sorting_str_of_term pretty_of_term_entry "" free_model) @
   18.81 +        chunks_of_entries sorting_str_of_term pretty_of_term_entry "Skolem constant" skolem_model @
   18.82 +        chunks_of_entries sorting_str_of_term pretty_of_term_entry "Underspecified constant"
   18.83 +          pat_incomplete_model' @
   18.84 +        (if Config.get ctxt show_consts then
   18.85 +           chunks_of_entries sorting_str_of_term pretty_of_term_entry "Fully specified constant"
   18.86 +             pat_complete_model
   18.87 +         else
   18.88 +           []) @
   18.89 +        chunks_of_entries sorting_str_of_typ pretty_of_typ_entry "Type" type_model;
   18.90 +    in
   18.91 +      Pretty.chunks chunks
   18.92 +    end;
   18.93 +
   18.94 +end;
    19.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.2 +++ b/src/HOL/Tools/Nunchaku/nunchaku_model.ML	Fri Sep 08 00:01:36 2017 +0200
    19.3 @@ -0,0 +1,284 @@
    19.4 +(*  Title:      HOL/Nunchaku/Tools/nunchaku_model.ML
    19.5 +    Author:     Jasmin Blanchette, VU Amsterdam
    19.6 +    Copyright   2015, 2016, 2017
    19.7 +
    19.8 +Abstract syntax tree for Nunchaku models.
    19.9 +*)
   19.10 +
   19.11 +signature NUNCHAKU_MODEL =
   19.12 +sig
   19.13 +  type ident = Nunchaku_Problem.ident
   19.14 +  type ty = Nunchaku_Problem.ty
   19.15 +  type tm = Nunchaku_Problem.tm
   19.16 +  type name_pool = Nunchaku_Problem.name_pool
   19.17 +
   19.18 +  type ty_entry = ty * tm list
   19.19 +  type tm_entry = tm * tm
   19.20 +
   19.21 +  type nun_model =
   19.22 +    {type_model: ty_entry list,
   19.23 +     const_model: tm_entry list,
   19.24 +     skolem_model: tm_entry list}
   19.25 +
   19.26 +  val str_of_nun_model: nun_model -> string
   19.27 +
   19.28 +  val allocate_ugly: name_pool -> string * string -> string * name_pool
   19.29 +
   19.30 +  val ugly_nun_model: name_pool -> nun_model -> nun_model
   19.31 +
   19.32 +  datatype token =
   19.33 +    Ident of ident
   19.34 +  | Symbol of ident
   19.35 +  | Atom of ident * int
   19.36 +  | End_of_Stream
   19.37 +
   19.38 +  val parse_tok: ''a -> ''a list -> ''a * ''a list
   19.39 +  val parse_ident: token list -> ident * token list
   19.40 +  val parse_id: ident -> token list -> token * token list
   19.41 +  val parse_sym: ident -> token list -> token * token list
   19.42 +  val parse_atom: token list -> (ident * int) * token list
   19.43 +  val nun_model_of_str: string -> nun_model
   19.44 +end;
   19.45 +
   19.46 +structure Nunchaku_Model : NUNCHAKU_MODEL =
   19.47 +struct
   19.48 +
   19.49 +open Nunchaku_Problem;
   19.50 +
   19.51 +type ty_entry = ty * tm list;
   19.52 +type tm_entry = tm * tm;
   19.53 +
   19.54 +type nun_model =
   19.55 +  {type_model: ty_entry list,
   19.56 +   const_model: tm_entry list,
   19.57 +   skolem_model: tm_entry list};
   19.58 +
   19.59 +val nun_SAT = str_of_ident "SAT";
   19.60 +
   19.61 +fun str_of_ty_entry (ty, tms) =
   19.62 +  "type " ^ str_of_ty ty ^ " := {" ^ commas (map str_of_tm tms) ^ "}.";
   19.63 +
   19.64 +fun str_of_tm_entry (tm, value) =
   19.65 +  "val " ^ str_of_tm tm ^ " := " ^ str_of_tm value ^ ".";
   19.66 +
   19.67 +fun str_of_nun_model {type_model, const_model, skolem_model} =
   19.68 +  map str_of_ty_entry type_model @ "" :: map str_of_tm_entry const_model @ "" ::
   19.69 +  map str_of_tm_entry skolem_model
   19.70 +  |> cat_lines;
   19.71 +
   19.72 +fun fold_map_ty_entry_idents f (ty, atoms) =
   19.73 +  fold_map_ty_idents f ty
   19.74 +  ##>> fold_map (fold_map_tm_idents f) atoms;
   19.75 +
   19.76 +fun fold_map_tm_entry_idents f (tm, value) =
   19.77 +  fold_map_tm_idents f tm
   19.78 +  ##>> fold_map_tm_idents f value;
   19.79 +
   19.80 +fun fold_map_nun_model_idents f {type_model, const_model, skolem_model} =
   19.81 +  fold_map (fold_map_ty_entry_idents f) type_model
   19.82 +  ##>> fold_map (fold_map_tm_entry_idents f) const_model
   19.83 +  ##>> fold_map (fold_map_tm_entry_idents f) skolem_model
   19.84 +  #>> (fn ((type_model, const_model), skolem_model) =>
   19.85 +    {type_model = type_model, const_model = const_model, skolem_model = skolem_model});
   19.86 +
   19.87 +fun swap_name_pool ({nice_of_ugly, ugly_of_nice} : name_pool) =
   19.88 +  {nice_of_ugly = ugly_of_nice, ugly_of_nice = nice_of_ugly};
   19.89 +
   19.90 +fun allocate_ugly pool (nice, ugly_sugg) =
   19.91 +  allocate_nice (swap_name_pool pool) (nice, ugly_sugg) ||> swap_name_pool;
   19.92 +
   19.93 +fun ugly_ident nice (pool as {ugly_of_nice, ...}) =
   19.94 +  (case Symtab.lookup ugly_of_nice nice of
   19.95 +    NONE => allocate_ugly pool (nice, nice)
   19.96 +  | SOME ugly => (ugly, pool));
   19.97 +
   19.98 +fun ugly_nun_model pool model =
   19.99 +  fst (fold_map_nun_model_idents ugly_ident model pool);
  19.100 +
  19.101 +datatype token =
  19.102 +  Ident of ident
  19.103 +| Symbol of ident
  19.104 +| Atom of ident * int
  19.105 +| End_of_Stream;
  19.106 +
  19.107 +val rev_str = String.implode o rev o String.explode;
  19.108 +
  19.109 +fun atom_of_str s =
  19.110 +  (case first_field "_" (rev_str s) of
  19.111 +    SOME (rev_suf, rev_pre) =>
  19.112 +    let
  19.113 +      val pre = rev_str rev_pre;
  19.114 +      val suf = rev_str rev_suf;
  19.115 +    in
  19.116 +      (case Int.fromString suf of
  19.117 +        SOME j => Atom (ident_of_str pre, j)
  19.118 +      | NONE => raise Fail "ill-formed atom")
  19.119 +    end
  19.120 +  | NONE => raise Fail "ill-formed atom");
  19.121 +
  19.122 +fun is_alnum_etc_char c = Char.isAlphaNum c orelse c = #"_" orelse c = #"/";
  19.123 +
  19.124 +val multi_ids =
  19.125 +  [nun_arrow, nun_assign, nun_conj, nun_disj, nun_implies, nun_unparsable, nun_irrelevant];
  19.126 +
  19.127 +val nun_anon_fun_prefix_exploded = String.explode nun_anon_fun_prefix;
  19.128 +val [nun_dollar_char] = String.explode nun_dollar;
  19.129 +
  19.130 +fun next_token [] = (End_of_Stream, [])
  19.131 +  | next_token (c :: cs) =
  19.132 +    if Char.isSpace c then
  19.133 +      next_token cs
  19.134 +    else if c = nun_dollar_char then
  19.135 +      let val n = find_index (not o is_alnum_etc_char) cs in
  19.136 +        (if n = ~1 then (cs, []) else chop n cs)
  19.137 +        |>> (String.implode
  19.138 +          #> (if is_prefix (op =) nun_anon_fun_prefix_exploded cs then ident_of_str #> Ident
  19.139 +            else atom_of_str))
  19.140 +      end
  19.141 +    else if is_alnum_etc_char c then
  19.142 +      let val n = find_index (not o is_alnum_etc_char) cs in
  19.143 +        (if n = ~1 then (cs, []) else chop n cs)
  19.144 +        |>> (cons c #> String.implode #> ident_of_str #> Ident)
  19.145 +      end
  19.146 +    else
  19.147 +      let
  19.148 +        fun next_multi id =
  19.149 +          let
  19.150 +            val s = str_of_ident id;
  19.151 +            val n = String.size s - 1;
  19.152 +          in
  19.153 +            if c = String.sub (s, 0) andalso
  19.154 +               is_prefix (op =) (String.explode (String.substring (s, 1, n))) cs then
  19.155 +              SOME (Symbol id, drop n cs)
  19.156 +            else
  19.157 +              NONE
  19.158 +          end;
  19.159 +      in
  19.160 +        (case get_first next_multi multi_ids of
  19.161 +          SOME res => res
  19.162 +        | NONE => (Symbol (ident_of_str (String.str c)), cs))
  19.163 +      end;
  19.164 +
  19.165 +val tokenize =
  19.166 +  let
  19.167 +    fun toks cs =
  19.168 +      (case next_token cs of
  19.169 +        (End_of_Stream, []) => []
  19.170 +      | (tok, cs') => tok :: toks cs');
  19.171 +  in
  19.172 +    toks o String.explode
  19.173 +  end;
  19.174 +
  19.175 +fun parse_enum sep scan = scan ::: Scan.repeat (sep |-- scan);
  19.176 +
  19.177 +fun parse_tok tok = Scan.one (curry (op =) tok);
  19.178 +
  19.179 +val parse_ident = Scan.some (try (fn Ident id => id));
  19.180 +val parse_id = parse_tok o Ident;
  19.181 +val parse_sym = parse_tok o Symbol;
  19.182 +val parse_atom = Scan.some (try (fn Atom id_j => id_j));
  19.183 +
  19.184 +val confusing_ids = [nun_else, nun_then, nun_with];
  19.185 +
  19.186 +val parse_confusing_id = Scan.one (fn Ident id => member (op =) confusing_ids id | _ => false);
  19.187 +
  19.188 +fun parse_ty toks =
  19.189 +  (parse_ty_arg -- Scan.option (parse_sym nun_arrow -- parse_ty)
  19.190 +   >> (fn (ty, NONE) => ty
  19.191 +     | (lhs, SOME (Symbol id, rhs)) => NType (id, [lhs, rhs]))) toks
  19.192 +and parse_ty_arg toks =
  19.193 +  (parse_ident >> (rpair [] #> NType)
  19.194 +   || parse_sym nun_lparen |-- parse_ty --| parse_sym nun_rparen) toks;
  19.195 +
  19.196 +val parse_choice_or_unique =
  19.197 +  (parse_tok (Ident nun_choice) || parse_tok (Ident nun_unique)
  19.198 +   || parse_tok (Ident nun_unique_unsafe))
  19.199 +  -- parse_ty_arg
  19.200 +  >> (fn (Ident id, ty) => NConst (id, [ty], mk_arrows_ty ([ty, prop_ty], ty)));
  19.201 +
  19.202 +fun parse_tm toks =
  19.203 +  (parse_id nun_lambda |-- Scan.repeat parse_arg --| parse_sym nun_dot -- parse_tm >> nabss
  19.204 +  || parse_id nun_mu |-- parse_arg --| parse_sym nun_dot -- parse_tm
  19.205 +     >> (fn (var, body) =>
  19.206 +       let val ty = safe_ty_of body in
  19.207 +         NApp (NConst (nun_mu, [ty], mk_arrow_ty (mk_arrow_ty (ty, ty), ty)), NAbs (var, body))
  19.208 +       end)
  19.209 +   || parse_id nun_if |-- parse_tm --| parse_id nun_then -- parse_tm --| parse_id nun_else
  19.210 +       -- parse_tm
  19.211 +     >> (fn ((cond, th), el) =>
  19.212 +       let val ty = safe_ty_of th in
  19.213 +         napps (NConst (nun_if, [ty], mk_arrows_ty ([prop_ty, ty, ty], ty)), [cond, th, el])
  19.214 +       end)
  19.215 +   || parse_implies) toks
  19.216 +and parse_implies toks =
  19.217 +  (parse_disj -- Scan.option (parse_sym nun_implies -- parse_implies)
  19.218 +   >> (fn (tm, NONE) => tm
  19.219 +     | (lhs, SOME (Symbol id, rhs)) => napps (NConst (id, [], dummy_ty), [lhs, rhs]))) toks
  19.220 +and parse_disj toks =
  19.221 +  (parse_conj -- Scan.option (parse_sym nun_disj -- parse_disj)
  19.222 +   >> (fn (tm, NONE) => tm
  19.223 +     | (lhs, SOME (Symbol id, rhs)) => napps (NConst (id, [], dummy_ty), [lhs, rhs]))) toks
  19.224 +and parse_conj toks =
  19.225 +  (parse_equals -- Scan.option (parse_sym nun_conj -- parse_conj)
  19.226 +   >> (fn (tm, NONE) => tm
  19.227 +     | (lhs, SOME (Symbol id, rhs)) => napps (NConst (id, [], dummy_ty), [lhs, rhs]))) toks
  19.228 +and parse_equals toks =
  19.229 +  (parse_comb -- Scan.option (parse_sym nun_equals -- parse_comb)
  19.230 +   >> (fn (tm, NONE) => tm
  19.231 +     | (lhs, SOME (Symbol id, rhs)) => napps (NConst (id, [], dummy_ty), [lhs, rhs]))) toks
  19.232 +and parse_comb toks =
  19.233 +  (parse_arg -- Scan.repeat (Scan.unless parse_confusing_id parse_arg) >> napps) toks
  19.234 +and parse_arg toks =
  19.235 +  (parse_choice_or_unique
  19.236 +   || parse_ident >> (fn id => NConst (id, [], dummy_ty))
  19.237 +   || parse_sym nun_irrelevant
  19.238 +      |-- Scan.option (parse_sym nun_lparen |-- parse_tm --| parse_sym nun_rparen) (* FIXME *)
  19.239 +     >> (fn _ => NConst (nun_irrelevant, [], dummy_ty))
  19.240 +   || parse_sym nun_unparsable |-- parse_ty >> (fn ty => NConst (nun_unparsable, [], ty))
  19.241 +   || parse_sym nun_lparen |-- parse_tm -- Scan.option (parse_sym nun_colon |-- parse_ty)
  19.242 +      --| parse_sym nun_rparen
  19.243 +     >> (fn (NConst (id, [], _), SOME ty) => NConst (id, [], ty)
  19.244 +       | (tm, _) => tm)
  19.245 +   || parse_atom >> (fn (id, j) => NAtom (j, NType (id, [])))) toks;
  19.246 +
  19.247 +val parse_witness_name =
  19.248 +  parse_ident >> (fn id => NConst (hd (space_explode "/" id), [], dummy_ty));
  19.249 +
  19.250 +val parse_witness =
  19.251 +  parse_id nun__witness_of |-- parse_sym nun_lparen |-- (parse_id nun_forall || parse_id nun_exists)
  19.252 +  |-- Scan.option (parse_sym nun_lparen) |-- parse_witness_name
  19.253 +  --| Scan.repeat (Scan.one (curry (op <>) (Symbol nun_assign)));
  19.254 +
  19.255 +datatype entry =
  19.256 +  Type_Entry of ty_entry
  19.257 +| Skolem_Entry of tm_entry
  19.258 +| Const_Entry of tm_entry;
  19.259 +
  19.260 +val parse_entry =
  19.261 +  (parse_id nun_type |-- parse_ty --| parse_sym nun_assign --| parse_sym nun_lbrace --
  19.262 +       parse_enum (parse_sym nun_comma) parse_tm --| parse_sym nun_rbrace
  19.263 +     >> Type_Entry
  19.264 +   || parse_id nun_val |-- parse_witness --| parse_sym nun_assign -- parse_tm >> Skolem_Entry
  19.265 +   || parse_id nun_val |-- parse_tm --| parse_sym nun_assign -- parse_tm >> Const_Entry)
  19.266 +  --| parse_sym nun_dot;
  19.267 +
  19.268 +val parse_model =
  19.269 +  parse_id nun_SAT |-- parse_sym nun_colon |-- parse_sym nun_lbrace |-- Scan.repeat parse_entry
  19.270 +  --| parse_sym nun_rbrace;
  19.271 +
  19.272 +fun add_entry entry ({type_model, const_model, skolem_model} : nun_model) =
  19.273 +  (case entry of
  19.274 +    Type_Entry e =>
  19.275 +    {type_model = e :: type_model, const_model = const_model, skolem_model = skolem_model}
  19.276 +  | Skolem_Entry e =>
  19.277 +    {type_model = type_model, const_model = const_model, skolem_model = e :: skolem_model}
  19.278 +  | Const_Entry e =>
  19.279 +    {type_model = type_model, const_model = e :: const_model, skolem_model = skolem_model});
  19.280 +
  19.281 +fun nun_model_of_str str =
  19.282 +  let val (entries, _) = parse_model (tokenize str) in
  19.283 +    {type_model = [], const_model = [], skolem_model = []}
  19.284 +    |> fold_rev add_entry entries
  19.285 +  end;
  19.286 +
  19.287 +end;
    20.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.2 +++ b/src/HOL/Tools/Nunchaku/nunchaku_problem.ML	Fri Sep 08 00:01:36 2017 +0200
    20.3 @@ -0,0 +1,799 @@
    20.4 +(*  Title:      HOL/Nunchaku/Tools/nunchaku_problem.ML
    20.5 +    Author:     Jasmin Blanchette, VU Amsterdam
    20.6 +    Copyright   2015, 2016, 2017
    20.7 +
    20.8 +Abstract syntax tree for Nunchaku problems.
    20.9 +*)
   20.10 +
   20.11 +signature NUNCHAKU_PROBLEM =
   20.12 +sig
   20.13 +  eqtype ident
   20.14 +
   20.15 +  datatype ty =
   20.16 +    NType of ident * ty list
   20.17 +
   20.18 +  datatype tm =
   20.19 +    NAtom of int * ty
   20.20 +  | NConst of ident * ty list * ty
   20.21 +  | NAbs of tm * tm
   20.22 +  | NMatch of tm * (ident * tm list * tm) list
   20.23 +  | NApp of tm * tm
   20.24 +
   20.25 +  type nun_copy_spec =
   20.26 +    {abs_ty: ty,
   20.27 +     rep_ty: ty,
   20.28 +     subset: tm option,
   20.29 +     quotient: tm option,
   20.30 +     abs: tm,
   20.31 +     rep: tm}
   20.32 +
   20.33 +  type nun_ctr_spec =
   20.34 +    {ctr: tm,
   20.35 +     arg_tys: ty list}
   20.36 +
   20.37 +  type nun_co_data_spec =
   20.38 +    {ty: ty,
   20.39 +     ctrs: nun_ctr_spec list}
   20.40 +
   20.41 +  type nun_const_spec =
   20.42 +    {const: tm,
   20.43 +     props: tm list}
   20.44 +
   20.45 +  type nun_consts_spec =
   20.46 +    {consts: tm list,
   20.47 +     props: tm list}
   20.48 +
   20.49 +  datatype nun_command =
   20.50 +    NTVal of ty * (int option * int option)
   20.51 +  | NCopy of nun_copy_spec
   20.52 +  | NData of nun_co_data_spec list
   20.53 +  | NCodata of nun_co_data_spec list
   20.54 +  | NVal of tm * ty
   20.55 +  | NPred of bool * nun_const_spec list
   20.56 +  | NCopred of nun_const_spec list
   20.57 +  | NRec of nun_const_spec list
   20.58 +  | NSpec of nun_consts_spec
   20.59 +  | NAxiom of tm
   20.60 +  | NGoal of tm
   20.61 +  | NEval of tm
   20.62 +
   20.63 +  type nun_problem =
   20.64 +    {commandss: nun_command list list,
   20.65 +     sound: bool,
   20.66 +     complete: bool}
   20.67 +
   20.68 +  type name_pool =
   20.69 +    {nice_of_ugly: string Symtab.table,
   20.70 +     ugly_of_nice: string Symtab.table}
   20.71 +
   20.72 +  val nun_abstract: string
   20.73 +  val nun_and: string
   20.74 +  val nun_anon_fun_prefix: string
   20.75 +  val nun_arrow: string
   20.76 +  val nun_asserting: string
   20.77 +  val nun_assign: string
   20.78 +  val nun_at: string
   20.79 +  val nun_axiom: string
   20.80 +  val nun_bar: string
   20.81 +  val nun_choice: string
   20.82 +  val nun_codata: string
   20.83 +  val nun_colon: string
   20.84 +  val nun_comma: string
   20.85 +  val nun_concrete: string
   20.86 +  val nun_conj: string
   20.87 +  val nun_copred: string
   20.88 +  val nun_copy: string
   20.89 +  val nun_data: string
   20.90 +  val nun_disj: string
   20.91 +  val nun_dollar: string
   20.92 +  val nun_dot: string
   20.93 +  val nun_dummy: string
   20.94 +  val nun_else: string
   20.95 +  val nun_end: string
   20.96 +  val nun_equals: string
   20.97 +  val nun_eval: string
   20.98 +  val nun_exists: string
   20.99 +  val nun_false: string
  20.100 +  val nun_forall: string
  20.101 +  val nun_goal: string
  20.102 +  val nun_hash: string
  20.103 +  val nun_if: string
  20.104 +  val nun_implies: string
  20.105 +  val nun_irrelevant: string
  20.106 +  val nun_lambda: string
  20.107 +  val nun_lbrace: string
  20.108 +  val nun_lbracket: string
  20.109 +  val nun_lparen: string
  20.110 +  val nun_match: string
  20.111 +  val nun_mu: string
  20.112 +  val nun_not: string
  20.113 +  val nun_partial_quotient: string
  20.114 +  val nun_pred: string
  20.115 +  val nun_prop: string
  20.116 +  val nun_quotient: string
  20.117 +  val nun_rbrace: string
  20.118 +  val nun_rbracket: string
  20.119 +  val nun_rec: string
  20.120 +  val nun_rparen: string
  20.121 +  val nun_semicolon: string
  20.122 +  val nun_spec: string
  20.123 +  val nun_subset: string
  20.124 +  val nun_then: string
  20.125 +  val nun_true: string
  20.126 +  val nun_type: string
  20.127 +  val nun_unparsable: string
  20.128 +  val nun_unique: string
  20.129 +  val nun_unique_unsafe: string
  20.130 +  val nun_val: string
  20.131 +  val nun_wf: string
  20.132 +  val nun_with: string
  20.133 +  val nun__witness_of: string
  20.134 +
  20.135 +  val ident_of_str: string -> ident
  20.136 +  val str_of_ident: ident -> string
  20.137 +  val encode_args: string list -> string
  20.138 +  val nun_const_of_str: string list -> string -> ident
  20.139 +  val nun_tconst_of_str: string list -> string -> ident
  20.140 +  val nun_free_of_str: string -> ident
  20.141 +  val nun_tfree_of_str: string -> ident
  20.142 +  val nun_var_of_str: string -> ident
  20.143 +  val str_of_nun_const: ident -> string list * string
  20.144 +  val str_of_nun_tconst: ident -> string list * string
  20.145 +  val str_of_nun_free: ident -> string
  20.146 +  val str_of_nun_tfree: ident -> string
  20.147 +  val str_of_nun_var: ident -> string
  20.148 +
  20.149 +  val dummy_ty: ty
  20.150 +  val prop_ty: ty
  20.151 +  val mk_arrow_ty: ty * ty -> ty
  20.152 +  val mk_arrows_ty: ty list * ty -> ty
  20.153 +  val nabss: tm list * tm -> tm
  20.154 +  val napps: tm * tm list -> tm
  20.155 +
  20.156 +  val ty_of: tm -> ty
  20.157 +  val safe_ty_of: tm -> ty
  20.158 +
  20.159 +  val fold_map_ty_idents: (string -> 'a -> string * 'a) -> ty -> 'a -> ty * 'a
  20.160 +  val fold_map_tm_idents: (string -> 'a -> string * 'a) -> tm -> 'a -> tm * 'a
  20.161 +  val fold_map_nun_command_idents: (string -> 'a -> string * 'a) -> nun_command -> 'a ->
  20.162 +    nun_command * 'a
  20.163 +  val fold_map_nun_problem_idents: (string -> 'a -> string * 'a) -> nun_problem -> 'a ->
  20.164 +    nun_problem * 'a
  20.165 +
  20.166 +  val allocate_nice: name_pool -> string * string -> string * name_pool
  20.167 +
  20.168 +  val rcomb_tms: tm list -> tm -> tm
  20.169 +  val abs_tms: tm list -> tm -> tm
  20.170 +  val beta_reduce_tm: tm -> tm
  20.171 +  val eta_expandN_tm: int -> tm -> tm
  20.172 +  val eta_expand_builtin_tm: tm -> tm
  20.173 +
  20.174 +  val str_of_ty: ty -> string
  20.175 +  val str_of_tm: tm -> string
  20.176 +  val str_of_tmty: tm -> string
  20.177 +
  20.178 +  val nice_nun_problem: nun_problem -> nun_problem * name_pool
  20.179 +  val str_of_nun_problem: nun_problem -> string
  20.180 +end;
  20.181 +
  20.182 +structure Nunchaku_Problem : NUNCHAKU_PROBLEM =
  20.183 +struct
  20.184 +
  20.185 +open Nunchaku_Util;
  20.186 +
  20.187 +type ident = string;
  20.188 +
  20.189 +datatype ty =
  20.190 +  NType of ident * ty list;
  20.191 +
  20.192 +datatype tm =
  20.193 +  NAtom of int * ty
  20.194 +| NConst of ident * ty list * ty
  20.195 +| NAbs of tm * tm
  20.196 +| NMatch of tm * (ident * tm list * tm) list
  20.197 +| NApp of tm * tm;
  20.198 +
  20.199 +type nun_copy_spec =
  20.200 +  {abs_ty: ty,
  20.201 +   rep_ty: ty,
  20.202 +   subset: tm option,
  20.203 +   quotient: tm option,
  20.204 +   abs: tm,
  20.205 +   rep: tm};
  20.206 +
  20.207 +type nun_ctr_spec =
  20.208 +  {ctr: tm,
  20.209 +   arg_tys: ty list};
  20.210 +
  20.211 +type nun_co_data_spec =
  20.212 +  {ty: ty,
  20.213 +   ctrs: nun_ctr_spec list};
  20.214 +
  20.215 +type nun_const_spec =
  20.216 +  {const: tm,
  20.217 +   props: tm list};
  20.218 +
  20.219 +type nun_consts_spec =
  20.220 +  {consts: tm list,
  20.221 +   props: tm list};
  20.222 +
  20.223 +datatype nun_command =
  20.224 +  NTVal of ty * (int option * int option)
  20.225 +| NCopy of nun_copy_spec
  20.226 +| NData of nun_co_data_spec list
  20.227 +| NCodata of nun_co_data_spec list
  20.228 +| NVal of tm * ty
  20.229 +| NPred of bool * nun_const_spec list
  20.230 +| NCopred of nun_const_spec list
  20.231 +| NRec of nun_const_spec list
  20.232 +| NSpec of nun_consts_spec
  20.233 +| NAxiom of tm
  20.234 +| NGoal of tm
  20.235 +| NEval of tm;
  20.236 +
  20.237 +type nun_problem =
  20.238 +  {commandss: nun_command list list,
  20.239 +   sound: bool,
  20.240 +   complete: bool};
  20.241 +
  20.242 +type name_pool =
  20.243 +  {nice_of_ugly: string Symtab.table,
  20.244 +   ugly_of_nice: string Symtab.table};
  20.245 +
  20.246 +val nun_abstract = "abstract";
  20.247 +val nun_and = "and";
  20.248 +val nun_anon_fun_prefix = "anon_fun_";
  20.249 +val nun_arrow = "->";
  20.250 +val nun_asserting = "asserting";
  20.251 +val nun_assign = ":=";
  20.252 +val nun_at = "@";
  20.253 +val nun_axiom = "axiom";
  20.254 +val nun_bar = "|";
  20.255 +val nun_choice = "choice";
  20.256 +val nun_codata = "codata";
  20.257 +val nun_colon = ":";
  20.258 +val nun_comma = ",";
  20.259 +val nun_concrete = "concrete";
  20.260 +val nun_conj = "&&";
  20.261 +val nun_copred = "copred";
  20.262 +val nun_copy = "copy";
  20.263 +val nun_data = "data";
  20.264 +val nun_disj = "||";
  20.265 +val nun_dollar = "$";
  20.266 +val nun_dot = ".";
  20.267 +val nun_dummy = "_";
  20.268 +val nun_else = "else";
  20.269 +val nun_end = "end";
  20.270 +val nun_equals = "=";
  20.271 +val nun_eval = "eval";
  20.272 +val nun_exists = "exists";
  20.273 +val nun_false = "false";
  20.274 +val nun_forall = "forall";
  20.275 +val nun_goal = "goal";
  20.276 +val nun_hash = "#";
  20.277 +val nun_if = "if";
  20.278 +val nun_implies = "=>";
  20.279 +val nun_irrelevant = "?__";
  20.280 +val nun_lambda = "fun";
  20.281 +val nun_lbrace = "{";
  20.282 +val nun_lbracket = "[";
  20.283 +val nun_lparen = "(";
  20.284 +val nun_match = "match";
  20.285 +val nun_mu = "mu";
  20.286 +val nun_not = "~";
  20.287 +val nun_partial_quotient = "partial_quotient";
  20.288 +val nun_pred = "pred";
  20.289 +val nun_prop = "prop";
  20.290 +val nun_quotient = "quotient";
  20.291 +val nun_rbrace = "}";
  20.292 +val nun_rbracket = "]";
  20.293 +val nun_rec = "rec";
  20.294 +val nun_rparen = ")";
  20.295 +val nun_semicolon = ";";
  20.296 +val nun_spec = "spec";
  20.297 +val nun_subset = "subset";
  20.298 +val nun_then = "then";
  20.299 +val nun_true = "true";
  20.300 +val nun_type = "type";
  20.301 +val nun_unique = "unique";
  20.302 +val nun_unique_unsafe = "unique_unsafe";
  20.303 +val nun_unparsable = "?__unparsable";
  20.304 +val nun_val = "val";
  20.305 +val nun_wf = "wf";
  20.306 +val nun_with = "with";
  20.307 +val nun__witness_of = "_witness_of";
  20.308 +
  20.309 +val nun_parens = enclose nun_lparen nun_rparen;
  20.310 +
  20.311 +fun nun_parens_if_space s = s |> String.isSubstring " " s ? nun_parens;
  20.312 +
  20.313 +fun str_of_nun_arg_list str_of_arg =
  20.314 +  map (prefix " " o nun_parens_if_space o str_of_arg) #> space_implode "";
  20.315 +
  20.316 +fun str_of_nun_and_list str_of_elem =
  20.317 +  map str_of_elem #> space_implode ("\n" ^ nun_and ^ " ");
  20.318 +
  20.319 +val is_nun_const_quantifier = member (op =) [nun_forall, nun_exists];
  20.320 +val is_nun_const_connective = member (op =) [nun_conj, nun_disj, nun_implies];
  20.321 +
  20.322 +val nun_builtin_arity =
  20.323 +  [(nun_asserting, 2),
  20.324 +   (nun_conj, 2),
  20.325 +   (nun_disj, 2),
  20.326 +   (nun_equals, 2),
  20.327 +   (nun_exists, 1),
  20.328 +   (nun_false, 0),
  20.329 +   (nun_forall, 1),
  20.330 +   (nun_if, 3),
  20.331 +   (nun_implies, 2),
  20.332 +   (nun_not, 1),
  20.333 +   (nun_true, 0)];
  20.334 +
  20.335 +val arity_of_nun_builtin = AList.lookup (op =) nun_builtin_arity #> the_default 0;
  20.336 +
  20.337 +val nun_const_prefix = "c.";
  20.338 +val nun_free_prefix = "f.";
  20.339 +val nun_var_prefix = "v.";
  20.340 +val nun_tconst_prefix = "C.";
  20.341 +val nun_tfree_prefix = "F.";
  20.342 +val nun_custom_id_suffix = "_";
  20.343 +
  20.344 +val ident_of_str = I : string -> ident;
  20.345 +val str_of_ident = I : ident -> string;
  20.346 +
  20.347 +val encode_args = enclose "(" ")" o commas;
  20.348 +
  20.349 +fun decode_args s =
  20.350 +  let
  20.351 +    fun delta #"(" = 1
  20.352 +      | delta #")" = ~1
  20.353 +      | delta _ = 0;
  20.354 +
  20.355 +    fun dec 0 (#"(" :: #")" :: cs) _ = ([], String.implode cs)
  20.356 +      | dec 0 (#"(" :: cs) [] = dec 1 cs [[]]
  20.357 +      | dec 0 cs _ = ([], String.implode cs)
  20.358 +      | dec _ [] _ = raise Fail ("ill-formed arguments in " ^ quote s)
  20.359 +      | dec 1 (#")" :: cs) args = (rev (map (String.implode o rev) args), String.implode cs)
  20.360 +      | dec 1 (#"," :: cs) args = dec 1 cs ([] :: args)
  20.361 +      | dec n (c :: cs) (arg :: args) = dec (n + delta c) cs ((c :: arg) :: args);
  20.362 +  in
  20.363 +    dec 0 (String.explode s) []
  20.364 +  end;
  20.365 +
  20.366 +fun nun_const_of_str args =
  20.367 +  suffix nun_custom_id_suffix #> prefix nun_const_prefix #> prefix (encode_args args);
  20.368 +fun nun_tconst_of_str args =
  20.369 +  suffix nun_custom_id_suffix #> prefix nun_tconst_prefix #> prefix (encode_args args);
  20.370 +
  20.371 +val nun_free_of_str = suffix nun_custom_id_suffix #> prefix nun_free_prefix;
  20.372 +val nun_tfree_of_str = suffix nun_custom_id_suffix #> prefix nun_tfree_prefix;
  20.373 +val nun_var_of_str = suffix nun_custom_id_suffix #> prefix nun_var_prefix;
  20.374 +val str_of_nun_const = decode_args ##> unprefix nun_const_prefix ##> unsuffix nun_custom_id_suffix;
  20.375 +val str_of_nun_tconst = decode_args ##> unprefix nun_tconst_prefix ##> unsuffix nun_custom_id_suffix;
  20.376 +val str_of_nun_free = unprefix nun_free_prefix #> unsuffix nun_custom_id_suffix;
  20.377 +val str_of_nun_tfree = unprefix nun_tfree_prefix #> unsuffix nun_custom_id_suffix;
  20.378 +val str_of_nun_var = unprefix nun_var_prefix #> unsuffix nun_custom_id_suffix;
  20.379 +
  20.380 +fun index_name s 0 = s
  20.381 +  | index_name s j =
  20.382 +    let
  20.383 +      val n = size s;
  20.384 +      val m = n - 1;
  20.385 +    in
  20.386 +      String.substring (s, 0, m) ^ string_of_int j ^ String.substring (s, m, n - m)
  20.387 +    end;
  20.388 +
  20.389 +val dummy_ty = NType (nun_dummy, []);
  20.390 +val prop_ty = NType (nun_prop, []);
  20.391 +
  20.392 +fun mk_arrow_ty (dom, ran) = NType (nun_arrow, [dom, ran]);
  20.393 +val mk_arrows_ty = Library.foldr mk_arrow_ty;
  20.394 +
  20.395 +val nabss = Library.foldr NAbs;
  20.396 +val napps = Library.foldl NApp;
  20.397 +
  20.398 +fun domain_ty (NType (_, [ty, _])) = ty
  20.399 +  | domain_ty ty = ty;
  20.400 +
  20.401 +fun range_ty (NType (_, [_, ty])) = ty
  20.402 +  | range_ty ty = ty;
  20.403 +
  20.404 +fun domain_tys 0 _ = []
  20.405 +  | domain_tys n ty = domain_ty ty :: domain_tys (n - 1) (range_ty ty);
  20.406 +
  20.407 +fun ty_of (NAtom (_, ty)) = ty
  20.408 +  | ty_of (NConst (_, _, ty)) = ty
  20.409 +  | ty_of (NAbs (var, body)) = mk_arrow_ty (ty_of var, ty_of body)
  20.410 +  | ty_of (NMatch (_, (_, _, body1) :: _)) = ty_of body1
  20.411 +  | ty_of (NApp (const, _)) = range_ty (ty_of const);
  20.412 +
  20.413 +val safe_ty_of = try ty_of #> the_default dummy_ty;
  20.414 +
  20.415 +fun strip_nun_binders binder (app as NApp (NConst (id, _, _), NAbs (var, body))) =
  20.416 +    if id = binder then
  20.417 +      strip_nun_binders binder body
  20.418 +      |>> cons var
  20.419 +    else
  20.420 +      ([], app)
  20.421 +  | strip_nun_binders _ tm = ([], tm);
  20.422 +
  20.423 +fun fold_map_option _ NONE = pair NONE
  20.424 +  | fold_map_option f (SOME x) = f x #>> SOME;
  20.425 +
  20.426 +fun fold_map_ty_idents f (NType (id, tys)) =
  20.427 +    f id
  20.428 +    ##>> fold_map (fold_map_ty_idents f) tys
  20.429 +    #>> NType;
  20.430 +
  20.431 +fun fold_map_match_branch_idents f (id, vars, body) =
  20.432 +    f id
  20.433 +    ##>> fold_map (fold_map_tm_idents f) vars
  20.434 +    ##>> fold_map_tm_idents f body
  20.435 +    #>> Scan.triple1
  20.436 +and fold_map_tm_idents f (NAtom (j, ty)) =
  20.437 +    fold_map_ty_idents f ty
  20.438 +    #>> curry NAtom j
  20.439 +  | fold_map_tm_idents f (NConst (id, tys, ty)) =
  20.440 +    f id
  20.441 +    ##>> fold_map (fold_map_ty_idents f) tys
  20.442 +    ##>> fold_map_ty_idents f ty
  20.443 +    #>> (Scan.triple1 #> NConst)
  20.444 +  | fold_map_tm_idents f (NAbs (var, body)) =
  20.445 +    fold_map_tm_idents f var
  20.446 +    ##>> fold_map_tm_idents f body
  20.447 +    #>> NAbs
  20.448 +  | fold_map_tm_idents f (NMatch (obj, branches)) =
  20.449 +    fold_map_tm_idents f obj
  20.450 +    ##>> fold_map (fold_map_match_branch_idents f) branches
  20.451 +    #>> NMatch
  20.452 +  | fold_map_tm_idents f (NApp (const, arg)) =
  20.453 +    fold_map_tm_idents f const
  20.454 +    ##>> fold_map_tm_idents f arg
  20.455 +    #>> NApp;
  20.456 +
  20.457 +fun fold_map_nun_copy_spec_idents f {abs_ty, rep_ty, subset, quotient, abs, rep} =
  20.458 +  fold_map_ty_idents f abs_ty
  20.459 +  ##>> fold_map_ty_idents f rep_ty
  20.460 +  ##>> fold_map_option (fold_map_tm_idents f) subset
  20.461 +  ##>> fold_map_option (fold_map_tm_idents f) quotient
  20.462 +  ##>> fold_map_tm_idents f abs
  20.463 +  ##>> fold_map_tm_idents f rep
  20.464 +  #>> (fn (((((abs_ty, rep_ty), subset), quotient), abs), rep) =>
  20.465 +    {abs_ty = abs_ty, rep_ty = rep_ty, subset = subset, quotient = quotient, abs = abs, rep = rep});
  20.466 +
  20.467 +fun fold_map_nun_ctr_spec_idents f {ctr, arg_tys} =
  20.468 +  fold_map_tm_idents f ctr
  20.469 +  ##>> fold_map (fold_map_ty_idents f) arg_tys
  20.470 +  #>> (fn (ctr, arg_tys) => {ctr = ctr, arg_tys = arg_tys});
  20.471 +
  20.472 +fun fold_map_nun_co_data_spec_idents f {ty, ctrs} =
  20.473 +  fold_map_ty_idents f ty
  20.474 +  ##>> fold_map (fold_map_nun_ctr_spec_idents f) ctrs
  20.475 +  #>> (fn (ty, ctrs) => {ty = ty, ctrs = ctrs});
  20.476 +
  20.477 +fun fold_map_nun_const_spec_idents f {const, props} =
  20.478 +  fold_map_tm_idents f const
  20.479 +  ##>> fold_map (fold_map_tm_idents f) props
  20.480 +  #>> (fn (const, props) => {const = const, props = props});
  20.481 +
  20.482 +fun fold_map_nun_consts_spec_idents f {consts, props} =
  20.483 +  fold_map (fold_map_tm_idents f) consts
  20.484 +  ##>> fold_map (fold_map_tm_idents f) props
  20.485 +  #>> (fn (consts, props) => {consts = consts, props = props});
  20.486 +
  20.487 +fun fold_map_nun_command_idents f (NTVal (ty, cards)) =
  20.488 +    fold_map_ty_idents f ty
  20.489 +    #>> (rpair cards #> NTVal)
  20.490 +  | fold_map_nun_command_idents f (NCopy spec) =
  20.491 +    fold_map_nun_copy_spec_idents f spec
  20.492 +    #>> NCopy
  20.493 +  | fold_map_nun_command_idents f (NData specs) =
  20.494 +    fold_map (fold_map_nun_co_data_spec_idents f) specs
  20.495 +    #>> NData
  20.496 +  | fold_map_nun_command_idents f (NCodata specs) =
  20.497 +    fold_map (fold_map_nun_co_data_spec_idents f) specs
  20.498 +    #>> NCodata
  20.499 +  | fold_map_nun_command_idents f (NVal (tm, ty)) =
  20.500 +    fold_map_tm_idents f tm
  20.501 +    ##>> fold_map_ty_idents f ty
  20.502 +    #>> NVal
  20.503 +  | fold_map_nun_command_idents f (NPred (wf, specs)) =
  20.504 +    fold_map (fold_map_nun_const_spec_idents f) specs
  20.505 +    #>> curry NPred wf
  20.506 +  | fold_map_nun_command_idents f (NCopred specs) =
  20.507 +    fold_map (fold_map_nun_const_spec_idents f) specs
  20.508 +    #>> NCopred
  20.509 +  | fold_map_nun_command_idents f (NRec specs) =
  20.510 +    fold_map (fold_map_nun_const_spec_idents f) specs
  20.511 +    #>> NRec
  20.512 +  | fold_map_nun_command_idents f (NSpec spec) =
  20.513 +    fold_map_nun_consts_spec_idents f spec
  20.514 +    #>> NSpec
  20.515 +  | fold_map_nun_command_idents f (NAxiom tm) =
  20.516 +    fold_map_tm_idents f tm
  20.517 +    #>> NAxiom
  20.518 +  | fold_map_nun_command_idents f (NGoal tm) =
  20.519 +    fold_map_tm_idents f tm
  20.520 +    #>> NGoal
  20.521 +  | fold_map_nun_command_idents f (NEval tm) =
  20.522 +    fold_map_tm_idents f tm
  20.523 +    #>> NEval;
  20.524 +
  20.525 +fun fold_map_nun_problem_idents f ({commandss, sound, complete} : nun_problem) =
  20.526 +  fold_map (fold_map (fold_map_nun_command_idents f)) commandss
  20.527 +  #>> (fn commandss' => {commandss = commandss', sound = sound, complete = complete});
  20.528 +
  20.529 +fun dest_rassoc_args oper arg0 rest =
  20.530 +  (case rest of
  20.531 +    NApp (NApp (oper', arg1), rest') =>
  20.532 +    if oper' = oper then arg0 :: dest_rassoc_args oper arg1 rest' else [arg0, rest]
  20.533 +  | _ => [arg0, rest]);
  20.534 +
  20.535 +fun replace_tm from to =
  20.536 +  let
  20.537 +    (* This code assumes all enclosing binders bind distinct variables and bound variables are
  20.538 +       distinct from any other variables. *)
  20.539 +    fun repl_br (id, vars, body) = (id, map repl vars, repl body)
  20.540 +    and repl (NApp (const, arg)) = NApp (repl const, repl arg)
  20.541 +      | repl (NAbs (var, body)) = NAbs (var, repl body)
  20.542 +      | repl (NMatch (obj, branches)) = NMatch (repl obj, map repl_br branches)
  20.543 +      | repl tm = if tm = from then to else tm;
  20.544 +  in
  20.545 +    repl
  20.546 +  end;
  20.547 +
  20.548 +val rcomb_tms = fold (fn arg => fn func => NApp (func, arg));
  20.549 +val abs_tms = fold_rev (curry NAbs);
  20.550 +
  20.551 +fun fresh_var_names_wrt_tm n tm =
  20.552 +  let
  20.553 +    fun max_var_br (_, vars, body) = fold max_var (body :: vars)
  20.554 +    and max_var (NAtom _) = I
  20.555 +      | max_var (NConst (id, _, _)) =
  20.556 +        (fn max => if String.isPrefix nun_var_prefix id andalso size id > size max then id else max)
  20.557 +      | max_var (NApp (func, arg)) = fold max_var [func, arg]
  20.558 +      | max_var (NAbs (var, body)) = fold max_var [var, body]
  20.559 +      | max_var (NMatch (obj, branches)) = max_var obj #> fold max_var_br branches;
  20.560 +
  20.561 +    val dummy_name = nun_var_of_str Name.uu;
  20.562 +    val max_name = max_var tm dummy_name;
  20.563 +  in
  20.564 +    map (index_name max_name) (1 upto n)
  20.565 +  end;
  20.566 +
  20.567 +fun beta_reduce_tm (NApp (NAbs (var, body), arg)) = beta_reduce_tm (replace_tm var arg body)
  20.568 +  | beta_reduce_tm (NApp (const, arg)) =
  20.569 +    (case beta_reduce_tm const of
  20.570 +      const' as NAbs _ => beta_reduce_tm (NApp (const', arg))
  20.571 +    | const' => NApp (const', beta_reduce_tm arg))
  20.572 +  | beta_reduce_tm (NAbs (var, body)) = NAbs (var, beta_reduce_tm body)
  20.573 +  | beta_reduce_tm (NMatch (obj, branches)) =
  20.574 +    NMatch (beta_reduce_tm obj, map (@{apply 3(3)} beta_reduce_tm) branches)
  20.575 +  | beta_reduce_tm tm = tm;
  20.576 +
  20.577 +fun eta_expandN_tm 0 tm = tm
  20.578 +  | eta_expandN_tm n tm =
  20.579 +    let
  20.580 +      val var_names = fresh_var_names_wrt_tm n tm;
  20.581 +      val arg_tys = domain_tys n (ty_of tm);
  20.582 +      val vars = map2 (fn id => fn ty => NConst (id, [], ty)) var_names arg_tys;
  20.583 +    in
  20.584 +      abs_tms vars (rcomb_tms vars tm)
  20.585 +    end;
  20.586 +
  20.587 +val eta_expand_builtin_tm =
  20.588 +  let
  20.589 +    fun expand_quant_arg (NAbs (var, body)) = NAbs (var, expand_quant_arg body)
  20.590 +      | expand_quant_arg (NMatch (obj, branches)) =
  20.591 +        NMatch (obj, map (@{apply 3(3)} expand_quant_arg) branches)
  20.592 +      | expand_quant_arg (tm as NApp (_, NAbs _)) = tm
  20.593 +      | expand_quant_arg (NApp (quant, arg)) = NApp (quant, eta_expandN_tm 1 arg)
  20.594 +      | expand_quant_arg tm = tm;
  20.595 +
  20.596 +    fun expand args (NApp (func, arg)) = expand (expand [] arg :: args) func
  20.597 +      | expand args (func as NConst (id, _, _)) =
  20.598 +        let val missing = Int.max (0, arity_of_nun_builtin id - length args) in
  20.599 +          rcomb_tms args func
  20.600 +          |> eta_expandN_tm missing
  20.601 +          |> is_nun_const_quantifier id ? expand_quant_arg
  20.602 +        end
  20.603 +      | expand args (func as NAtom _) = rcomb_tms args func
  20.604 +      | expand args (NAbs (var, body)) = rcomb_tms args (NAbs (var, expand [] body))
  20.605 +      | expand args (NMatch (obj, branches)) =
  20.606 +        rcomb_tms args (NMatch (obj, map (@{apply 3(3)} (expand [])) branches));
  20.607 +  in
  20.608 +    expand []
  20.609 +  end;
  20.610 +
  20.611 +val str_of_ty =
  20.612 +  let
  20.613 +    fun str_of maybe_parens (NType (id, tys)) =
  20.614 +      if id = nun_arrow then
  20.615 +        (case tys of
  20.616 +          [ty, ty'] => maybe_parens (str_of nun_parens ty ^ " " ^ nun_arrow ^ " " ^ str_of I ty'))
  20.617 +      else
  20.618 +        id ^ str_of_nun_arg_list (str_of I) tys
  20.619 +  in
  20.620 +    str_of I
  20.621 +  end;
  20.622 +
  20.623 +val (str_of_tmty, str_of_tm) =
  20.624 +  let
  20.625 +    fun is_triv_head (NConst (id, _, _)) = (arity_of_nun_builtin id = 0)
  20.626 +      | is_triv_head (NAtom _) = true
  20.627 +      | is_triv_head (NApp (const, _)) = is_triv_head const
  20.628 +      | is_triv_head (NAbs _) = false
  20.629 +      | is_triv_head (NMatch _) = false;
  20.630 +
  20.631 +    fun str_of_at_const id tys =
  20.632 +      nun_at ^ str_of_ident id ^ str_of_nun_arg_list str_of_ty tys;
  20.633 +
  20.634 +    fun str_of_app ty_opt const arg =
  20.635 +      let
  20.636 +        val ty_opt' =
  20.637 +          try (Option.map (fn ty => mk_arrow_ty (ty_of arg, ty))) ty_opt
  20.638 +          |> the_default NONE;
  20.639 +      in
  20.640 +        (str_of ty_opt' const |> (case const of NAbs _ => nun_parens | _ => I)) ^
  20.641 +        str_of_nun_arg_list (str_of NONE) [arg]
  20.642 +      end
  20.643 +    and str_of_br ty_opt (id, vars, body) =
  20.644 +      " " ^ nun_bar ^ " " ^ id ^ space_implode "" (map (prefix " " o str_of NONE) vars) ^ " " ^
  20.645 +      nun_arrow ^ " " ^ str_of ty_opt body
  20.646 +    and str_of_tmty tm =
  20.647 +      let val ty = ty_of tm in
  20.648 +        str_of (SOME ty) tm ^ " " ^ nun_colon ^ " " ^ str_of_ty ty
  20.649 +      end
  20.650 +    and str_of _ (NAtom (j, _)) = nun_dollar ^ string_of_int j
  20.651 +      | str_of _ (NConst (id, [], _)) = str_of_ident id
  20.652 +      | str_of (SOME ty0) (NConst (id, tys, ty)) =
  20.653 +        if ty = ty0 then str_of_ident id else str_of_at_const id tys
  20.654 +      | str_of _ (NConst (id, tys, _)) = str_of_at_const id tys
  20.655 +      | str_of ty_opt (NAbs (var, body)) =
  20.656 +        nun_lambda ^ " " ^
  20.657 +        (case ty_opt of
  20.658 +          SOME ty => str_of (SOME (domain_ty ty))
  20.659 +        | NONE => nun_parens o str_of_tmty) var ^
  20.660 +        nun_dot ^ " " ^ str_of (Option.map range_ty ty_opt) body
  20.661 +      | str_of ty_opt (NMatch (obj, branches)) =
  20.662 +        nun_match ^ " " ^ str_of NONE obj ^ " " ^ nun_with ^ " " ^
  20.663 +        space_implode "" (map (str_of_br ty_opt) branches) ^ " " ^ nun_end
  20.664 +      | str_of ty_opt (app as NApp (func, argN)) =
  20.665 +        (case (func, argN) of
  20.666 +          (NApp (oper as NConst (id, _, _), arg1), arg2) =>
  20.667 +          if id = nun_asserting then
  20.668 +            str_of ty_opt arg1 ^ " " ^ nun_asserting ^ " " ^ str_of (SOME prop_ty) arg2
  20.669 +            |> nun_parens
  20.670 +          else if id = nun_equals then
  20.671 +            (str_of NONE arg1 |> not (is_triv_head arg1) ? nun_parens) ^ " " ^ id ^ " " ^
  20.672 +            (str_of (try ty_of arg2) arg2 |> not (is_triv_head arg2) ? nun_parens)
  20.673 +          else if is_nun_const_connective id then
  20.674 +            let val args = dest_rassoc_args oper arg1 arg2 in
  20.675 +              space_implode (" " ^ id ^ " ")
  20.676 +                (map (fn arg => str_of NONE arg |> not (is_triv_head arg) ? nun_parens) args)
  20.677 +            end
  20.678 +          else
  20.679 +            str_of_app ty_opt func argN
  20.680 +        | (NApp (NApp (NConst (id, _, _), arg1), arg2), arg3) =>
  20.681 +          if id = nun_if then
  20.682 +            nun_if ^ " " ^ str_of NONE arg1 ^ " " ^ nun_then ^ " " ^ str_of NONE arg2 ^ " " ^
  20.683 +            nun_else ^ " " ^ str_of NONE arg3
  20.684 +            |> nun_parens
  20.685 +          else
  20.686 +            str_of_app ty_opt func argN
  20.687 +        | (NConst (id, _, _), NAbs _) =>
  20.688 +          if is_nun_const_quantifier id then
  20.689 +            let val (vars, body) = strip_nun_binders id app in
  20.690 +              id ^ " " ^ space_implode " " (map (nun_parens o str_of_tmty) vars) ^ nun_dot ^ " " ^
  20.691 +              str_of NONE body
  20.692 +            end
  20.693 +          else
  20.694 +            str_of_app ty_opt func argN
  20.695 +        | _ => str_of_app ty_opt func argN);
  20.696 +  in
  20.697 +    (str_of_tmty, str_of NONE)
  20.698 +  end;
  20.699 +
  20.700 +val empty_name_pool = {nice_of_ugly = Symtab.empty, ugly_of_nice = Symtab.empty};
  20.701 +
  20.702 +val nice_of_ugly_suggestion =
  20.703 +  unascii_of #> Long_Name.base_name #> ascii_of #> unsuffix nun_custom_id_suffix
  20.704 +  #> (fn s => if s = "" orelse not (Char.isAlpha (String.sub (s, 0))) then "x" ^ s else s);
  20.705 +
  20.706 +fun allocate_nice ({nice_of_ugly, ugly_of_nice} : name_pool) (ugly, nice_sugg0) =
  20.707 +  let
  20.708 +    fun alloc j =
  20.709 +      let val nice_sugg = index_name nice_sugg0 j in
  20.710 +        (case Symtab.lookup ugly_of_nice nice_sugg of
  20.711 +          NONE =>
  20.712 +          (nice_sugg,
  20.713 +           {nice_of_ugly = Symtab.update_new (ugly, nice_sugg) nice_of_ugly,
  20.714 +            ugly_of_nice = Symtab.update_new (nice_sugg, ugly) ugly_of_nice})
  20.715 +        | SOME _ => alloc (j + 1))
  20.716 +      end;
  20.717 +  in
  20.718 +    alloc 0
  20.719 +  end;
  20.720 +
  20.721 +fun nice_ident ugly (pool as {nice_of_ugly, ...}) =
  20.722 +  if String.isSuffix nun_custom_id_suffix ugly then
  20.723 +    (case Symtab.lookup nice_of_ugly ugly of
  20.724 +      NONE => allocate_nice pool (ugly, nice_of_ugly_suggestion ugly)
  20.725 +    | SOME nice => (nice, pool))
  20.726 +  else
  20.727 +    (ugly, pool);
  20.728 +
  20.729 +fun nice_nun_problem problem =
  20.730 +  fold_map_nun_problem_idents nice_ident problem empty_name_pool;
  20.731 +
  20.732 +fun str_of_tval (NType (id, tys)) =
  20.733 +  str_of_ident id ^ " " ^ nun_colon ^ " " ^
  20.734 +  fold (K (prefix (nun_type ^ " " ^ nun_arrow ^ " "))) tys nun_type;
  20.735 +
  20.736 +fun is_triv_subset (NAbs (_, body)) = is_triv_subset body
  20.737 +  | is_triv_subset (NConst (id, _, _)) = (id = nun_true)
  20.738 +  | is_triv_subset _ = false;
  20.739 +
  20.740 +fun str_of_nun_copy_spec {abs_ty, rep_ty, subset, quotient, abs, rep} =
  20.741 +  str_of_ty abs_ty ^ " " ^ nun_assign ^ " " ^ str_of_ty rep_ty ^
  20.742 +  (case subset of
  20.743 +    NONE => ""
  20.744 +  | SOME s => if is_triv_subset s then "" else "\n  " ^ nun_subset ^ " " ^ str_of_tm s) ^
  20.745 +  (* TODO: use nun_quotient when possible *)
  20.746 +  (case quotient of
  20.747 +    NONE => ""
  20.748 +  | SOME q => "\n  " ^ nun_partial_quotient ^ " " ^ str_of_tm q) ^
  20.749 +  "\n  " ^ nun_abstract ^ " " ^ str_of_tm abs ^ "\n  " ^ nun_concrete ^ " " ^ str_of_tm rep;
  20.750 +
  20.751 +fun str_of_nun_ctr_spec {ctr, arg_tys} =
  20.752 +  str_of_tm ctr ^ str_of_nun_arg_list str_of_ty arg_tys;
  20.753 +
  20.754 +fun str_of_nun_co_data_spec {ty, ctrs} =
  20.755 +  str_of_ty ty ^ " " ^ nun_assign ^ "\n  " ^
  20.756 +  space_implode ("\n" ^ nun_bar ^ " ") (map str_of_nun_ctr_spec ctrs);
  20.757 +
  20.758 +fun str_of_nun_const_spec {const, props} =
  20.759 +  str_of_tmty const ^ " " ^ nun_assign ^ "\n  " ^
  20.760 +  space_implode (nun_semicolon ^ "\n  ") (map str_of_tm props);
  20.761 +
  20.762 +fun str_of_nun_consts_spec {consts, props} =
  20.763 +  space_implode (" " ^ nun_and ^ "\n     ") (map str_of_tmty consts) ^ " " ^ nun_assign ^ "\n  " ^
  20.764 +  space_implode (nun_semicolon ^ "\n  ") (map str_of_tm props);
  20.765 +
  20.766 +fun str_of_nun_cards_suffix (NONE, NONE) = ""
  20.767 +  | str_of_nun_cards_suffix (c1, c2) =
  20.768 +    let
  20.769 +      val s1 = Option.map (prefix "min_card " o signed_string_of_int) c1;
  20.770 +      val s2 = Option.map (prefix "max_card " o signed_string_of_int) c2;
  20.771 +    in
  20.772 +      enclose " [" "]" (space_implode ", " (map_filter I [s1, s2]))
  20.773 +    end;
  20.774 +
  20.775 +fun str_of_nun_command (NTVal (ty, cards)) =
  20.776 +    nun_val ^ " " ^ str_of_tval ty ^ str_of_nun_cards_suffix cards
  20.777 +  | str_of_nun_command (NCopy spec) = nun_copy ^ " " ^ str_of_nun_copy_spec spec
  20.778 +  | str_of_nun_command (NData specs) =
  20.779 +    nun_data ^ " " ^ str_of_nun_and_list str_of_nun_co_data_spec specs
  20.780 +  | str_of_nun_command (NCodata specs) =
  20.781 +    nun_codata ^ " " ^ str_of_nun_and_list str_of_nun_co_data_spec specs
  20.782 +  | str_of_nun_command (NVal (tm, ty)) =
  20.783 +    nun_val ^ " " ^ str_of_tm tm ^ " " ^ nun_colon ^ " " ^ str_of_ty ty
  20.784 +  | str_of_nun_command (NPred (wf, specs)) =
  20.785 +    nun_pred ^ " " ^ (if wf then nun_lbracket ^ nun_wf ^ nun_rbracket ^ " " else "") ^
  20.786 +    str_of_nun_and_list str_of_nun_const_spec specs
  20.787 +  | str_of_nun_command (NCopred specs) =
  20.788 +    nun_copred ^ " " ^ str_of_nun_and_list str_of_nun_const_spec specs
  20.789 +  | str_of_nun_command (NRec specs) =
  20.790 +    nun_rec ^ " " ^ str_of_nun_and_list str_of_nun_const_spec specs
  20.791 +  | str_of_nun_command (NSpec spec) = nun_spec ^ " " ^ str_of_nun_consts_spec spec
  20.792 +  | str_of_nun_command (NAxiom tm) = nun_axiom ^ " " ^ str_of_tm tm
  20.793 +  | str_of_nun_command (NGoal tm) = nun_goal ^ " " ^ str_of_tm tm
  20.794 +  | str_of_nun_command (NEval tm) = nun_hash ^ " " ^ nun_eval ^ " " ^ str_of_tm tm;
  20.795 +
  20.796 +fun str_of_nun_problem {commandss, sound, complete} =
  20.797 +  map (cat_lines o map (suffix nun_dot o str_of_nun_command)) commandss
  20.798 +  |> space_implode "\n\n" |> suffix "\n"
  20.799 +  |> prefix (nun_hash ^ " " ^ (if sound then "sound" else "unsound") ^ "\n")
  20.800 +  |> prefix (nun_hash ^ " " ^ (if complete then "complete" else "incomplete") ^ "\n");
  20.801 +
  20.802 +end;
    21.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.2 +++ b/src/HOL/Tools/Nunchaku/nunchaku_reconstruct.ML	Fri Sep 08 00:01:36 2017 +0200
    21.3 @@ -0,0 +1,244 @@
    21.4 +(*  Title:      HOL/Nunchaku/Tools/nunchaku_reconstruct.ML
    21.5 +    Author:     Jasmin Blanchette, VU Amsterdam
    21.6 +    Copyright   2015, 2016, 2017
    21.7 +
    21.8 +Reconstruction of Nunchaku models in Isabelle/HOL.
    21.9 +*)
   21.10 +
   21.11 +signature NUNCHAKU_RECONSTRUCT =
   21.12 +sig
   21.13 +  type nun_model = Nunchaku_Model.nun_model
   21.14 +
   21.15 +  type typ_entry = typ * term list
   21.16 +  type term_entry = term * term
   21.17 +
   21.18 +  type isa_model =
   21.19 +    {type_model: typ_entry list,
   21.20 +     free_model: term_entry list,
   21.21 +     pat_complete_model: term_entry list,
   21.22 +     pat_incomplete_model: term_entry list,
   21.23 +     skolem_model: term_entry list}
   21.24 +
   21.25 +  val str_of_isa_model: Proof.context -> isa_model -> string
   21.26 +
   21.27 +  val isa_model_of_nun: Proof.context -> term list -> (typ option * string list) list ->
   21.28 +    nun_model -> isa_model
   21.29 +end;
   21.30 +
   21.31 +structure Nunchaku_Reconstruct : NUNCHAKU_RECONSTRUCT =
   21.32 +struct
   21.33 +
   21.34 +open Nunchaku_Util;
   21.35 +open Nunchaku_Problem;
   21.36 +open Nunchaku_Translate;
   21.37 +open Nunchaku_Model;
   21.38 +
   21.39 +type typ_entry = typ * term list;
   21.40 +type term_entry = term * term;
   21.41 +
   21.42 +type isa_model =
   21.43 +  {type_model: typ_entry list,
   21.44 +   free_model: term_entry list,
   21.45 +   pat_complete_model: term_entry list,
   21.46 +   pat_incomplete_model: term_entry list,
   21.47 +   skolem_model: term_entry list};
   21.48 +
   21.49 +val anonymousN = "anonymous";
   21.50 +val irrelevantN = "irrelevant";
   21.51 +val unparsableN = "unparsable";
   21.52 +
   21.53 +val nun_arrow_exploded = String.explode nun_arrow;
   21.54 +
   21.55 +val is_ty_meta = member (op =) (String.explode "()->,");
   21.56 +
   21.57 +fun next_token_lowlevel [] = (End_of_Stream, [])
   21.58 +  | next_token_lowlevel (c :: cs) =
   21.59 +    if Char.isSpace c then
   21.60 +      next_token_lowlevel cs
   21.61 +    else if not (is_ty_meta c) then
   21.62 +      let val n = find_index (Char.isSpace orf is_ty_meta) cs in
   21.63 +        (if n = ~1 then (cs, []) else chop n cs)
   21.64 +        |>> (cons c #> String.implode #> ident_of_str #> Ident)
   21.65 +      end
   21.66 +    else if is_prefix (op =) nun_arrow_exploded (c :: cs) then
   21.67 +      (Ident nun_arrow, tl cs)
   21.68 +    else
   21.69 +      (Symbol (String.str c), cs);
   21.70 +
   21.71 +val tokenize_lowlevel =
   21.72 +  let
   21.73 +    fun toks cs =
   21.74 +      (case next_token_lowlevel cs of
   21.75 +        (End_of_Stream, []) => []
   21.76 +      | (tok, cs') => tok :: toks cs');
   21.77 +  in
   21.78 +    toks o String.explode
   21.79 +  end;
   21.80 +
   21.81 +fun parse_lowlevel_ty tok =
   21.82 +  (Scan.optional
   21.83 +     (parse_sym "(" |-- Scan.repeat (parse_lowlevel_ty --| Scan.option (parse_sym ",")) --|
   21.84 +      parse_sym ")")
   21.85 +     []
   21.86 +   -- parse_ident >> (swap #> NType)) tok;
   21.87 +
   21.88 +val ty_of_lowlevel_str = fst o parse_lowlevel_ty o tokenize_lowlevel;
   21.89 +
   21.90 +fun ident_of_const (NConst (id, _, _)) = id
   21.91 +  | ident_of_const _ = nun_dummy;
   21.92 +
   21.93 +fun str_of_typ_entry ctxt (T, ts) =
   21.94 +  "type " ^ Syntax.string_of_typ ctxt T  ^
   21.95 +  " := {" ^ commas (map (Syntax.string_of_term ctxt) ts) ^ "}.";
   21.96 +
   21.97 +fun str_of_term_entry ctxt (tm, value) =
   21.98 +  "val " ^ Syntax.string_of_term ctxt tm ^ " := " ^ Syntax.string_of_term ctxt value ^ ".";
   21.99 +
  21.100 +fun str_of_isa_model ctxt
  21.101 +    {type_model, free_model, pat_complete_model, pat_incomplete_model, skolem_model} =
  21.102 +  map (str_of_typ_entry ctxt) type_model @ "" ::
  21.103 +  map (str_of_term_entry ctxt) free_model @ "" ::
  21.104 +  map (str_of_term_entry ctxt) pat_complete_model @ "" ::
  21.105 +  map (str_of_term_entry ctxt) pat_incomplete_model @ "" ::
  21.106 +  map (str_of_term_entry ctxt) skolem_model
  21.107 +  |> cat_lines;
  21.108 +
  21.109 +fun typ_of_nun ctxt =
  21.110 +  let
  21.111 +    fun typ_of (NType (id, tys)) =
  21.112 +      let val Ts = map typ_of tys in
  21.113 +        if id = nun_dummy then
  21.114 +          dummyT
  21.115 +        else if id = nun_prop then
  21.116 +          @{typ bool}
  21.117 +        else if id = nun_arrow then
  21.118 +          Type (@{type_name fun}, Ts)
  21.119 +        else
  21.120 +          (case try str_of_nun_tconst id of
  21.121 +            SOME (args, s) =>
  21.122 +            let val tys' = map ty_of_lowlevel_str args in
  21.123 +              Type (s, map typ_of (tys' @ tys))
  21.124 +            end
  21.125 +          | NONE =>
  21.126 +            (case try str_of_nun_tfree id of
  21.127 +              SOME s => TFree (Proof_Context.check_tfree ctxt (flip_quote s, dummyS))
  21.128 +            | NONE => raise Fail ("unknown type constructor: " ^ quote (str_of_ident id))))
  21.129 +      end;
  21.130 +  in
  21.131 +    typ_of
  21.132 +  end;
  21.133 +
  21.134 +fun one_letter_of s =
  21.135 +  let val c = String.sub (Long_Name.base_name s, 0) in
  21.136 +    String.str (if Char.isAlpha c then c else #"x")
  21.137 +  end;
  21.138 +
  21.139 +fun base_of_typ (Type (s, _)) = s
  21.140 +  | base_of_typ (TFree (s, _)) = flip_quote s
  21.141 +  | base_of_typ (TVar ((s, _), _)) = flip_quote s;
  21.142 +
  21.143 +fun term_of_nun ctxt atomss =
  21.144 +  let
  21.145 +    val thy = Proof_Context.theory_of ctxt;
  21.146 +
  21.147 +    val typ_of = typ_of_nun ctxt;
  21.148 +
  21.149 +    fun nth_atom T j =
  21.150 +      let val ss = these (triple_lookup (typ_match thy) atomss T) in
  21.151 +        if j >= 0 andalso j < length ss then nth ss j
  21.152 +        else one_letter_of (base_of_typ T) ^ nat_subscript (j + 1)
  21.153 +      end;
  21.154 +
  21.155 +    fun term_of _ (NAtom (j, ty)) =
  21.156 +        let val T = typ_of ty in Var ((nth_atom T j, 0), T) end
  21.157 +      | term_of bounds (NConst (id, tys0, ty)) =
  21.158 +        if id = nun_conj then
  21.159 +          HOLogic.conj
  21.160 +        else if id = nun_disj then
  21.161 +          HOLogic.disj
  21.162 +        else if id = nun_choice then
  21.163 +          Const (@{const_name Eps}, typ_of ty)
  21.164 +        else if id = nun_equals then
  21.165 +          Const (@{const_name HOL.eq}, typ_of ty)
  21.166 +        else if id = nun_false then
  21.167 +          @{const False}
  21.168 +        else if id = nun_if then
  21.169 +          Const (@{const_name If}, typ_of ty)
  21.170 +        else if id = nun_implies then
  21.171 +          @{term implies}
  21.172 +        else if id = nun_unique then
  21.173 +          Const (@{const_name The}, typ_of ty)
  21.174 +        else if id = nun_unique_unsafe then
  21.175 +          Const (@{const_name The_unsafe}, typ_of ty)
  21.176 +        else if id = nun_true then
  21.177 +          @{const True}
  21.178 +        else if String.isPrefix nun_anon_fun_prefix id then
  21.179 +          let val j = Int.fromString (unprefix nun_anon_fun_prefix id) |> the_default ~1 in
  21.180 +            Var ((anonymousN ^ nat_subscript (j + 1), 0), typ_of ty)
  21.181 +          end
  21.182 +        else if id = nun_irrelevant then
  21.183 +          (* FIXME: get bounds from Nunchaku *)
  21.184 +          list_comb (Var ((irrelevantN, 0), map (typ_of o safe_ty_of) bounds ---> typ_of ty),
  21.185 +            map Bound (length bounds - 1 downto 0))
  21.186 +        else if id = nun_unparsable then
  21.187 +          (* FIXME: get bounds from Nunchaku *)
  21.188 +          list_comb (Var ((unparsableN, 0), typ_of ty), map Bound (length bounds - 1 downto 0))
  21.189 +        else
  21.190 +          (case try str_of_nun_const id of
  21.191 +            SOME (args, s) =>
  21.192 +            let val tys = map ty_of_lowlevel_str args in
  21.193 +              Sign.mk_const thy (s, map typ_of (tys @ tys0))
  21.194 +            end
  21.195 +          | NONE =>
  21.196 +            (case try str_of_nun_free id of
  21.197 +              SOME s => Free (s, typ_of ty)
  21.198 +            | NONE =>
  21.199 +              (case try str_of_nun_var id of
  21.200 +                SOME s => Var ((s, 0), typ_of ty)
  21.201 +              | NONE =>
  21.202 +                (case find_index (fn bound => ident_of_const bound = id) bounds of
  21.203 +                  ~1 => Var ((str_of_ident id, 0), typ_of ty) (* shouldn't happen? *)
  21.204 +                | j => Bound j))))
  21.205 +      | term_of bounds (NAbs (var, body)) =
  21.206 +        let val T = typ_of (safe_ty_of var) in
  21.207 +          Abs (one_letter_of (base_of_typ T), T, term_of (var :: bounds) body)
  21.208 +        end
  21.209 +      | term_of bounds (NApp (func, arg)) =
  21.210 +        let
  21.211 +          fun same () = term_of bounds func $ term_of bounds arg;
  21.212 +        in
  21.213 +          (case (func, arg) of
  21.214 +            (NConst (id, _, _), NAbs _) =>
  21.215 +            if id = nun_mu then
  21.216 +              let val Abs (s, T, body) = term_of bounds arg in
  21.217 +                Const (@{const_name The}, (T --> HOLogic.boolT) --> T)
  21.218 +                $ Abs (s, T, HOLogic.eq_const T $ Bound 0 $ body)
  21.219 +              end
  21.220 +            else
  21.221 +              same ()
  21.222 +          | _ => same ())
  21.223 +        end
  21.224 +      | term_of _ (NMatch _) = raise Fail "unexpected match";
  21.225 +  in
  21.226 +    term_of []
  21.227 +  end;
  21.228 +
  21.229 +fun isa_typ_entry_of_nun ctxt atomss (ty, atoms) =
  21.230 +  (typ_of_nun ctxt ty, map (term_of_nun ctxt atomss) atoms);
  21.231 +
  21.232 +fun isa_term_entry_of_nun ctxt atomss (tm, value) =
  21.233 +  (term_of_nun ctxt atomss tm, term_of_nun ctxt atomss value);
  21.234 +
  21.235 +fun isa_model_of_nun ctxt pat_completes atomss {type_model, const_model, skolem_model} =
  21.236 +  let
  21.237 +    val free_and_const_model = map (isa_term_entry_of_nun ctxt atomss) const_model;
  21.238 +    val (free_model, (pat_complete_model, pat_incomplete_model)) =
  21.239 +      List.partition (is_Free o fst) free_and_const_model
  21.240 +      ||> List.partition (member (op aconv) pat_completes o fst);
  21.241 +  in
  21.242 +    {type_model = map (isa_typ_entry_of_nun ctxt atomss) type_model, free_model = free_model,
  21.243 +     pat_complete_model = pat_complete_model, pat_incomplete_model = pat_incomplete_model,
  21.244 +     skolem_model = map (isa_term_entry_of_nun ctxt atomss) skolem_model}
  21.245 +  end;
  21.246 +
  21.247 +end;
    22.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.2 +++ b/src/HOL/Tools/Nunchaku/nunchaku_tool.ML	Fri Sep 08 00:01:36 2017 +0200
    22.3 @@ -0,0 +1,141 @@
    22.4 +(*  Title:      HOL/Nunchaku/Tools/nunchaku_tool.ML
    22.5 +    Author:     Jasmin Blanchette, VU Amsterdam
    22.6 +    Copyright   2015, 2016, 2017
    22.7 +
    22.8 +Interface to the external "nunchaku" tool.
    22.9 +*)
   22.10 +
   22.11 +signature NUNCHAKU_TOOL =
   22.12 +sig
   22.13 +  type ty = Nunchaku_Problem.ty
   22.14 +  type tm = Nunchaku_Problem.tm
   22.15 +  type nun_problem = Nunchaku_Problem.nun_problem
   22.16 +
   22.17 +  type tool_params =
   22.18 +    {solvers: string list,
   22.19 +     overlord: bool,
   22.20 +     debug: bool,
   22.21 +     specialize: bool,
   22.22 +     timeout: Time.time}
   22.23 +
   22.24 +  type nun_solution =
   22.25 +    {tys: (ty * tm list) list,
   22.26 +     tms: (tm * tm) list}
   22.27 +
   22.28 +  datatype nun_outcome =
   22.29 +    Unsat
   22.30 +  | Sat of string * nun_solution
   22.31 +  | Unknown of (string * nun_solution) option
   22.32 +  | Timeout
   22.33 +  | Nunchaku_Var_Not_Set
   22.34 +  | Nunchaku_Cannot_Execute
   22.35 +  | Nunchaku_Not_Found
   22.36 +  | CVC4_Cannot_Execute
   22.37 +  | CVC4_Not_Found
   22.38 +  | Unknown_Error of int * string
   22.39 +
   22.40 +  val nunchaku_home_env_var: string
   22.41 +
   22.42 +  val solve_nun_problem: tool_params -> nun_problem -> nun_outcome
   22.43 +end;
   22.44 +
   22.45 +structure Nunchaku_Tool : NUNCHAKU_TOOL =
   22.46 +struct
   22.47 +
   22.48 +open Nunchaku_Util;
   22.49 +open Nunchaku_Problem;
   22.50 +
   22.51 +type tool_params =
   22.52 +  {solvers: string list,
   22.53 +   overlord: bool,
   22.54 +   debug: bool,
   22.55 +   specialize: bool,
   22.56 +   timeout: Time.time};
   22.57 +
   22.58 +type nun_solution =
   22.59 +  {tys: (ty * tm list) list,
   22.60 +   tms: (tm * tm) list};
   22.61 +
   22.62 +datatype nun_outcome =
   22.63 +  Unsat
   22.64 +| Sat of string * nun_solution
   22.65 +| Unknown of (string * nun_solution) option
   22.66 +| Timeout
   22.67 +| Nunchaku_Var_Not_Set
   22.68 +| Nunchaku_Cannot_Execute
   22.69 +| Nunchaku_Not_Found
   22.70 +| CVC4_Cannot_Execute
   22.71 +| CVC4_Not_Found
   22.72 +| Unknown_Error of int * string;
   22.73 +
   22.74 +fun bash_output_error s =
   22.75 +  let val {out, err, rc, ...} = Bash.process s in
   22.76 +    ((out, err), rc)
   22.77 +  end;
   22.78 +
   22.79 +val nunchaku_home_env_var = "NUNCHAKU_HOME";
   22.80 +
   22.81 +val cached_outcome = Synchronized.var "Nunchaku_Tool.cached_outcome"
   22.82 +  (NONE : ((string list * nun_problem) * nun_outcome) option);
   22.83 +
   22.84 +fun uncached_solve_nun_problem ({solvers, overlord, specialize, timeout, ...} : tool_params)
   22.85 +    (problem as {sound, complete, ...}) =
   22.86 +  with_tmp_or_overlord_file overlord "nunchaku" "nun" (fn prob_path =>
   22.87 +    if getenv nunchaku_home_env_var = "" then
   22.88 +      Nunchaku_Var_Not_Set
   22.89 +    else
   22.90 +      let
   22.91 +        val bash_cmd =
   22.92 +          "PATH=\"$CVC4_HOME:$KODKODI/bin:$PATH\" \"$" ^
   22.93 +          nunchaku_home_env_var ^ "\"/nunchaku --skolems-in-model --no-color " ^
   22.94 +          (if specialize then "" else "--no-specialize ") ^
   22.95 +          "--solvers \"" ^ Bash_Syntax.string (space_implode " " solvers) ^ "\" " ^
   22.96 +          "--timeout " ^ string_of_int (Time.toSeconds timeout) ^ " " ^
   22.97 +          File.bash_path prob_path;
   22.98 +        val comments =
   22.99 +          [bash_cmd, "This file was generated by Isabelle (most likely Nunchaku)", timestamp ()];
  22.100 +        val prob_str = cat_lines (map (prefix "# ") comments) ^ "\n\n" ^ str_of_nun_problem problem;
  22.101 +        val _ = File.write prob_path prob_str;
  22.102 +        val ((output, error), code) = bash_output_error bash_cmd;
  22.103 +      in
  22.104 +        if String.isPrefix "SAT" output then
  22.105 +          (if sound then Sat else Unknown o SOME) (output, {tys = [], tms = []})
  22.106 +        else if String.isPrefix "UNSAT" output then
  22.107 +          if complete then Unsat else Unknown NONE
  22.108 +        else if String.isSubstring "TIMEOUT" output
  22.109 +            (* FIXME: temporary *)
  22.110 +            orelse String.isSubstring "kodkod failed (errcode 152)" error then
  22.111 +          Timeout
  22.112 +        else if String.isPrefix "UNKNOWN" output then
  22.113 +          Unknown NONE
  22.114 +        else if code = 126 then
  22.115 +          Nunchaku_Cannot_Execute
  22.116 +        else if code = 127 then
  22.117 +          Nunchaku_Not_Found
  22.118 +        else
  22.119 +          Unknown_Error (code,
  22.120 +            simplify_spaces (elide_string 1000 (if error <> "" then error else output)))
  22.121 +      end);
  22.122 +
  22.123 +fun solve_nun_problem (params as {solvers, overlord, debug, ...}) problem =
  22.124 +  let val key = (solvers, problem) in
  22.125 +    (case (overlord orelse debug,
  22.126 +        AList.lookup (op =) (the_list (Synchronized.value cached_outcome)) key) of
  22.127 +      (false, SOME outcome) => outcome
  22.128 +    | _ =>
  22.129 +      let
  22.130 +        val outcome = uncached_solve_nun_problem params problem;
  22.131 +
  22.132 +        fun update_cache () =
  22.133 +          Synchronized.change cached_outcome (K (SOME (key, outcome)));
  22.134 +      in
  22.135 +        (case outcome of
  22.136 +          Unsat => update_cache ()
  22.137 +        | Sat _ => update_cache ()
  22.138 +        | Unknown _ => update_cache ()
  22.139 +        | _ => ());
  22.140 +        outcome
  22.141 +      end)
  22.142 +  end;
  22.143 +
  22.144 +end;
    23.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.2 +++ b/src/HOL/Tools/Nunchaku/nunchaku_translate.ML	Fri Sep 08 00:01:36 2017 +0200
    23.3 @@ -0,0 +1,193 @@
    23.4 +(*  Title:      HOL/Nunchaku/Tools/nunchaku_translate.ML
    23.5 +    Author:     Jasmin Blanchette, VU Amsterdam
    23.6 +    Copyright   2015, 2016, 2017
    23.7 +
    23.8 +Translation of Isabelle/HOL problems to Nunchaku.
    23.9 +*)
   23.10 +
   23.11 +signature NUNCHAKU_TRANSLATE =
   23.12 +sig
   23.13 +  type isa_problem = Nunchaku_Collect.isa_problem
   23.14 +  type ty = Nunchaku_Problem.ty
   23.15 +  type nun_problem = Nunchaku_Problem.nun_problem
   23.16 +
   23.17 +  val flip_quote: string -> string
   23.18 +  val lowlevel_str_of_ty: ty -> string
   23.19 +
   23.20 +  val nun_problem_of_isa: Proof.context -> isa_problem -> nun_problem
   23.21 +end;
   23.22 +
   23.23 +structure Nunchaku_Translate : NUNCHAKU_TRANSLATE =
   23.24 +struct
   23.25 +
   23.26 +open Nunchaku_Util;
   23.27 +open Nunchaku_Collect;
   23.28 +open Nunchaku_Problem;
   23.29 +
   23.30 +fun flip_quote s =
   23.31 +  (case try (unprefix "'") s of
   23.32 +    SOME s' => s'
   23.33 +  | NONE => prefix "'" s);
   23.34 +
   23.35 +fun lowlevel_str_of_ty (NType (id, tys)) =
   23.36 +  (if null tys then "" else encode_args (map lowlevel_str_of_ty tys)) ^ id;
   23.37 +
   23.38 +fun strip_nun_abs 0 tm = ([], tm)
   23.39 +  | strip_nun_abs n (NAbs (var, body)) =
   23.40 +    strip_nun_abs (n - 1) body
   23.41 +    |>> cons var;
   23.42 +
   23.43 +val strip_nun_comb =
   23.44 +  let
   23.45 +    fun strip args (NApp (func, arg)) = strip (arg :: args) func
   23.46 +      | strip args tm = (tm, args);
   23.47 +  in
   23.48 +    strip []
   23.49 +  end;
   23.50 +
   23.51 +fun ty_of_isa (Type (s, Ts)) =
   23.52 +    let val tys = map ty_of_isa Ts in
   23.53 +      (case s of
   23.54 +        @{type_name bool} => prop_ty
   23.55 +      | @{type_name fun} => NType (nun_arrow, tys)
   23.56 +      | _ =>
   23.57 +        let
   23.58 +          val args = map lowlevel_str_of_ty tys;
   23.59 +          val id = nun_tconst_of_str args s;
   23.60 +        in
   23.61 +          NType (id, [])
   23.62 +        end)
   23.63 +    end
   23.64 +  | ty_of_isa (TFree (s, _)) = NType (nun_tfree_of_str (flip_quote s), [])
   23.65 +  | ty_of_isa (TVar _) = raise Fail "unexpected TVar";
   23.66 +
   23.67 +fun gen_tm_of_isa in_prop ctxt t =
   23.68 +  let
   23.69 +    val thy = Proof_Context.theory_of ctxt;
   23.70 +
   23.71 +    fun id_of_const (x as (s, _)) =
   23.72 +      let val args = map (lowlevel_str_of_ty o ty_of_isa) (Sign.const_typargs thy x) in
   23.73 +        nun_const_of_str args s
   23.74 +      end;
   23.75 +
   23.76 +    fun tm_of_branch ctr_id var_count f_arg_tm =
   23.77 +      let val (vars, body) = strip_nun_abs var_count f_arg_tm in
   23.78 +        (ctr_id, vars, body)
   23.79 +      end;
   23.80 +
   23.81 +    fun tm_of bounds (Const (x as (s, T))) =
   23.82 +        (case try (dest_co_datatype_case ctxt) x of
   23.83 +          SOME ctrs =>
   23.84 +          let
   23.85 +            val num_f_args = length ctrs;
   23.86 +            val min_args = num_f_args + 1;
   23.87 +            val var_counts = map (num_binder_types o snd) ctrs;
   23.88 +
   23.89 +            val dummy_free = Free (Name.uu, T);
   23.90 +            val tm = tm_of bounds dummy_free;
   23.91 +            val tm' = eta_expandN_tm min_args tm;
   23.92 +            val (vars, body) = strip_nun_abs min_args tm';
   23.93 +            val (_, (f_args, obj :: other_args)) = strip_nun_comb body ||> chop num_f_args;
   23.94 +            val f_args' = map2 eta_expandN_tm var_counts f_args;
   23.95 +
   23.96 +            val ctr_ids = map id_of_const ctrs;
   23.97 +          in
   23.98 +            NMatch (obj, @{map 3} tm_of_branch ctr_ids var_counts f_args')
   23.99 +            |> rcomb_tms other_args
  23.100 +            |> abs_tms vars
  23.101 +          end
  23.102 +        | NONE =>
  23.103 +          if s = @{const_name unreachable} andalso in_prop then
  23.104 +            let val ty = ty_of_isa T in
  23.105 +              napps (NConst (nun_asserting, [ty], mk_arrows_ty ([ty, prop_ty], ty)),
  23.106 +                [NConst (id_of_const x, [], ty), NConst (nun_false, [], prop_ty)])
  23.107 +            end
  23.108 +          else
  23.109 +            let
  23.110 +              val id =
  23.111 +                (case s of
  23.112 +                  @{const_name All} => nun_forall
  23.113 +                | @{const_name conj} => nun_conj
  23.114 +                | @{const_name disj} => nun_disj
  23.115 +                | @{const_name HOL.eq} => nun_equals
  23.116 +                | @{const_name Eps} => nun_choice
  23.117 +                | @{const_name Ex} => nun_exists
  23.118 +                | @{const_name False} => nun_false
  23.119 +                | @{const_name If} => nun_if
  23.120 +                | @{const_name implies} => nun_implies
  23.121 +                | @{const_name Not} => nun_not
  23.122 +                | @{const_name The} => nun_unique
  23.123 +                | @{const_name The_unsafe} => nun_unique_unsafe
  23.124 +                | @{const_name True} => nun_true
  23.125 +                | _ => id_of_const x);
  23.126 +            in
  23.127 +              NConst (id, [], ty_of_isa T)
  23.128 +            end)
  23.129 +      | tm_of _ (Free (s, T)) = NConst (nun_free_of_str s, [], ty_of_isa T)
  23.130 +      | tm_of _ (Var ((s, _), T)) = NConst (nun_var_of_str s, [], ty_of_isa T)
  23.131 +      | tm_of bounds (Abs (s, T, t)) =
  23.132 +        let
  23.133 +          val (s', bounds') = Name.variant s bounds;
  23.134 +          val x = Var ((s', 0), T);
  23.135 +        in
  23.136 +          NAbs (tm_of bounds' x, tm_of bounds' (subst_bound (x, t)))
  23.137 +        end
  23.138 +      | tm_of bounds (t $ u) = NApp (tm_of bounds t, tm_of bounds u)
  23.139 +      | tm_of _ (Bound _) = raise Fail "unexpected Bound";
  23.140 +  in
  23.141 +    t
  23.142 +    |> tm_of Name.context
  23.143 +    |> beta_reduce_tm
  23.144 +    |> eta_expand_builtin_tm
  23.145 +  end;
  23.146 +
  23.147 +val tm_of_isa = gen_tm_of_isa false;
  23.148 +val prop_of_isa = gen_tm_of_isa true;
  23.149 +
  23.150 +fun nun_copy_spec_of_isa_typedef ctxt {abs_typ, rep_typ, wrt, abs, rep} =
  23.151 +  {abs_ty = ty_of_isa abs_typ, rep_ty = ty_of_isa rep_typ, subset = SOME (tm_of_isa ctxt wrt),
  23.152 +   quotient = NONE, abs = tm_of_isa ctxt abs, rep = tm_of_isa ctxt rep};
  23.153 +
  23.154 +fun nun_copy_spec_of_isa_quotient ctxt {abs_typ, rep_typ, wrt, abs, rep} =
  23.155 +  {abs_ty = ty_of_isa abs_typ, rep_ty = ty_of_isa rep_typ, subset = NONE,
  23.156 +   quotient = SOME (tm_of_isa ctxt wrt), abs = tm_of_isa ctxt abs, rep = tm_of_isa ctxt rep};
  23.157 +
  23.158 +fun nun_ctr_of_isa ctxt ctr =
  23.159 +  {ctr = tm_of_isa ctxt ctr, arg_tys = map ty_of_isa (binder_types (fastype_of ctr))};
  23.160 +
  23.161 +fun nun_co_data_spec_of_isa ctxt {typ, ctrs} =
  23.162 +  {ty = ty_of_isa typ, ctrs = map (nun_ctr_of_isa ctxt) ctrs};
  23.163 +
  23.164 +fun nun_const_spec_of_isa ctxt {const, props} =
  23.165 +  {const = tm_of_isa ctxt const, props = map (prop_of_isa ctxt) props};
  23.166 +
  23.167 +fun nun_rec_spec_of_isa ctxt {const, props, ...} =
  23.168 +  {const = tm_of_isa ctxt const, props = map (prop_of_isa ctxt) props};
  23.169 +
  23.170 +fun nun_consts_spec_of_isa ctxt {consts, props} =
  23.171 +  {consts = map (tm_of_isa ctxt) consts, props = map (prop_of_isa ctxt) props};
  23.172 +
  23.173 +fun nun_problem_of_isa ctxt {commandss, sound, complete} =
  23.174 +  let
  23.175 +    fun cmd_of cmd =
  23.176 +      (case cmd of
  23.177 +        ITVal (T, cards) => NTVal (ty_of_isa T, cards)
  23.178 +      | ITypedef spec => NCopy (nun_copy_spec_of_isa_typedef ctxt spec)
  23.179 +      | IQuotient spec => NCopy (nun_copy_spec_of_isa_quotient ctxt spec)
  23.180 +      | ICoData (fp, specs) =>
  23.181 +        BNF_Util.case_fp fp NData NCodata (map (nun_co_data_spec_of_isa ctxt) specs)
  23.182 +      | IVal t => NVal (tm_of_isa ctxt t, ty_of_isa (fastype_of t))
  23.183 +      | ICoPred (fp, wf, specs) =>
  23.184 +        (if wf then curry NPred true
  23.185 +         else if fp = BNF_Util.Least_FP then curry NPred false
  23.186 +         else NCopred) (map (nun_const_spec_of_isa ctxt) specs)
  23.187 +      | IRec specs => NRec (map (nun_rec_spec_of_isa ctxt) specs)
  23.188 +      | ISpec spec => NSpec (nun_consts_spec_of_isa ctxt spec)
  23.189 +      | IAxiom prop => NAxiom (prop_of_isa ctxt prop)
  23.190 +      | IGoal prop => NGoal (prop_of_isa ctxt prop)
  23.191 +      | IEval t => NEval (tm_of_isa ctxt t));
  23.192 +  in
  23.193 +    {commandss = map (map cmd_of) commandss, sound = sound, complete = complete}
  23.194 +  end;
  23.195 +
  23.196 +end;
    24.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.2 +++ b/src/HOL/Tools/Nunchaku/nunchaku_util.ML	Fri Sep 08 00:01:36 2017 +0200
    24.3 @@ -0,0 +1,95 @@
    24.4 +(*  Title:      HOL/Nunchaku/Tools/nunchaku_util.ML
    24.5 +    Author:     Jasmin Blanchette, VU Amsterdam
    24.6 +    Copyright   2015, 2016, 2017
    24.7 +
    24.8 +General-purpose functions used by Nunchaku.
    24.9 +*)
   24.10 +
   24.11 +signature NUNCHAKU_UTIL =
   24.12 +sig
   24.13 +  val elide_string: int -> string -> string
   24.14 +  val nat_subscript: int -> string
   24.15 +  val timestamp: unit -> string
   24.16 +  val parse_bool_option: bool -> string -> string -> bool option
   24.17 +  val parse_time: string -> string -> Time.time
   24.18 +  val string_of_time: Time.time -> string
   24.19 +  val simplify_spaces: string -> string
   24.20 +  val ascii_of: string -> string
   24.21 +  val unascii_of: string -> string
   24.22 +  val double_lookup: ('a * 'a -> bool) -> ('a option * 'b) list -> 'a -> 'b option
   24.23 +  val triple_lookup: (''a * ''a -> bool) -> (''a option * 'b) list -> ''a -> 'b option
   24.24 +  val plural_s_for_list: 'a list -> string
   24.25 +  val with_overlord_file: string -> string -> (Path.T -> 'a) -> 'a
   24.26 +  val with_tmp_or_overlord_file: bool -> string -> string -> (Path.T -> 'a) -> 'a
   24.27 +  val num_binder_types: typ -> int
   24.28 +  val strip_fun_type: typ -> typ list * typ
   24.29 +  val attach_typeS: term -> term
   24.30 +  val specialize_type: theory -> string * typ -> term -> term
   24.31 +  val typ_match: theory -> typ * typ -> bool
   24.32 +  val term_match: theory -> term * term -> bool
   24.33 +  val const_match: theory -> (string * typ) * (string * typ) -> bool
   24.34 +  val DETERM_TIMEOUT: Time.time -> tactic -> tactic
   24.35 +  val spying: bool -> (unit -> Proof.state * int * string) -> unit
   24.36 +end;
   24.37 +
   24.38 +structure Nunchaku_Util : NUNCHAKU_UTIL =
   24.39 +struct
   24.40 +
   24.41 +val elide_string = ATP_Util.elide_string;
   24.42 +val nat_subscript = Nitpick_Util.nat_subscript;
   24.43 +val timestamp = ATP_Util.timestamp;
   24.44 +
   24.45 +val parse_bool_option = Sledgehammer_Util.parse_bool_option;
   24.46 +val parse_time = Sledgehammer_Util.parse_time;
   24.47 +val string_of_time = ATP_Util.string_of_time;
   24.48 +val simplify_spaces = Sledgehammer_Util.simplify_spaces;
   24.49 +val ascii_of = ATP_Problem_Generate.ascii_of;
   24.50 +val unascii_of = ATP_Problem_Generate.unascii_of;
   24.51 +val double_lookup = Nitpick_Util.double_lookup;
   24.52 +val triple_lookup = Nitpick_Util.triple_lookup;
   24.53 +val plural_s_for_list = Nitpick_Util.plural_s_for_list;
   24.54 +
   24.55 +fun with_overlord_file name ext f =
   24.56 +  f (Path.explode ("$ISABELLE_HOME_USER/" ^ name ^ "." ^ ext));
   24.57 +
   24.58 +fun with_tmp_or_overlord_file overlord =
   24.59 +  if overlord then with_overlord_file else Isabelle_System.with_tmp_file;
   24.60 +
   24.61 +val num_binder_types = BNF_Util.num_binder_types
   24.62 +val strip_fun_type = BNF_Util.strip_fun_type;
   24.63 +
   24.64 +(* Clone from "HOL/Tools/inductive_realizer.ML". *)
   24.65 +val attach_typeS =
   24.66 +  map_types (map_atyps
   24.67 +    (fn TFree (s, []) => TFree (s, @{sort type})
   24.68 +      | TVar (ixn, []) => TVar (ixn, @{sort type})
   24.69 +      | T => T));
   24.70 +
   24.71 +val specialize_type = ATP_Util.specialize_type;
   24.72 +
   24.73 +fun typ_match thy TU = can (Sign.typ_match thy TU) Vartab.empty;
   24.74 +fun term_match thy tu = can (Pattern.match thy tu) (Vartab.empty, Vartab.empty);
   24.75 +fun const_match thy = term_match thy o apply2 Const;
   24.76 +
   24.77 +val DETERM_TIMEOUT = Nitpick_Util.DETERM_TIMEOUT;
   24.78 +
   24.79 +val spying_version = "a"
   24.80 +
   24.81 +val hackish_string_of_term = Sledgehammer_Util.hackish_string_of_term;
   24.82 +
   24.83 +fun spying spy f =
   24.84 +  if spy then
   24.85 +    let
   24.86 +      val (state, i, message) = f ();
   24.87 +      val ctxt = Proof.context_of state;
   24.88 +      val goal = Logic.get_goal (Thm.prop_of (#goal (Proof.goal state))) i;
   24.89 +      val hash =
   24.90 +        String.substring (SHA1.rep (SHA1.digest (hackish_string_of_term ctxt goal)), 0, 12);
   24.91 +    in
   24.92 +      File.append (Path.explode "$ISABELLE_HOME_USER/spy_nunchaku")
   24.93 +        (spying_version ^ " " ^ timestamp () ^ ": " ^ hash ^ ": " ^ message ^ "\n")
   24.94 +    end
   24.95 +  else
   24.96 +    ();
   24.97 +
   24.98 +end;